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();
1979 HvTOTALKEYS(sv) = 0;
1980 HvPLACEHOLDERS(sv) = 0;
1982 /* Fall through... */
1985 SvANY(sv) = new_XPVAV();
1995 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1997 /* FIXME. Should be able to remove all this if()... if the above
1998 assertion is genuinely always true. */
2001 SvFLAGS(sv) &= ~SVf_OOK;
2004 SvPV_set(sv, (char*)0);
2005 SvMAGIC_set(sv, magic);
2006 SvSTASH_set(sv, stash);
2010 SvANY(sv) = new_XPVIO();
2011 Zero(SvANY(sv), 1, XPVIO);
2012 IoPAGE_LEN(sv) = 60;
2013 goto set_magic_common;
2015 SvANY(sv) = new_XPVFM();
2016 Zero(SvANY(sv), 1, XPVFM);
2017 goto set_magic_common;
2019 SvANY(sv) = new_XPVBM();
2023 goto set_magic_common;
2025 SvANY(sv) = new_XPVGV();
2031 goto set_magic_common;
2033 SvANY(sv) = new_XPVCV();
2034 Zero(SvANY(sv), 1, XPVCV);
2035 goto set_magic_common;
2037 SvANY(sv) = new_XPVLV();
2050 SvANY(sv) = new_XPVMG();
2053 SvMAGIC_set(sv, magic);
2054 SvSTASH_set(sv, stash);
2058 SvANY(sv) = new_XPVNV();
2064 SvANY(sv) = new_XPVIV();
2073 SvANY(sv) = new_XPV();
2084 =for apidoc sv_backoff
2086 Remove any string offset. You should normally use the C<SvOOK_off> macro
2093 Perl_sv_backoff(pTHX_ register SV *sv)
2097 char *s = SvPVX(sv);
2098 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2099 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2101 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2103 SvFLAGS(sv) &= ~SVf_OOK;
2110 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2111 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2112 Use the C<SvGROW> wrapper instead.
2118 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2122 #ifdef HAS_64K_LIMIT
2123 if (newlen >= 0x10000) {
2124 PerlIO_printf(Perl_debug_log,
2125 "Allocation too large: %"UVxf"\n", (UV)newlen);
2128 #endif /* HAS_64K_LIMIT */
2131 if (SvTYPE(sv) < SVt_PV) {
2132 sv_upgrade(sv, SVt_PV);
2135 else if (SvOOK(sv)) { /* pv is offset? */
2138 if (newlen > SvLEN(sv))
2139 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2140 #ifdef HAS_64K_LIMIT
2141 if (newlen >= 0x10000)
2148 if (newlen > SvLEN(sv)) { /* need more room? */
2149 if (SvLEN(sv) && s) {
2151 const STRLEN l = malloced_size((void*)SvPVX(sv));
2157 Renew(s,newlen,char);
2160 New(703, s, newlen, char);
2161 if (SvPVX(sv) && SvCUR(sv)) {
2162 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2166 SvLEN_set(sv, newlen);
2172 =for apidoc sv_setiv
2174 Copies an integer into the given SV, upgrading first if necessary.
2175 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2181 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2183 SV_CHECK_THINKFIRST_COW_DROP(sv);
2184 switch (SvTYPE(sv)) {
2186 sv_upgrade(sv, SVt_IV);
2189 sv_upgrade(sv, SVt_PVNV);
2193 sv_upgrade(sv, SVt_PVIV);
2202 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2205 (void)SvIOK_only(sv); /* validate number */
2211 =for apidoc sv_setiv_mg
2213 Like C<sv_setiv>, but also handles 'set' magic.
2219 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2226 =for apidoc sv_setuv
2228 Copies an unsigned integer into the given SV, upgrading first if necessary.
2229 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2235 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2237 /* With these two if statements:
2238 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2241 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2243 If you wish to remove them, please benchmark to see what the effect is
2245 if (u <= (UV)IV_MAX) {
2246 sv_setiv(sv, (IV)u);
2255 =for apidoc sv_setuv_mg
2257 Like C<sv_setuv>, but also handles 'set' magic.
2263 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2265 /* With these two if statements:
2266 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2269 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2271 If you wish to remove them, please benchmark to see what the effect is
2273 if (u <= (UV)IV_MAX) {
2274 sv_setiv(sv, (IV)u);
2284 =for apidoc sv_setnv
2286 Copies a double into the given SV, upgrading first if necessary.
2287 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2293 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2295 SV_CHECK_THINKFIRST_COW_DROP(sv);
2296 switch (SvTYPE(sv)) {
2299 sv_upgrade(sv, SVt_NV);
2304 sv_upgrade(sv, SVt_PVNV);
2313 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2317 (void)SvNOK_only(sv); /* validate number */
2322 =for apidoc sv_setnv_mg
2324 Like C<sv_setnv>, but also handles 'set' magic.
2330 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2336 /* Print an "isn't numeric" warning, using a cleaned-up,
2337 * printable version of the offending string
2341 S_not_a_number(pTHX_ SV *sv)
2348 dsv = sv_2mortal(newSVpv("", 0));
2349 pv = sv_uni_display(dsv, sv, 10, 0);
2352 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2353 /* each *s can expand to 4 chars + "...\0",
2354 i.e. need room for 8 chars */
2357 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2359 if (ch & 128 && !isPRINT_LC(ch)) {
2368 else if (ch == '\r') {
2372 else if (ch == '\f') {
2376 else if (ch == '\\') {
2380 else if (ch == '\0') {
2384 else if (isPRINT_LC(ch))
2401 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2402 "Argument \"%s\" isn't numeric in %s", pv,
2405 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2406 "Argument \"%s\" isn't numeric", pv);
2410 =for apidoc looks_like_number
2412 Test if the content of an SV looks like a number (or is a number).
2413 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2414 non-numeric warning), even if your atof() doesn't grok them.
2420 Perl_looks_like_number(pTHX_ SV *sv)
2422 register const char *sbegin;
2429 else if (SvPOKp(sv))
2430 sbegin = SvPV(sv, len);
2432 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2433 return grok_number(sbegin, len, NULL);
2436 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2437 until proven guilty, assume that things are not that bad... */
2442 As 64 bit platforms often have an NV that doesn't preserve all bits of
2443 an IV (an assumption perl has been based on to date) it becomes necessary
2444 to remove the assumption that the NV always carries enough precision to
2445 recreate the IV whenever needed, and that the NV is the canonical form.
2446 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2447 precision as a side effect of conversion (which would lead to insanity
2448 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2449 1) to distinguish between IV/UV/NV slots that have cached a valid
2450 conversion where precision was lost and IV/UV/NV slots that have a
2451 valid conversion which has lost no precision
2452 2) to ensure that if a numeric conversion to one form is requested that
2453 would lose precision, the precise conversion (or differently
2454 imprecise conversion) is also performed and cached, to prevent
2455 requests for different numeric formats on the same SV causing
2456 lossy conversion chains. (lossless conversion chains are perfectly
2461 SvIOKp is true if the IV slot contains a valid value
2462 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2463 SvNOKp is true if the NV slot contains a valid value
2464 SvNOK is true only if the NV value is accurate
2467 while converting from PV to NV, check to see if converting that NV to an
2468 IV(or UV) would lose accuracy over a direct conversion from PV to
2469 IV(or UV). If it would, cache both conversions, return NV, but mark
2470 SV as IOK NOKp (ie not NOK).
2472 While converting from PV to IV, check to see if converting that IV to an
2473 NV would lose accuracy over a direct conversion from PV to NV. If it
2474 would, cache both conversions, flag similarly.
2476 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2477 correctly because if IV & NV were set NV *always* overruled.
2478 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2479 changes - now IV and NV together means that the two are interchangeable:
2480 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2482 The benefit of this is that operations such as pp_add know that if
2483 SvIOK is true for both left and right operands, then integer addition
2484 can be used instead of floating point (for cases where the result won't
2485 overflow). Before, floating point was always used, which could lead to
2486 loss of precision compared with integer addition.
2488 * making IV and NV equal status should make maths accurate on 64 bit
2490 * may speed up maths somewhat if pp_add and friends start to use
2491 integers when possible instead of fp. (Hopefully the overhead in
2492 looking for SvIOK and checking for overflow will not outweigh the
2493 fp to integer speedup)
2494 * will slow down integer operations (callers of SvIV) on "inaccurate"
2495 values, as the change from SvIOK to SvIOKp will cause a call into
2496 sv_2iv each time rather than a macro access direct to the IV slot
2497 * should speed up number->string conversion on integers as IV is
2498 favoured when IV and NV are equally accurate
2500 ####################################################################
2501 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2502 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2503 On the other hand, SvUOK is true iff UV.
2504 ####################################################################
2506 Your mileage will vary depending your CPU's relative fp to integer
2510 #ifndef NV_PRESERVES_UV
2511 # define IS_NUMBER_UNDERFLOW_IV 1
2512 # define IS_NUMBER_UNDERFLOW_UV 2
2513 # define IS_NUMBER_IV_AND_UV 2
2514 # define IS_NUMBER_OVERFLOW_IV 4
2515 # define IS_NUMBER_OVERFLOW_UV 5
2517 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2519 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2521 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2523 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));
2524 if (SvNVX(sv) < (NV)IV_MIN) {
2525 (void)SvIOKp_on(sv);
2527 SvIV_set(sv, IV_MIN);
2528 return IS_NUMBER_UNDERFLOW_IV;
2530 if (SvNVX(sv) > (NV)UV_MAX) {
2531 (void)SvIOKp_on(sv);
2534 SvUV_set(sv, UV_MAX);
2535 return IS_NUMBER_OVERFLOW_UV;
2537 (void)SvIOKp_on(sv);
2539 /* Can't use strtol etc to convert this string. (See truth table in
2541 if (SvNVX(sv) <= (UV)IV_MAX) {
2542 SvIV_set(sv, I_V(SvNVX(sv)));
2543 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2544 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2546 /* Integer is imprecise. NOK, IOKp */
2548 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2551 SvUV_set(sv, U_V(SvNVX(sv)));
2552 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2553 if (SvUVX(sv) == UV_MAX) {
2554 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2555 possibly be preserved by NV. Hence, it must be overflow.
2557 return IS_NUMBER_OVERFLOW_UV;
2559 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2561 /* Integer is imprecise. NOK, IOKp */
2563 return IS_NUMBER_OVERFLOW_IV;
2565 #endif /* !NV_PRESERVES_UV*/
2567 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2568 * this function provided for binary compatibility only
2572 Perl_sv_2iv(pTHX_ register SV *sv)
2574 return sv_2iv_flags(sv, SV_GMAGIC);
2578 =for apidoc sv_2iv_flags
2580 Return the integer value of an SV, doing any necessary string
2581 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2582 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2588 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2592 if (SvGMAGICAL(sv)) {
2593 if (flags & SV_GMAGIC)
2598 return I_V(SvNVX(sv));
2600 if (SvPOKp(sv) && SvLEN(sv))
2603 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2604 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2610 if (SvTHINKFIRST(sv)) {
2613 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2614 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2615 return SvIV(tmpstr);
2616 return PTR2IV(SvRV(sv));
2619 sv_force_normal_flags(sv, 0);
2621 if (SvREADONLY(sv) && !SvOK(sv)) {
2622 if (ckWARN(WARN_UNINITIALIZED))
2629 return (IV)(SvUVX(sv));
2636 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2637 * without also getting a cached IV/UV from it at the same time
2638 * (ie PV->NV conversion should detect loss of accuracy and cache
2639 * IV or UV at same time to avoid this. NWC */
2641 if (SvTYPE(sv) == SVt_NV)
2642 sv_upgrade(sv, SVt_PVNV);
2644 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2645 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2646 certainly cast into the IV range at IV_MAX, whereas the correct
2647 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2649 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2650 SvIV_set(sv, I_V(SvNVX(sv)));
2651 if (SvNVX(sv) == (NV) SvIVX(sv)
2652 #ifndef NV_PRESERVES_UV
2653 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2654 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2655 /* Don't flag it as "accurately an integer" if the number
2656 came from a (by definition imprecise) NV operation, and
2657 we're outside the range of NV integer precision */
2660 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2661 DEBUG_c(PerlIO_printf(Perl_debug_log,
2662 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2668 /* IV not precise. No need to convert from PV, as NV
2669 conversion would already have cached IV if it detected
2670 that PV->IV would be better than PV->NV->IV
2671 flags already correct - don't set public IOK. */
2672 DEBUG_c(PerlIO_printf(Perl_debug_log,
2673 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2678 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2679 but the cast (NV)IV_MIN rounds to a the value less (more
2680 negative) than IV_MIN which happens to be equal to SvNVX ??
2681 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2682 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2683 (NV)UVX == NVX are both true, but the values differ. :-(
2684 Hopefully for 2s complement IV_MIN is something like
2685 0x8000000000000000 which will be exact. NWC */
2688 SvUV_set(sv, U_V(SvNVX(sv)));
2690 (SvNVX(sv) == (NV) SvUVX(sv))
2691 #ifndef NV_PRESERVES_UV
2692 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2693 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2694 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2695 /* Don't flag it as "accurately an integer" if the number
2696 came from a (by definition imprecise) NV operation, and
2697 we're outside the range of NV integer precision */
2703 DEBUG_c(PerlIO_printf(Perl_debug_log,
2704 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2708 return (IV)SvUVX(sv);
2711 else if (SvPOKp(sv) && SvLEN(sv)) {
2713 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2714 /* We want to avoid a possible problem when we cache an IV which
2715 may be later translated to an NV, and the resulting NV is not
2716 the same as the direct translation of the initial string
2717 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2718 be careful to ensure that the value with the .456 is around if the
2719 NV value is requested in the future).
2721 This means that if we cache such an IV, we need to cache the
2722 NV as well. Moreover, we trade speed for space, and do not
2723 cache the NV if we are sure it's not needed.
2726 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2727 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2728 == IS_NUMBER_IN_UV) {
2729 /* It's definitely an integer, only upgrade to PVIV */
2730 if (SvTYPE(sv) < SVt_PVIV)
2731 sv_upgrade(sv, SVt_PVIV);
2733 } else if (SvTYPE(sv) < SVt_PVNV)
2734 sv_upgrade(sv, SVt_PVNV);
2736 /* If NV preserves UV then we only use the UV value if we know that
2737 we aren't going to call atof() below. If NVs don't preserve UVs
2738 then the value returned may have more precision than atof() will
2739 return, even though value isn't perfectly accurate. */
2740 if ((numtype & (IS_NUMBER_IN_UV
2741 #ifdef NV_PRESERVES_UV
2744 )) == IS_NUMBER_IN_UV) {
2745 /* This won't turn off the public IOK flag if it was set above */
2746 (void)SvIOKp_on(sv);
2748 if (!(numtype & IS_NUMBER_NEG)) {
2750 if (value <= (UV)IV_MAX) {
2751 SvIV_set(sv, (IV)value);
2753 SvUV_set(sv, value);
2757 /* 2s complement assumption */
2758 if (value <= (UV)IV_MIN) {
2759 SvIV_set(sv, -(IV)value);
2761 /* Too negative for an IV. This is a double upgrade, but
2762 I'm assuming it will be rare. */
2763 if (SvTYPE(sv) < SVt_PVNV)
2764 sv_upgrade(sv, SVt_PVNV);
2768 SvNV_set(sv, -(NV)value);
2769 SvIV_set(sv, IV_MIN);
2773 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2774 will be in the previous block to set the IV slot, and the next
2775 block to set the NV slot. So no else here. */
2777 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2778 != IS_NUMBER_IN_UV) {
2779 /* It wasn't an (integer that doesn't overflow the UV). */
2780 SvNV_set(sv, Atof(SvPVX(sv)));
2782 if (! numtype && ckWARN(WARN_NUMERIC))
2785 #if defined(USE_LONG_DOUBLE)
2786 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2787 PTR2UV(sv), SvNVX(sv)));
2789 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2790 PTR2UV(sv), SvNVX(sv)));
2794 #ifdef NV_PRESERVES_UV
2795 (void)SvIOKp_on(sv);
2797 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2798 SvIV_set(sv, I_V(SvNVX(sv)));
2799 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2802 /* Integer is imprecise. NOK, IOKp */
2804 /* UV will not work better than IV */
2806 if (SvNVX(sv) > (NV)UV_MAX) {
2808 /* Integer is inaccurate. NOK, IOKp, is UV */
2809 SvUV_set(sv, UV_MAX);
2812 SvUV_set(sv, U_V(SvNVX(sv)));
2813 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2814 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2818 /* Integer is imprecise. NOK, IOKp, is UV */
2824 #else /* NV_PRESERVES_UV */
2825 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2826 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2827 /* The IV slot will have been set from value returned by
2828 grok_number above. The NV slot has just been set using
2831 assert (SvIOKp(sv));
2833 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2834 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2835 /* Small enough to preserve all bits. */
2836 (void)SvIOKp_on(sv);
2838 SvIV_set(sv, I_V(SvNVX(sv)));
2839 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2841 /* Assumption: first non-preserved integer is < IV_MAX,
2842 this NV is in the preserved range, therefore: */
2843 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2845 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);
2849 0 0 already failed to read UV.
2850 0 1 already failed to read UV.
2851 1 0 you won't get here in this case. IV/UV
2852 slot set, public IOK, Atof() unneeded.
2853 1 1 already read UV.
2854 so there's no point in sv_2iuv_non_preserve() attempting
2855 to use atol, strtol, strtoul etc. */
2856 if (sv_2iuv_non_preserve (sv, numtype)
2857 >= IS_NUMBER_OVERFLOW_IV)
2861 #endif /* NV_PRESERVES_UV */
2864 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2866 if (SvTYPE(sv) < SVt_IV)
2867 /* Typically the caller expects that sv_any is not NULL now. */
2868 sv_upgrade(sv, SVt_IV);
2871 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2872 PTR2UV(sv),SvIVX(sv)));
2873 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2876 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2877 * this function provided for binary compatibility only
2881 Perl_sv_2uv(pTHX_ register SV *sv)
2883 return sv_2uv_flags(sv, SV_GMAGIC);
2887 =for apidoc sv_2uv_flags
2889 Return the unsigned integer value of an SV, doing any necessary string
2890 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2891 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2897 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2901 if (SvGMAGICAL(sv)) {
2902 if (flags & SV_GMAGIC)
2907 return U_V(SvNVX(sv));
2908 if (SvPOKp(sv) && SvLEN(sv))
2911 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2912 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2918 if (SvTHINKFIRST(sv)) {
2921 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2922 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2923 return SvUV(tmpstr);
2924 return PTR2UV(SvRV(sv));
2927 sv_force_normal_flags(sv, 0);
2929 if (SvREADONLY(sv) && !SvOK(sv)) {
2930 if (ckWARN(WARN_UNINITIALIZED))
2940 return (UV)SvIVX(sv);
2944 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2945 * without also getting a cached IV/UV from it at the same time
2946 * (ie PV->NV conversion should detect loss of accuracy and cache
2947 * IV or UV at same time to avoid this. */
2948 /* IV-over-UV optimisation - choose to cache IV if possible */
2950 if (SvTYPE(sv) == SVt_NV)
2951 sv_upgrade(sv, SVt_PVNV);
2953 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2954 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2955 SvIV_set(sv, I_V(SvNVX(sv)));
2956 if (SvNVX(sv) == (NV) SvIVX(sv)
2957 #ifndef NV_PRESERVES_UV
2958 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2959 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2960 /* Don't flag it as "accurately an integer" if the number
2961 came from a (by definition imprecise) NV operation, and
2962 we're outside the range of NV integer precision */
2965 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2966 DEBUG_c(PerlIO_printf(Perl_debug_log,
2967 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2973 /* IV not precise. No need to convert from PV, as NV
2974 conversion would already have cached IV if it detected
2975 that PV->IV would be better than PV->NV->IV
2976 flags already correct - don't set public IOK. */
2977 DEBUG_c(PerlIO_printf(Perl_debug_log,
2978 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2983 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2984 but the cast (NV)IV_MIN rounds to a the value less (more
2985 negative) than IV_MIN which happens to be equal to SvNVX ??
2986 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2987 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2988 (NV)UVX == NVX are both true, but the values differ. :-(
2989 Hopefully for 2s complement IV_MIN is something like
2990 0x8000000000000000 which will be exact. NWC */
2993 SvUV_set(sv, U_V(SvNVX(sv)));
2995 (SvNVX(sv) == (NV) SvUVX(sv))
2996 #ifndef NV_PRESERVES_UV
2997 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2998 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2999 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
3000 /* Don't flag it as "accurately an integer" if the number
3001 came from a (by definition imprecise) NV operation, and
3002 we're outside the range of NV integer precision */
3007 DEBUG_c(PerlIO_printf(Perl_debug_log,
3008 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
3014 else if (SvPOKp(sv) && SvLEN(sv)) {
3016 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3018 /* We want to avoid a possible problem when we cache a UV which
3019 may be later translated to an NV, and the resulting NV is not
3020 the translation of the initial data.
3022 This means that if we cache such a UV, we need to cache the
3023 NV as well. Moreover, we trade speed for space, and do not
3024 cache the NV if not needed.
3027 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3028 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3029 == IS_NUMBER_IN_UV) {
3030 /* It's definitely an integer, only upgrade to PVIV */
3031 if (SvTYPE(sv) < SVt_PVIV)
3032 sv_upgrade(sv, SVt_PVIV);
3034 } else if (SvTYPE(sv) < SVt_PVNV)
3035 sv_upgrade(sv, SVt_PVNV);
3037 /* If NV preserves UV then we only use the UV value if we know that
3038 we aren't going to call atof() below. If NVs don't preserve UVs
3039 then the value returned may have more precision than atof() will
3040 return, even though it isn't accurate. */
3041 if ((numtype & (IS_NUMBER_IN_UV
3042 #ifdef NV_PRESERVES_UV
3045 )) == IS_NUMBER_IN_UV) {
3046 /* This won't turn off the public IOK flag if it was set above */
3047 (void)SvIOKp_on(sv);
3049 if (!(numtype & IS_NUMBER_NEG)) {
3051 if (value <= (UV)IV_MAX) {
3052 SvIV_set(sv, (IV)value);
3054 /* it didn't overflow, and it was positive. */
3055 SvUV_set(sv, value);
3059 /* 2s complement assumption */
3060 if (value <= (UV)IV_MIN) {
3061 SvIV_set(sv, -(IV)value);
3063 /* Too negative for an IV. This is a double upgrade, but
3064 I'm assuming it will be rare. */
3065 if (SvTYPE(sv) < SVt_PVNV)
3066 sv_upgrade(sv, SVt_PVNV);
3070 SvNV_set(sv, -(NV)value);
3071 SvIV_set(sv, IV_MIN);
3076 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3077 != IS_NUMBER_IN_UV) {
3078 /* It wasn't an integer, or it overflowed the UV. */
3079 SvNV_set(sv, Atof(SvPVX(sv)));
3081 if (! numtype && ckWARN(WARN_NUMERIC))
3084 #if defined(USE_LONG_DOUBLE)
3085 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3086 PTR2UV(sv), SvNVX(sv)));
3088 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3089 PTR2UV(sv), SvNVX(sv)));
3092 #ifdef NV_PRESERVES_UV
3093 (void)SvIOKp_on(sv);
3095 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3096 SvIV_set(sv, I_V(SvNVX(sv)));
3097 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3100 /* Integer is imprecise. NOK, IOKp */
3102 /* UV will not work better than IV */
3104 if (SvNVX(sv) > (NV)UV_MAX) {
3106 /* Integer is inaccurate. NOK, IOKp, is UV */
3107 SvUV_set(sv, UV_MAX);
3110 SvUV_set(sv, U_V(SvNVX(sv)));
3111 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3112 NV preservse UV so can do correct comparison. */
3113 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3117 /* Integer is imprecise. NOK, IOKp, is UV */
3122 #else /* NV_PRESERVES_UV */
3123 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3124 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3125 /* The UV slot will have been set from value returned by
3126 grok_number above. The NV slot has just been set using
3129 assert (SvIOKp(sv));
3131 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3132 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3133 /* Small enough to preserve all bits. */
3134 (void)SvIOKp_on(sv);
3136 SvIV_set(sv, I_V(SvNVX(sv)));
3137 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3139 /* Assumption: first non-preserved integer is < IV_MAX,
3140 this NV is in the preserved range, therefore: */
3141 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3143 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);
3146 sv_2iuv_non_preserve (sv, numtype);
3148 #endif /* NV_PRESERVES_UV */
3152 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3153 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3156 if (SvTYPE(sv) < SVt_IV)
3157 /* Typically the caller expects that sv_any is not NULL now. */
3158 sv_upgrade(sv, SVt_IV);
3162 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3163 PTR2UV(sv),SvUVX(sv)));
3164 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3170 Return the num value of an SV, doing any necessary string or integer
3171 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3178 Perl_sv_2nv(pTHX_ register SV *sv)
3182 if (SvGMAGICAL(sv)) {
3186 if (SvPOKp(sv) && SvLEN(sv)) {
3187 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3188 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3190 return Atof(SvPVX(sv));
3194 return (NV)SvUVX(sv);
3196 return (NV)SvIVX(sv);
3199 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3200 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3206 if (SvTHINKFIRST(sv)) {
3209 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3210 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3211 return SvNV(tmpstr);
3212 return PTR2NV(SvRV(sv));
3215 sv_force_normal_flags(sv, 0);
3217 if (SvREADONLY(sv) && !SvOK(sv)) {
3218 if (ckWARN(WARN_UNINITIALIZED))
3223 if (SvTYPE(sv) < SVt_NV) {
3224 if (SvTYPE(sv) == SVt_IV)
3225 sv_upgrade(sv, SVt_PVNV);
3227 sv_upgrade(sv, SVt_NV);
3228 #ifdef USE_LONG_DOUBLE
3230 STORE_NUMERIC_LOCAL_SET_STANDARD();
3231 PerlIO_printf(Perl_debug_log,
3232 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3233 PTR2UV(sv), SvNVX(sv));
3234 RESTORE_NUMERIC_LOCAL();
3238 STORE_NUMERIC_LOCAL_SET_STANDARD();
3239 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3240 PTR2UV(sv), SvNVX(sv));
3241 RESTORE_NUMERIC_LOCAL();
3245 else if (SvTYPE(sv) < SVt_PVNV)
3246 sv_upgrade(sv, SVt_PVNV);
3251 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3252 #ifdef NV_PRESERVES_UV
3255 /* Only set the public NV OK flag if this NV preserves the IV */
3256 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3257 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3258 : (SvIVX(sv) == I_V(SvNVX(sv))))
3264 else if (SvPOKp(sv) && SvLEN(sv)) {
3266 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3267 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3269 #ifdef NV_PRESERVES_UV
3270 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3271 == IS_NUMBER_IN_UV) {
3272 /* It's definitely an integer */
3273 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3275 SvNV_set(sv, Atof(SvPVX(sv)));
3278 SvNV_set(sv, Atof(SvPVX(sv)));
3279 /* Only set the public NV OK flag if this NV preserves the value in
3280 the PV at least as well as an IV/UV would.
3281 Not sure how to do this 100% reliably. */
3282 /* if that shift count is out of range then Configure's test is
3283 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3285 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3286 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3287 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3288 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3289 /* Can't use strtol etc to convert this string, so don't try.
3290 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3293 /* value has been set. It may not be precise. */
3294 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3295 /* 2s complement assumption for (UV)IV_MIN */
3296 SvNOK_on(sv); /* Integer is too negative. */
3301 if (numtype & IS_NUMBER_NEG) {
3302 SvIV_set(sv, -(IV)value);
3303 } else if (value <= (UV)IV_MAX) {
3304 SvIV_set(sv, (IV)value);
3306 SvUV_set(sv, value);
3310 if (numtype & IS_NUMBER_NOT_INT) {
3311 /* I believe that even if the original PV had decimals,
3312 they are lost beyond the limit of the FP precision.
3313 However, neither is canonical, so both only get p
3314 flags. NWC, 2000/11/25 */
3315 /* Both already have p flags, so do nothing */
3318 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3319 if (SvIVX(sv) == I_V(nv)) {
3324 /* It had no "." so it must be integer. */
3327 /* between IV_MAX and NV(UV_MAX).
3328 Could be slightly > UV_MAX */
3330 if (numtype & IS_NUMBER_NOT_INT) {
3331 /* UV and NV both imprecise. */
3333 UV nv_as_uv = U_V(nv);
3335 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3346 #endif /* NV_PRESERVES_UV */
3349 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3351 if (SvTYPE(sv) < SVt_NV)
3352 /* Typically the caller expects that sv_any is not NULL now. */
3353 /* XXX Ilya implies that this is a bug in callers that assume this
3354 and ideally should be fixed. */
3355 sv_upgrade(sv, SVt_NV);
3358 #if defined(USE_LONG_DOUBLE)
3360 STORE_NUMERIC_LOCAL_SET_STANDARD();
3361 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3362 PTR2UV(sv), SvNVX(sv));
3363 RESTORE_NUMERIC_LOCAL();
3367 STORE_NUMERIC_LOCAL_SET_STANDARD();
3368 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3369 PTR2UV(sv), SvNVX(sv));
3370 RESTORE_NUMERIC_LOCAL();
3376 /* asIV(): extract an integer from the string value of an SV.
3377 * Caller must validate PVX */
3380 S_asIV(pTHX_ SV *sv)
3383 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3385 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3386 == IS_NUMBER_IN_UV) {
3387 /* It's definitely an integer */
3388 if (numtype & IS_NUMBER_NEG) {
3389 if (value < (UV)IV_MIN)
3392 if (value < (UV)IV_MAX)
3397 if (ckWARN(WARN_NUMERIC))
3400 return I_V(Atof(SvPVX(sv)));
3403 /* asUV(): extract an unsigned integer from the string value of an SV
3404 * Caller must validate PVX */
3407 S_asUV(pTHX_ SV *sv)
3410 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3412 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3413 == IS_NUMBER_IN_UV) {
3414 /* It's definitely an integer */
3415 if (!(numtype & IS_NUMBER_NEG))
3419 if (ckWARN(WARN_NUMERIC))
3422 return U_V(Atof(SvPVX(sv)));
3426 =for apidoc sv_2pv_nolen
3428 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3429 use the macro wrapper C<SvPV_nolen(sv)> instead.
3434 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3437 return sv_2pv(sv, &n_a);
3440 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3441 * UV as a string towards the end of buf, and return pointers to start and
3444 * We assume that buf is at least TYPE_CHARS(UV) long.
3448 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3450 char *ptr = buf + TYPE_CHARS(UV);
3464 *--ptr = '0' + (char)(uv % 10);
3472 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3473 * this function provided for binary compatibility only
3477 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3479 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3483 =for apidoc sv_2pv_flags
3485 Returns a pointer to the string value of an SV, and sets *lp to its length.
3486 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3488 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3489 usually end up here too.
3495 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3500 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3501 char *tmpbuf = tbuf;
3507 if (SvGMAGICAL(sv)) {
3508 if (flags & SV_GMAGIC)
3516 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3518 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3523 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3528 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3529 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3536 if (SvTHINKFIRST(sv)) {
3539 register const char *typestr;
3540 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3541 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3542 char *pv = SvPV(tmpstr, *lp);
3552 typestr = "NULLREF";
3556 switch (SvTYPE(sv)) {
3558 if ( ((SvFLAGS(sv) &
3559 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3560 == (SVs_OBJECT|SVs_SMG))
3561 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3562 const regexp *re = (regexp *)mg->mg_obj;
3565 const char *fptr = "msix";
3570 char need_newline = 0;
3571 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3573 while((ch = *fptr++)) {
3575 reflags[left++] = ch;
3578 reflags[right--] = ch;
3583 reflags[left] = '-';
3587 mg->mg_len = re->prelen + 4 + left;
3589 * If /x was used, we have to worry about a regex
3590 * ending with a comment later being embedded
3591 * within another regex. If so, we don't want this
3592 * regex's "commentization" to leak out to the
3593 * right part of the enclosing regex, we must cap
3594 * it with a newline.
3596 * So, if /x was used, we scan backwards from the
3597 * end of the regex. If we find a '#' before we
3598 * find a newline, we need to add a newline
3599 * ourself. If we find a '\n' first (or if we
3600 * don't find '#' or '\n'), we don't need to add
3601 * anything. -jfriedl
3603 if (PMf_EXTENDED & re->reganch)
3605 const char *endptr = re->precomp + re->prelen;
3606 while (endptr >= re->precomp)
3608 const char c = *(endptr--);
3610 break; /* don't need another */
3612 /* we end while in a comment, so we
3614 mg->mg_len++; /* save space for it */
3615 need_newline = 1; /* note to add it */
3621 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3622 Copy("(?", mg->mg_ptr, 2, char);
3623 Copy(reflags, mg->mg_ptr+2, left, char);
3624 Copy(":", mg->mg_ptr+left+2, 1, char);
3625 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3627 mg->mg_ptr[mg->mg_len - 2] = '\n';
3628 mg->mg_ptr[mg->mg_len - 1] = ')';
3629 mg->mg_ptr[mg->mg_len] = 0;
3631 PL_reginterp_cnt += re->program[0].next_off;
3633 if (re->reganch & ROPT_UTF8)
3648 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3649 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3650 /* tied lvalues should appear to be
3651 * scalars for backwards compatitbility */
3652 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3653 ? "SCALAR" : "LVALUE"; break;
3654 case SVt_PVAV: typestr = "ARRAY"; break;
3655 case SVt_PVHV: typestr = "HASH"; break;
3656 case SVt_PVCV: typestr = "CODE"; break;
3657 case SVt_PVGV: typestr = "GLOB"; break;
3658 case SVt_PVFM: typestr = "FORMAT"; break;
3659 case SVt_PVIO: typestr = "IO"; break;
3660 default: typestr = "UNKNOWN"; break;
3664 const char *name = HvNAME(SvSTASH(sv));
3665 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3666 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3669 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3672 *lp = strlen(typestr);
3673 return (char *)typestr;
3675 if (SvREADONLY(sv) && !SvOK(sv)) {
3676 if (ckWARN(WARN_UNINITIALIZED))
3682 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3683 /* I'm assuming that if both IV and NV are equally valid then
3684 converting the IV is going to be more efficient */
3685 const U32 isIOK = SvIOK(sv);
3686 const U32 isUIOK = SvIsUV(sv);
3687 char buf[TYPE_CHARS(UV)];
3690 if (SvTYPE(sv) < SVt_PVIV)
3691 sv_upgrade(sv, SVt_PVIV);
3693 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3695 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3696 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3697 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3698 SvCUR_set(sv, ebuf - ptr);
3708 else if (SvNOKp(sv)) {
3709 if (SvTYPE(sv) < SVt_PVNV)
3710 sv_upgrade(sv, SVt_PVNV);
3711 /* The +20 is pure guesswork. Configure test needed. --jhi */
3712 SvGROW(sv, NV_DIG + 20);
3714 olderrno = errno; /* some Xenix systems wipe out errno here */
3716 if (SvNVX(sv) == 0.0)
3717 (void)strcpy(s,"0");
3721 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3724 #ifdef FIXNEGATIVEZERO
3725 if (*s == '-' && s[1] == '0' && !s[2])
3735 if (ckWARN(WARN_UNINITIALIZED)
3736 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3739 if (SvTYPE(sv) < SVt_PV)
3740 /* Typically the caller expects that sv_any is not NULL now. */
3741 sv_upgrade(sv, SVt_PV);
3744 *lp = s - SvPVX(sv);
3747 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3748 PTR2UV(sv),SvPVX(sv)));
3752 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3753 /* Sneaky stuff here */
3757 tsv = newSVpv(tmpbuf, 0);
3774 len = strlen(tmpbuf);
3776 #ifdef FIXNEGATIVEZERO
3777 if (len == 2 && t[0] == '-' && t[1] == '0') {
3782 (void)SvUPGRADE(sv, SVt_PV);
3784 s = SvGROW(sv, len + 1);
3787 return strcpy(s, t);
3792 =for apidoc sv_copypv
3794 Copies a stringified representation of the source SV into the
3795 destination SV. Automatically performs any necessary mg_get and
3796 coercion of numeric values into strings. Guaranteed to preserve
3797 UTF-8 flag even from overloaded objects. Similar in nature to
3798 sv_2pv[_flags] but operates directly on an SV instead of just the
3799 string. Mostly uses sv_2pv_flags to do its work, except when that
3800 would lose the UTF-8'ness of the PV.
3806 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3811 sv_setpvn(dsv,s,len);
3819 =for apidoc sv_2pvbyte_nolen
3821 Return a pointer to the byte-encoded representation of the SV.
3822 May cause the SV to be downgraded from UTF-8 as a side-effect.
3824 Usually accessed via the C<SvPVbyte_nolen> macro.
3830 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3833 return sv_2pvbyte(sv, &n_a);
3837 =for apidoc sv_2pvbyte
3839 Return a pointer to the byte-encoded representation of the SV, and set *lp
3840 to its length. May cause the SV to be downgraded from UTF-8 as a
3843 Usually accessed via the C<SvPVbyte> macro.
3849 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3851 sv_utf8_downgrade(sv,0);
3852 return SvPV(sv,*lp);
3856 =for apidoc sv_2pvutf8_nolen
3858 Return a pointer to the UTF-8-encoded representation of the SV.
3859 May cause the SV to be upgraded to UTF-8 as a side-effect.
3861 Usually accessed via the C<SvPVutf8_nolen> macro.
3867 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3870 return sv_2pvutf8(sv, &n_a);
3874 =for apidoc sv_2pvutf8
3876 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3877 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3879 Usually accessed via the C<SvPVutf8> macro.
3885 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3887 sv_utf8_upgrade(sv);
3888 return SvPV(sv,*lp);
3892 =for apidoc sv_2bool
3894 This function is only called on magical items, and is only used by
3895 sv_true() or its macro equivalent.
3901 Perl_sv_2bool(pTHX_ register SV *sv)
3910 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3911 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3912 return (bool)SvTRUE(tmpsv);
3913 return SvRV(sv) != 0;
3916 register XPV* Xpvtmp;
3917 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3918 (*Xpvtmp->xpv_pv > '0' ||
3919 Xpvtmp->xpv_cur > 1 ||
3920 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3927 return SvIVX(sv) != 0;
3930 return SvNVX(sv) != 0.0;
3937 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3938 * this function provided for binary compatibility only
3943 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3945 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3949 =for apidoc sv_utf8_upgrade
3951 Converts the PV of an SV to its UTF-8-encoded form.
3952 Forces the SV to string form if it is not already.
3953 Always sets the SvUTF8 flag to avoid future validity checks even
3954 if all the bytes have hibit clear.
3956 This is not as a general purpose byte encoding to Unicode interface:
3957 use the Encode extension for that.
3959 =for apidoc sv_utf8_upgrade_flags
3961 Converts the PV of an SV to its UTF-8-encoded form.
3962 Forces the SV to string form if it is not already.
3963 Always sets the SvUTF8 flag to avoid future validity checks even
3964 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3965 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3966 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3968 This is not as a general purpose byte encoding to Unicode interface:
3969 use the Encode extension for that.
3975 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3977 if (sv == &PL_sv_undef)
3981 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3982 (void) sv_2pv_flags(sv,&len, flags);
3986 (void) SvPV_force(sv,len);
3995 sv_force_normal_flags(sv, 0);
3998 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3999 sv_recode_to_utf8(sv, PL_encoding);
4000 else { /* Assume Latin-1/EBCDIC */
4001 /* This function could be much more efficient if we
4002 * had a FLAG in SVs to signal if there are any hibit
4003 * chars in the PV. Given that there isn't such a flag
4004 * make the loop as fast as possible. */
4005 U8 *s = (U8 *) SvPVX(sv);
4006 U8 *e = (U8 *) SvEND(sv);
4012 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
4016 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
4017 s = bytes_to_utf8((U8*)s, &len);
4019 SvPV_free(sv); /* No longer using what was there before. */
4021 SvPV_set(sv, (char*)s);
4022 SvCUR_set(sv, len - 1);
4023 SvLEN_set(sv, len); /* No longer know the real size. */
4025 /* Mark as UTF-8 even if no hibit - saves scanning loop */
4032 =for apidoc sv_utf8_downgrade
4034 Attempts to convert the PV of an SV from characters to bytes.
4035 If the PV contains a character beyond byte, this conversion will fail;
4036 in this case, either returns false or, if C<fail_ok> is not
4039 This is not as a general purpose Unicode to byte encoding interface:
4040 use the Encode extension for that.
4046 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4048 if (SvPOKp(sv) && SvUTF8(sv)) {
4054 sv_force_normal_flags(sv, 0);
4056 s = (U8 *) SvPV(sv, len);
4057 if (!utf8_to_bytes(s, &len)) {
4062 Perl_croak(aTHX_ "Wide character in %s",
4065 Perl_croak(aTHX_ "Wide character");
4076 =for apidoc sv_utf8_encode
4078 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4079 flag off so that it looks like octets again.
4085 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4087 (void) sv_utf8_upgrade(sv);
4089 sv_force_normal_flags(sv, 0);
4091 if (SvREADONLY(sv)) {
4092 Perl_croak(aTHX_ PL_no_modify);
4098 =for apidoc sv_utf8_decode
4100 If the PV of the SV is an octet sequence in UTF-8
4101 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4102 so that it looks like a character. If the PV contains only single-byte
4103 characters, the C<SvUTF8> flag stays being off.
4104 Scans PV for validity and returns false if the PV is invalid UTF-8.
4110 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4116 /* The octets may have got themselves encoded - get them back as
4119 if (!sv_utf8_downgrade(sv, TRUE))
4122 /* it is actually just a matter of turning the utf8 flag on, but
4123 * we want to make sure everything inside is valid utf8 first.
4125 c = (U8 *) SvPVX(sv);
4126 if (!is_utf8_string(c, SvCUR(sv)+1))
4128 e = (U8 *) SvEND(sv);
4131 if (!UTF8_IS_INVARIANT(ch)) {
4140 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4141 * this function provided for binary compatibility only
4145 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4147 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4151 =for apidoc sv_setsv
4153 Copies the contents of the source SV C<ssv> into the destination SV
4154 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4155 function if the source SV needs to be reused. Does not handle 'set' magic.
4156 Loosely speaking, it performs a copy-by-value, obliterating any previous
4157 content of the destination.
4159 You probably want to use one of the assortment of wrappers, such as
4160 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4161 C<SvSetMagicSV_nosteal>.
4163 =for apidoc sv_setsv_flags
4165 Copies the contents of the source SV C<ssv> into the destination SV
4166 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4167 function if the source SV needs to be reused. Does not handle 'set' magic.
4168 Loosely speaking, it performs a copy-by-value, obliterating any previous
4169 content of the destination.
4170 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4171 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4172 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4173 and C<sv_setsv_nomg> are implemented in terms of this function.
4175 You probably want to use one of the assortment of wrappers, such as
4176 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4177 C<SvSetMagicSV_nosteal>.
4179 This is the primary function for copying scalars, and most other
4180 copy-ish functions and macros use this underneath.
4186 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4188 register U32 sflags;
4194 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4196 sstr = &PL_sv_undef;
4197 stype = SvTYPE(sstr);
4198 dtype = SvTYPE(dstr);
4203 /* need to nuke the magic */
4205 SvRMAGICAL_off(dstr);
4208 /* There's a lot of redundancy below but we're going for speed here */
4213 if (dtype != SVt_PVGV) {
4214 (void)SvOK_off(dstr);
4222 sv_upgrade(dstr, SVt_IV);
4225 sv_upgrade(dstr, SVt_PVNV);
4229 sv_upgrade(dstr, SVt_PVIV);
4232 (void)SvIOK_only(dstr);
4233 SvIV_set(dstr, SvIVX(sstr));
4236 if (SvTAINTED(sstr))
4247 sv_upgrade(dstr, SVt_NV);
4252 sv_upgrade(dstr, SVt_PVNV);
4255 SvNV_set(dstr, SvNVX(sstr));
4256 (void)SvNOK_only(dstr);
4257 if (SvTAINTED(sstr))
4265 sv_upgrade(dstr, SVt_RV);
4266 else if (dtype == SVt_PVGV &&
4267 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4270 if (GvIMPORTED(dstr) != GVf_IMPORTED
4271 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4273 GvIMPORTED_on(dstr);
4282 #ifdef PERL_COPY_ON_WRITE
4283 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4284 if (dtype < SVt_PVIV)
4285 sv_upgrade(dstr, SVt_PVIV);
4292 sv_upgrade(dstr, SVt_PV);
4295 if (dtype < SVt_PVIV)
4296 sv_upgrade(dstr, SVt_PVIV);
4299 if (dtype < SVt_PVNV)
4300 sv_upgrade(dstr, SVt_PVNV);
4307 const char * const type = sv_reftype(sstr,0);
4309 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4311 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4316 if (dtype <= SVt_PVGV) {
4318 if (dtype != SVt_PVGV) {
4319 const char * const name = GvNAME(sstr);
4320 const STRLEN len = GvNAMELEN(sstr);
4321 /* don't upgrade SVt_PVLV: it can hold a glob */
4322 if (dtype != SVt_PVLV)
4323 sv_upgrade(dstr, SVt_PVGV);
4324 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4325 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4326 GvNAME(dstr) = savepvn(name, len);
4327 GvNAMELEN(dstr) = len;
4328 SvFAKE_on(dstr); /* can coerce to non-glob */
4330 /* ahem, death to those who redefine active sort subs */
4331 else if (PL_curstackinfo->si_type == PERLSI_SORT
4332 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4333 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4336 #ifdef GV_UNIQUE_CHECK
4337 if (GvUNIQUE((GV*)dstr)) {
4338 Perl_croak(aTHX_ PL_no_modify);
4342 (void)SvOK_off(dstr);
4343 GvINTRO_off(dstr); /* one-shot flag */
4345 GvGP(dstr) = gp_ref(GvGP(sstr));
4346 if (SvTAINTED(sstr))
4348 if (GvIMPORTED(dstr) != GVf_IMPORTED
4349 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4351 GvIMPORTED_on(dstr);
4359 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4361 if ((int)SvTYPE(sstr) != stype) {
4362 stype = SvTYPE(sstr);
4363 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4367 if (stype == SVt_PVLV)
4368 (void)SvUPGRADE(dstr, SVt_PVNV);
4370 (void)SvUPGRADE(dstr, (U32)stype);
4373 sflags = SvFLAGS(sstr);
4375 if (sflags & SVf_ROK) {
4376 if (dtype >= SVt_PV) {
4377 if (dtype == SVt_PVGV) {
4378 SV *sref = SvREFCNT_inc(SvRV(sstr));
4380 const int intro = GvINTRO(dstr);
4382 #ifdef GV_UNIQUE_CHECK
4383 if (GvUNIQUE((GV*)dstr)) {
4384 Perl_croak(aTHX_ PL_no_modify);
4389 GvINTRO_off(dstr); /* one-shot flag */
4390 GvLINE(dstr) = CopLINE(PL_curcop);
4391 GvEGV(dstr) = (GV*)dstr;
4394 switch (SvTYPE(sref)) {
4397 SAVEGENERICSV(GvAV(dstr));
4399 dref = (SV*)GvAV(dstr);
4400 GvAV(dstr) = (AV*)sref;
4401 if (!GvIMPORTED_AV(dstr)
4402 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4404 GvIMPORTED_AV_on(dstr);
4409 SAVEGENERICSV(GvHV(dstr));
4411 dref = (SV*)GvHV(dstr);
4412 GvHV(dstr) = (HV*)sref;
4413 if (!GvIMPORTED_HV(dstr)
4414 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4416 GvIMPORTED_HV_on(dstr);
4421 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4422 SvREFCNT_dec(GvCV(dstr));
4423 GvCV(dstr) = Nullcv;
4424 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4425 PL_sub_generation++;
4427 SAVEGENERICSV(GvCV(dstr));
4430 dref = (SV*)GvCV(dstr);
4431 if (GvCV(dstr) != (CV*)sref) {
4432 CV* cv = GvCV(dstr);
4434 if (!GvCVGEN((GV*)dstr) &&
4435 (CvROOT(cv) || CvXSUB(cv)))
4437 /* ahem, death to those who redefine
4438 * active sort subs */
4439 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4440 PL_sortcop == CvSTART(cv))
4442 "Can't redefine active sort subroutine %s",
4443 GvENAME((GV*)dstr));
4444 /* Redefining a sub - warning is mandatory if
4445 it was a const and its value changed. */
4446 if (ckWARN(WARN_REDEFINE)
4448 && (!CvCONST((CV*)sref)
4449 || sv_cmp(cv_const_sv(cv),
4450 cv_const_sv((CV*)sref)))))
4452 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4454 ? "Constant subroutine %s::%s redefined"
4455 : "Subroutine %s::%s redefined",
4456 HvNAME(GvSTASH((GV*)dstr)),
4457 GvENAME((GV*)dstr));
4461 cv_ckproto(cv, (GV*)dstr,
4462 SvPOK(sref) ? SvPVX(sref) : Nullch);
4464 GvCV(dstr) = (CV*)sref;
4465 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4466 GvASSUMECV_on(dstr);
4467 PL_sub_generation++;
4469 if (!GvIMPORTED_CV(dstr)
4470 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4472 GvIMPORTED_CV_on(dstr);
4477 SAVEGENERICSV(GvIOp(dstr));
4479 dref = (SV*)GvIOp(dstr);
4480 GvIOp(dstr) = (IO*)sref;
4484 SAVEGENERICSV(GvFORM(dstr));
4486 dref = (SV*)GvFORM(dstr);
4487 GvFORM(dstr) = (CV*)sref;
4491 SAVEGENERICSV(GvSV(dstr));
4493 dref = (SV*)GvSV(dstr);
4495 if (!GvIMPORTED_SV(dstr)
4496 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4498 GvIMPORTED_SV_on(dstr);
4504 if (SvTAINTED(sstr))
4514 (void)SvOK_off(dstr);
4515 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4517 if (sflags & SVp_NOK) {
4519 /* Only set the public OK flag if the source has public OK. */
4520 if (sflags & SVf_NOK)
4521 SvFLAGS(dstr) |= SVf_NOK;
4522 SvNV_set(dstr, SvNVX(sstr));
4524 if (sflags & SVp_IOK) {
4525 (void)SvIOKp_on(dstr);
4526 if (sflags & SVf_IOK)
4527 SvFLAGS(dstr) |= SVf_IOK;
4528 if (sflags & SVf_IVisUV)
4530 SvIV_set(dstr, SvIVX(sstr));
4532 if (SvAMAGIC(sstr)) {
4536 else if (sflags & SVp_POK) {
4540 * Check to see if we can just swipe the string. If so, it's a
4541 * possible small lose on short strings, but a big win on long ones.
4542 * It might even be a win on short strings if SvPVX(dstr)
4543 * has to be allocated and SvPVX(sstr) has to be freed.
4546 /* Whichever path we take through the next code, we want this true,
4547 and doing it now facilitates the COW check. */
4548 (void)SvPOK_only(dstr);
4551 #ifdef PERL_COPY_ON_WRITE
4552 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4556 (sflags & SVs_TEMP) && /* slated for free anyway? */
4557 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4558 (!(flags & SV_NOSTEAL)) &&
4559 /* and we're allowed to steal temps */
4560 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4561 SvLEN(sstr) && /* and really is a string */
4562 /* and won't be needed again, potentially */
4563 !(PL_op && PL_op->op_type == OP_AASSIGN))
4564 #ifdef PERL_COPY_ON_WRITE
4565 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4566 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4567 && SvTYPE(sstr) >= SVt_PVIV)
4570 /* Failed the swipe test, and it's not a shared hash key either.
4571 Have to copy the string. */
4572 STRLEN len = SvCUR(sstr);
4573 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4574 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4575 SvCUR_set(dstr, len);
4576 *SvEND(dstr) = '\0';
4578 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4580 #ifdef PERL_COPY_ON_WRITE
4581 /* Either it's a shared hash key, or it's suitable for
4582 copy-on-write or we can swipe the string. */
4584 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4589 /* I believe I should acquire a global SV mutex if
4590 it's a COW sv (not a shared hash key) to stop
4591 it going un copy-on-write.
4592 If the source SV has gone un copy on write between up there
4593 and down here, then (assert() that) it is of the correct
4594 form to make it copy on write again */
4595 if ((sflags & (SVf_FAKE | SVf_READONLY))
4596 != (SVf_FAKE | SVf_READONLY)) {
4597 SvREADONLY_on(sstr);
4599 /* Make the source SV into a loop of 1.
4600 (about to become 2) */
4601 SV_COW_NEXT_SV_SET(sstr, sstr);
4605 /* Initial code is common. */
4606 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4608 SvFLAGS(dstr) &= ~SVf_OOK;
4609 Safefree(SvPVX(dstr) - SvIVX(dstr));
4611 else if (SvLEN(dstr))
4612 Safefree(SvPVX(dstr));
4615 #ifdef PERL_COPY_ON_WRITE
4617 /* making another shared SV. */
4618 STRLEN cur = SvCUR(sstr);
4619 STRLEN len = SvLEN(sstr);
4620 assert (SvTYPE(dstr) >= SVt_PVIV);
4622 /* SvIsCOW_normal */
4623 /* splice us in between source and next-after-source. */
4624 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4625 SV_COW_NEXT_SV_SET(sstr, dstr);
4626 SvPV_set(dstr, SvPVX(sstr));
4628 /* SvIsCOW_shared_hash */
4629 UV hash = SvUVX(sstr);
4630 DEBUG_C(PerlIO_printf(Perl_debug_log,
4631 "Copy on write: Sharing hash\n"));
4633 sharepvn(SvPVX(sstr),
4634 (sflags & SVf_UTF8?-cur:cur), hash));
4635 SvUV_set(dstr, hash);
4637 SvLEN_set(dstr, len);
4638 SvCUR_set(dstr, cur);
4639 SvREADONLY_on(dstr);
4641 /* Relesase a global SV mutex. */
4645 { /* Passes the swipe test. */
4646 SvPV_set(dstr, SvPVX(sstr));
4647 SvLEN_set(dstr, SvLEN(sstr));
4648 SvCUR_set(dstr, SvCUR(sstr));
4651 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4652 SvPV_set(sstr, Nullch);
4658 if (sflags & SVf_UTF8)
4661 if (sflags & SVp_NOK) {
4663 if (sflags & SVf_NOK)
4664 SvFLAGS(dstr) |= SVf_NOK;
4665 SvNV_set(dstr, SvNVX(sstr));
4667 if (sflags & SVp_IOK) {
4668 (void)SvIOKp_on(dstr);
4669 if (sflags & SVf_IOK)
4670 SvFLAGS(dstr) |= SVf_IOK;
4671 if (sflags & SVf_IVisUV)
4673 SvIV_set(dstr, SvIVX(sstr));
4676 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4677 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4678 smg->mg_ptr, smg->mg_len);
4679 SvRMAGICAL_on(dstr);
4682 else if (sflags & SVp_IOK) {
4683 if (sflags & SVf_IOK)
4684 (void)SvIOK_only(dstr);
4686 (void)SvOK_off(dstr);
4687 (void)SvIOKp_on(dstr);
4689 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4690 if (sflags & SVf_IVisUV)
4692 SvIV_set(dstr, SvIVX(sstr));
4693 if (sflags & SVp_NOK) {
4694 if (sflags & SVf_NOK)
4695 (void)SvNOK_on(dstr);
4697 (void)SvNOKp_on(dstr);
4698 SvNV_set(dstr, SvNVX(sstr));
4701 else if (sflags & SVp_NOK) {
4702 if (sflags & SVf_NOK)
4703 (void)SvNOK_only(dstr);
4705 (void)SvOK_off(dstr);
4708 SvNV_set(dstr, SvNVX(sstr));
4711 if (dtype == SVt_PVGV) {
4712 if (ckWARN(WARN_MISC))
4713 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4716 (void)SvOK_off(dstr);
4718 if (SvTAINTED(sstr))
4723 =for apidoc sv_setsv_mg
4725 Like C<sv_setsv>, but also handles 'set' magic.
4731 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4733 sv_setsv(dstr,sstr);
4737 #ifdef PERL_COPY_ON_WRITE
4739 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4741 STRLEN cur = SvCUR(sstr);
4742 STRLEN len = SvLEN(sstr);
4743 register char *new_pv;
4746 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4754 if (SvTHINKFIRST(dstr))
4755 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4756 else if (SvPVX(dstr))
4757 Safefree(SvPVX(dstr));
4761 (void)SvUPGRADE (dstr, SVt_PVIV);
4763 assert (SvPOK(sstr));
4764 assert (SvPOKp(sstr));
4765 assert (!SvIOK(sstr));
4766 assert (!SvIOKp(sstr));
4767 assert (!SvNOK(sstr));
4768 assert (!SvNOKp(sstr));
4770 if (SvIsCOW(sstr)) {
4772 if (SvLEN(sstr) == 0) {
4773 /* source is a COW shared hash key. */
4774 UV hash = SvUVX(sstr);
4775 DEBUG_C(PerlIO_printf(Perl_debug_log,
4776 "Fast copy on write: Sharing hash\n"));
4777 SvUV_set(dstr, hash);
4778 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4781 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4783 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4784 (void)SvUPGRADE (sstr, SVt_PVIV);
4785 SvREADONLY_on(sstr);
4787 DEBUG_C(PerlIO_printf(Perl_debug_log,
4788 "Fast copy on write: Converting sstr to COW\n"));
4789 SV_COW_NEXT_SV_SET(dstr, sstr);
4791 SV_COW_NEXT_SV_SET(sstr, dstr);
4792 new_pv = SvPVX(sstr);
4795 SvPV_set(dstr, new_pv);
4796 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4799 SvLEN_set(dstr, len);
4800 SvCUR_set(dstr, cur);
4809 =for apidoc sv_setpvn
4811 Copies a string into an SV. The C<len> parameter indicates the number of
4812 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4813 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4819 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4821 register char *dptr;
4823 SV_CHECK_THINKFIRST_COW_DROP(sv);
4829 /* len is STRLEN which is unsigned, need to copy to signed */
4832 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4834 (void)SvUPGRADE(sv, SVt_PV);
4836 SvGROW(sv, len + 1);
4838 Move(ptr,dptr,len,char);
4841 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4846 =for apidoc sv_setpvn_mg
4848 Like C<sv_setpvn>, but also handles 'set' magic.
4854 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4856 sv_setpvn(sv,ptr,len);
4861 =for apidoc sv_setpv
4863 Copies a string into an SV. The string must be null-terminated. Does not
4864 handle 'set' magic. See C<sv_setpv_mg>.
4870 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4872 register STRLEN len;
4874 SV_CHECK_THINKFIRST_COW_DROP(sv);
4880 (void)SvUPGRADE(sv, SVt_PV);
4882 SvGROW(sv, len + 1);
4883 Move(ptr,SvPVX(sv),len+1,char);
4885 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4890 =for apidoc sv_setpv_mg
4892 Like C<sv_setpv>, but also handles 'set' magic.
4898 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4905 =for apidoc sv_usepvn
4907 Tells an SV to use C<ptr> to find its string value. Normally the string is
4908 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4909 The C<ptr> should point to memory that was allocated by C<malloc>. The
4910 string length, C<len>, must be supplied. This function will realloc the
4911 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4912 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4913 See C<sv_usepvn_mg>.
4919 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4921 SV_CHECK_THINKFIRST_COW_DROP(sv);
4922 (void)SvUPGRADE(sv, SVt_PV);
4929 Renew(ptr, len+1, char);
4932 SvLEN_set(sv, len+1);
4934 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4939 =for apidoc sv_usepvn_mg
4941 Like C<sv_usepvn>, but also handles 'set' magic.
4947 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4949 sv_usepvn(sv,ptr,len);
4953 #ifdef PERL_COPY_ON_WRITE
4954 /* Need to do this *after* making the SV normal, as we need the buffer
4955 pointer to remain valid until after we've copied it. If we let go too early,
4956 another thread could invalidate it by unsharing last of the same hash key
4957 (which it can do by means other than releasing copy-on-write Svs)
4958 or by changing the other copy-on-write SVs in the loop. */
4960 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4961 U32 hash, SV *after)
4963 if (len) { /* this SV was SvIsCOW_normal(sv) */
4964 /* we need to find the SV pointing to us. */
4965 SV *current = SV_COW_NEXT_SV(after);
4967 if (current == sv) {
4968 /* The SV we point to points back to us (there were only two of us
4970 Hence other SV is no longer copy on write either. */
4972 SvREADONLY_off(after);
4974 /* We need to follow the pointers around the loop. */
4976 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4979 /* don't loop forever if the structure is bust, and we have
4980 a pointer into a closed loop. */
4981 assert (current != after);
4982 assert (SvPVX(current) == pvx);
4984 /* Make the SV before us point to the SV after us. */
4985 SV_COW_NEXT_SV_SET(current, after);
4988 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4993 Perl_sv_release_IVX(pTHX_ register SV *sv)
4996 sv_force_normal_flags(sv, 0);
5002 =for apidoc sv_force_normal_flags
5004 Undo various types of fakery on an SV: if the PV is a shared string, make
5005 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5006 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
5007 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
5008 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5009 SvPOK_off rather than making a copy. (Used where this scalar is about to be
5010 set to some other value.) In addition, the C<flags> parameter gets passed to
5011 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
5012 with flags set to 0.
5018 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
5020 #ifdef PERL_COPY_ON_WRITE
5021 if (SvREADONLY(sv)) {
5022 /* At this point I believe I should acquire a global SV mutex. */
5024 char *pvx = SvPVX(sv);
5025 STRLEN len = SvLEN(sv);
5026 STRLEN cur = SvCUR(sv);
5027 U32 hash = SvUVX(sv);
5028 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
5030 PerlIO_printf(Perl_debug_log,
5031 "Copy on write: Force normal %ld\n",
5037 /* This SV doesn't own the buffer, so need to New() a new one: */
5038 SvPV_set(sv, (char*)0);
5040 if (flags & SV_COW_DROP_PV) {
5041 /* OK, so we don't need to copy our buffer. */
5044 SvGROW(sv, cur + 1);
5045 Move(pvx,SvPVX(sv),cur,char);
5049 sv_release_COW(sv, pvx, cur, len, hash, next);
5054 else if (IN_PERL_RUNTIME)
5055 Perl_croak(aTHX_ PL_no_modify);
5056 /* At this point I believe that I can drop the global SV mutex. */
5059 if (SvREADONLY(sv)) {
5061 char *pvx = SvPVX(sv);
5062 int is_utf8 = SvUTF8(sv);
5063 STRLEN len = SvCUR(sv);
5064 U32 hash = SvUVX(sv);
5067 SvPV_set(sv, (char*)0);
5069 SvGROW(sv, len + 1);
5070 Move(pvx,SvPVX(sv),len,char);
5072 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5074 else if (IN_PERL_RUNTIME)
5075 Perl_croak(aTHX_ PL_no_modify);
5079 sv_unref_flags(sv, flags);
5080 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5085 =for apidoc sv_force_normal
5087 Undo various types of fakery on an SV: if the PV is a shared string, make
5088 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5089 an xpvmg. See also C<sv_force_normal_flags>.
5095 Perl_sv_force_normal(pTHX_ register SV *sv)
5097 sv_force_normal_flags(sv, 0);
5103 Efficient removal of characters from the beginning of the string buffer.
5104 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5105 the string buffer. The C<ptr> becomes the first character of the adjusted
5106 string. Uses the "OOK hack".
5107 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5108 refer to the same chunk of data.
5114 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
5116 register STRLEN delta;
5117 if (!ptr || !SvPOKp(sv))
5119 delta = ptr - SvPVX(sv);
5120 SV_CHECK_THINKFIRST(sv);
5121 if (SvTYPE(sv) < SVt_PVIV)
5122 sv_upgrade(sv,SVt_PVIV);
5125 if (!SvLEN(sv)) { /* make copy of shared string */
5126 const char *pvx = SvPVX(sv);
5127 STRLEN len = SvCUR(sv);
5128 SvGROW(sv, len + 1);
5129 Move(pvx,SvPVX(sv),len,char);
5133 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5134 and we do that anyway inside the SvNIOK_off
5136 SvFLAGS(sv) |= SVf_OOK;
5139 SvLEN_set(sv, SvLEN(sv) - delta);
5140 SvCUR_set(sv, SvCUR(sv) - delta);
5141 SvPV_set(sv, SvPVX(sv) + delta);
5142 SvIV_set(sv, SvIVX(sv) + delta);
5145 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5146 * this function provided for binary compatibility only
5150 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5152 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5156 =for apidoc sv_catpvn
5158 Concatenates the string onto the end of the string which is in the SV. The
5159 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5160 status set, then the bytes appended should be valid UTF-8.
5161 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5163 =for apidoc sv_catpvn_flags
5165 Concatenates the string onto the end of the string which is in the SV. The
5166 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5167 status set, then the bytes appended should be valid UTF-8.
5168 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5169 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5170 in terms of this function.
5176 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5179 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
5181 SvGROW(dsv, dlen + slen + 1);
5184 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5185 SvCUR_set(dsv, SvCUR(dsv) + slen);
5187 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5192 =for apidoc sv_catpvn_mg
5194 Like C<sv_catpvn>, but also handles 'set' magic.
5200 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5202 sv_catpvn(sv,ptr,len);
5206 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5207 * this function provided for binary compatibility only
5211 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5213 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5217 =for apidoc sv_catsv
5219 Concatenates the string from SV C<ssv> onto the end of the string in
5220 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5221 not 'set' magic. See C<sv_catsv_mg>.
5223 =for apidoc sv_catsv_flags
5225 Concatenates the string from SV C<ssv> onto the end of the string in
5226 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5227 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5228 and C<sv_catsv_nomg> are implemented in terms of this function.
5233 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5239 if ((spv = SvPV(ssv, slen))) {
5240 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5241 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5242 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5243 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5244 dsv->sv_flags doesn't have that bit set.
5245 Andy Dougherty 12 Oct 2001
5247 I32 sutf8 = DO_UTF8(ssv);
5250 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5252 dutf8 = DO_UTF8(dsv);
5254 if (dutf8 != sutf8) {
5256 /* Not modifying source SV, so taking a temporary copy. */
5257 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5259 sv_utf8_upgrade(csv);
5260 spv = SvPV(csv, slen);
5263 sv_utf8_upgrade_nomg(dsv);
5265 sv_catpvn_nomg(dsv, spv, slen);
5270 =for apidoc sv_catsv_mg
5272 Like C<sv_catsv>, but also handles 'set' magic.
5278 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5285 =for apidoc sv_catpv
5287 Concatenates the string onto the end of the string which is in the SV.
5288 If the SV has the UTF-8 status set, then the bytes appended should be
5289 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5294 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5296 register STRLEN len;
5302 junk = SvPV_force(sv, tlen);
5304 SvGROW(sv, tlen + len + 1);
5307 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5308 SvCUR_set(sv, SvCUR(sv) + len);
5309 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5314 =for apidoc sv_catpv_mg
5316 Like C<sv_catpv>, but also handles 'set' magic.
5322 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5331 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5332 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5339 Perl_newSV(pTHX_ STRLEN len)
5345 sv_upgrade(sv, SVt_PV);
5346 SvGROW(sv, len + 1);
5351 =for apidoc sv_magicext
5353 Adds magic to an SV, upgrading it if necessary. Applies the
5354 supplied vtable and returns a pointer to the magic added.
5356 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5357 In particular, you can add magic to SvREADONLY SVs, and add more than
5358 one instance of the same 'how'.
5360 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5361 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5362 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5363 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5365 (This is now used as a subroutine by C<sv_magic>.)
5370 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5371 const char* name, I32 namlen)
5375 if (SvTYPE(sv) < SVt_PVMG) {
5376 (void)SvUPGRADE(sv, SVt_PVMG);
5378 Newz(702,mg, 1, MAGIC);
5379 mg->mg_moremagic = SvMAGIC(sv);
5380 SvMAGIC_set(sv, mg);
5382 /* Sometimes a magic contains a reference loop, where the sv and
5383 object refer to each other. To prevent a reference loop that
5384 would prevent such objects being freed, we look for such loops
5385 and if we find one we avoid incrementing the object refcount.
5387 Note we cannot do this to avoid self-tie loops as intervening RV must
5388 have its REFCNT incremented to keep it in existence.
5391 if (!obj || obj == sv ||
5392 how == PERL_MAGIC_arylen ||
5393 how == PERL_MAGIC_qr ||
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_vstring:
5568 case PERL_MAGIC_utf8:
5569 vtable = &PL_vtbl_utf8;
5571 case PERL_MAGIC_substr:
5572 vtable = &PL_vtbl_substr;
5574 case PERL_MAGIC_defelem:
5575 vtable = &PL_vtbl_defelem;
5577 case PERL_MAGIC_glob:
5578 vtable = &PL_vtbl_glob;
5580 case PERL_MAGIC_arylen:
5581 vtable = &PL_vtbl_arylen;
5583 case PERL_MAGIC_pos:
5584 vtable = &PL_vtbl_pos;
5586 case PERL_MAGIC_backref:
5587 vtable = &PL_vtbl_backref;
5589 case PERL_MAGIC_ext:
5590 /* Reserved for use by extensions not perl internals. */
5591 /* Useful for attaching extension internal data to perl vars. */
5592 /* Note that multiple extensions may clash if magical scalars */
5593 /* etc holding private data from one are passed to another. */
5596 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5599 /* Rest of work is done else where */
5600 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5603 case PERL_MAGIC_taint:
5606 case PERL_MAGIC_ext:
5607 case PERL_MAGIC_dbfile:
5614 =for apidoc sv_unmagic
5616 Removes all magic of type C<type> from an SV.
5622 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5626 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5629 for (mg = *mgp; mg; mg = *mgp) {
5630 if (mg->mg_type == type) {
5631 const MGVTBL* const vtbl = mg->mg_virtual;
5632 *mgp = mg->mg_moremagic;
5633 if (vtbl && vtbl->svt_free)
5634 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5635 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5637 Safefree(mg->mg_ptr);
5638 else if (mg->mg_len == HEf_SVKEY)
5639 SvREFCNT_dec((SV*)mg->mg_ptr);
5640 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5641 Safefree(mg->mg_ptr);
5643 if (mg->mg_flags & MGf_REFCOUNTED)
5644 SvREFCNT_dec(mg->mg_obj);
5648 mgp = &mg->mg_moremagic;
5652 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5659 =for apidoc sv_rvweaken
5661 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5662 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5663 push a back-reference to this RV onto the array of backreferences
5664 associated with that magic.
5670 Perl_sv_rvweaken(pTHX_ SV *sv)
5673 if (!SvOK(sv)) /* let undefs pass */
5676 Perl_croak(aTHX_ "Can't weaken a nonreference");
5677 else if (SvWEAKREF(sv)) {
5678 if (ckWARN(WARN_MISC))
5679 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5683 sv_add_backref(tsv, sv);
5689 /* Give tsv backref magic if it hasn't already got it, then push a
5690 * back-reference to sv onto the array associated with the backref magic.
5694 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5698 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5699 av = (AV*)mg->mg_obj;
5702 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5703 /* av now has a refcnt of 2, which avoids it getting freed
5704 * before us during global cleanup. The extra ref is removed
5705 * by magic_killbackrefs() when tsv is being freed */
5707 if (AvFILLp(av) >= AvMAX(av)) {
5709 SV **svp = AvARRAY(av);
5710 for (i = AvFILLp(av); i >= 0; i--)
5712 svp[i] = sv; /* reuse the slot */
5715 av_extend(av, AvFILLp(av)+1);
5717 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5720 /* delete a back-reference to ourselves from the backref magic associated
5721 * with the SV we point to.
5725 S_sv_del_backref(pTHX_ SV *sv)
5732 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5733 Perl_croak(aTHX_ "panic: del_backref");
5734 av = (AV *)mg->mg_obj;
5736 for (i = AvFILLp(av); i >= 0; i--)
5737 if (svp[i] == sv) svp[i] = Nullsv;
5741 =for apidoc sv_insert
5743 Inserts a string at the specified offset/length within the SV. Similar to
5744 the Perl substr() function.
5750 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5754 register char *midend;
5755 register char *bigend;
5761 Perl_croak(aTHX_ "Can't modify non-existent substring");
5762 SvPV_force(bigstr, curlen);
5763 (void)SvPOK_only_UTF8(bigstr);
5764 if (offset + len > curlen) {
5765 SvGROW(bigstr, offset+len+1);
5766 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5767 SvCUR_set(bigstr, offset+len);
5771 i = littlelen - len;
5772 if (i > 0) { /* string might grow */
5773 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5774 mid = big + offset + len;
5775 midend = bigend = big + SvCUR(bigstr);
5778 while (midend > mid) /* shove everything down */
5779 *--bigend = *--midend;
5780 Move(little,big+offset,littlelen,char);
5781 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5786 Move(little,SvPVX(bigstr)+offset,len,char);
5791 big = SvPVX(bigstr);
5794 bigend = big + SvCUR(bigstr);
5796 if (midend > bigend)
5797 Perl_croak(aTHX_ "panic: sv_insert");
5799 if (mid - big > bigend - midend) { /* faster to shorten from end */
5801 Move(little, mid, littlelen,char);
5804 i = bigend - midend;
5806 Move(midend, mid, i,char);
5810 SvCUR_set(bigstr, mid - big);
5813 else if ((i = mid - big)) { /* faster from front */
5814 midend -= littlelen;
5816 sv_chop(bigstr,midend-i);
5821 Move(little, mid, littlelen,char);
5823 else if (littlelen) {
5824 midend -= littlelen;
5825 sv_chop(bigstr,midend);
5826 Move(little,midend,littlelen,char);
5829 sv_chop(bigstr,midend);
5835 =for apidoc sv_replace
5837 Make the first argument a copy of the second, then delete the original.
5838 The target SV physically takes over ownership of the body of the source SV
5839 and inherits its flags; however, the target keeps any magic it owns,
5840 and any magic in the source is discarded.
5841 Note that this is a rather specialist SV copying operation; most of the
5842 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5848 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5850 const U32 refcnt = SvREFCNT(sv);
5851 SV_CHECK_THINKFIRST_COW_DROP(sv);
5852 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5853 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5854 if (SvMAGICAL(sv)) {
5858 sv_upgrade(nsv, SVt_PVMG);
5859 SvMAGIC_set(nsv, SvMAGIC(sv));
5860 SvFLAGS(nsv) |= SvMAGICAL(sv);
5862 SvMAGIC_set(sv, NULL);
5866 assert(!SvREFCNT(sv));
5867 #ifdef DEBUG_LEAKING_SCALARS
5868 sv->sv_flags = nsv->sv_flags;
5869 sv->sv_any = nsv->sv_any;
5870 sv->sv_refcnt = nsv->sv_refcnt;
5872 StructCopy(nsv,sv,SV);
5875 #ifdef PERL_COPY_ON_WRITE
5876 if (SvIsCOW_normal(nsv)) {
5877 /* We need to follow the pointers around the loop to make the
5878 previous SV point to sv, rather than nsv. */
5881 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5884 assert(SvPVX(current) == SvPVX(nsv));
5886 /* Make the SV before us point to the SV after us. */
5888 PerlIO_printf(Perl_debug_log, "previous is\n");
5890 PerlIO_printf(Perl_debug_log,
5891 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5892 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5894 SV_COW_NEXT_SV_SET(current, sv);
5897 SvREFCNT(sv) = refcnt;
5898 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5904 =for apidoc sv_clear
5906 Clear an SV: call any destructors, free up any memory used by the body,
5907 and free the body itself. The SV's head is I<not> freed, although
5908 its type is set to all 1's so that it won't inadvertently be assumed
5909 to be live during global destruction etc.
5910 This function should only be called when REFCNT is zero. Most of the time
5911 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5918 Perl_sv_clear(pTHX_ register SV *sv)
5923 assert(SvREFCNT(sv) == 0);
5926 if (PL_defstash) { /* Still have a symbol table? */
5933 stash = SvSTASH(sv);
5934 destructor = StashHANDLER(stash,DESTROY);
5936 SV* tmpref = newRV(sv);
5937 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5939 PUSHSTACKi(PERLSI_DESTROY);
5944 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5950 if(SvREFCNT(tmpref) < 2) {
5951 /* tmpref is not kept alive! */
5953 SvRV_set(tmpref, NULL);
5956 SvREFCNT_dec(tmpref);
5958 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5962 if (PL_in_clean_objs)
5963 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5965 /* DESTROY gave object new lease on life */
5971 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5972 SvOBJECT_off(sv); /* Curse the object. */
5973 if (SvTYPE(sv) != SVt_PVIO)
5974 --PL_sv_objcount; /* XXX Might want something more general */
5977 if (SvTYPE(sv) >= SVt_PVMG) {
5980 if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5981 SvREFCNT_dec(SvSTASH(sv));
5984 switch (SvTYPE(sv)) {
5987 IoIFP(sv) != PerlIO_stdin() &&
5988 IoIFP(sv) != PerlIO_stdout() &&
5989 IoIFP(sv) != PerlIO_stderr())
5991 io_close((IO*)sv, FALSE);
5993 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5994 PerlDir_close(IoDIRP(sv));
5995 IoDIRP(sv) = (DIR*)NULL;
5996 Safefree(IoTOP_NAME(sv));
5997 Safefree(IoFMT_NAME(sv));
5998 Safefree(IoBOTTOM_NAME(sv));
6013 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6014 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6015 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6016 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6018 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6019 SvREFCNT_dec(LvTARG(sv));
6023 Safefree(GvNAME(sv));
6024 /* cannot decrease stash refcount yet, as we might recursively delete
6025 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
6026 of stash until current sv is completely gone.
6027 -- JohnPC, 27 Mar 1998 */
6028 stash = GvSTASH(sv);
6034 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
6036 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
6037 /* Don't even bother with turning off the OOK flag. */
6046 SvREFCNT_dec(SvRV(sv));
6048 #ifdef PERL_COPY_ON_WRITE
6049 else if (SvPVX(sv)) {
6051 /* I believe I need to grab the global SV mutex here and
6052 then recheck the COW status. */
6054 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6057 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
6058 SvUVX(sv), SV_COW_NEXT_SV(sv));
6059 /* And drop it here. */
6061 } else if (SvLEN(sv)) {
6062 Safefree(SvPVX(sv));
6066 else if (SvPVX(sv) && SvLEN(sv))
6067 Safefree(SvPVX(sv));
6068 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6069 unsharepvn(SvPVX(sv),
6070 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6084 switch (SvTYPE(sv)) {
6100 del_XPVIV(SvANY(sv));
6103 del_XPVNV(SvANY(sv));
6106 del_XPVMG(SvANY(sv));
6109 del_XPVLV(SvANY(sv));
6112 del_XPVAV(SvANY(sv));
6115 del_XPVHV(SvANY(sv));
6118 del_XPVCV(SvANY(sv));
6121 del_XPVGV(SvANY(sv));
6122 /* code duplication for increased performance. */
6123 SvFLAGS(sv) &= SVf_BREAK;
6124 SvFLAGS(sv) |= SVTYPEMASK;
6125 /* decrease refcount of the stash that owns this GV, if any */
6127 SvREFCNT_dec(stash);
6128 return; /* not break, SvFLAGS reset already happened */
6130 del_XPVBM(SvANY(sv));
6133 del_XPVFM(SvANY(sv));
6136 del_XPVIO(SvANY(sv));
6139 SvFLAGS(sv) &= SVf_BREAK;
6140 SvFLAGS(sv) |= SVTYPEMASK;
6144 =for apidoc sv_newref
6146 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6153 Perl_sv_newref(pTHX_ SV *sv)
6163 Decrement an SV's reference count, and if it drops to zero, call
6164 C<sv_clear> to invoke destructors and free up any memory used by
6165 the body; finally, deallocate the SV's head itself.
6166 Normally called via a wrapper macro C<SvREFCNT_dec>.
6172 Perl_sv_free(pTHX_ SV *sv)
6177 if (SvREFCNT(sv) == 0) {
6178 if (SvFLAGS(sv) & SVf_BREAK)
6179 /* this SV's refcnt has been artificially decremented to
6180 * trigger cleanup */
6182 if (PL_in_clean_all) /* All is fair */
6184 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6185 /* make sure SvREFCNT(sv)==0 happens very seldom */
6186 SvREFCNT(sv) = (~(U32)0)/2;
6189 if (ckWARN_d(WARN_INTERNAL))
6190 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6191 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6192 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6195 if (--(SvREFCNT(sv)) > 0)
6197 Perl_sv_free2(aTHX_ sv);
6201 Perl_sv_free2(pTHX_ SV *sv)
6206 if (ckWARN_d(WARN_DEBUGGING))
6207 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6208 "Attempt to free temp prematurely: SV 0x%"UVxf
6209 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6213 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6214 /* make sure SvREFCNT(sv)==0 happens very seldom */
6215 SvREFCNT(sv) = (~(U32)0)/2;
6226 Returns the length of the string in the SV. Handles magic and type
6227 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6233 Perl_sv_len(pTHX_ register SV *sv)
6241 len = mg_length(sv);
6243 (void)SvPV(sv, len);
6248 =for apidoc sv_len_utf8
6250 Returns the number of characters in the string in an SV, counting wide
6251 UTF-8 bytes as a single character. Handles magic and type coercion.
6257 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6258 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6259 * (Note that the mg_len is not the length of the mg_ptr field.)
6264 Perl_sv_len_utf8(pTHX_ register SV *sv)
6270 return mg_length(sv);
6274 const U8 *s = (U8*)SvPV(sv, len);
6275 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6277 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6279 #ifdef PERL_UTF8_CACHE_ASSERT
6280 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6284 ulen = Perl_utf8_length(aTHX_ s, s + len);
6285 if (!mg && !SvREADONLY(sv)) {
6286 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6287 mg = mg_find(sv, PERL_MAGIC_utf8);
6297 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6298 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6299 * between UTF-8 and byte offsets. There are two (substr offset and substr
6300 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6301 * and byte offset) cache positions.
6303 * The mg_len field is used by sv_len_utf8(), see its comments.
6304 * Note that the mg_len is not the length of the mg_ptr field.
6308 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start)
6312 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6314 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6318 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6320 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6321 (*mgp)->mg_ptr = (char *) *cachep;
6325 (*cachep)[i] = offsetp;
6326 (*cachep)[i+1] = s - start;
6334 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6335 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6336 * between UTF-8 and byte offsets. See also the comments of
6337 * S_utf8_mg_pos_init().
6341 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6345 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6347 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6348 if (*mgp && (*mgp)->mg_ptr) {
6349 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6350 ASSERT_UTF8_CACHE(*cachep);
6351 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6353 else { /* We will skip to the right spot. */
6358 /* The assumption is that going backward is half
6359 * the speed of going forward (that's where the
6360 * 2 * backw in the below comes from). (The real
6361 * figure of course depends on the UTF-8 data.) */
6363 if ((*cachep)[i] > (STRLEN)uoff) {
6365 backw = (*cachep)[i] - (STRLEN)uoff;
6367 if (forw < 2 * backw)
6370 p = start + (*cachep)[i+1];
6372 /* Try this only for the substr offset (i == 0),
6373 * not for the substr length (i == 2). */
6374 else if (i == 0) { /* (*cachep)[i] < uoff */
6375 const STRLEN ulen = sv_len_utf8(sv);
6377 if ((STRLEN)uoff < ulen) {
6378 forw = (STRLEN)uoff - (*cachep)[i];
6379 backw = ulen - (STRLEN)uoff;
6381 if (forw < 2 * backw)
6382 p = start + (*cachep)[i+1];
6387 /* If the string is not long enough for uoff,
6388 * we could extend it, but not at this low a level. */
6392 if (forw < 2 * backw) {
6399 while (UTF8_IS_CONTINUATION(*p))
6404 /* Update the cache. */
6405 (*cachep)[i] = (STRLEN)uoff;
6406 (*cachep)[i+1] = p - start;
6408 /* Drop the stale "length" cache */
6417 if (found) { /* Setup the return values. */
6418 *offsetp = (*cachep)[i+1];
6419 *sp = start + *offsetp;
6422 *offsetp = send - start;
6424 else if (*sp < start) {
6430 #ifdef PERL_UTF8_CACHE_ASSERT
6435 while (n-- && s < send)
6439 assert(*offsetp == s - start);
6440 assert((*cachep)[0] == (STRLEN)uoff);
6441 assert((*cachep)[1] == *offsetp);
6443 ASSERT_UTF8_CACHE(*cachep);
6452 =for apidoc sv_pos_u2b
6454 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6455 the start of the string, to a count of the equivalent number of bytes; if
6456 lenp is non-zero, it does the same to lenp, but this time starting from
6457 the offset, rather than from the start of the string. Handles magic and
6464 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6465 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6466 * byte offsets. See also the comments of S_utf8_mg_pos().
6471 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6482 start = s = (U8*)SvPV(sv, len);
6484 I32 uoffset = *offsetp;
6489 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6491 if (!found && uoffset > 0) {
6492 while (s < send && uoffset--)
6496 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6498 *offsetp = s - start;
6503 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6507 if (!found && *lenp > 0) {
6510 while (s < send && ulen--)
6514 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6518 ASSERT_UTF8_CACHE(cache);
6530 =for apidoc sv_pos_b2u
6532 Converts the value pointed to by offsetp from a count of bytes from the
6533 start of the string, to a count of the equivalent number of UTF-8 chars.
6534 Handles magic and type coercion.
6540 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6541 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6542 * byte offsets. See also the comments of S_utf8_mg_pos().
6547 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6555 s = (U8*)SvPV(sv, len);
6556 if ((I32)len < *offsetp)
6557 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6559 U8* send = s + *offsetp;
6561 STRLEN *cache = NULL;
6565 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6566 mg = mg_find(sv, PERL_MAGIC_utf8);
6567 if (mg && mg->mg_ptr) {
6568 cache = (STRLEN *) mg->mg_ptr;
6569 if (cache[1] == (STRLEN)*offsetp) {
6570 /* An exact match. */
6571 *offsetp = cache[0];
6575 else if (cache[1] < (STRLEN)*offsetp) {
6576 /* We already know part of the way. */
6579 /* Let the below loop do the rest. */
6581 else { /* cache[1] > *offsetp */
6582 /* We already know all of the way, now we may
6583 * be able to walk back. The same assumption
6584 * is made as in S_utf8_mg_pos(), namely that
6585 * walking backward is twice slower than
6586 * walking forward. */
6587 STRLEN forw = *offsetp;
6588 STRLEN backw = cache[1] - *offsetp;
6590 if (!(forw < 2 * backw)) {
6591 U8 *p = s + cache[1];
6598 while (UTF8_IS_CONTINUATION(*p)) {
6606 *offsetp = cache[0];
6608 /* Drop the stale "length" cache */
6616 ASSERT_UTF8_CACHE(cache);
6622 /* Call utf8n_to_uvchr() to validate the sequence
6623 * (unless a simple non-UTF character) */
6624 if (!UTF8_IS_INVARIANT(*s))
6625 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6634 if (!SvREADONLY(sv)) {
6636 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6637 mg = mg_find(sv, PERL_MAGIC_utf8);
6642 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6643 mg->mg_ptr = (char *) cache;
6648 cache[1] = *offsetp;
6649 /* Drop the stale "length" cache */
6662 Returns a boolean indicating whether the strings in the two SVs are
6663 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6664 coerce its args to strings if necessary.
6670 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6678 SV* svrecode = Nullsv;
6685 pv1 = SvPV(sv1, cur1);
6692 pv2 = SvPV(sv2, cur2);
6694 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6695 /* Differing utf8ness.
6696 * Do not UTF8size the comparands as a side-effect. */
6699 svrecode = newSVpvn(pv2, cur2);
6700 sv_recode_to_utf8(svrecode, PL_encoding);
6701 pv2 = SvPV(svrecode, cur2);
6704 svrecode = newSVpvn(pv1, cur1);
6705 sv_recode_to_utf8(svrecode, PL_encoding);
6706 pv1 = SvPV(svrecode, cur1);
6708 /* Now both are in UTF-8. */
6710 SvREFCNT_dec(svrecode);
6715 bool is_utf8 = TRUE;
6718 /* sv1 is the UTF-8 one,
6719 * if is equal it must be downgrade-able */
6720 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6726 /* sv2 is the UTF-8 one,
6727 * if is equal it must be downgrade-able */
6728 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6734 /* Downgrade not possible - cannot be eq */
6742 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6745 SvREFCNT_dec(svrecode);
6756 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6757 string in C<sv1> is less than, equal to, or greater than the string in
6758 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6759 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6765 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6768 const char *pv1, *pv2;
6771 SV *svrecode = Nullsv;
6778 pv1 = SvPV(sv1, cur1);
6785 pv2 = SvPV(sv2, cur2);
6787 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6788 /* Differing utf8ness.
6789 * Do not UTF8size the comparands as a side-effect. */
6792 svrecode = newSVpvn(pv2, cur2);
6793 sv_recode_to_utf8(svrecode, PL_encoding);
6794 pv2 = SvPV(svrecode, cur2);
6797 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6802 svrecode = newSVpvn(pv1, cur1);
6803 sv_recode_to_utf8(svrecode, PL_encoding);
6804 pv1 = SvPV(svrecode, cur1);
6807 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6813 cmp = cur2 ? -1 : 0;
6817 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6820 cmp = retval < 0 ? -1 : 1;
6821 } else if (cur1 == cur2) {
6824 cmp = cur1 < cur2 ? -1 : 1;
6829 SvREFCNT_dec(svrecode);
6838 =for apidoc sv_cmp_locale
6840 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6841 'use bytes' aware, handles get magic, and will coerce its args to strings
6842 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6848 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6850 #ifdef USE_LOCALE_COLLATE
6856 if (PL_collation_standard)
6860 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6862 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6864 if (!pv1 || !len1) {
6875 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6878 return retval < 0 ? -1 : 1;
6881 * When the result of collation is equality, that doesn't mean
6882 * that there are no differences -- some locales exclude some
6883 * characters from consideration. So to avoid false equalities,
6884 * we use the raw string as a tiebreaker.
6890 #endif /* USE_LOCALE_COLLATE */
6892 return sv_cmp(sv1, sv2);
6896 #ifdef USE_LOCALE_COLLATE
6899 =for apidoc sv_collxfrm
6901 Add Collate Transform magic to an SV if it doesn't already have it.
6903 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6904 scalar data of the variable, but transformed to such a format that a normal
6905 memory comparison can be used to compare the data according to the locale
6912 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6916 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6917 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6922 Safefree(mg->mg_ptr);
6924 if ((xf = mem_collxfrm(s, len, &xlen))) {
6925 if (SvREADONLY(sv)) {
6928 return xf + sizeof(PL_collation_ix);
6931 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6932 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6945 if (mg && mg->mg_ptr) {
6947 return mg->mg_ptr + sizeof(PL_collation_ix);
6955 #endif /* USE_LOCALE_COLLATE */
6960 Get a line from the filehandle and store it into the SV, optionally
6961 appending to the currently-stored string.
6967 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6971 register STDCHAR rslast;
6972 register STDCHAR *bp;
6978 if (SvTHINKFIRST(sv))
6979 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6980 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6982 However, perlbench says it's slower, because the existing swipe code
6983 is faster than copy on write.
6984 Swings and roundabouts. */
6985 (void)SvUPGRADE(sv, SVt_PV);
6990 if (PerlIO_isutf8(fp)) {
6992 sv_utf8_upgrade_nomg(sv);
6993 sv_pos_u2b(sv,&append,0);
6995 } else if (SvUTF8(sv)) {
6996 SV *tsv = NEWSV(0,0);
6997 sv_gets(tsv, fp, 0);
6998 sv_utf8_upgrade_nomg(tsv);
6999 SvCUR_set(sv,append);
7002 goto return_string_or_null;
7007 if (PerlIO_isutf8(fp))
7010 if (IN_PERL_COMPILETIME) {
7011 /* we always read code in line mode */
7015 else if (RsSNARF(PL_rs)) {
7016 /* If it is a regular disk file use size from stat() as estimate
7017 of amount we are going to read - may result in malloc-ing
7018 more memory than we realy need if layers bellow reduce
7019 size we read (e.g. CRLF or a gzip layer)
7022 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7023 const Off_t offset = PerlIO_tell(fp);
7024 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7025 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7031 else if (RsRECORD(PL_rs)) {
7035 /* Grab the size of the record we're getting */
7036 recsize = SvIV(SvRV(PL_rs));
7037 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7040 /* VMS wants read instead of fread, because fread doesn't respect */
7041 /* RMS record boundaries. This is not necessarily a good thing to be */
7042 /* doing, but we've got no other real choice - except avoid stdio
7043 as implementation - perhaps write a :vms layer ?
7045 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
7047 bytesread = PerlIO_read(fp, buffer, recsize);
7051 SvCUR_set(sv, bytesread += append);
7052 buffer[bytesread] = '\0';
7053 goto return_string_or_null;
7055 else if (RsPARA(PL_rs)) {
7061 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7062 if (PerlIO_isutf8(fp)) {
7063 rsptr = SvPVutf8(PL_rs, rslen);
7066 if (SvUTF8(PL_rs)) {
7067 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7068 Perl_croak(aTHX_ "Wide character in $/");
7071 rsptr = SvPV(PL_rs, rslen);
7075 rslast = rslen ? rsptr[rslen - 1] : '\0';
7077 if (rspara) { /* have to do this both before and after */
7078 do { /* to make sure file boundaries work right */
7081 i = PerlIO_getc(fp);
7085 PerlIO_ungetc(fp,i);
7091 /* See if we know enough about I/O mechanism to cheat it ! */
7093 /* This used to be #ifdef test - it is made run-time test for ease
7094 of abstracting out stdio interface. One call should be cheap
7095 enough here - and may even be a macro allowing compile
7099 if (PerlIO_fast_gets(fp)) {
7102 * We're going to steal some values from the stdio struct
7103 * and put EVERYTHING in the innermost loop into registers.
7105 register STDCHAR *ptr;
7109 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7110 /* An ungetc()d char is handled separately from the regular
7111 * buffer, so we getc() it back out and stuff it in the buffer.
7113 i = PerlIO_getc(fp);
7114 if (i == EOF) return 0;
7115 *(--((*fp)->_ptr)) = (unsigned char) i;
7119 /* Here is some breathtakingly efficient cheating */
7121 cnt = PerlIO_get_cnt(fp); /* get count into register */
7122 /* make sure we have the room */
7123 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7124 /* Not room for all of it
7125 if we are looking for a separator and room for some
7127 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7128 /* just process what we have room for */
7129 shortbuffered = cnt - SvLEN(sv) + append + 1;
7130 cnt -= shortbuffered;
7134 /* remember that cnt can be negative */
7135 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7140 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7141 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7142 DEBUG_P(PerlIO_printf(Perl_debug_log,
7143 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7144 DEBUG_P(PerlIO_printf(Perl_debug_log,
7145 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7146 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7147 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7152 while (cnt > 0) { /* this | eat */
7154 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7155 goto thats_all_folks; /* screams | sed :-) */
7159 Copy(ptr, bp, cnt, char); /* this | eat */
7160 bp += cnt; /* screams | dust */
7161 ptr += cnt; /* louder | sed :-) */
7166 if (shortbuffered) { /* oh well, must extend */
7167 cnt = shortbuffered;
7169 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7171 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7172 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7176 DEBUG_P(PerlIO_printf(Perl_debug_log,
7177 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7178 PTR2UV(ptr),(long)cnt));
7179 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7181 DEBUG_P(PerlIO_printf(Perl_debug_log,
7182 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7183 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7184 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7186 /* This used to call 'filbuf' in stdio form, but as that behaves like
7187 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7188 another abstraction. */
7189 i = PerlIO_getc(fp); /* get more characters */
7191 DEBUG_P(PerlIO_printf(Perl_debug_log,
7192 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7193 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7194 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7196 cnt = PerlIO_get_cnt(fp);
7197 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7198 DEBUG_P(PerlIO_printf(Perl_debug_log,
7199 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7201 if (i == EOF) /* all done for ever? */
7202 goto thats_really_all_folks;
7204 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7206 SvGROW(sv, bpx + cnt + 2);
7207 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7209 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7211 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7212 goto thats_all_folks;
7216 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7217 memNE((char*)bp - rslen, rsptr, rslen))
7218 goto screamer; /* go back to the fray */
7219 thats_really_all_folks:
7221 cnt += shortbuffered;
7222 DEBUG_P(PerlIO_printf(Perl_debug_log,
7223 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7224 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7225 DEBUG_P(PerlIO_printf(Perl_debug_log,
7226 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7227 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7228 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7230 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7231 DEBUG_P(PerlIO_printf(Perl_debug_log,
7232 "Screamer: done, len=%ld, string=|%.*s|\n",
7233 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7237 /*The big, slow, and stupid way. */
7238 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7240 New(0, buf, 8192, STDCHAR);
7248 const register STDCHAR *bpe = buf + sizeof(buf);
7250 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7251 ; /* keep reading */
7255 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7256 /* Accomodate broken VAXC compiler, which applies U8 cast to
7257 * both args of ?: operator, causing EOF to change into 255
7260 i = (U8)buf[cnt - 1];
7266 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7268 sv_catpvn(sv, (char *) buf, cnt);
7270 sv_setpvn(sv, (char *) buf, cnt);
7272 if (i != EOF && /* joy */
7274 SvCUR(sv) < rslen ||
7275 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7279 * If we're reading from a TTY and we get a short read,
7280 * indicating that the user hit his EOF character, we need
7281 * to notice it now, because if we try to read from the TTY
7282 * again, the EOF condition will disappear.
7284 * The comparison of cnt to sizeof(buf) is an optimization
7285 * that prevents unnecessary calls to feof().
7289 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7293 #ifdef USE_HEAP_INSTEAD_OF_STACK
7298 if (rspara) { /* have to do this both before and after */
7299 while (i != EOF) { /* to make sure file boundaries work right */
7300 i = PerlIO_getc(fp);
7302 PerlIO_ungetc(fp,i);
7308 return_string_or_null:
7309 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7315 Auto-increment of the value in the SV, doing string to numeric conversion
7316 if necessary. Handles 'get' magic.
7322 Perl_sv_inc(pTHX_ register SV *sv)
7331 if (SvTHINKFIRST(sv)) {
7333 sv_force_normal_flags(sv, 0);
7334 if (SvREADONLY(sv)) {
7335 if (IN_PERL_RUNTIME)
7336 Perl_croak(aTHX_ PL_no_modify);
7340 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7342 i = PTR2IV(SvRV(sv));
7347 flags = SvFLAGS(sv);
7348 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7349 /* It's (privately or publicly) a float, but not tested as an
7350 integer, so test it to see. */
7352 flags = SvFLAGS(sv);
7354 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7355 /* It's publicly an integer, or privately an integer-not-float */
7356 #ifdef PERL_PRESERVE_IVUV
7360 if (SvUVX(sv) == UV_MAX)
7361 sv_setnv(sv, UV_MAX_P1);
7363 (void)SvIOK_only_UV(sv);
7364 SvUV_set(sv, SvUVX(sv) + 1);
7366 if (SvIVX(sv) == IV_MAX)
7367 sv_setuv(sv, (UV)IV_MAX + 1);
7369 (void)SvIOK_only(sv);
7370 SvIV_set(sv, SvIVX(sv) + 1);
7375 if (flags & SVp_NOK) {
7376 (void)SvNOK_only(sv);
7377 SvNV_set(sv, SvNVX(sv) + 1.0);
7381 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7382 if ((flags & SVTYPEMASK) < SVt_PVIV)
7383 sv_upgrade(sv, SVt_IV);
7384 (void)SvIOK_only(sv);
7389 while (isALPHA(*d)) d++;
7390 while (isDIGIT(*d)) d++;
7392 #ifdef PERL_PRESERVE_IVUV
7393 /* Got to punt this as an integer if needs be, but we don't issue
7394 warnings. Probably ought to make the sv_iv_please() that does
7395 the conversion if possible, and silently. */
7396 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7397 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7398 /* Need to try really hard to see if it's an integer.
7399 9.22337203685478e+18 is an integer.
7400 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7401 so $a="9.22337203685478e+18"; $a+0; $a++
7402 needs to be the same as $a="9.22337203685478e+18"; $a++
7409 /* sv_2iv *should* have made this an NV */
7410 if (flags & SVp_NOK) {
7411 (void)SvNOK_only(sv);
7412 SvNV_set(sv, SvNVX(sv) + 1.0);
7415 /* I don't think we can get here. Maybe I should assert this
7416 And if we do get here I suspect that sv_setnv will croak. NWC
7418 #if defined(USE_LONG_DOUBLE)
7419 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",
7420 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7422 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7423 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7426 #endif /* PERL_PRESERVE_IVUV */
7427 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7431 while (d >= SvPVX(sv)) {
7439 /* MKS: The original code here died if letters weren't consecutive.
7440 * at least it didn't have to worry about non-C locales. The
7441 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7442 * arranged in order (although not consecutively) and that only
7443 * [A-Za-z] are accepted by isALPHA in the C locale.
7445 if (*d != 'z' && *d != 'Z') {
7446 do { ++*d; } while (!isALPHA(*d));
7449 *(d--) -= 'z' - 'a';
7454 *(d--) -= 'z' - 'a' + 1;
7458 /* oh,oh, the number grew */
7459 SvGROW(sv, SvCUR(sv) + 2);
7460 SvCUR_set(sv, SvCUR(sv) + 1);
7461 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7472 Auto-decrement of the value in the SV, doing string to numeric conversion
7473 if necessary. Handles 'get' magic.
7479 Perl_sv_dec(pTHX_ register SV *sv)
7487 if (SvTHINKFIRST(sv)) {
7489 sv_force_normal_flags(sv, 0);
7490 if (SvREADONLY(sv)) {
7491 if (IN_PERL_RUNTIME)
7492 Perl_croak(aTHX_ PL_no_modify);
7496 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7498 i = PTR2IV(SvRV(sv));
7503 /* Unlike sv_inc we don't have to worry about string-never-numbers
7504 and keeping them magic. But we mustn't warn on punting */
7505 flags = SvFLAGS(sv);
7506 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7507 /* It's publicly an integer, or privately an integer-not-float */
7508 #ifdef PERL_PRESERVE_IVUV
7512 if (SvUVX(sv) == 0) {
7513 (void)SvIOK_only(sv);
7517 (void)SvIOK_only_UV(sv);
7518 SvUV_set(sv, SvUVX(sv) + 1);
7521 if (SvIVX(sv) == IV_MIN)
7522 sv_setnv(sv, (NV)IV_MIN - 1.0);
7524 (void)SvIOK_only(sv);
7525 SvIV_set(sv, SvIVX(sv) - 1);
7530 if (flags & SVp_NOK) {
7531 SvNV_set(sv, SvNVX(sv) - 1.0);
7532 (void)SvNOK_only(sv);
7535 if (!(flags & SVp_POK)) {
7536 if ((flags & SVTYPEMASK) < SVt_PVNV)
7537 sv_upgrade(sv, SVt_NV);
7539 (void)SvNOK_only(sv);
7542 #ifdef PERL_PRESERVE_IVUV
7544 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7545 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7546 /* Need to try really hard to see if it's an integer.
7547 9.22337203685478e+18 is an integer.
7548 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7549 so $a="9.22337203685478e+18"; $a+0; $a--
7550 needs to be the same as $a="9.22337203685478e+18"; $a--
7557 /* sv_2iv *should* have made this an NV */
7558 if (flags & SVp_NOK) {
7559 (void)SvNOK_only(sv);
7560 SvNV_set(sv, SvNVX(sv) - 1.0);
7563 /* I don't think we can get here. Maybe I should assert this
7564 And if we do get here I suspect that sv_setnv will croak. NWC
7566 #if defined(USE_LONG_DOUBLE)
7567 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",
7568 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7571 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7575 #endif /* PERL_PRESERVE_IVUV */
7576 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7580 =for apidoc sv_mortalcopy
7582 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7583 The new SV is marked as mortal. It will be destroyed "soon", either by an
7584 explicit call to FREETMPS, or by an implicit call at places such as
7585 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7590 /* Make a string that will exist for the duration of the expression
7591 * evaluation. Actually, it may have to last longer than that, but
7592 * hopefully we won't free it until it has been assigned to a
7593 * permanent location. */
7596 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7601 sv_setsv(sv,oldstr);
7603 PL_tmps_stack[++PL_tmps_ix] = sv;
7609 =for apidoc sv_newmortal
7611 Creates a new null SV which is mortal. The reference count of the SV is
7612 set to 1. It will be destroyed "soon", either by an explicit call to
7613 FREETMPS, or by an implicit call at places such as statement boundaries.
7614 See also C<sv_mortalcopy> and C<sv_2mortal>.
7620 Perl_sv_newmortal(pTHX)
7625 SvFLAGS(sv) = SVs_TEMP;
7627 PL_tmps_stack[++PL_tmps_ix] = sv;
7632 =for apidoc sv_2mortal
7634 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7635 by an explicit call to FREETMPS, or by an implicit call at places such as
7636 statement boundaries. SvTEMP() is turned on which means that the SV's
7637 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7638 and C<sv_mortalcopy>.
7644 Perl_sv_2mortal(pTHX_ register SV *sv)
7649 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7652 PL_tmps_stack[++PL_tmps_ix] = sv;
7660 Creates a new SV and copies a string into it. The reference count for the
7661 SV is set to 1. If C<len> is zero, Perl will compute the length using
7662 strlen(). For efficiency, consider using C<newSVpvn> instead.
7668 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7675 sv_setpvn(sv,s,len);
7680 =for apidoc newSVpvn
7682 Creates a new SV and copies a string into it. The reference count for the
7683 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7684 string. You are responsible for ensuring that the source string is at least
7685 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7691 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7696 sv_setpvn(sv,s,len);
7701 =for apidoc newSVpvn_share
7703 Creates a new SV with its SvPVX pointing to a shared string in the string
7704 table. If the string does not already exist in the table, it is created
7705 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7706 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7707 otherwise the hash is computed. The idea here is that as the string table
7708 is used for shared hash keys these strings will have SvPVX == HeKEY and
7709 hash lookup will avoid string compare.
7715 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7718 bool is_utf8 = FALSE;
7720 STRLEN tmplen = -len;
7722 /* See the note in hv.c:hv_fetch() --jhi */
7723 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7727 PERL_HASH(hash, src, len);
7729 sv_upgrade(sv, SVt_PVIV);
7730 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7743 #if defined(PERL_IMPLICIT_CONTEXT)
7745 /* pTHX_ magic can't cope with varargs, so this is a no-context
7746 * version of the main function, (which may itself be aliased to us).
7747 * Don't access this version directly.
7751 Perl_newSVpvf_nocontext(const char* pat, ...)
7756 va_start(args, pat);
7757 sv = vnewSVpvf(pat, &args);
7764 =for apidoc newSVpvf
7766 Creates a new SV and initializes it with the string formatted like
7773 Perl_newSVpvf(pTHX_ const char* pat, ...)
7777 va_start(args, pat);
7778 sv = vnewSVpvf(pat, &args);
7783 /* backend for newSVpvf() and newSVpvf_nocontext() */
7786 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7790 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7797 Creates a new SV and copies a floating point value into it.
7798 The reference count for the SV is set to 1.
7804 Perl_newSVnv(pTHX_ NV n)
7816 Creates a new SV and copies an integer into it. The reference count for the
7823 Perl_newSViv(pTHX_ IV i)
7835 Creates a new SV and copies an unsigned integer into it.
7836 The reference count for the SV is set to 1.
7842 Perl_newSVuv(pTHX_ UV u)
7852 =for apidoc newRV_noinc
7854 Creates an RV wrapper for an SV. The reference count for the original
7855 SV is B<not> incremented.
7861 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7866 sv_upgrade(sv, SVt_RV);
7868 SvRV_set(sv, tmpRef);
7873 /* newRV_inc is the official function name to use now.
7874 * newRV_inc is in fact #defined to newRV in sv.h
7878 Perl_newRV(pTHX_ SV *tmpRef)
7880 return newRV_noinc(SvREFCNT_inc(tmpRef));
7886 Creates a new SV which is an exact duplicate of the original SV.
7893 Perl_newSVsv(pTHX_ register SV *old)
7899 if (SvTYPE(old) == SVTYPEMASK) {
7900 if (ckWARN_d(WARN_INTERNAL))
7901 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7905 /* SV_GMAGIC is the default for sv_setv()
7906 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7907 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7908 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7913 =for apidoc sv_reset
7915 Underlying implementation for the C<reset> Perl function.
7916 Note that the perl-level function is vaguely deprecated.
7922 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7931 char todo[PERL_UCHAR_MAX+1];
7936 if (!*s) { /* reset ?? searches */
7937 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7938 pm->op_pmdynflags &= ~PMdf_USED;
7943 /* reset variables */
7945 if (!HvARRAY(stash))
7948 Zero(todo, 256, char);
7950 i = (unsigned char)*s;
7954 max = (unsigned char)*s++;
7955 for ( ; i <= max; i++) {
7958 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7959 for (entry = HvARRAY(stash)[i];
7961 entry = HeNEXT(entry))
7963 if (!todo[(U8)*HeKEY(entry)])
7965 gv = (GV*)HeVAL(entry);
7967 if (SvTHINKFIRST(sv)) {
7968 if (!SvREADONLY(sv) && SvROK(sv))
7973 if (SvTYPE(sv) >= SVt_PV) {
7975 if (SvPVX(sv) != Nullch)
7982 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7985 #ifdef USE_ENVIRON_ARRAY
7987 # ifdef USE_ITHREADS
7988 && PL_curinterp == aTHX
7992 environ[0] = Nullch;
7995 #endif /* !PERL_MICRO */
8005 Using various gambits, try to get an IO from an SV: the IO slot if its a
8006 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8007 named after the PV if we're a string.
8013 Perl_sv_2io(pTHX_ SV *sv)
8018 switch (SvTYPE(sv)) {
8026 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8030 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8032 return sv_2io(SvRV(sv));
8033 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
8039 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
8048 Using various gambits, try to get a CV from an SV; in addition, try if
8049 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8055 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
8062 return *gvp = Nullgv, Nullcv;
8063 switch (SvTYPE(sv)) {
8082 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8083 tryAMAGICunDEREF(to_cv);
8086 if (SvTYPE(sv) == SVt_PVCV) {
8095 Perl_croak(aTHX_ "Not a subroutine reference");
8100 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8106 if (lref && !GvCVu(gv)) {
8109 tmpsv = NEWSV(704,0);
8110 gv_efullname3(tmpsv, gv, Nullch);
8111 /* XXX this is probably not what they think they're getting.
8112 * It has the same effect as "sub name;", i.e. just a forward
8114 newSUB(start_subparse(FALSE, 0),
8115 newSVOP(OP_CONST, 0, tmpsv),
8120 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8130 Returns true if the SV has a true value by Perl's rules.
8131 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8132 instead use an in-line version.
8138 Perl_sv_true(pTHX_ register SV *sv)
8143 const register XPV* tXpv;
8144 if ((tXpv = (XPV*)SvANY(sv)) &&
8145 (tXpv->xpv_cur > 1 ||
8146 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8153 return SvIVX(sv) != 0;
8156 return SvNVX(sv) != 0.0;
8158 return sv_2bool(sv);
8166 A private implementation of the C<SvIVx> macro for compilers which can't
8167 cope with complex macro expressions. Always use the macro instead.
8173 Perl_sv_iv(pTHX_ register SV *sv)
8177 return (IV)SvUVX(sv);
8186 A private implementation of the C<SvUVx> macro for compilers which can't
8187 cope with complex macro expressions. Always use the macro instead.
8193 Perl_sv_uv(pTHX_ register SV *sv)
8198 return (UV)SvIVX(sv);
8206 A private implementation of the C<SvNVx> macro for compilers which can't
8207 cope with complex macro expressions. Always use the macro instead.
8213 Perl_sv_nv(pTHX_ register SV *sv)
8220 /* sv_pv() is now a macro using SvPV_nolen();
8221 * this function provided for binary compatibility only
8225 Perl_sv_pv(pTHX_ SV *sv)
8232 return sv_2pv(sv, &n_a);
8238 Use the C<SvPV_nolen> macro instead
8242 A private implementation of the C<SvPV> macro for compilers which can't
8243 cope with complex macro expressions. Always use the macro instead.
8249 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8255 return sv_2pv(sv, lp);
8260 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8266 return sv_2pv_flags(sv, lp, 0);
8269 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8270 * this function provided for binary compatibility only
8274 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8276 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8280 =for apidoc sv_pvn_force
8282 Get a sensible string out of the SV somehow.
8283 A private implementation of the C<SvPV_force> macro for compilers which
8284 can't cope with complex macro expressions. Always use the macro instead.
8286 =for apidoc sv_pvn_force_flags
8288 Get a sensible string out of the SV somehow.
8289 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8290 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8291 implemented in terms of this function.
8292 You normally want to use the various wrapper macros instead: see
8293 C<SvPV_force> and C<SvPV_force_nomg>
8299 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8302 if (SvTHINKFIRST(sv) && !SvROK(sv))
8303 sv_force_normal_flags(sv, 0);
8310 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8311 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8315 s = sv_2pv_flags(sv, lp, flags);
8316 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8317 const STRLEN len = *lp;
8321 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8322 SvGROW(sv, len + 1);
8323 Move(s,SvPVX(sv),len,char);
8328 SvPOK_on(sv); /* validate pointer */
8330 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8331 PTR2UV(sv),SvPVX(sv)));
8337 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8338 * this function provided for binary compatibility only
8342 Perl_sv_pvbyte(pTHX_ SV *sv)
8344 sv_utf8_downgrade(sv,0);
8349 =for apidoc sv_pvbyte
8351 Use C<SvPVbyte_nolen> instead.
8353 =for apidoc sv_pvbyten
8355 A private implementation of the C<SvPVbyte> macro for compilers
8356 which can't cope with complex macro expressions. Always use the macro
8363 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8365 sv_utf8_downgrade(sv,0);
8366 return sv_pvn(sv,lp);
8370 =for apidoc sv_pvbyten_force
8372 A private implementation of the C<SvPVbytex_force> macro for compilers
8373 which can't cope with complex macro expressions. Always use the macro
8380 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8382 sv_pvn_force(sv,lp);
8383 sv_utf8_downgrade(sv,0);
8388 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8389 * this function provided for binary compatibility only
8393 Perl_sv_pvutf8(pTHX_ SV *sv)
8395 sv_utf8_upgrade(sv);
8400 =for apidoc sv_pvutf8
8402 Use the C<SvPVutf8_nolen> macro instead
8404 =for apidoc sv_pvutf8n
8406 A private implementation of the C<SvPVutf8> macro for compilers
8407 which can't cope with complex macro expressions. Always use the macro
8414 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8416 sv_utf8_upgrade(sv);
8417 return sv_pvn(sv,lp);
8421 =for apidoc sv_pvutf8n_force
8423 A private implementation of the C<SvPVutf8_force> macro for compilers
8424 which can't cope with complex macro expressions. Always use the macro
8431 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8433 sv_pvn_force(sv,lp);
8434 sv_utf8_upgrade(sv);
8440 =for apidoc sv_reftype
8442 Returns a string describing what the SV is a reference to.
8448 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8450 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8451 inside return suggests a const propagation bug in g++. */
8452 if (ob && SvOBJECT(sv)) {
8453 char *name = HvNAME(SvSTASH(sv));
8454 return name ? name : (char *) "__ANON__";
8457 switch (SvTYPE(sv)) {
8474 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8475 /* tied lvalues should appear to be
8476 * scalars for backwards compatitbility */
8477 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8478 ? "SCALAR" : "LVALUE");
8479 case SVt_PVAV: return "ARRAY";
8480 case SVt_PVHV: return "HASH";
8481 case SVt_PVCV: return "CODE";
8482 case SVt_PVGV: return "GLOB";
8483 case SVt_PVFM: return "FORMAT";
8484 case SVt_PVIO: return "IO";
8485 default: return "UNKNOWN";
8491 =for apidoc sv_isobject
8493 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8494 object. If the SV is not an RV, or if the object is not blessed, then this
8501 Perl_sv_isobject(pTHX_ SV *sv)
8518 Returns a boolean indicating whether the SV is blessed into the specified
8519 class. This does not check for subtypes; use C<sv_derived_from> to verify
8520 an inheritance relationship.
8526 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8537 if (!HvNAME(SvSTASH(sv)))
8540 return strEQ(HvNAME(SvSTASH(sv)), name);
8546 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8547 it will be upgraded to one. If C<classname> is non-null then the new SV will
8548 be blessed in the specified package. The new SV is returned and its
8549 reference count is 1.
8555 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8561 SV_CHECK_THINKFIRST_COW_DROP(rv);
8564 if (SvTYPE(rv) >= SVt_PVMG) {
8565 const U32 refcnt = SvREFCNT(rv);
8569 SvREFCNT(rv) = refcnt;
8572 if (SvTYPE(rv) < SVt_RV)
8573 sv_upgrade(rv, SVt_RV);
8574 else if (SvTYPE(rv) > SVt_RV) {
8585 HV* stash = gv_stashpv(classname, TRUE);
8586 (void)sv_bless(rv, stash);
8592 =for apidoc sv_setref_pv
8594 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8595 argument will be upgraded to an RV. That RV will be modified to point to
8596 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8597 into the SV. The C<classname> argument indicates the package for the
8598 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8599 will have a reference count of 1, and the RV will be returned.
8601 Do not use with other Perl types such as HV, AV, SV, CV, because those
8602 objects will become corrupted by the pointer copy process.
8604 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8610 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8613 sv_setsv(rv, &PL_sv_undef);
8617 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8622 =for apidoc sv_setref_iv
8624 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8625 argument will be upgraded to an RV. That RV will be modified to point to
8626 the new SV. The C<classname> argument indicates the package for the
8627 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8628 will have a reference count of 1, and the RV will be returned.
8634 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8636 sv_setiv(newSVrv(rv,classname), iv);
8641 =for apidoc sv_setref_uv
8643 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8644 argument will be upgraded to an RV. That RV will be modified to point to
8645 the new SV. The C<classname> argument indicates the package for the
8646 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8647 will have a reference count of 1, and the RV will be returned.
8653 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8655 sv_setuv(newSVrv(rv,classname), uv);
8660 =for apidoc sv_setref_nv
8662 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8663 argument will be upgraded to an RV. That RV will be modified to point to
8664 the new SV. The C<classname> argument indicates the package for the
8665 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8666 will have a reference count of 1, and the RV will be returned.
8672 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8674 sv_setnv(newSVrv(rv,classname), nv);
8679 =for apidoc sv_setref_pvn
8681 Copies a string into a new SV, optionally blessing the SV. The length of the
8682 string must be specified with C<n>. The C<rv> argument will be upgraded to
8683 an RV. That RV will be modified to point to the new SV. The C<classname>
8684 argument indicates the package for the blessing. Set C<classname> to
8685 C<Nullch> to avoid the blessing. The new SV will have a reference count
8686 of 1, and the RV will be returned.
8688 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8694 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8696 sv_setpvn(newSVrv(rv,classname), pv, n);
8701 =for apidoc sv_bless
8703 Blesses an SV into a specified package. The SV must be an RV. The package
8704 must be designated by its stash (see C<gv_stashpv()>). The reference count
8705 of the SV is unaffected.
8711 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8715 Perl_croak(aTHX_ "Can't bless non-reference value");
8717 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8718 if (SvREADONLY(tmpRef))
8719 Perl_croak(aTHX_ PL_no_modify);
8720 if (SvOBJECT(tmpRef)) {
8721 if (SvTYPE(tmpRef) != SVt_PVIO)
8723 SvREFCNT_dec(SvSTASH(tmpRef));
8726 SvOBJECT_on(tmpRef);
8727 if (SvTYPE(tmpRef) != SVt_PVIO)
8729 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8730 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8737 if(SvSMAGICAL(tmpRef))
8738 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8746 /* Downgrades a PVGV to a PVMG.
8750 S_sv_unglob(pTHX_ SV *sv)
8754 assert(SvTYPE(sv) == SVt_PVGV);
8759 SvREFCNT_dec(GvSTASH(sv));
8760 GvSTASH(sv) = Nullhv;
8762 sv_unmagic(sv, PERL_MAGIC_glob);
8763 Safefree(GvNAME(sv));
8766 /* need to keep SvANY(sv) in the right arena */
8767 xpvmg = new_XPVMG();
8768 StructCopy(SvANY(sv), xpvmg, XPVMG);
8769 del_XPVGV(SvANY(sv));
8772 SvFLAGS(sv) &= ~SVTYPEMASK;
8773 SvFLAGS(sv) |= SVt_PVMG;
8777 =for apidoc sv_unref_flags
8779 Unsets the RV status of the SV, and decrements the reference count of
8780 whatever was being referenced by the RV. This can almost be thought of
8781 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8782 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8783 (otherwise the decrementing is conditional on the reference count being
8784 different from one or the reference being a readonly SV).
8791 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8795 if (SvWEAKREF(sv)) {
8803 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8804 assigned to as BEGIN {$a = \"Foo"} will fail. */
8805 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8807 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8808 sv_2mortal(rv); /* Schedule for freeing later */
8812 =for apidoc sv_unref
8814 Unsets the RV status of the SV, and decrements the reference count of
8815 whatever was being referenced by the RV. This can almost be thought of
8816 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8817 being zero. See C<SvROK_off>.
8823 Perl_sv_unref(pTHX_ SV *sv)
8825 sv_unref_flags(sv, 0);
8829 =for apidoc sv_taint
8831 Taint an SV. Use C<SvTAINTED_on> instead.
8836 Perl_sv_taint(pTHX_ SV *sv)
8838 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8842 =for apidoc sv_untaint
8844 Untaint an SV. Use C<SvTAINTED_off> instead.
8849 Perl_sv_untaint(pTHX_ SV *sv)
8851 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8852 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8859 =for apidoc sv_tainted
8861 Test an SV for taintedness. Use C<SvTAINTED> instead.
8866 Perl_sv_tainted(pTHX_ SV *sv)
8868 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8869 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8870 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8877 =for apidoc sv_setpviv
8879 Copies an integer into the given SV, also updating its string value.
8880 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8886 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8888 char buf[TYPE_CHARS(UV)];
8890 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8892 sv_setpvn(sv, ptr, ebuf - ptr);
8896 =for apidoc sv_setpviv_mg
8898 Like C<sv_setpviv>, but also handles 'set' magic.
8904 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8906 char buf[TYPE_CHARS(UV)];
8908 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8910 sv_setpvn(sv, ptr, ebuf - ptr);
8914 #if defined(PERL_IMPLICIT_CONTEXT)
8916 /* pTHX_ magic can't cope with varargs, so this is a no-context
8917 * version of the main function, (which may itself be aliased to us).
8918 * Don't access this version directly.
8922 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8926 va_start(args, pat);
8927 sv_vsetpvf(sv, pat, &args);
8931 /* pTHX_ magic can't cope with varargs, so this is a no-context
8932 * version of the main function, (which may itself be aliased to us).
8933 * Don't access this version directly.
8937 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8941 va_start(args, pat);
8942 sv_vsetpvf_mg(sv, pat, &args);
8948 =for apidoc sv_setpvf
8950 Works like C<sv_catpvf> but copies the text into the SV instead of
8951 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8957 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8960 va_start(args, pat);
8961 sv_vsetpvf(sv, pat, &args);
8966 =for apidoc sv_vsetpvf
8968 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8969 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8971 Usually used via its frontend C<sv_setpvf>.
8977 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8979 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8983 =for apidoc sv_setpvf_mg
8985 Like C<sv_setpvf>, but also handles 'set' magic.
8991 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8994 va_start(args, pat);
8995 sv_vsetpvf_mg(sv, pat, &args);
9000 =for apidoc sv_vsetpvf_mg
9002 Like C<sv_vsetpvf>, but also handles 'set' magic.
9004 Usually used via its frontend C<sv_setpvf_mg>.
9010 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9012 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9016 #if defined(PERL_IMPLICIT_CONTEXT)
9018 /* pTHX_ magic can't cope with varargs, so this is a no-context
9019 * version of the main function, (which may itself be aliased to us).
9020 * Don't access this version directly.
9024 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
9028 va_start(args, pat);
9029 sv_vcatpvf(sv, pat, &args);
9033 /* pTHX_ magic can't cope with varargs, so this is a no-context
9034 * version of the main function, (which may itself be aliased to us).
9035 * Don't access this version directly.
9039 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
9043 va_start(args, pat);
9044 sv_vcatpvf_mg(sv, pat, &args);
9050 =for apidoc sv_catpvf
9052 Processes its arguments like C<sprintf> and appends the formatted
9053 output to an SV. If the appended data contains "wide" characters
9054 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9055 and characters >255 formatted with %c), the original SV might get
9056 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9057 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9058 valid UTF-8; if the original SV was bytes, the pattern should be too.
9063 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
9066 va_start(args, pat);
9067 sv_vcatpvf(sv, pat, &args);
9072 =for apidoc sv_vcatpvf
9074 Processes its arguments like C<vsprintf> and appends the formatted output
9075 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9077 Usually used via its frontend C<sv_catpvf>.
9083 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9085 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9089 =for apidoc sv_catpvf_mg
9091 Like C<sv_catpvf>, but also handles 'set' magic.
9097 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9100 va_start(args, pat);
9101 sv_vcatpvf_mg(sv, pat, &args);
9106 =for apidoc sv_vcatpvf_mg
9108 Like C<sv_vcatpvf>, but also handles 'set' magic.
9110 Usually used via its frontend C<sv_catpvf_mg>.
9116 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9118 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9123 =for apidoc sv_vsetpvfn
9125 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9128 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9134 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9136 sv_setpvn(sv, "", 0);
9137 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9140 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9143 S_expect_number(pTHX_ char** pattern)
9146 switch (**pattern) {
9147 case '1': case '2': case '3':
9148 case '4': case '5': case '6':
9149 case '7': case '8': case '9':
9150 while (isDIGIT(**pattern))
9151 var = var * 10 + (*(*pattern)++ - '0');
9155 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9158 F0convert(NV nv, char *endbuf, STRLEN *len)
9160 const int neg = nv < 0;
9169 if (uv & 1 && uv == nv)
9170 uv--; /* Round to even */
9172 const unsigned dig = uv % 10;
9185 =for apidoc sv_vcatpvfn
9187 Processes its arguments like C<vsprintf> and appends the formatted output
9188 to an SV. Uses an array of SVs if the C style variable argument list is
9189 missing (NULL). When running with taint checks enabled, indicates via
9190 C<maybe_tainted> if results are untrustworthy (often due to the use of
9193 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9198 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9201 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9208 static const char nullstr[] = "(null)";
9210 bool has_utf8; /* has the result utf8? */
9211 bool pat_utf8; /* the pattern is in utf8? */
9213 /* Times 4: a decimal digit takes more than 3 binary digits.
9214 * NV_DIG: mantissa takes than many decimal digits.
9215 * Plus 32: Playing safe. */
9216 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9217 /* large enough for "%#.#f" --chip */
9218 /* what about long double NVs? --jhi */
9220 has_utf8 = pat_utf8 = DO_UTF8(sv);
9222 /* no matter what, this is a string now */
9223 (void)SvPV_force(sv, origlen);
9225 /* special-case "", "%s", and "%-p" (SVf) */
9228 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9230 const char *s = va_arg(*args, char*);
9231 sv_catpv(sv, s ? s : nullstr);
9233 else if (svix < svmax) {
9234 sv_catsv(sv, *svargs);
9235 if (DO_UTF8(*svargs))
9240 if (patlen == 3 && pat[0] == '%' &&
9241 pat[1] == '-' && pat[2] == 'p') {
9243 argsv = va_arg(*args, SV*);
9244 sv_catsv(sv, argsv);
9251 #ifndef USE_LONG_DOUBLE
9252 /* special-case "%.<number>[gf]" */
9253 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9254 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9255 unsigned digits = 0;
9259 while (*pp >= '0' && *pp <= '9')
9260 digits = 10 * digits + (*pp++ - '0');
9261 if (pp - pat == (int)patlen - 1) {
9265 nv = (NV)va_arg(*args, double);
9266 else if (svix < svmax)
9271 /* Add check for digits != 0 because it seems that some
9272 gconverts are buggy in this case, and we don't yet have
9273 a Configure test for this. */
9274 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9275 /* 0, point, slack */
9276 Gconvert(nv, (int)digits, 0, ebuf);
9278 if (*ebuf) /* May return an empty string for digits==0 */
9281 } else if (!digits) {
9284 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9285 sv_catpvn(sv, p, l);
9291 #endif /* !USE_LONG_DOUBLE */
9293 if (!args && svix < svmax && DO_UTF8(*svargs))
9296 patend = (char*)pat + patlen;
9297 for (p = (char*)pat; p < patend; p = q) {
9300 bool vectorize = FALSE;
9301 bool vectorarg = FALSE;
9302 bool vec_utf8 = FALSE;
9308 bool has_precis = FALSE;
9311 bool is_utf8 = FALSE; /* is this item utf8? */
9312 #ifdef HAS_LDBL_SPRINTF_BUG
9313 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9314 with sfio - Allen <allens@cpan.org> */
9315 bool fix_ldbl_sprintf_bug = FALSE;
9319 U8 utf8buf[UTF8_MAXBYTES+1];
9320 STRLEN esignlen = 0;
9322 char *eptr = Nullch;
9325 U8 *vecstr = Null(U8*);
9332 /* we need a long double target in case HAS_LONG_DOUBLE but
9335 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9343 const char *dotstr = ".";
9344 STRLEN dotstrlen = 1;
9345 I32 efix = 0; /* explicit format parameter index */
9346 I32 ewix = 0; /* explicit width index */
9347 I32 epix = 0; /* explicit precision index */
9348 I32 evix = 0; /* explicit vector index */
9349 bool asterisk = FALSE;
9351 /* echo everything up to the next format specification */
9352 for (q = p; q < patend && *q != '%'; ++q) ;
9354 if (has_utf8 && !pat_utf8)
9355 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9357 sv_catpvn(sv, p, q - p);
9364 We allow format specification elements in this order:
9365 \d+\$ explicit format parameter index
9367 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9368 0 flag (as above): repeated to allow "v02"
9369 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9370 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9372 [%bcdefginopsux_DFOUX] format (mandatory)
9374 if (EXPECT_NUMBER(q, width)) {
9415 if (EXPECT_NUMBER(q, ewix))
9424 if ((vectorarg = asterisk)) {
9436 EXPECT_NUMBER(q, width);
9441 vecsv = va_arg(*args, SV*);
9443 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9444 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9445 dotstr = SvPVx(vecsv, dotstrlen);
9450 vecsv = va_arg(*args, SV*);
9451 vecstr = (U8*)SvPVx(vecsv,veclen);
9452 vec_utf8 = DO_UTF8(vecsv);
9454 else if (efix ? efix <= svmax : svix < svmax) {
9455 vecsv = svargs[efix ? efix-1 : svix++];
9456 vecstr = (U8*)SvPVx(vecsv,veclen);
9457 vec_utf8 = DO_UTF8(vecsv);
9458 /* if this is a version object, we need to return the
9459 * stringified representation (which the SvPVX has
9460 * already done for us), but not vectorize the args
9462 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9464 q++; /* skip past the rest of the %vd format */
9465 eptr = (char *) vecstr;
9466 elen = strlen(eptr);
9479 i = va_arg(*args, int);
9481 i = (ewix ? ewix <= svmax : svix < svmax) ?
9482 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9484 width = (i < 0) ? -i : i;
9494 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9496 /* XXX: todo, support specified precision parameter */
9500 i = va_arg(*args, int);
9502 i = (ewix ? ewix <= svmax : svix < svmax)
9503 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9504 precis = (i < 0) ? 0 : i;
9509 precis = precis * 10 + (*q++ - '0');
9518 case 'I': /* Ix, I32x, and I64x */
9520 if (q[1] == '6' && q[2] == '4') {
9526 if (q[1] == '3' && q[2] == '2') {
9536 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9547 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9548 if (*(q + 1) == 'l') { /* lld, llf */
9573 argsv = (efix ? efix <= svmax : svix < svmax) ?
9574 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9581 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9583 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9585 eptr = (char*)utf8buf;
9586 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9597 if (args && !vectorize) {
9598 eptr = va_arg(*args, char*);
9600 #ifdef MACOS_TRADITIONAL
9601 /* On MacOS, %#s format is used for Pascal strings */
9606 elen = strlen(eptr);
9608 eptr = (char *)nullstr;
9609 elen = sizeof nullstr - 1;
9613 eptr = SvPVx(argsv, elen);
9614 if (DO_UTF8(argsv)) {
9615 if (has_precis && precis < elen) {
9617 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9620 if (width) { /* fudge width (can't fudge elen) */
9621 width += elen - sv_len_utf8(argsv);
9629 if (has_precis && elen > precis)
9636 if (left && args) { /* SVf */
9645 argsv = va_arg(*args, SV*);
9646 eptr = SvPVx(argsv, elen);
9651 if (alt || vectorize)
9653 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9671 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9680 esignbuf[esignlen++] = plus;
9684 case 'h': iv = (short)va_arg(*args, int); break;
9685 case 'l': iv = va_arg(*args, long); break;
9686 case 'V': iv = va_arg(*args, IV); break;
9687 default: iv = va_arg(*args, int); break;
9689 case 'q': iv = va_arg(*args, Quad_t); break;
9694 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9696 case 'h': iv = (short)tiv; break;
9697 case 'l': iv = (long)tiv; break;
9699 default: iv = tiv; break;
9701 case 'q': iv = (Quad_t)tiv; break;
9705 if ( !vectorize ) /* we already set uv above */
9710 esignbuf[esignlen++] = plus;
9714 esignbuf[esignlen++] = '-';
9757 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9768 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9769 case 'l': uv = va_arg(*args, unsigned long); break;
9770 case 'V': uv = va_arg(*args, UV); break;
9771 default: uv = va_arg(*args, unsigned); break;
9773 case 'q': uv = va_arg(*args, Uquad_t); break;
9778 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9780 case 'h': uv = (unsigned short)tuv; break;
9781 case 'l': uv = (unsigned long)tuv; break;
9783 default: uv = tuv; break;
9785 case 'q': uv = (Uquad_t)tuv; break;
9791 eptr = ebuf + sizeof ebuf;
9797 p = (char*)((c == 'X')
9798 ? "0123456789ABCDEF" : "0123456789abcdef");
9804 esignbuf[esignlen++] = '0';
9805 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9811 *--eptr = '0' + dig;
9813 if (alt && *eptr != '0')
9819 *--eptr = '0' + dig;
9822 esignbuf[esignlen++] = '0';
9823 esignbuf[esignlen++] = 'b';
9826 default: /* it had better be ten or less */
9829 *--eptr = '0' + dig;
9830 } while (uv /= base);
9833 elen = (ebuf + sizeof ebuf) - eptr;
9836 zeros = precis - elen;
9837 else if (precis == 0 && elen == 1 && *eptr == '0')
9842 /* FLOATING POINT */
9845 c = 'f'; /* maybe %F isn't supported here */
9851 /* This is evil, but floating point is even more evil */
9853 /* for SV-style calling, we can only get NV
9854 for C-style calling, we assume %f is double;
9855 for simplicity we allow any of %Lf, %llf, %qf for long double
9859 #if defined(USE_LONG_DOUBLE)
9863 /* [perl #20339] - we should accept and ignore %lf rather than die */
9867 #if defined(USE_LONG_DOUBLE)
9868 intsize = args ? 0 : 'q';
9872 #if defined(HAS_LONG_DOUBLE)
9881 /* now we need (long double) if intsize == 'q', else (double) */
9882 nv = (args && !vectorize) ?
9883 #if LONG_DOUBLESIZE > DOUBLESIZE
9885 va_arg(*args, long double) :
9886 va_arg(*args, double)
9888 va_arg(*args, double)
9894 if (c != 'e' && c != 'E') {
9896 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9897 will cast our (long double) to (double) */
9898 (void)Perl_frexp(nv, &i);
9899 if (i == PERL_INT_MIN)
9900 Perl_die(aTHX_ "panic: frexp");
9902 need = BIT_DIGITS(i);
9904 need += has_precis ? precis : 6; /* known default */
9909 #ifdef HAS_LDBL_SPRINTF_BUG
9910 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9911 with sfio - Allen <allens@cpan.org> */
9914 # define MY_DBL_MAX DBL_MAX
9915 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9916 # if DOUBLESIZE >= 8
9917 # define MY_DBL_MAX 1.7976931348623157E+308L
9919 # define MY_DBL_MAX 3.40282347E+38L
9923 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9924 # define MY_DBL_MAX_BUG 1L
9926 # define MY_DBL_MAX_BUG MY_DBL_MAX
9930 # define MY_DBL_MIN DBL_MIN
9931 # else /* XXX guessing! -Allen */
9932 # if DOUBLESIZE >= 8
9933 # define MY_DBL_MIN 2.2250738585072014E-308L
9935 # define MY_DBL_MIN 1.17549435E-38L
9939 if ((intsize == 'q') && (c == 'f') &&
9940 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9942 /* it's going to be short enough that
9943 * long double precision is not needed */
9945 if ((nv <= 0L) && (nv >= -0L))
9946 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9948 /* would use Perl_fp_class as a double-check but not
9949 * functional on IRIX - see perl.h comments */
9951 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9952 /* It's within the range that a double can represent */
9953 #if defined(DBL_MAX) && !defined(DBL_MIN)
9954 if ((nv >= ((long double)1/DBL_MAX)) ||
9955 (nv <= (-(long double)1/DBL_MAX)))
9957 fix_ldbl_sprintf_bug = TRUE;
9960 if (fix_ldbl_sprintf_bug == TRUE) {
9970 # undef MY_DBL_MAX_BUG
9973 #endif /* HAS_LDBL_SPRINTF_BUG */
9975 need += 20; /* fudge factor */
9976 if (PL_efloatsize < need) {
9977 Safefree(PL_efloatbuf);
9978 PL_efloatsize = need + 20; /* more fudge */
9979 New(906, PL_efloatbuf, PL_efloatsize, char);
9980 PL_efloatbuf[0] = '\0';
9983 if ( !(width || left || plus || alt) && fill != '0'
9984 && has_precis && intsize != 'q' ) { /* Shortcuts */
9985 /* See earlier comment about buggy Gconvert when digits,
9987 if ( c == 'g' && precis) {
9988 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9989 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9990 goto float_converted;
9991 } else if ( c == 'f' && !precis) {
9992 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9996 eptr = ebuf + sizeof ebuf;
9999 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10000 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10001 if (intsize == 'q') {
10002 /* Copy the one or more characters in a long double
10003 * format before the 'base' ([efgEFG]) character to
10004 * the format string. */
10005 static char const prifldbl[] = PERL_PRIfldbl;
10006 char const *p = prifldbl + sizeof(prifldbl) - 3;
10007 while (p >= prifldbl) { *--eptr = *p--; }
10012 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10017 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10029 /* No taint. Otherwise we are in the strange situation
10030 * where printf() taints but print($float) doesn't.
10032 #if defined(HAS_LONG_DOUBLE)
10033 if (intsize == 'q')
10034 (void)sprintf(PL_efloatbuf, eptr, nv);
10036 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
10038 (void)sprintf(PL_efloatbuf, eptr, nv);
10041 eptr = PL_efloatbuf;
10042 elen = strlen(PL_efloatbuf);
10048 i = SvCUR(sv) - origlen;
10049 if (args && !vectorize) {
10051 case 'h': *(va_arg(*args, short*)) = i; break;
10052 default: *(va_arg(*args, int*)) = i; break;
10053 case 'l': *(va_arg(*args, long*)) = i; break;
10054 case 'V': *(va_arg(*args, IV*)) = i; break;
10056 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10061 sv_setuv_mg(argsv, (UV)i);
10063 continue; /* not "break" */
10069 if (!args && ckWARN(WARN_PRINTF) &&
10070 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10071 SV *msg = sv_newmortal();
10072 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10073 (PL_op->op_type == OP_PRTF) ? "" : "s");
10076 Perl_sv_catpvf(aTHX_ msg,
10077 "\"%%%c\"", c & 0xFF);
10079 Perl_sv_catpvf(aTHX_ msg,
10080 "\"%%\\%03"UVof"\"",
10083 sv_catpv(msg, "end of string");
10084 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10087 /* output mangled stuff ... */
10093 /* ... right here, because formatting flags should not apply */
10094 SvGROW(sv, SvCUR(sv) + elen + 1);
10096 Copy(eptr, p, elen, char);
10099 SvCUR_set(sv, p - SvPVX(sv));
10101 continue; /* not "break" */
10104 /* calculate width before utf8_upgrade changes it */
10105 have = esignlen + zeros + elen;
10107 if (is_utf8 != has_utf8) {
10110 sv_utf8_upgrade(sv);
10113 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10114 sv_utf8_upgrade(nsv);
10118 SvGROW(sv, SvCUR(sv) + elen + 1);
10123 need = (have > width ? have : width);
10126 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10128 if (esignlen && fill == '0') {
10129 for (i = 0; i < (int)esignlen; i++)
10130 *p++ = esignbuf[i];
10132 if (gap && !left) {
10133 memset(p, fill, gap);
10136 if (esignlen && fill != '0') {
10137 for (i = 0; i < (int)esignlen; i++)
10138 *p++ = esignbuf[i];
10141 for (i = zeros; i; i--)
10145 Copy(eptr, p, elen, char);
10149 memset(p, ' ', gap);
10154 Copy(dotstr, p, dotstrlen, char);
10158 vectorize = FALSE; /* done iterating over vecstr */
10165 SvCUR_set(sv, p - SvPVX(sv));
10173 /* =========================================================================
10175 =head1 Cloning an interpreter
10177 All the macros and functions in this section are for the private use of
10178 the main function, perl_clone().
10180 The foo_dup() functions make an exact copy of an existing foo thinngy.
10181 During the course of a cloning, a hash table is used to map old addresses
10182 to new addresses. The table is created and manipulated with the
10183 ptr_table_* functions.
10187 ============================================================================*/
10190 #if defined(USE_ITHREADS)
10192 #ifndef GpREFCNT_inc
10193 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10197 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10198 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10199 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10200 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10201 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10202 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10203 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10204 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10205 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10206 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10207 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10208 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10209 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10212 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10213 regcomp.c. AMS 20010712 */
10216 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10221 struct reg_substr_datum *s;
10224 return (REGEXP *)NULL;
10226 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10229 len = r->offsets[0];
10230 npar = r->nparens+1;
10232 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10233 Copy(r->program, ret->program, len+1, regnode);
10235 New(0, ret->startp, npar, I32);
10236 Copy(r->startp, ret->startp, npar, I32);
10237 New(0, ret->endp, npar, I32);
10238 Copy(r->startp, ret->startp, npar, I32);
10240 New(0, ret->substrs, 1, struct reg_substr_data);
10241 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10242 s->min_offset = r->substrs->data[i].min_offset;
10243 s->max_offset = r->substrs->data[i].max_offset;
10244 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10245 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10248 ret->regstclass = NULL;
10250 struct reg_data *d;
10251 const int count = r->data->count;
10253 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10254 char, struct reg_data);
10255 New(0, d->what, count, U8);
10258 for (i = 0; i < count; i++) {
10259 d->what[i] = r->data->what[i];
10260 switch (d->what[i]) {
10261 /* legal options are one of: sfpont
10262 see also regcomp.h and pregfree() */
10264 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10267 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10270 /* This is cheating. */
10271 New(0, d->data[i], 1, struct regnode_charclass_class);
10272 StructCopy(r->data->data[i], d->data[i],
10273 struct regnode_charclass_class);
10274 ret->regstclass = (regnode*)d->data[i];
10277 /* Compiled op trees are readonly, and can thus be
10278 shared without duplication. */
10280 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10284 d->data[i] = r->data->data[i];
10287 d->data[i] = r->data->data[i];
10289 ((reg_trie_data*)d->data[i])->refcount++;
10293 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10302 New(0, ret->offsets, 2*len+1, U32);
10303 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10305 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10306 ret->refcnt = r->refcnt;
10307 ret->minlen = r->minlen;
10308 ret->prelen = r->prelen;
10309 ret->nparens = r->nparens;
10310 ret->lastparen = r->lastparen;
10311 ret->lastcloseparen = r->lastcloseparen;
10312 ret->reganch = r->reganch;
10314 ret->sublen = r->sublen;
10316 if (RX_MATCH_COPIED(ret))
10317 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10319 ret->subbeg = Nullch;
10320 #ifdef PERL_COPY_ON_WRITE
10321 ret->saved_copy = Nullsv;
10324 ptr_table_store(PL_ptr_table, r, ret);
10328 /* duplicate a file handle */
10331 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10337 return (PerlIO*)NULL;
10339 /* look for it in the table first */
10340 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10344 /* create anew and remember what it is */
10345 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10346 ptr_table_store(PL_ptr_table, fp, ret);
10350 /* duplicate a directory handle */
10353 Perl_dirp_dup(pTHX_ DIR *dp)
10361 /* duplicate a typeglob */
10364 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10369 /* look for it in the table first */
10370 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10374 /* create anew and remember what it is */
10375 Newz(0, ret, 1, GP);
10376 ptr_table_store(PL_ptr_table, gp, ret);
10379 ret->gp_refcnt = 0; /* must be before any other dups! */
10380 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10381 ret->gp_io = io_dup_inc(gp->gp_io, param);
10382 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10383 ret->gp_av = av_dup_inc(gp->gp_av, param);
10384 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10385 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10386 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10387 ret->gp_cvgen = gp->gp_cvgen;
10388 ret->gp_flags = gp->gp_flags;
10389 ret->gp_line = gp->gp_line;
10390 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10394 /* duplicate a chain of magic */
10397 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10399 MAGIC *mgprev = (MAGIC*)NULL;
10402 return (MAGIC*)NULL;
10403 /* look for it in the table first */
10404 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10408 for (; mg; mg = mg->mg_moremagic) {
10410 Newz(0, nmg, 1, MAGIC);
10412 mgprev->mg_moremagic = nmg;
10415 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10416 nmg->mg_private = mg->mg_private;
10417 nmg->mg_type = mg->mg_type;
10418 nmg->mg_flags = mg->mg_flags;
10419 if (mg->mg_type == PERL_MAGIC_qr) {
10420 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10422 else if(mg->mg_type == PERL_MAGIC_backref) {
10423 const AV * const av = (AV*) mg->mg_obj;
10426 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10428 for (i = AvFILLp(av); i >= 0; i--) {
10429 if (!svp[i]) continue;
10430 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10434 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10435 ? sv_dup_inc(mg->mg_obj, param)
10436 : sv_dup(mg->mg_obj, param);
10438 nmg->mg_len = mg->mg_len;
10439 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10440 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10441 if (mg->mg_len > 0) {
10442 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10443 if (mg->mg_type == PERL_MAGIC_overload_table &&
10444 AMT_AMAGIC((AMT*)mg->mg_ptr))
10446 AMT *amtp = (AMT*)mg->mg_ptr;
10447 AMT *namtp = (AMT*)nmg->mg_ptr;
10449 for (i = 1; i < NofAMmeth; i++) {
10450 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10454 else if (mg->mg_len == HEf_SVKEY)
10455 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10457 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10458 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10465 /* create a new pointer-mapping table */
10468 Perl_ptr_table_new(pTHX)
10471 Newz(0, tbl, 1, PTR_TBL_t);
10472 tbl->tbl_max = 511;
10473 tbl->tbl_items = 0;
10474 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10479 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10481 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10489 struct ptr_tbl_ent* pte;
10490 struct ptr_tbl_ent* pteend;
10491 New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
10492 pte->next = PL_pte_arenaroot;
10493 PL_pte_arenaroot = pte;
10495 pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
10496 PL_pte_root = ++pte;
10497 while (pte < pteend) {
10498 pte->next = pte + 1;
10504 STATIC struct ptr_tbl_ent*
10507 struct ptr_tbl_ent* pte;
10511 PL_pte_root = pte->next;
10516 S_del_pte(pTHX_ struct ptr_tbl_ent*p)
10518 p->next = PL_pte_root;
10522 /* map an existing pointer using a table */
10525 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10527 PTR_TBL_ENT_t *tblent;
10528 const UV hash = PTR_TABLE_HASH(sv);
10530 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10531 for (; tblent; tblent = tblent->next) {
10532 if (tblent->oldval == sv)
10533 return tblent->newval;
10535 return (void*)NULL;
10538 /* add a new entry to a pointer-mapping table */
10541 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10543 PTR_TBL_ENT_t *tblent, **otblent;
10544 /* XXX this may be pessimal on platforms where pointers aren't good
10545 * hash values e.g. if they grow faster in the most significant
10547 const UV hash = PTR_TABLE_HASH(oldv);
10551 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10552 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10553 if (tblent->oldval == oldv) {
10554 tblent->newval = newv;
10558 tblent = S_new_pte(aTHX);
10559 tblent->oldval = oldv;
10560 tblent->newval = newv;
10561 tblent->next = *otblent;
10564 if (!empty && tbl->tbl_items > tbl->tbl_max)
10565 ptr_table_split(tbl);
10568 /* double the hash bucket size of an existing ptr table */
10571 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10573 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10574 const UV oldsize = tbl->tbl_max + 1;
10575 UV newsize = oldsize * 2;
10578 Renew(ary, newsize, PTR_TBL_ENT_t*);
10579 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10580 tbl->tbl_max = --newsize;
10581 tbl->tbl_ary = ary;
10582 for (i=0; i < oldsize; i++, ary++) {
10583 PTR_TBL_ENT_t **curentp, **entp, *ent;
10586 curentp = ary + oldsize;
10587 for (entp = ary, ent = *ary; ent; ent = *entp) {
10588 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10590 ent->next = *curentp;
10600 /* remove all the entries from a ptr table */
10603 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10605 register PTR_TBL_ENT_t **array;
10606 register PTR_TBL_ENT_t *entry;
10610 if (!tbl || !tbl->tbl_items) {
10614 array = tbl->tbl_ary;
10616 max = tbl->tbl_max;
10620 PTR_TBL_ENT_t *oentry = entry;
10621 entry = entry->next;
10622 S_del_pte(aTHX_ oentry);
10625 if (++riter > max) {
10628 entry = array[riter];
10632 tbl->tbl_items = 0;
10635 /* clear and free a ptr table */
10638 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10643 ptr_table_clear(tbl);
10644 Safefree(tbl->tbl_ary);
10648 /* attempt to make everything in the typeglob readonly */
10651 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10653 GV *gv = (GV*)sstr;
10654 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10656 if (GvIO(gv) || GvFORM(gv)) {
10657 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10659 else if (!GvCV(gv)) {
10660 GvCV(gv) = (CV*)sv;
10663 /* CvPADLISTs cannot be shared */
10664 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10669 if (!GvUNIQUE(gv)) {
10671 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10672 HvNAME(GvSTASH(gv)), GvNAME(gv));
10678 * write attempts will die with
10679 * "Modification of a read-only value attempted"
10685 SvREADONLY_on(GvSV(gv));
10689 GvAV(gv) = (AV*)sv;
10692 SvREADONLY_on(GvAV(gv));
10696 GvHV(gv) = (HV*)sv;
10699 SvREADONLY_on(GvHV(gv));
10702 return sstr; /* he_dup() will SvREFCNT_inc() */
10705 /* duplicate an SV of any type (including AV, HV etc) */
10708 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10711 SvRV_set(dstr, SvWEAKREF(sstr)
10712 ? sv_dup(SvRV(sstr), param)
10713 : sv_dup_inc(SvRV(sstr), param));
10716 else if (SvPVX(sstr)) {
10717 /* Has something there */
10719 /* Normal PV - clone whole allocated space */
10720 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
10721 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10722 /* Not that normal - actually sstr is copy on write.
10723 But we are a true, independant SV, so: */
10724 SvREADONLY_off(dstr);
10729 /* Special case - not normally malloced for some reason */
10730 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10731 /* A "shared" PV - clone it as unshared string */
10732 if(SvPADTMP(sstr)) {
10733 /* However, some of them live in the pad
10734 and they should not have these flags
10737 SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
10739 SvUV_set(dstr, SvUVX(sstr));
10742 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
10744 SvREADONLY_off(dstr);
10748 /* Some other special case - random pointer */
10749 SvPV_set(dstr, SvPVX(sstr));
10754 /* Copy the Null */
10755 if (SvTYPE(dstr) == SVt_RV)
10756 SvRV_set(dstr, NULL);
10763 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10768 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10770 /* look for it in the table first */
10771 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10775 if(param->flags & CLONEf_JOIN_IN) {
10776 /** We are joining here so we don't want do clone
10777 something that is bad **/
10779 if(SvTYPE(sstr) == SVt_PVHV &&
10781 /** don't clone stashes if they already exist **/
10782 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10783 return (SV*) old_stash;
10787 /* create anew and remember what it is */
10790 #ifdef DEBUG_LEAKING_SCALARS
10791 dstr->sv_debug_optype = sstr->sv_debug_optype;
10792 dstr->sv_debug_line = sstr->sv_debug_line;
10793 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10794 dstr->sv_debug_cloned = 1;
10796 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10798 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10802 ptr_table_store(PL_ptr_table, sstr, dstr);
10805 SvFLAGS(dstr) = SvFLAGS(sstr);
10806 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10807 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10810 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10811 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10812 PL_watch_pvx, SvPVX(sstr));
10815 /* don't clone objects whose class has asked us not to */
10816 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10817 SvFLAGS(dstr) &= ~SVTYPEMASK;
10818 SvOBJECT_off(dstr);
10822 switch (SvTYPE(sstr)) {
10824 SvANY(dstr) = NULL;
10827 SvANY(dstr) = new_XIV();
10828 SvIV_set(dstr, SvIVX(sstr));
10831 SvANY(dstr) = new_XNV();
10832 SvNV_set(dstr, SvNVX(sstr));
10835 SvANY(dstr) = new_XRV();
10836 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10839 SvANY(dstr) = new_XPV();
10840 SvCUR_set(dstr, SvCUR(sstr));
10841 SvLEN_set(dstr, SvLEN(sstr));
10842 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10845 SvANY(dstr) = new_XPVIV();
10846 SvCUR_set(dstr, SvCUR(sstr));
10847 SvLEN_set(dstr, SvLEN(sstr));
10848 SvIV_set(dstr, SvIVX(sstr));
10849 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10852 SvANY(dstr) = new_XPVNV();
10853 SvCUR_set(dstr, SvCUR(sstr));
10854 SvLEN_set(dstr, SvLEN(sstr));
10855 SvIV_set(dstr, SvIVX(sstr));
10856 SvNV_set(dstr, SvNVX(sstr));
10857 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10860 SvANY(dstr) = new_XPVMG();
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 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10866 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10867 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10870 SvANY(dstr) = new_XPVBM();
10871 SvCUR_set(dstr, SvCUR(sstr));
10872 SvLEN_set(dstr, SvLEN(sstr));
10873 SvIV_set(dstr, SvIVX(sstr));
10874 SvNV_set(dstr, SvNVX(sstr));
10875 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10876 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10877 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10878 BmRARE(dstr) = BmRARE(sstr);
10879 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10880 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10883 SvANY(dstr) = new_XPVLV();
10884 SvCUR_set(dstr, SvCUR(sstr));
10885 SvLEN_set(dstr, SvLEN(sstr));
10886 SvIV_set(dstr, SvIVX(sstr));
10887 SvNV_set(dstr, SvNVX(sstr));
10888 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10889 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10890 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10891 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10892 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10893 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10894 LvTARG(dstr) = dstr;
10895 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10896 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10898 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10899 LvTYPE(dstr) = LvTYPE(sstr);
10902 if (GvUNIQUE((GV*)sstr)) {
10904 if ((share = gv_share(sstr, param))) {
10907 ptr_table_store(PL_ptr_table, sstr, dstr);
10909 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10910 HvNAME(GvSTASH(share)), GvNAME(share));
10915 SvANY(dstr) = new_XPVGV();
10916 SvCUR_set(dstr, SvCUR(sstr));
10917 SvLEN_set(dstr, SvLEN(sstr));
10918 SvIV_set(dstr, SvIVX(sstr));
10919 SvNV_set(dstr, SvNVX(sstr));
10920 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10921 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10922 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10923 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10924 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10925 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10926 GvFLAGS(dstr) = GvFLAGS(sstr);
10927 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10928 (void)GpREFCNT_inc(GvGP(dstr));
10931 SvANY(dstr) = new_XPVIO();
10932 SvCUR_set(dstr, SvCUR(sstr));
10933 SvLEN_set(dstr, SvLEN(sstr));
10934 SvIV_set(dstr, SvIVX(sstr));
10935 SvNV_set(dstr, SvNVX(sstr));
10936 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10937 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10938 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10939 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10940 if (IoOFP(sstr) == IoIFP(sstr))
10941 IoOFP(dstr) = IoIFP(dstr);
10943 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10944 /* PL_rsfp_filters entries have fake IoDIRP() */
10945 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10946 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10948 IoDIRP(dstr) = IoDIRP(sstr);
10949 IoLINES(dstr) = IoLINES(sstr);
10950 IoPAGE(dstr) = IoPAGE(sstr);
10951 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10952 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10953 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10954 /* I have no idea why fake dirp (rsfps)
10955 should be treaded differently but otherwise
10956 we end up with leaks -- sky*/
10957 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10958 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10959 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10961 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10962 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10963 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10965 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10966 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10967 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10968 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10969 IoTYPE(dstr) = IoTYPE(sstr);
10970 IoFLAGS(dstr) = IoFLAGS(sstr);
10973 SvANY(dstr) = new_XPVAV();
10974 SvCUR_set(dstr, SvCUR(sstr));
10975 SvLEN_set(dstr, SvLEN(sstr));
10976 SvIV_set(dstr, SvIVX(sstr));
10977 SvNV_set(dstr, SvNVX(sstr));
10978 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10979 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10980 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10981 if (AvARRAY((AV*)sstr)) {
10982 SV **dst_ary, **src_ary;
10983 SSize_t items = AvFILLp((AV*)sstr) + 1;
10985 src_ary = AvARRAY((AV*)sstr);
10986 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10987 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10988 SvPV_set(dstr, (char*)dst_ary);
10989 AvALLOC((AV*)dstr) = dst_ary;
10990 if (AvREAL((AV*)sstr)) {
10991 while (items-- > 0)
10992 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10995 while (items-- > 0)
10996 *dst_ary++ = sv_dup(*src_ary++, param);
10998 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10999 while (items-- > 0) {
11000 *dst_ary++ = &PL_sv_undef;
11004 SvPV_set(dstr, Nullch);
11005 AvALLOC((AV*)dstr) = (SV**)NULL;
11009 SvANY(dstr) = new_XPVHV();
11010 SvCUR_set(dstr, SvCUR(sstr));
11011 SvLEN_set(dstr, SvLEN(sstr));
11012 SvIV_set(dstr, SvIVX(sstr));
11013 SvNV_set(dstr, SvNVX(sstr));
11014 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11015 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11016 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
11017 if (HvARRAY((HV*)sstr)) {
11019 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
11020 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
11021 Newz(0, dxhv->xhv_array,
11022 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
11023 while (i <= sxhv->xhv_max) {
11024 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
11025 (bool)!!HvSHAREKEYS(sstr),
11029 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
11030 (bool)!!HvSHAREKEYS(sstr), param);
11033 SvPV_set(dstr, Nullch);
11034 HvEITER((HV*)dstr) = (HE*)NULL;
11036 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
11037 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
11038 /* Record stashes for possible cloning in Perl_clone(). */
11039 if(HvNAME((HV*)dstr))
11040 av_push(param->stashes, dstr);
11043 SvANY(dstr) = new_XPVFM();
11044 FmLINES(dstr) = FmLINES(sstr);
11048 SvANY(dstr) = new_XPVCV();
11050 SvCUR_set(dstr, SvCUR(sstr));
11051 SvLEN_set(dstr, SvLEN(sstr));
11052 SvIV_set(dstr, SvIVX(sstr));
11053 SvNV_set(dstr, SvNVX(sstr));
11054 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11055 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11056 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11057 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11058 CvSTART(dstr) = CvSTART(sstr);
11060 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11062 CvXSUB(dstr) = CvXSUB(sstr);
11063 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11064 if (CvCONST(sstr)) {
11065 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11066 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11067 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
11069 /* don't dup if copying back - CvGV isn't refcounted, so the
11070 * duped GV may never be freed. A bit of a hack! DAPM */
11071 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11072 Nullgv : gv_dup(CvGV(sstr), param) ;
11073 if (param->flags & CLONEf_COPY_STACKS) {
11074 CvDEPTH(dstr) = CvDEPTH(sstr);
11078 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11079 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11081 CvWEAKOUTSIDE(sstr)
11082 ? cv_dup( CvOUTSIDE(sstr), param)
11083 : cv_dup_inc(CvOUTSIDE(sstr), param);
11084 CvFLAGS(dstr) = CvFLAGS(sstr);
11085 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11088 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11092 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11098 /* duplicate a context */
11101 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11103 PERL_CONTEXT *ncxs;
11106 return (PERL_CONTEXT*)NULL;
11108 /* look for it in the table first */
11109 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11113 /* create anew and remember what it is */
11114 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11115 ptr_table_store(PL_ptr_table, cxs, ncxs);
11118 PERL_CONTEXT *cx = &cxs[ix];
11119 PERL_CONTEXT *ncx = &ncxs[ix];
11120 ncx->cx_type = cx->cx_type;
11121 if (CxTYPE(cx) == CXt_SUBST) {
11122 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11125 ncx->blk_oldsp = cx->blk_oldsp;
11126 ncx->blk_oldcop = cx->blk_oldcop;
11127 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11128 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11129 ncx->blk_oldpm = cx->blk_oldpm;
11130 ncx->blk_gimme = cx->blk_gimme;
11131 switch (CxTYPE(cx)) {
11133 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11134 ? cv_dup_inc(cx->blk_sub.cv, param)
11135 : cv_dup(cx->blk_sub.cv,param));
11136 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11137 ? av_dup_inc(cx->blk_sub.argarray, param)
11139 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11140 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11141 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11142 ncx->blk_sub.lval = cx->blk_sub.lval;
11143 ncx->blk_sub.retop = cx->blk_sub.retop;
11146 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11147 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11148 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11149 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11150 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11151 ncx->blk_eval.retop = cx->blk_eval.retop;
11154 ncx->blk_loop.label = cx->blk_loop.label;
11155 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11156 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11157 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11158 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11159 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11160 ? cx->blk_loop.iterdata
11161 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11162 ncx->blk_loop.oldcomppad
11163 = (PAD*)ptr_table_fetch(PL_ptr_table,
11164 cx->blk_loop.oldcomppad);
11165 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11166 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11167 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11168 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11169 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11172 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11173 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11174 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11175 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11176 ncx->blk_sub.retop = cx->blk_sub.retop;
11188 /* duplicate a stack info structure */
11191 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11196 return (PERL_SI*)NULL;
11198 /* look for it in the table first */
11199 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11203 /* create anew and remember what it is */
11204 Newz(56, nsi, 1, PERL_SI);
11205 ptr_table_store(PL_ptr_table, si, nsi);
11207 nsi->si_stack = av_dup_inc(si->si_stack, param);
11208 nsi->si_cxix = si->si_cxix;
11209 nsi->si_cxmax = si->si_cxmax;
11210 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11211 nsi->si_type = si->si_type;
11212 nsi->si_prev = si_dup(si->si_prev, param);
11213 nsi->si_next = si_dup(si->si_next, param);
11214 nsi->si_markoff = si->si_markoff;
11219 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11220 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11221 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11222 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11223 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11224 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11225 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11226 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11227 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11228 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11229 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11230 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11231 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11232 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11235 #define pv_dup_inc(p) SAVEPV(p)
11236 #define pv_dup(p) SAVEPV(p)
11237 #define svp_dup_inc(p,pp) any_dup(p,pp)
11239 /* map any object to the new equivent - either something in the
11240 * ptr table, or something in the interpreter structure
11244 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11249 return (void*)NULL;
11251 /* look for it in the table first */
11252 ret = ptr_table_fetch(PL_ptr_table, v);
11256 /* see if it is part of the interpreter structure */
11257 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11258 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11266 /* duplicate the save stack */
11269 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11271 ANY *ss = proto_perl->Tsavestack;
11272 I32 ix = proto_perl->Tsavestack_ix;
11273 I32 max = proto_perl->Tsavestack_max;
11286 void (*dptr) (void*);
11287 void (*dxptr) (pTHX_ void*);
11290 Newz(54, nss, max, ANY);
11294 TOPINT(nss,ix) = i;
11296 case SAVEt_ITEM: /* normal string */
11297 sv = (SV*)POPPTR(ss,ix);
11298 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11299 sv = (SV*)POPPTR(ss,ix);
11300 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11302 case SAVEt_SV: /* scalar reference */
11303 sv = (SV*)POPPTR(ss,ix);
11304 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11305 gv = (GV*)POPPTR(ss,ix);
11306 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11308 case SAVEt_GENERIC_PVREF: /* generic char* */
11309 c = (char*)POPPTR(ss,ix);
11310 TOPPTR(nss,ix) = pv_dup(c);
11311 ptr = POPPTR(ss,ix);
11312 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11314 case SAVEt_SHARED_PVREF: /* char* in shared space */
11315 c = (char*)POPPTR(ss,ix);
11316 TOPPTR(nss,ix) = savesharedpv(c);
11317 ptr = POPPTR(ss,ix);
11318 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11320 case SAVEt_GENERIC_SVREF: /* generic sv */
11321 case SAVEt_SVREF: /* scalar reference */
11322 sv = (SV*)POPPTR(ss,ix);
11323 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11324 ptr = POPPTR(ss,ix);
11325 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11327 case SAVEt_AV: /* array reference */
11328 av = (AV*)POPPTR(ss,ix);
11329 TOPPTR(nss,ix) = av_dup_inc(av, param);
11330 gv = (GV*)POPPTR(ss,ix);
11331 TOPPTR(nss,ix) = gv_dup(gv, param);
11333 case SAVEt_HV: /* hash reference */
11334 hv = (HV*)POPPTR(ss,ix);
11335 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11336 gv = (GV*)POPPTR(ss,ix);
11337 TOPPTR(nss,ix) = gv_dup(gv, param);
11339 case SAVEt_INT: /* int reference */
11340 ptr = POPPTR(ss,ix);
11341 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11342 intval = (int)POPINT(ss,ix);
11343 TOPINT(nss,ix) = intval;
11345 case SAVEt_LONG: /* long reference */
11346 ptr = POPPTR(ss,ix);
11347 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11348 longval = (long)POPLONG(ss,ix);
11349 TOPLONG(nss,ix) = longval;
11351 case SAVEt_I32: /* I32 reference */
11352 case SAVEt_I16: /* I16 reference */
11353 case SAVEt_I8: /* I8 reference */
11354 ptr = POPPTR(ss,ix);
11355 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11357 TOPINT(nss,ix) = i;
11359 case SAVEt_IV: /* IV reference */
11360 ptr = POPPTR(ss,ix);
11361 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11363 TOPIV(nss,ix) = iv;
11365 case SAVEt_SPTR: /* SV* reference */
11366 ptr = POPPTR(ss,ix);
11367 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11368 sv = (SV*)POPPTR(ss,ix);
11369 TOPPTR(nss,ix) = sv_dup(sv, param);
11371 case SAVEt_VPTR: /* random* reference */
11372 ptr = POPPTR(ss,ix);
11373 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11374 ptr = POPPTR(ss,ix);
11375 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11377 case SAVEt_PPTR: /* char* reference */
11378 ptr = POPPTR(ss,ix);
11379 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11380 c = (char*)POPPTR(ss,ix);
11381 TOPPTR(nss,ix) = pv_dup(c);
11383 case SAVEt_HPTR: /* HV* reference */
11384 ptr = POPPTR(ss,ix);
11385 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11386 hv = (HV*)POPPTR(ss,ix);
11387 TOPPTR(nss,ix) = hv_dup(hv, param);
11389 case SAVEt_APTR: /* AV* reference */
11390 ptr = POPPTR(ss,ix);
11391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11392 av = (AV*)POPPTR(ss,ix);
11393 TOPPTR(nss,ix) = av_dup(av, param);
11396 gv = (GV*)POPPTR(ss,ix);
11397 TOPPTR(nss,ix) = gv_dup(gv, param);
11399 case SAVEt_GP: /* scalar reference */
11400 gp = (GP*)POPPTR(ss,ix);
11401 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11402 (void)GpREFCNT_inc(gp);
11403 gv = (GV*)POPPTR(ss,ix);
11404 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11405 c = (char*)POPPTR(ss,ix);
11406 TOPPTR(nss,ix) = pv_dup(c);
11408 TOPIV(nss,ix) = iv;
11410 TOPIV(nss,ix) = iv;
11413 case SAVEt_MORTALIZESV:
11414 sv = (SV*)POPPTR(ss,ix);
11415 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11418 ptr = POPPTR(ss,ix);
11419 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11420 /* these are assumed to be refcounted properly */
11421 switch (((OP*)ptr)->op_type) {
11423 case OP_LEAVESUBLV:
11427 case OP_LEAVEWRITE:
11428 TOPPTR(nss,ix) = ptr;
11433 TOPPTR(nss,ix) = Nullop;
11438 TOPPTR(nss,ix) = Nullop;
11441 c = (char*)POPPTR(ss,ix);
11442 TOPPTR(nss,ix) = pv_dup_inc(c);
11444 case SAVEt_CLEARSV:
11445 longval = POPLONG(ss,ix);
11446 TOPLONG(nss,ix) = longval;
11449 hv = (HV*)POPPTR(ss,ix);
11450 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11451 c = (char*)POPPTR(ss,ix);
11452 TOPPTR(nss,ix) = pv_dup_inc(c);
11454 TOPINT(nss,ix) = i;
11456 case SAVEt_DESTRUCTOR:
11457 ptr = POPPTR(ss,ix);
11458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11459 dptr = POPDPTR(ss,ix);
11460 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11462 case SAVEt_DESTRUCTOR_X:
11463 ptr = POPPTR(ss,ix);
11464 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11465 dxptr = POPDXPTR(ss,ix);
11466 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11468 case SAVEt_REGCONTEXT:
11471 TOPINT(nss,ix) = i;
11474 case SAVEt_STACK_POS: /* Position on Perl stack */
11476 TOPINT(nss,ix) = i;
11478 case SAVEt_AELEM: /* array element */
11479 sv = (SV*)POPPTR(ss,ix);
11480 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11482 TOPINT(nss,ix) = i;
11483 av = (AV*)POPPTR(ss,ix);
11484 TOPPTR(nss,ix) = av_dup_inc(av, param);
11486 case SAVEt_HELEM: /* hash element */
11487 sv = (SV*)POPPTR(ss,ix);
11488 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11489 sv = (SV*)POPPTR(ss,ix);
11490 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11491 hv = (HV*)POPPTR(ss,ix);
11492 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11495 ptr = POPPTR(ss,ix);
11496 TOPPTR(nss,ix) = ptr;
11500 TOPINT(nss,ix) = i;
11502 case SAVEt_COMPPAD:
11503 av = (AV*)POPPTR(ss,ix);
11504 TOPPTR(nss,ix) = av_dup(av, param);
11507 longval = (long)POPLONG(ss,ix);
11508 TOPLONG(nss,ix) = longval;
11509 ptr = POPPTR(ss,ix);
11510 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11511 sv = (SV*)POPPTR(ss,ix);
11512 TOPPTR(nss,ix) = sv_dup(sv, param);
11515 ptr = POPPTR(ss,ix);
11516 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11517 longval = (long)POPBOOL(ss,ix);
11518 TOPBOOL(nss,ix) = (bool)longval;
11520 case SAVEt_SET_SVFLAGS:
11522 TOPINT(nss,ix) = i;
11524 TOPINT(nss,ix) = i;
11525 sv = (SV*)POPPTR(ss,ix);
11526 TOPPTR(nss,ix) = sv_dup(sv, param);
11529 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11537 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11538 * flag to the result. This is done for each stash before cloning starts,
11539 * so we know which stashes want their objects cloned */
11542 do_mark_cloneable_stash(pTHX_ SV *sv)
11544 if (HvNAME((HV*)sv)) {
11545 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11546 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11547 if (cloner && GvCV(cloner)) {
11554 XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
11556 call_sv((SV*)GvCV(cloner), G_SCALAR);
11563 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11571 =for apidoc perl_clone
11573 Create and return a new interpreter by cloning the current one.
11575 perl_clone takes these flags as parameters:
11577 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11578 without it we only clone the data and zero the stacks,
11579 with it we copy the stacks and the new perl interpreter is
11580 ready to run at the exact same point as the previous one.
11581 The pseudo-fork code uses COPY_STACKS while the
11582 threads->new doesn't.
11584 CLONEf_KEEP_PTR_TABLE
11585 perl_clone keeps a ptr_table with the pointer of the old
11586 variable as a key and the new variable as a value,
11587 this allows it to check if something has been cloned and not
11588 clone it again but rather just use the value and increase the
11589 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11590 the ptr_table using the function
11591 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11592 reason to keep it around is if you want to dup some of your own
11593 variable who are outside the graph perl scans, example of this
11594 code is in threads.xs create
11597 This is a win32 thing, it is ignored on unix, it tells perls
11598 win32host code (which is c++) to clone itself, this is needed on
11599 win32 if you want to run two threads at the same time,
11600 if you just want to do some stuff in a separate perl interpreter
11601 and then throw it away and return to the original one,
11602 you don't need to do anything.
11607 /* XXX the above needs expanding by someone who actually understands it ! */
11608 EXTERN_C PerlInterpreter *
11609 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11612 perl_clone(PerlInterpreter *proto_perl, UV flags)
11615 #ifdef PERL_IMPLICIT_SYS
11617 /* perlhost.h so we need to call into it
11618 to clone the host, CPerlHost should have a c interface, sky */
11620 if (flags & CLONEf_CLONE_HOST) {
11621 return perl_clone_host(proto_perl,flags);
11623 return perl_clone_using(proto_perl, flags,
11625 proto_perl->IMemShared,
11626 proto_perl->IMemParse,
11628 proto_perl->IStdIO,
11632 proto_perl->IProc);
11636 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11637 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11638 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11639 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11640 struct IPerlDir* ipD, struct IPerlSock* ipS,
11641 struct IPerlProc* ipP)
11643 /* XXX many of the string copies here can be optimized if they're
11644 * constants; they need to be allocated as common memory and just
11645 * their pointers copied. */
11648 CLONE_PARAMS clone_params;
11649 CLONE_PARAMS* param = &clone_params;
11651 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11652 /* for each stash, determine whether its objects should be cloned */
11653 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11654 PERL_SET_THX(my_perl);
11657 Poison(my_perl, 1, PerlInterpreter);
11659 PL_curcop = (COP *)Nullop;
11663 PL_savestack_ix = 0;
11664 PL_savestack_max = -1;
11665 PL_sig_pending = 0;
11666 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11667 # else /* !DEBUGGING */
11668 Zero(my_perl, 1, PerlInterpreter);
11669 # endif /* DEBUGGING */
11671 /* host pointers */
11673 PL_MemShared = ipMS;
11674 PL_MemParse = ipMP;
11681 #else /* !PERL_IMPLICIT_SYS */
11683 CLONE_PARAMS clone_params;
11684 CLONE_PARAMS* param = &clone_params;
11685 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11686 /* for each stash, determine whether its objects should be cloned */
11687 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11688 PERL_SET_THX(my_perl);
11691 Poison(my_perl, 1, PerlInterpreter);
11693 PL_curcop = (COP *)Nullop;
11697 PL_savestack_ix = 0;
11698 PL_savestack_max = -1;
11699 PL_sig_pending = 0;
11700 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11701 # else /* !DEBUGGING */
11702 Zero(my_perl, 1, PerlInterpreter);
11703 # endif /* DEBUGGING */
11704 #endif /* PERL_IMPLICIT_SYS */
11705 param->flags = flags;
11706 param->proto_perl = proto_perl;
11709 PL_xiv_arenaroot = NULL;
11710 PL_xiv_root = NULL;
11711 PL_xnv_arenaroot = NULL;
11712 PL_xnv_root = NULL;
11713 PL_xrv_arenaroot = NULL;
11714 PL_xrv_root = NULL;
11715 PL_xpv_arenaroot = NULL;
11716 PL_xpv_root = NULL;
11717 PL_xpviv_arenaroot = NULL;
11718 PL_xpviv_root = NULL;
11719 PL_xpvnv_arenaroot = NULL;
11720 PL_xpvnv_root = NULL;
11721 PL_xpvcv_arenaroot = NULL;
11722 PL_xpvcv_root = NULL;
11723 PL_xpvav_arenaroot = NULL;
11724 PL_xpvav_root = NULL;
11725 PL_xpvhv_arenaroot = NULL;
11726 PL_xpvhv_root = NULL;
11727 PL_xpvmg_arenaroot = NULL;
11728 PL_xpvmg_root = NULL;
11729 PL_xpvgv_arenaroot = NULL;
11730 PL_xpvgv_root = NULL;
11731 PL_xpvlv_arenaroot = NULL;
11732 PL_xpvlv_root = NULL;
11733 PL_xpvbm_arenaroot = NULL;
11734 PL_xpvbm_root = NULL;
11735 PL_he_arenaroot = NULL;
11737 #if defined(USE_ITHREADS)
11738 PL_pte_arenaroot = NULL;
11739 PL_pte_root = NULL;
11741 PL_nice_chunk = NULL;
11742 PL_nice_chunk_size = 0;
11744 PL_sv_objcount = 0;
11745 PL_sv_root = Nullsv;
11746 PL_sv_arenaroot = Nullsv;
11748 PL_debug = proto_perl->Idebug;
11750 #ifdef USE_REENTRANT_API
11751 /* XXX: things like -Dm will segfault here in perlio, but doing
11752 * PERL_SET_CONTEXT(proto_perl);
11753 * breaks too many other things
11755 Perl_reentrant_init(aTHX);
11758 /* create SV map for pointer relocation */
11759 PL_ptr_table = ptr_table_new();
11761 /* initialize these special pointers as early as possible */
11762 SvANY(&PL_sv_undef) = NULL;
11763 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11764 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11765 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11767 SvANY(&PL_sv_no) = new_XPVNV();
11768 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11769 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11770 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11771 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11772 SvCUR_set(&PL_sv_no, 0);
11773 SvLEN_set(&PL_sv_no, 1);
11774 SvIV_set(&PL_sv_no, 0);
11775 SvNV_set(&PL_sv_no, 0);
11776 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11778 SvANY(&PL_sv_yes) = new_XPVNV();
11779 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11780 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11781 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11782 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11783 SvCUR_set(&PL_sv_yes, 1);
11784 SvLEN_set(&PL_sv_yes, 2);
11785 SvIV_set(&PL_sv_yes, 1);
11786 SvNV_set(&PL_sv_yes, 1);
11787 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11789 /* create (a non-shared!) shared string table */
11790 PL_strtab = newHV();
11791 HvSHAREKEYS_off(PL_strtab);
11792 hv_ksplit(PL_strtab, 512);
11793 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11795 PL_compiling = proto_perl->Icompiling;
11797 /* These two PVs will be free'd special way so must set them same way op.c does */
11798 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11799 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11801 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11802 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11804 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11805 if (!specialWARN(PL_compiling.cop_warnings))
11806 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11807 if (!specialCopIO(PL_compiling.cop_io))
11808 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11809 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11811 /* pseudo environmental stuff */
11812 PL_origargc = proto_perl->Iorigargc;
11813 PL_origargv = proto_perl->Iorigargv;
11815 param->stashes = newAV(); /* Setup array of objects to call clone on */
11817 #ifdef PERLIO_LAYERS
11818 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11819 PerlIO_clone(aTHX_ proto_perl, param);
11822 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11823 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11824 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11825 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11826 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11827 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11830 PL_minus_c = proto_perl->Iminus_c;
11831 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11832 PL_localpatches = proto_perl->Ilocalpatches;
11833 PL_splitstr = proto_perl->Isplitstr;
11834 PL_preprocess = proto_perl->Ipreprocess;
11835 PL_minus_n = proto_perl->Iminus_n;
11836 PL_minus_p = proto_perl->Iminus_p;
11837 PL_minus_l = proto_perl->Iminus_l;
11838 PL_minus_a = proto_perl->Iminus_a;
11839 PL_minus_F = proto_perl->Iminus_F;
11840 PL_doswitches = proto_perl->Idoswitches;
11841 PL_dowarn = proto_perl->Idowarn;
11842 PL_doextract = proto_perl->Idoextract;
11843 PL_sawampersand = proto_perl->Isawampersand;
11844 PL_unsafe = proto_perl->Iunsafe;
11845 PL_inplace = SAVEPV(proto_perl->Iinplace);
11846 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11847 PL_perldb = proto_perl->Iperldb;
11848 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11849 PL_exit_flags = proto_perl->Iexit_flags;
11851 /* magical thingies */
11852 /* XXX time(&PL_basetime) when asked for? */
11853 PL_basetime = proto_perl->Ibasetime;
11854 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11856 PL_maxsysfd = proto_perl->Imaxsysfd;
11857 PL_multiline = proto_perl->Imultiline;
11858 PL_statusvalue = proto_perl->Istatusvalue;
11860 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11862 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11864 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11865 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11866 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11868 /* Clone the regex array */
11869 PL_regex_padav = newAV();
11871 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11872 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11873 av_push(PL_regex_padav,
11874 sv_dup_inc(regexen[0],param));
11875 for(i = 1; i <= len; i++) {
11876 if(SvREPADTMP(regexen[i])) {
11877 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11879 av_push(PL_regex_padav,
11881 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11882 SvIVX(regexen[i])), param)))
11887 PL_regex_pad = AvARRAY(PL_regex_padav);
11889 /* shortcuts to various I/O objects */
11890 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11891 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11892 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11893 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11894 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11895 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11897 /* shortcuts to regexp stuff */
11898 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11900 /* shortcuts to misc objects */
11901 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11903 /* shortcuts to debugging objects */
11904 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11905 PL_DBline = gv_dup(proto_perl->IDBline, param);
11906 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11907 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11908 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11909 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11910 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11911 PL_lineary = av_dup(proto_perl->Ilineary, param);
11912 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11914 /* symbol tables */
11915 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11916 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11917 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11918 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11919 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11921 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11922 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11923 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11924 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11925 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11926 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11928 PL_sub_generation = proto_perl->Isub_generation;
11930 /* funky return mechanisms */
11931 PL_forkprocess = proto_perl->Iforkprocess;
11933 /* subprocess state */
11934 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11936 /* internal state */
11937 PL_tainting = proto_perl->Itainting;
11938 PL_taint_warn = proto_perl->Itaint_warn;
11939 PL_maxo = proto_perl->Imaxo;
11940 if (proto_perl->Iop_mask)
11941 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11943 PL_op_mask = Nullch;
11944 /* PL_asserting = proto_perl->Iasserting; */
11946 /* current interpreter roots */
11947 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11948 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11949 PL_main_start = proto_perl->Imain_start;
11950 PL_eval_root = proto_perl->Ieval_root;
11951 PL_eval_start = proto_perl->Ieval_start;
11953 /* runtime control stuff */
11954 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11955 PL_copline = proto_perl->Icopline;
11957 PL_filemode = proto_perl->Ifilemode;
11958 PL_lastfd = proto_perl->Ilastfd;
11959 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11962 PL_gensym = proto_perl->Igensym;
11963 PL_preambled = proto_perl->Ipreambled;
11964 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11965 PL_laststatval = proto_perl->Ilaststatval;
11966 PL_laststype = proto_perl->Ilaststype;
11967 PL_mess_sv = Nullsv;
11969 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11970 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11972 /* interpreter atexit processing */
11973 PL_exitlistlen = proto_perl->Iexitlistlen;
11974 if (PL_exitlistlen) {
11975 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11976 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11979 PL_exitlist = (PerlExitListEntry*)NULL;
11980 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11981 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11982 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11984 PL_profiledata = NULL;
11985 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11986 /* PL_rsfp_filters entries have fake IoDIRP() */
11987 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11989 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11991 PAD_CLONE_VARS(proto_perl, param);
11993 #ifdef HAVE_INTERP_INTERN
11994 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11997 /* more statics moved here */
11998 PL_generation = proto_perl->Igeneration;
11999 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12001 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12002 PL_in_clean_all = proto_perl->Iin_clean_all;
12004 PL_uid = proto_perl->Iuid;
12005 PL_euid = proto_perl->Ieuid;
12006 PL_gid = proto_perl->Igid;
12007 PL_egid = proto_perl->Iegid;
12008 PL_nomemok = proto_perl->Inomemok;
12009 PL_an = proto_perl->Ian;
12010 PL_evalseq = proto_perl->Ievalseq;
12011 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12012 PL_origalen = proto_perl->Iorigalen;
12013 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12014 PL_osname = SAVEPV(proto_perl->Iosname);
12015 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
12016 PL_sighandlerp = proto_perl->Isighandlerp;
12019 PL_runops = proto_perl->Irunops;
12021 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
12024 PL_cshlen = proto_perl->Icshlen;
12025 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
12028 PL_lex_state = proto_perl->Ilex_state;
12029 PL_lex_defer = proto_perl->Ilex_defer;
12030 PL_lex_expect = proto_perl->Ilex_expect;
12031 PL_lex_formbrack = proto_perl->Ilex_formbrack;
12032 PL_lex_dojoin = proto_perl->Ilex_dojoin;
12033 PL_lex_starts = proto_perl->Ilex_starts;
12034 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
12035 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
12036 PL_lex_op = proto_perl->Ilex_op;
12037 PL_lex_inpat = proto_perl->Ilex_inpat;
12038 PL_lex_inwhat = proto_perl->Ilex_inwhat;
12039 PL_lex_brackets = proto_perl->Ilex_brackets;
12040 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
12041 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
12042 PL_lex_casemods = proto_perl->Ilex_casemods;
12043 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
12044 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
12046 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
12047 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
12048 PL_nexttoke = proto_perl->Inexttoke;
12050 /* XXX This is probably masking the deeper issue of why
12051 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
12052 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
12053 * (A little debugging with a watchpoint on it may help.)
12055 if (SvANY(proto_perl->Ilinestr)) {
12056 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
12057 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
12058 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12059 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
12060 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12061 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
12062 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12063 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
12064 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12067 PL_linestr = NEWSV(65,79);
12068 sv_upgrade(PL_linestr,SVt_PVIV);
12069 sv_setpvn(PL_linestr,"",0);
12070 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
12072 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12073 PL_pending_ident = proto_perl->Ipending_ident;
12074 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
12076 PL_expect = proto_perl->Iexpect;
12078 PL_multi_start = proto_perl->Imulti_start;
12079 PL_multi_end = proto_perl->Imulti_end;
12080 PL_multi_open = proto_perl->Imulti_open;
12081 PL_multi_close = proto_perl->Imulti_close;
12083 PL_error_count = proto_perl->Ierror_count;
12084 PL_subline = proto_perl->Isubline;
12085 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12087 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12088 if (SvANY(proto_perl->Ilinestr)) {
12089 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12090 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12091 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12092 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12093 PL_last_lop_op = proto_perl->Ilast_lop_op;
12096 PL_last_uni = SvPVX(PL_linestr);
12097 PL_last_lop = SvPVX(PL_linestr);
12098 PL_last_lop_op = 0;
12100 PL_in_my = proto_perl->Iin_my;
12101 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12103 PL_cryptseen = proto_perl->Icryptseen;
12106 PL_hints = proto_perl->Ihints;
12108 PL_amagic_generation = proto_perl->Iamagic_generation;
12110 #ifdef USE_LOCALE_COLLATE
12111 PL_collation_ix = proto_perl->Icollation_ix;
12112 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12113 PL_collation_standard = proto_perl->Icollation_standard;
12114 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12115 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12116 #endif /* USE_LOCALE_COLLATE */
12118 #ifdef USE_LOCALE_NUMERIC
12119 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12120 PL_numeric_standard = proto_perl->Inumeric_standard;
12121 PL_numeric_local = proto_perl->Inumeric_local;
12122 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12123 #endif /* !USE_LOCALE_NUMERIC */
12125 /* utf8 character classes */
12126 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12127 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12128 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12129 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12130 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12131 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12132 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12133 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12134 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12135 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12136 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12137 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12138 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12139 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12140 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12141 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12142 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12143 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12144 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12145 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12147 /* Did the locale setup indicate UTF-8? */
12148 PL_utf8locale = proto_perl->Iutf8locale;
12149 /* Unicode features (see perlrun/-C) */
12150 PL_unicode = proto_perl->Iunicode;
12152 /* Pre-5.8 signals control */
12153 PL_signals = proto_perl->Isignals;
12155 /* times() ticks per second */
12156 PL_clocktick = proto_perl->Iclocktick;
12158 /* Recursion stopper for PerlIO_find_layer */
12159 PL_in_load_module = proto_perl->Iin_load_module;
12161 /* sort() routine */
12162 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12164 /* Not really needed/useful since the reenrant_retint is "volatile",
12165 * but do it for consistency's sake. */
12166 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12168 /* Hooks to shared SVs and locks. */
12169 PL_sharehook = proto_perl->Isharehook;
12170 PL_lockhook = proto_perl->Ilockhook;
12171 PL_unlockhook = proto_perl->Iunlockhook;
12172 PL_threadhook = proto_perl->Ithreadhook;
12174 PL_runops_std = proto_perl->Irunops_std;
12175 PL_runops_dbg = proto_perl->Irunops_dbg;
12177 #ifdef THREADS_HAVE_PIDS
12178 PL_ppid = proto_perl->Ippid;
12182 PL_last_swash_hv = Nullhv; /* reinits on demand */
12183 PL_last_swash_klen = 0;
12184 PL_last_swash_key[0]= '\0';
12185 PL_last_swash_tmps = (U8*)NULL;
12186 PL_last_swash_slen = 0;
12188 PL_glob_index = proto_perl->Iglob_index;
12189 PL_srand_called = proto_perl->Isrand_called;
12190 PL_hash_seed = proto_perl->Ihash_seed;
12191 PL_rehash_seed = proto_perl->Irehash_seed;
12192 PL_uudmap['M'] = 0; /* reinits on demand */
12193 PL_bitcount = Nullch; /* reinits on demand */
12195 if (proto_perl->Ipsig_pend) {
12196 Newz(0, PL_psig_pend, SIG_SIZE, int);
12199 PL_psig_pend = (int*)NULL;
12202 if (proto_perl->Ipsig_ptr) {
12203 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12204 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12205 for (i = 1; i < SIG_SIZE; i++) {
12206 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12207 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12211 PL_psig_ptr = (SV**)NULL;
12212 PL_psig_name = (SV**)NULL;
12215 /* thrdvar.h stuff */
12217 if (flags & CLONEf_COPY_STACKS) {
12218 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12219 PL_tmps_ix = proto_perl->Ttmps_ix;
12220 PL_tmps_max = proto_perl->Ttmps_max;
12221 PL_tmps_floor = proto_perl->Ttmps_floor;
12222 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12224 while (i <= PL_tmps_ix) {
12225 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12229 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12230 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12231 Newz(54, PL_markstack, i, I32);
12232 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12233 - proto_perl->Tmarkstack);
12234 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12235 - proto_perl->Tmarkstack);
12236 Copy(proto_perl->Tmarkstack, PL_markstack,
12237 PL_markstack_ptr - PL_markstack + 1, I32);
12239 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12240 * NOTE: unlike the others! */
12241 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12242 PL_scopestack_max = proto_perl->Tscopestack_max;
12243 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12244 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12246 /* NOTE: si_dup() looks at PL_markstack */
12247 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12249 /* PL_curstack = PL_curstackinfo->si_stack; */
12250 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12251 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12253 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12254 PL_stack_base = AvARRAY(PL_curstack);
12255 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12256 - proto_perl->Tstack_base);
12257 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12259 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12260 * NOTE: unlike the others! */
12261 PL_savestack_ix = proto_perl->Tsavestack_ix;
12262 PL_savestack_max = proto_perl->Tsavestack_max;
12263 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12264 PL_savestack = ss_dup(proto_perl, param);
12268 ENTER; /* perl_destruct() wants to LEAVE; */
12271 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12272 PL_top_env = &PL_start_env;
12274 PL_op = proto_perl->Top;
12277 PL_Xpv = (XPV*)NULL;
12278 PL_na = proto_perl->Tna;
12280 PL_statbuf = proto_perl->Tstatbuf;
12281 PL_statcache = proto_perl->Tstatcache;
12282 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12283 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12285 PL_timesbuf = proto_perl->Ttimesbuf;
12288 PL_tainted = proto_perl->Ttainted;
12289 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12290 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12291 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12292 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12293 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12294 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12295 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12296 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12297 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12299 PL_restartop = proto_perl->Trestartop;
12300 PL_in_eval = proto_perl->Tin_eval;
12301 PL_delaymagic = proto_perl->Tdelaymagic;
12302 PL_dirty = proto_perl->Tdirty;
12303 PL_localizing = proto_perl->Tlocalizing;
12305 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12306 PL_hv_fetch_ent_mh = Nullhe;
12307 PL_modcount = proto_perl->Tmodcount;
12308 PL_lastgotoprobe = Nullop;
12309 PL_dumpindent = proto_perl->Tdumpindent;
12311 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12312 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12313 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12314 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12315 PL_sortcxix = proto_perl->Tsortcxix;
12316 PL_efloatbuf = Nullch; /* reinits on demand */
12317 PL_efloatsize = 0; /* reinits on demand */
12321 PL_screamfirst = NULL;
12322 PL_screamnext = NULL;
12323 PL_maxscream = -1; /* reinits on demand */
12324 PL_lastscream = Nullsv;
12326 PL_watchaddr = NULL;
12327 PL_watchok = Nullch;
12329 PL_regdummy = proto_perl->Tregdummy;
12330 PL_regprecomp = Nullch;
12333 PL_colorset = 0; /* reinits PL_colors[] */
12334 /*PL_colors[6] = {0,0,0,0,0,0};*/
12335 PL_reginput = Nullch;
12336 PL_regbol = Nullch;
12337 PL_regeol = Nullch;
12338 PL_regstartp = (I32*)NULL;
12339 PL_regendp = (I32*)NULL;
12340 PL_reglastparen = (U32*)NULL;
12341 PL_reglastcloseparen = (U32*)NULL;
12342 PL_regtill = Nullch;
12343 PL_reg_start_tmp = (char**)NULL;
12344 PL_reg_start_tmpl = 0;
12345 PL_regdata = (struct reg_data*)NULL;
12348 PL_reg_eval_set = 0;
12350 PL_regprogram = (regnode*)NULL;
12352 PL_regcc = (CURCUR*)NULL;
12353 PL_reg_call_cc = (struct re_cc_state*)NULL;
12354 PL_reg_re = (regexp*)NULL;
12355 PL_reg_ganch = Nullch;
12356 PL_reg_sv = Nullsv;
12357 PL_reg_match_utf8 = FALSE;
12358 PL_reg_magic = (MAGIC*)NULL;
12360 PL_reg_oldcurpm = (PMOP*)NULL;
12361 PL_reg_curpm = (PMOP*)NULL;
12362 PL_reg_oldsaved = Nullch;
12363 PL_reg_oldsavedlen = 0;
12364 #ifdef PERL_COPY_ON_WRITE
12367 PL_reg_maxiter = 0;
12368 PL_reg_leftiter = 0;
12369 PL_reg_poscache = Nullch;
12370 PL_reg_poscache_size= 0;
12372 /* RE engine - function pointers */
12373 PL_regcompp = proto_perl->Tregcompp;
12374 PL_regexecp = proto_perl->Tregexecp;
12375 PL_regint_start = proto_perl->Tregint_start;
12376 PL_regint_string = proto_perl->Tregint_string;
12377 PL_regfree = proto_perl->Tregfree;
12379 PL_reginterp_cnt = 0;
12380 PL_reg_starttry = 0;
12382 /* Pluggable optimizer */
12383 PL_peepp = proto_perl->Tpeepp;
12385 PL_stashcache = newHV();
12387 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12388 ptr_table_free(PL_ptr_table);
12389 PL_ptr_table = NULL;
12392 /* Call the ->CLONE method, if it exists, for each of the stashes
12393 identified by sv_dup() above.
12395 while(av_len(param->stashes) != -1) {
12396 HV* stash = (HV*) av_shift(param->stashes);
12397 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12398 if (cloner && GvCV(cloner)) {
12403 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12405 call_sv((SV*)GvCV(cloner), G_DISCARD);
12411 SvREFCNT_dec(param->stashes);
12413 /* orphaned? eg threads->new inside BEGIN or use */
12414 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12415 (void)SvREFCNT_inc(PL_compcv);
12416 SAVEFREESV(PL_compcv);
12422 #endif /* USE_ITHREADS */
12425 =head1 Unicode Support
12427 =for apidoc sv_recode_to_utf8
12429 The encoding is assumed to be an Encode object, on entry the PV
12430 of the sv is assumed to be octets in that encoding, and the sv
12431 will be converted into Unicode (and UTF-8).
12433 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12434 is not a reference, nothing is done to the sv. If the encoding is not
12435 an C<Encode::XS> Encoding object, bad things will happen.
12436 (See F<lib/encoding.pm> and L<Encode>).
12438 The PV of the sv is returned.
12443 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12446 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12460 Passing sv_yes is wrong - it needs to be or'ed set of constants
12461 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12462 remove converted chars from source.
12464 Both will default the value - let them.
12466 XPUSHs(&PL_sv_yes);
12469 call_method("decode", G_SCALAR);
12473 s = SvPV(uni, len);
12474 if (s != SvPVX(sv)) {
12475 SvGROW(sv, len + 1);
12476 Move(s, SvPVX(sv), len, char);
12477 SvCUR_set(sv, len);
12478 SvPVX(sv)[len] = 0;
12485 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12489 =for apidoc sv_cat_decode
12491 The encoding is assumed to be an Encode object, the PV of the ssv is
12492 assumed to be octets in that encoding and decoding the input starts
12493 from the position which (PV + *offset) pointed to. The dsv will be
12494 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12495 when the string tstr appears in decoding output or the input ends on
12496 the PV of the ssv. The value which the offset points will be modified
12497 to the last input position on the ssv.
12499 Returns TRUE if the terminator was found, else returns FALSE.
12504 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12505 SV *ssv, int *offset, char *tstr, int tlen)
12509 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12520 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12521 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12523 call_method("cat_decode", G_SCALAR);
12525 ret = SvTRUE(TOPs);
12526 *offset = SvIV(offsv);
12532 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12538 * c-indentation-style: bsd
12539 * c-basic-offset: 4
12540 * indent-tabs-mode: t
12543 * ex: set ts=8 sts=4 sw=4 noet: