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) SvUVX(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 are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 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
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
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..."
168 #ifdef DEBUG_LEAKING_SCALARS
170 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
172 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
175 # define FREE_SV_DEBUG_FILE(sv)
178 #define plant_SV(p) \
180 FREE_SV_DEBUG_FILE(p); \
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
187 /* sv_mutex must be held while calling uproot_SV() */
188 #define uproot_SV(p) \
191 PL_sv_root = (SV*)SvANY(p); \
196 /* new_SV(): return a new, empty SV head */
198 #ifdef DEBUG_LEAKING_SCALARS
199 /* provide a real function for a debugger to play with */
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
227 # define new_SV(p) (p)=S_new_SV(aTHX)
245 /* del_SV(): return an empty SV head to the free list */
260 S_del_sv(pTHX_ SV *p)
267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
269 svend = &sva[SvREFCNT(sva)];
270 if (p >= sv && p < svend)
274 if (ckWARN_d(WARN_INTERNAL))
275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
284 #else /* ! DEBUGGING */
286 #define del_SV(p) plant_SV(p)
288 #endif /* DEBUGGING */
292 =head1 SV Manipulation Functions
294 =for apidoc sv_add_arena
296 Given a chunk of memory, link it to the head of the list of arenas,
297 and split it into a list of free SVs.
303 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
309 /* The first SV in an arena isn't an SV. */
310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
317 svend = &sva[SvREFCNT(sva) - 1];
320 SvANY(sv) = (void *)(SV*)(sv + 1);
322 SvFLAGS(sv) = SVTYPEMASK;
326 SvFLAGS(sv) = SVTYPEMASK;
329 /* make some more SVs by adding another arena */
331 /* sv_mutex must be held while calling more_sv() */
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
340 PL_nice_chunk_size = 0;
343 char *chunk; /* must use New here to match call to */
344 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
345 sv_add_arena(chunk, 1008, 0);
351 /* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
355 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 svend = &sva[SvREFCNT(sva)];
364 for (sv = sva + 1; sv < svend; ++sv) {
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
379 /* called by sv_report_used() for each live SV */
382 do_report_used(pTHX_ SV *sv)
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
392 =for apidoc sv_report_used
394 Dump the contents of all SVs not yet freed. (Debugging aid).
400 Perl_sv_report_used(pTHX)
403 visit(do_report_used, 0, 0);
407 /* called by sv_clean_objs() for each live SV */
410 do_clean_objs(pTHX_ SV *sv)
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
427 /* XXX Might want to check arrays, etc. */
430 /* called by sv_clean_objs() for each live SV */
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
434 do_clean_named_objs(pTHX_ SV *sv)
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
444 SvFLAGS(sv) |= SVf_BREAK;
452 =for apidoc sv_clean_objs
454 Attempt to destroy all objects not yet freed
460 Perl_sv_clean_objs(pTHX)
462 PL_in_clean_objs = TRUE;
463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
464 #ifndef DISABLE_DESTRUCTOR_KLUDGE
465 /* some barnacles may yet remain, clinging to typeglobs */
466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
468 PL_in_clean_objs = FALSE;
471 /* called by sv_clean_all() for each live SV */
474 do_clean_all(pTHX_ SV *sv)
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
478 if (PL_comppad == (AV*)sv) {
480 PL_curpad = Null(SV**);
486 =for apidoc sv_clean_all
488 Decrement the refcnt of each remaining SV, possibly triggering a
489 cleanup. This function may have to be called multiple times to free
490 SVs which are in complex self-referential hierarchies.
496 Perl_sv_clean_all(pTHX)
499 PL_in_clean_all = TRUE;
500 cleaned = visit(do_clean_all, 0,0);
501 PL_in_clean_all = FALSE;
506 =for apidoc sv_free_arenas
508 Deallocate the memory used by all arenas. Note that all the individual SV
509 heads and bodies within the arenas must already have been freed.
515 Perl_sv_free_arenas(pTHX)
519 XPV *arena, *arenanext;
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
530 Safefree((void *)sva);
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xiv_arenaroot = 0;
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xrv_arenaroot = 0;
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xpv_arenaroot = 0;
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpviv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpvnv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvcv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvav_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvhv_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvmg_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvbm_arenaroot = 0;
617 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
625 Safefree(PL_nice_chunk);
626 PL_nice_chunk = Nullch;
627 PL_nice_chunk_size = 0;
632 /* ---------------------------------------------------------------------
634 * support functions for report_uninit()
637 /* the maxiumum size of array or hash where we will scan looking
638 * for the undefined element that triggered the warning */
640 #define FUV_MAX_SEARCH_SIZE 1000
642 /* Look for an entry in the hash whose value has the same SV as val;
643 * If so, return a mortal copy of the key. */
646 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
652 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
653 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
658 for (i=HvMAX(hv); i>0; i--) {
659 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
660 if (HeVAL(entry) != val)
662 if ( HeVAL(entry) == &PL_sv_undef ||
663 HeVAL(entry) == &PL_sv_placeholder)
667 if (HeKLEN(entry) == HEf_SVKEY)
668 return sv_mortalcopy(HeKEY_sv(entry));
669 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
675 /* Look for an entry in the array whose value has the same SV as val;
676 * If so, return the index, otherwise return -1. */
679 S_find_array_subscript(pTHX_ AV *av, SV* val)
683 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
684 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
688 for (i=AvFILLp(av); i>=0; i--) {
689 if (svp[i] == val && svp[i] != &PL_sv_undef)
695 /* S_varname(): return the name of a variable, optionally with a subscript.
696 * If gv is non-zero, use the name of that global, along with gvtype (one
697 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
698 * targ. Depending on the value of the subscript_type flag, return:
701 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
702 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
703 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
704 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
707 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
708 SV* keyname, I32 aindex, int subscript_type)
714 name = sv_newmortal();
717 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
718 * XXX get rid of all this if gv_fullnameX() ever supports this
722 HV *hv = GvSTASH(gv);
723 sv_setpv(name, gvtype);
726 else if (!(p=HvNAME(hv)))
728 if (strNE(p, "main")) {
730 sv_catpvn(name,"::", 2);
732 if (GvNAMELEN(gv)>= 1 &&
733 ((unsigned int)*GvNAME(gv)) <= 26)
735 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
736 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
739 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
743 CV *cv = find_runcv(&u);
744 if (!cv || !CvPADLIST(cv))
746 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
747 sv = *av_fetch(av, targ, FALSE);
748 /* SvLEN in a pad name is not to be trusted */
749 sv_setpv(name, SvPV_nolen(sv));
752 if (subscript_type == FUV_SUBSCRIPT_HASH) {
755 Perl_sv_catpvf(aTHX_ name, "{%s}",
756 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
759 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
761 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
763 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
764 sv_insert(name, 0, 0, "within ", 7);
771 =for apidoc find_uninit_var
773 Find the name of the undefined variable (if any) that caused the operator o
774 to issue a "Use of uninitialized value" warning.
775 If match is true, only return a name if it's value matches uninit_sv.
776 So roughly speaking, if a unary operator (such as OP_COS) generates a
777 warning, then following the direct child of the op may yield an
778 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
779 other hand, with OP_ADD there are two branches to follow, so we only print
780 the variable name if we get an exact match.
782 The name is returned as a mortal SV.
784 Assumes that PL_op is the op that originally triggered the error, and that
785 PL_comppad/PL_curpad points to the currently executing pad.
791 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
799 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
800 uninit_sv == &PL_sv_placeholder)))
803 switch (obase->op_type) {
810 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
811 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
814 int subscript_type = FUV_SUBSCRIPT_WITHIN;
816 if (pad) { /* @lex, %lex */
817 sv = PAD_SVl(obase->op_targ);
821 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
822 /* @global, %global */
823 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
826 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
828 else /* @{expr}, %{expr} */
829 return find_uninit_var(cUNOPx(obase)->op_first,
833 /* attempt to find a match within the aggregate */
835 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
837 subscript_type = FUV_SUBSCRIPT_HASH;
840 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
842 subscript_type = FUV_SUBSCRIPT_ARRAY;
845 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
848 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
849 keysv, index, subscript_type);
853 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
855 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
856 Nullsv, 0, FUV_SUBSCRIPT_NONE);
859 gv = cGVOPx_gv(obase);
860 if (!gv || (match && GvSV(gv) != uninit_sv))
862 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
865 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
867 av = (AV*)PAD_SV(obase->op_targ);
868 if (!av || SvRMAGICAL(av))
870 svp = av_fetch(av, (I32)obase->op_private, FALSE);
871 if (!svp || *svp != uninit_sv)
874 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
875 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
878 gv = cGVOPx_gv(obase);
883 if (!av || SvRMAGICAL(av))
885 svp = av_fetch(av, (I32)obase->op_private, FALSE);
886 if (!svp || *svp != uninit_sv)
889 return S_varname(aTHX_ gv, "$", 0,
890 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
895 o = cUNOPx(obase)->op_first;
896 if (!o || o->op_type != OP_NULL ||
897 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
899 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
904 /* $a[uninit_expr] or $h{uninit_expr} */
905 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
908 o = cBINOPx(obase)->op_first;
909 kid = cBINOPx(obase)->op_last;
911 /* get the av or hv, and optionally the gv */
913 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
914 sv = PAD_SV(o->op_targ);
916 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
917 && cUNOPo->op_first->op_type == OP_GV)
919 gv = cGVOPx_gv(cUNOPo->op_first);
922 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
927 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
928 /* index is constant */
932 if (obase->op_type == OP_HELEM) {
933 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
934 if (!he || HeVAL(he) != uninit_sv)
938 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
939 if (!svp || *svp != uninit_sv)
943 if (obase->op_type == OP_HELEM)
944 return S_varname(aTHX_ gv, "%", o->op_targ,
945 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
947 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
948 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
952 /* index is an expression;
953 * attempt to find a match within the aggregate */
954 if (obase->op_type == OP_HELEM) {
955 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
957 return S_varname(aTHX_ gv, "%", o->op_targ,
958 keysv, 0, FUV_SUBSCRIPT_HASH);
961 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
963 return S_varname(aTHX_ gv, "@", o->op_targ,
964 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
968 return S_varname(aTHX_ gv,
969 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
971 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
977 /* only examine RHS */
978 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
981 o = cUNOPx(obase)->op_first;
982 if (o->op_type == OP_PUSHMARK)
985 if (!o->op_sibling) {
986 /* one-arg version of open is highly magical */
988 if (o->op_type == OP_GV) { /* open FOO; */
990 if (match && GvSV(gv) != uninit_sv)
992 return S_varname(aTHX_ gv, "$", 0,
993 Nullsv, 0, FUV_SUBSCRIPT_NONE);
995 /* other possibilities not handled are:
996 * open $x; or open my $x; should return '${*$x}'
997 * open expr; should return '$'.expr ideally
1003 /* ops where $_ may be an implicit arg */
1007 if ( !(obase->op_flags & OPf_STACKED)) {
1008 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1009 ? PAD_SVl(obase->op_targ)
1012 sv = sv_newmortal();
1021 /* skip filehandle as it can't produce 'undef' warning */
1022 o = cUNOPx(obase)->op_first;
1023 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1024 o = o->op_sibling->op_sibling;
1031 match = 1; /* XS or custom code could trigger random warnings */
1036 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1037 return sv_2mortal(newSVpv("${$/}", 0));
1042 if (!(obase->op_flags & OPf_KIDS))
1044 o = cUNOPx(obase)->op_first;
1050 /* if all except one arg are constant, or have no side-effects,
1051 * or are optimized away, then it's unambiguous */
1053 for (kid=o; kid; kid = kid->op_sibling) {
1055 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1056 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1057 || (kid->op_type == OP_PUSHMARK)
1061 if (o2) { /* more than one found */
1068 return find_uninit_var(o2, uninit_sv, match);
1072 sv = find_uninit_var(o, uninit_sv, 1);
1084 =for apidoc report_uninit
1086 Print appropriate "Use of uninitialized variable" warning
1092 Perl_report_uninit(pTHX_ SV* uninit_sv)
1095 SV* varname = Nullsv;
1097 varname = find_uninit_var(PL_op, uninit_sv,0);
1099 sv_insert(varname, 0, 0, " ", 1);
1101 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1102 varname ? SvPV_nolen(varname) : "",
1103 " in ", OP_DESC(PL_op));
1106 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1110 /* grab a new IV body from the free list, allocating more if necessary */
1121 * See comment in more_xiv() -- RAM.
1123 PL_xiv_root = *(IV**)xiv;
1125 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1128 /* return an IV body to the free list */
1131 S_del_xiv(pTHX_ XPVIV *p)
1133 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1135 *(IV**)xiv = PL_xiv_root;
1140 /* allocate another arena's worth of IV bodies */
1146 register IV* xivend;
1148 New(705, ptr, 1008/sizeof(XPV), XPV);
1149 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1150 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1153 xivend = &xiv[1008 / sizeof(IV) - 1];
1154 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1156 while (xiv < xivend) {
1157 *(IV**)xiv = (IV *)(xiv + 1);
1163 /* grab a new NV body from the free list, allocating more if necessary */
1173 PL_xnv_root = *(NV**)xnv;
1175 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1178 /* return an NV body to the free list */
1181 S_del_xnv(pTHX_ XPVNV *p)
1183 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1185 *(NV**)xnv = PL_xnv_root;
1190 /* allocate another arena's worth of NV bodies */
1196 register NV* xnvend;
1198 New(711, ptr, 1008/sizeof(XPV), XPV);
1199 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1200 PL_xnv_arenaroot = ptr;
1203 xnvend = &xnv[1008 / sizeof(NV) - 1];
1204 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1206 while (xnv < xnvend) {
1207 *(NV**)xnv = (NV*)(xnv + 1);
1213 /* grab a new struct xrv from the free list, allocating more if necessary */
1223 PL_xrv_root = (XRV*)xrv->xrv_rv;
1228 /* return a struct xrv to the free list */
1231 S_del_xrv(pTHX_ XRV *p)
1234 p->xrv_rv = (SV*)PL_xrv_root;
1239 /* allocate another arena's worth of struct xrv */
1245 register XRV* xrvend;
1247 New(712, ptr, 1008/sizeof(XPV), XPV);
1248 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1249 PL_xrv_arenaroot = ptr;
1252 xrvend = &xrv[1008 / sizeof(XRV) - 1];
1253 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1255 while (xrv < xrvend) {
1256 xrv->xrv_rv = (SV*)(xrv + 1);
1262 /* grab a new struct xpv from the free list, allocating more if necessary */
1272 PL_xpv_root = (XPV*)xpv->xpv_pv;
1277 /* return a struct xpv to the free list */
1280 S_del_xpv(pTHX_ XPV *p)
1283 p->xpv_pv = (char*)PL_xpv_root;
1288 /* allocate another arena's worth of struct xpv */
1294 register XPV* xpvend;
1295 New(713, xpv, 1008/sizeof(XPV), XPV);
1296 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1297 PL_xpv_arenaroot = xpv;
1299 xpvend = &xpv[1008 / sizeof(XPV) - 1];
1300 PL_xpv_root = ++xpv;
1301 while (xpv < xpvend) {
1302 xpv->xpv_pv = (char*)(xpv + 1);
1308 /* grab a new struct xpviv from the free list, allocating more if necessary */
1317 xpviv = PL_xpviv_root;
1318 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1323 /* return a struct xpviv to the free list */
1326 S_del_xpviv(pTHX_ XPVIV *p)
1329 p->xpv_pv = (char*)PL_xpviv_root;
1334 /* allocate another arena's worth of struct xpviv */
1339 register XPVIV* xpviv;
1340 register XPVIV* xpvivend;
1341 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
1342 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1343 PL_xpviv_arenaroot = xpviv;
1345 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
1346 PL_xpviv_root = ++xpviv;
1347 while (xpviv < xpvivend) {
1348 xpviv->xpv_pv = (char*)(xpviv + 1);
1354 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1363 xpvnv = PL_xpvnv_root;
1364 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1369 /* return a struct xpvnv to the free list */
1372 S_del_xpvnv(pTHX_ XPVNV *p)
1375 p->xpv_pv = (char*)PL_xpvnv_root;
1380 /* allocate another arena's worth of struct xpvnv */
1385 register XPVNV* xpvnv;
1386 register XPVNV* xpvnvend;
1387 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
1388 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1389 PL_xpvnv_arenaroot = xpvnv;
1391 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
1392 PL_xpvnv_root = ++xpvnv;
1393 while (xpvnv < xpvnvend) {
1394 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1400 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1409 xpvcv = PL_xpvcv_root;
1410 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1415 /* return a struct xpvcv to the free list */
1418 S_del_xpvcv(pTHX_ XPVCV *p)
1421 p->xpv_pv = (char*)PL_xpvcv_root;
1426 /* allocate another arena's worth of struct xpvcv */
1431 register XPVCV* xpvcv;
1432 register XPVCV* xpvcvend;
1433 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
1434 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1435 PL_xpvcv_arenaroot = xpvcv;
1437 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
1438 PL_xpvcv_root = ++xpvcv;
1439 while (xpvcv < xpvcvend) {
1440 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1446 /* grab a new struct xpvav from the free list, allocating more if necessary */
1455 xpvav = PL_xpvav_root;
1456 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1461 /* return a struct xpvav to the free list */
1464 S_del_xpvav(pTHX_ XPVAV *p)
1467 p->xav_array = (char*)PL_xpvav_root;
1472 /* allocate another arena's worth of struct xpvav */
1477 register XPVAV* xpvav;
1478 register XPVAV* xpvavend;
1479 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
1480 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1481 PL_xpvav_arenaroot = xpvav;
1483 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
1484 PL_xpvav_root = ++xpvav;
1485 while (xpvav < xpvavend) {
1486 xpvav->xav_array = (char*)(xpvav + 1);
1489 xpvav->xav_array = 0;
1492 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1501 xpvhv = PL_xpvhv_root;
1502 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1507 /* return a struct xpvhv to the free list */
1510 S_del_xpvhv(pTHX_ XPVHV *p)
1513 p->xhv_array = (char*)PL_xpvhv_root;
1518 /* allocate another arena's worth of struct xpvhv */
1523 register XPVHV* xpvhv;
1524 register XPVHV* xpvhvend;
1525 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1526 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1527 PL_xpvhv_arenaroot = xpvhv;
1529 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1530 PL_xpvhv_root = ++xpvhv;
1531 while (xpvhv < xpvhvend) {
1532 xpvhv->xhv_array = (char*)(xpvhv + 1);
1535 xpvhv->xhv_array = 0;
1538 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1547 xpvmg = PL_xpvmg_root;
1548 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1553 /* return a struct xpvmg to the free list */
1556 S_del_xpvmg(pTHX_ XPVMG *p)
1559 p->xpv_pv = (char*)PL_xpvmg_root;
1564 /* allocate another arena's worth of struct xpvmg */
1569 register XPVMG* xpvmg;
1570 register XPVMG* xpvmgend;
1571 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1572 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1573 PL_xpvmg_arenaroot = xpvmg;
1575 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1576 PL_xpvmg_root = ++xpvmg;
1577 while (xpvmg < xpvmgend) {
1578 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1584 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1593 xpvlv = PL_xpvlv_root;
1594 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1599 /* return a struct xpvlv to the free list */
1602 S_del_xpvlv(pTHX_ XPVLV *p)
1605 p->xpv_pv = (char*)PL_xpvlv_root;
1610 /* allocate another arena's worth of struct xpvlv */
1615 register XPVLV* xpvlv;
1616 register XPVLV* xpvlvend;
1617 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1618 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1619 PL_xpvlv_arenaroot = xpvlv;
1621 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1622 PL_xpvlv_root = ++xpvlv;
1623 while (xpvlv < xpvlvend) {
1624 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1630 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1639 xpvbm = PL_xpvbm_root;
1640 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1645 /* return a struct xpvbm to the free list */
1648 S_del_xpvbm(pTHX_ XPVBM *p)
1651 p->xpv_pv = (char*)PL_xpvbm_root;
1656 /* allocate another arena's worth of struct xpvbm */
1661 register XPVBM* xpvbm;
1662 register XPVBM* xpvbmend;
1663 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1664 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1665 PL_xpvbm_arenaroot = xpvbm;
1667 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1668 PL_xpvbm_root = ++xpvbm;
1669 while (xpvbm < xpvbmend) {
1670 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1676 #define my_safemalloc(s) (void*)safemalloc(s)
1677 #define my_safefree(p) safefree((char*)p)
1681 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1682 #define del_XIV(p) my_safefree(p)
1684 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1685 #define del_XNV(p) my_safefree(p)
1687 #define new_XRV() my_safemalloc(sizeof(XRV))
1688 #define del_XRV(p) my_safefree(p)
1690 #define new_XPV() my_safemalloc(sizeof(XPV))
1691 #define del_XPV(p) my_safefree(p)
1693 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1694 #define del_XPVIV(p) my_safefree(p)
1696 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1697 #define del_XPVNV(p) my_safefree(p)
1699 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1700 #define del_XPVCV(p) my_safefree(p)
1702 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1703 #define del_XPVAV(p) my_safefree(p)
1705 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1706 #define del_XPVHV(p) my_safefree(p)
1708 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1709 #define del_XPVMG(p) my_safefree(p)
1711 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1712 #define del_XPVLV(p) my_safefree(p)
1714 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1715 #define del_XPVBM(p) my_safefree(p)
1719 #define new_XIV() (void*)new_xiv()
1720 #define del_XIV(p) del_xiv((XPVIV*) p)
1722 #define new_XNV() (void*)new_xnv()
1723 #define del_XNV(p) del_xnv((XPVNV*) p)
1725 #define new_XRV() (void*)new_xrv()
1726 #define del_XRV(p) del_xrv((XRV*) p)
1728 #define new_XPV() (void*)new_xpv()
1729 #define del_XPV(p) del_xpv((XPV *)p)
1731 #define new_XPVIV() (void*)new_xpviv()
1732 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1734 #define new_XPVNV() (void*)new_xpvnv()
1735 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1737 #define new_XPVCV() (void*)new_xpvcv()
1738 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1740 #define new_XPVAV() (void*)new_xpvav()
1741 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1743 #define new_XPVHV() (void*)new_xpvhv()
1744 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1746 #define new_XPVMG() (void*)new_xpvmg()
1747 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1749 #define new_XPVLV() (void*)new_xpvlv()
1750 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1752 #define new_XPVBM() (void*)new_xpvbm()
1753 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1757 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1758 #define del_XPVGV(p) my_safefree(p)
1760 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1761 #define del_XPVFM(p) my_safefree(p)
1763 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1764 #define del_XPVIO(p) my_safefree(p)
1767 =for apidoc sv_upgrade
1769 Upgrade an SV to a more complex form. Generally adds a new body type to the
1770 SV, then copies across as much information as possible from the old body.
1771 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1777 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1785 MAGIC* magic = NULL;
1788 if (mt != SVt_PV && SvIsCOW(sv)) {
1789 sv_force_normal_flags(sv, 0);
1792 if (SvTYPE(sv) == mt)
1796 (void)SvOOK_off(sv);
1798 switch (SvTYPE(sv)) {
1819 else if (mt < SVt_PVIV)
1836 pv = (char*)SvRV(sv);
1856 else if (mt == SVt_NV)
1867 del_XPVIV(SvANY(sv));
1877 del_XPVNV(SvANY(sv));
1885 magic = SvMAGIC(sv);
1886 stash = SvSTASH(sv);
1887 del_XPVMG(SvANY(sv));
1890 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1893 SvFLAGS(sv) &= ~SVTYPEMASK;
1898 Perl_croak(aTHX_ "Can't upgrade to undef");
1900 SvANY(sv) = new_XIV();
1904 SvANY(sv) = new_XNV();
1908 SvANY(sv) = new_XRV();
1912 SvANY(sv) = new_XPV();
1918 SvANY(sv) = new_XPVIV();
1928 SvANY(sv) = new_XPVNV();
1936 SvANY(sv) = new_XPVMG();
1942 SvMAGIC(sv) = magic;
1943 SvSTASH(sv) = stash;
1946 SvANY(sv) = new_XPVLV();
1952 SvMAGIC(sv) = magic;
1953 SvSTASH(sv) = stash;
1965 SvANY(sv) = new_XPVAV();
1973 SvMAGIC(sv) = magic;
1974 SvSTASH(sv) = stash;
1977 AvFLAGS(sv) = AVf_REAL;
1980 SvANY(sv) = new_XPVHV();
1986 HvTOTALKEYS(sv) = 0;
1987 HvPLACEHOLDERS(sv) = 0;
1988 SvMAGIC(sv) = magic;
1989 SvSTASH(sv) = stash;
1996 SvANY(sv) = new_XPVCV();
1997 Zero(SvANY(sv), 1, XPVCV);
2003 SvMAGIC(sv) = magic;
2004 SvSTASH(sv) = stash;
2007 SvANY(sv) = new_XPVGV();
2013 SvMAGIC(sv) = magic;
2014 SvSTASH(sv) = stash;
2022 SvANY(sv) = new_XPVBM();
2028 SvMAGIC(sv) = magic;
2029 SvSTASH(sv) = stash;
2035 SvANY(sv) = new_XPVFM();
2036 Zero(SvANY(sv), 1, XPVFM);
2042 SvMAGIC(sv) = magic;
2043 SvSTASH(sv) = stash;
2046 SvANY(sv) = new_XPVIO();
2047 Zero(SvANY(sv), 1, XPVIO);
2053 SvMAGIC(sv) = magic;
2054 SvSTASH(sv) = stash;
2055 IoPAGE_LEN(sv) = 60;
2062 =for apidoc sv_backoff
2064 Remove any string offset. You should normally use the C<SvOOK_off> macro
2071 Perl_sv_backoff(pTHX_ register SV *sv)
2075 char *s = SvPVX(sv);
2076 SvLEN(sv) += SvIVX(sv);
2077 SvPVX(sv) -= SvIVX(sv);
2079 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2081 SvFLAGS(sv) &= ~SVf_OOK;
2088 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2089 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2090 Use the C<SvGROW> wrapper instead.
2096 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2100 #ifdef HAS_64K_LIMIT
2101 if (newlen >= 0x10000) {
2102 PerlIO_printf(Perl_debug_log,
2103 "Allocation too large: %"UVxf"\n", (UV)newlen);
2106 #endif /* HAS_64K_LIMIT */
2109 if (SvTYPE(sv) < SVt_PV) {
2110 sv_upgrade(sv, SVt_PV);
2113 else if (SvOOK(sv)) { /* pv is offset? */
2116 if (newlen > SvLEN(sv))
2117 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2118 #ifdef HAS_64K_LIMIT
2119 if (newlen >= 0x10000)
2126 if (newlen > SvLEN(sv)) { /* need more room? */
2127 if (SvLEN(sv) && s) {
2129 STRLEN l = malloced_size((void*)SvPVX(sv));
2135 Renew(s,newlen,char);
2138 New(703, s, newlen, char);
2139 if (SvPVX(sv) && SvCUR(sv)) {
2140 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2144 SvLEN_set(sv, newlen);
2150 =for apidoc sv_setiv
2152 Copies an integer into the given SV, upgrading first if necessary.
2153 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2159 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2161 SV_CHECK_THINKFIRST_COW_DROP(sv);
2162 switch (SvTYPE(sv)) {
2164 sv_upgrade(sv, SVt_IV);
2167 sv_upgrade(sv, SVt_PVNV);
2171 sv_upgrade(sv, SVt_PVIV);
2180 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2183 (void)SvIOK_only(sv); /* validate number */
2189 =for apidoc sv_setiv_mg
2191 Like C<sv_setiv>, but also handles 'set' magic.
2197 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2204 =for apidoc sv_setuv
2206 Copies an unsigned integer into the given SV, upgrading first if necessary.
2207 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2213 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2215 /* With these two if statements:
2216 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2219 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2221 If you wish to remove them, please benchmark to see what the effect is
2223 if (u <= (UV)IV_MAX) {
2224 sv_setiv(sv, (IV)u);
2233 =for apidoc sv_setuv_mg
2235 Like C<sv_setuv>, but also handles 'set' magic.
2241 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2243 /* With these two if statements:
2244 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2247 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2249 If you wish to remove them, please benchmark to see what the effect is
2251 if (u <= (UV)IV_MAX) {
2252 sv_setiv(sv, (IV)u);
2262 =for apidoc sv_setnv
2264 Copies a double into the given SV, upgrading first if necessary.
2265 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2271 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2273 SV_CHECK_THINKFIRST_COW_DROP(sv);
2274 switch (SvTYPE(sv)) {
2277 sv_upgrade(sv, SVt_NV);
2282 sv_upgrade(sv, SVt_PVNV);
2291 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2295 (void)SvNOK_only(sv); /* validate number */
2300 =for apidoc sv_setnv_mg
2302 Like C<sv_setnv>, but also handles 'set' magic.
2308 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2314 /* Print an "isn't numeric" warning, using a cleaned-up,
2315 * printable version of the offending string
2319 S_not_a_number(pTHX_ SV *sv)
2326 dsv = sv_2mortal(newSVpv("", 0));
2327 pv = sv_uni_display(dsv, sv, 10, 0);
2330 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2331 /* each *s can expand to 4 chars + "...\0",
2332 i.e. need room for 8 chars */
2335 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2337 if (ch & 128 && !isPRINT_LC(ch)) {
2346 else if (ch == '\r') {
2350 else if (ch == '\f') {
2354 else if (ch == '\\') {
2358 else if (ch == '\0') {
2362 else if (isPRINT_LC(ch))
2379 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2380 "Argument \"%s\" isn't numeric in %s", pv,
2383 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2384 "Argument \"%s\" isn't numeric", pv);
2388 =for apidoc looks_like_number
2390 Test if the content of an SV looks like a number (or is a number).
2391 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2392 non-numeric warning), even if your atof() doesn't grok them.
2398 Perl_looks_like_number(pTHX_ SV *sv)
2400 register char *sbegin;
2407 else if (SvPOKp(sv))
2408 sbegin = SvPV(sv, len);
2410 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2411 return grok_number(sbegin, len, NULL);
2414 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2415 until proven guilty, assume that things are not that bad... */
2420 As 64 bit platforms often have an NV that doesn't preserve all bits of
2421 an IV (an assumption perl has been based on to date) it becomes necessary
2422 to remove the assumption that the NV always carries enough precision to
2423 recreate the IV whenever needed, and that the NV is the canonical form.
2424 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2425 precision as a side effect of conversion (which would lead to insanity
2426 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2427 1) to distinguish between IV/UV/NV slots that have cached a valid
2428 conversion where precision was lost and IV/UV/NV slots that have a
2429 valid conversion which has lost no precision
2430 2) to ensure that if a numeric conversion to one form is requested that
2431 would lose precision, the precise conversion (or differently
2432 imprecise conversion) is also performed and cached, to prevent
2433 requests for different numeric formats on the same SV causing
2434 lossy conversion chains. (lossless conversion chains are perfectly
2439 SvIOKp is true if the IV slot contains a valid value
2440 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2441 SvNOKp is true if the NV slot contains a valid value
2442 SvNOK is true only if the NV value is accurate
2445 while converting from PV to NV, check to see if converting that NV to an
2446 IV(or UV) would lose accuracy over a direct conversion from PV to
2447 IV(or UV). If it would, cache both conversions, return NV, but mark
2448 SV as IOK NOKp (ie not NOK).
2450 While converting from PV to IV, check to see if converting that IV to an
2451 NV would lose accuracy over a direct conversion from PV to NV. If it
2452 would, cache both conversions, flag similarly.
2454 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2455 correctly because if IV & NV were set NV *always* overruled.
2456 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2457 changes - now IV and NV together means that the two are interchangeable:
2458 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2460 The benefit of this is that operations such as pp_add know that if
2461 SvIOK is true for both left and right operands, then integer addition
2462 can be used instead of floating point (for cases where the result won't
2463 overflow). Before, floating point was always used, which could lead to
2464 loss of precision compared with integer addition.
2466 * making IV and NV equal status should make maths accurate on 64 bit
2468 * may speed up maths somewhat if pp_add and friends start to use
2469 integers when possible instead of fp. (Hopefully the overhead in
2470 looking for SvIOK and checking for overflow will not outweigh the
2471 fp to integer speedup)
2472 * will slow down integer operations (callers of SvIV) on "inaccurate"
2473 values, as the change from SvIOK to SvIOKp will cause a call into
2474 sv_2iv each time rather than a macro access direct to the IV slot
2475 * should speed up number->string conversion on integers as IV is
2476 favoured when IV and NV are equally accurate
2478 ####################################################################
2479 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2480 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2481 On the other hand, SvUOK is true iff UV.
2482 ####################################################################
2484 Your mileage will vary depending your CPU's relative fp to integer
2488 #ifndef NV_PRESERVES_UV
2489 # define IS_NUMBER_UNDERFLOW_IV 1
2490 # define IS_NUMBER_UNDERFLOW_UV 2
2491 # define IS_NUMBER_IV_AND_UV 2
2492 # define IS_NUMBER_OVERFLOW_IV 4
2493 # define IS_NUMBER_OVERFLOW_UV 5
2495 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2497 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2499 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2501 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));
2502 if (SvNVX(sv) < (NV)IV_MIN) {
2503 (void)SvIOKp_on(sv);
2506 return IS_NUMBER_UNDERFLOW_IV;
2508 if (SvNVX(sv) > (NV)UV_MAX) {
2509 (void)SvIOKp_on(sv);
2513 return IS_NUMBER_OVERFLOW_UV;
2515 (void)SvIOKp_on(sv);
2517 /* Can't use strtol etc to convert this string. (See truth table in
2519 if (SvNVX(sv) <= (UV)IV_MAX) {
2520 SvIVX(sv) = I_V(SvNVX(sv));
2521 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2522 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2524 /* Integer is imprecise. NOK, IOKp */
2526 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2529 SvUVX(sv) = U_V(SvNVX(sv));
2530 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2531 if (SvUVX(sv) == UV_MAX) {
2532 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2533 possibly be preserved by NV. Hence, it must be overflow.
2535 return IS_NUMBER_OVERFLOW_UV;
2537 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2539 /* Integer is imprecise. NOK, IOKp */
2541 return IS_NUMBER_OVERFLOW_IV;
2543 #endif /* !NV_PRESERVES_UV*/
2545 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2546 * this function provided for binary compatibility only
2550 Perl_sv_2iv(pTHX_ register SV *sv)
2552 return sv_2iv_flags(sv, SV_GMAGIC);
2556 =for apidoc sv_2iv_flags
2558 Return the integer value of an SV, doing any necessary string
2559 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2560 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2566 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2570 if (SvGMAGICAL(sv)) {
2571 if (flags & SV_GMAGIC)
2576 return I_V(SvNVX(sv));
2578 if (SvPOKp(sv) && SvLEN(sv))
2581 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2588 if (SvTHINKFIRST(sv)) {
2591 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2592 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2593 return SvIV(tmpstr);
2594 return PTR2IV(SvRV(sv));
2597 sv_force_normal_flags(sv, 0);
2599 if (SvREADONLY(sv) && !SvOK(sv)) {
2600 if (ckWARN(WARN_UNINITIALIZED))
2607 return (IV)(SvUVX(sv));
2614 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2615 * without also getting a cached IV/UV from it at the same time
2616 * (ie PV->NV conversion should detect loss of accuracy and cache
2617 * IV or UV at same time to avoid this. NWC */
2619 if (SvTYPE(sv) == SVt_NV)
2620 sv_upgrade(sv, SVt_PVNV);
2622 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2623 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2624 certainly cast into the IV range at IV_MAX, whereas the correct
2625 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2627 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2628 SvIVX(sv) = I_V(SvNVX(sv));
2629 if (SvNVX(sv) == (NV) SvIVX(sv)
2630 #ifndef NV_PRESERVES_UV
2631 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2632 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2633 /* Don't flag it as "accurately an integer" if the number
2634 came from a (by definition imprecise) NV operation, and
2635 we're outside the range of NV integer precision */
2638 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2639 DEBUG_c(PerlIO_printf(Perl_debug_log,
2640 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2646 /* IV not precise. No need to convert from PV, as NV
2647 conversion would already have cached IV if it detected
2648 that PV->IV would be better than PV->NV->IV
2649 flags already correct - don't set public IOK. */
2650 DEBUG_c(PerlIO_printf(Perl_debug_log,
2651 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2656 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2657 but the cast (NV)IV_MIN rounds to a the value less (more
2658 negative) than IV_MIN which happens to be equal to SvNVX ??
2659 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2660 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2661 (NV)UVX == NVX are both true, but the values differ. :-(
2662 Hopefully for 2s complement IV_MIN is something like
2663 0x8000000000000000 which will be exact. NWC */
2666 SvUVX(sv) = U_V(SvNVX(sv));
2668 (SvNVX(sv) == (NV) SvUVX(sv))
2669 #ifndef NV_PRESERVES_UV
2670 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2671 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2672 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2673 /* Don't flag it as "accurately an integer" if the number
2674 came from a (by definition imprecise) NV operation, and
2675 we're outside the range of NV integer precision */
2681 DEBUG_c(PerlIO_printf(Perl_debug_log,
2682 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2686 return (IV)SvUVX(sv);
2689 else if (SvPOKp(sv) && SvLEN(sv)) {
2691 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2692 /* We want to avoid a possible problem when we cache an IV which
2693 may be later translated to an NV, and the resulting NV is not
2694 the same as the direct translation of the initial string
2695 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2696 be careful to ensure that the value with the .456 is around if the
2697 NV value is requested in the future).
2699 This means that if we cache such an IV, we need to cache the
2700 NV as well. Moreover, we trade speed for space, and do not
2701 cache the NV if we are sure it's not needed.
2704 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2705 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2706 == IS_NUMBER_IN_UV) {
2707 /* It's definitely an integer, only upgrade to PVIV */
2708 if (SvTYPE(sv) < SVt_PVIV)
2709 sv_upgrade(sv, SVt_PVIV);
2711 } else if (SvTYPE(sv) < SVt_PVNV)
2712 sv_upgrade(sv, SVt_PVNV);
2714 /* If NV preserves UV then we only use the UV value if we know that
2715 we aren't going to call atof() below. If NVs don't preserve UVs
2716 then the value returned may have more precision than atof() will
2717 return, even though value isn't perfectly accurate. */
2718 if ((numtype & (IS_NUMBER_IN_UV
2719 #ifdef NV_PRESERVES_UV
2722 )) == IS_NUMBER_IN_UV) {
2723 /* This won't turn off the public IOK flag if it was set above */
2724 (void)SvIOKp_on(sv);
2726 if (!(numtype & IS_NUMBER_NEG)) {
2728 if (value <= (UV)IV_MAX) {
2729 SvIVX(sv) = (IV)value;
2735 /* 2s complement assumption */
2736 if (value <= (UV)IV_MIN) {
2737 SvIVX(sv) = -(IV)value;
2739 /* Too negative for an IV. This is a double upgrade, but
2740 I'm assuming it will be rare. */
2741 if (SvTYPE(sv) < SVt_PVNV)
2742 sv_upgrade(sv, SVt_PVNV);
2746 SvNVX(sv) = -(NV)value;
2751 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2752 will be in the previous block to set the IV slot, and the next
2753 block to set the NV slot. So no else here. */
2755 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2756 != IS_NUMBER_IN_UV) {
2757 /* It wasn't an (integer that doesn't overflow the UV). */
2758 SvNVX(sv) = Atof(SvPVX(sv));
2760 if (! numtype && ckWARN(WARN_NUMERIC))
2763 #if defined(USE_LONG_DOUBLE)
2764 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2765 PTR2UV(sv), SvNVX(sv)));
2767 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2768 PTR2UV(sv), SvNVX(sv)));
2772 #ifdef NV_PRESERVES_UV
2773 (void)SvIOKp_on(sv);
2775 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2776 SvIVX(sv) = I_V(SvNVX(sv));
2777 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2780 /* Integer is imprecise. NOK, IOKp */
2782 /* UV will not work better than IV */
2784 if (SvNVX(sv) > (NV)UV_MAX) {
2786 /* Integer is inaccurate. NOK, IOKp, is UV */
2790 SvUVX(sv) = U_V(SvNVX(sv));
2791 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2792 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2796 /* Integer is imprecise. NOK, IOKp, is UV */
2802 #else /* NV_PRESERVES_UV */
2803 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2804 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2805 /* The IV slot will have been set from value returned by
2806 grok_number above. The NV slot has just been set using
2809 assert (SvIOKp(sv));
2811 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2812 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2813 /* Small enough to preserve all bits. */
2814 (void)SvIOKp_on(sv);
2816 SvIVX(sv) = I_V(SvNVX(sv));
2817 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2819 /* Assumption: first non-preserved integer is < IV_MAX,
2820 this NV is in the preserved range, therefore: */
2821 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2823 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);
2827 0 0 already failed to read UV.
2828 0 1 already failed to read UV.
2829 1 0 you won't get here in this case. IV/UV
2830 slot set, public IOK, Atof() unneeded.
2831 1 1 already read UV.
2832 so there's no point in sv_2iuv_non_preserve() attempting
2833 to use atol, strtol, strtoul etc. */
2834 if (sv_2iuv_non_preserve (sv, numtype)
2835 >= IS_NUMBER_OVERFLOW_IV)
2839 #endif /* NV_PRESERVES_UV */
2842 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2844 if (SvTYPE(sv) < SVt_IV)
2845 /* Typically the caller expects that sv_any is not NULL now. */
2846 sv_upgrade(sv, SVt_IV);
2849 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2850 PTR2UV(sv),SvIVX(sv)));
2851 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2854 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2855 * this function provided for binary compatibility only
2859 Perl_sv_2uv(pTHX_ register SV *sv)
2861 return sv_2uv_flags(sv, SV_GMAGIC);
2865 =for apidoc sv_2uv_flags
2867 Return the unsigned integer value of an SV, doing any necessary string
2868 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2869 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2875 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2879 if (SvGMAGICAL(sv)) {
2880 if (flags & SV_GMAGIC)
2885 return U_V(SvNVX(sv));
2886 if (SvPOKp(sv) && SvLEN(sv))
2889 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2890 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2896 if (SvTHINKFIRST(sv)) {
2899 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2900 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2901 return SvUV(tmpstr);
2902 return PTR2UV(SvRV(sv));
2905 sv_force_normal_flags(sv, 0);
2907 if (SvREADONLY(sv) && !SvOK(sv)) {
2908 if (ckWARN(WARN_UNINITIALIZED))
2918 return (UV)SvIVX(sv);
2922 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2923 * without also getting a cached IV/UV from it at the same time
2924 * (ie PV->NV conversion should detect loss of accuracy and cache
2925 * IV or UV at same time to avoid this. */
2926 /* IV-over-UV optimisation - choose to cache IV if possible */
2928 if (SvTYPE(sv) == SVt_NV)
2929 sv_upgrade(sv, SVt_PVNV);
2931 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2932 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2933 SvIVX(sv) = I_V(SvNVX(sv));
2934 if (SvNVX(sv) == (NV) SvIVX(sv)
2935 #ifndef NV_PRESERVES_UV
2936 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2937 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2938 /* Don't flag it as "accurately an integer" if the number
2939 came from a (by definition imprecise) NV operation, and
2940 we're outside the range of NV integer precision */
2943 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2944 DEBUG_c(PerlIO_printf(Perl_debug_log,
2945 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2951 /* IV not precise. No need to convert from PV, as NV
2952 conversion would already have cached IV if it detected
2953 that PV->IV would be better than PV->NV->IV
2954 flags already correct - don't set public IOK. */
2955 DEBUG_c(PerlIO_printf(Perl_debug_log,
2956 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2961 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2962 but the cast (NV)IV_MIN rounds to a the value less (more
2963 negative) than IV_MIN which happens to be equal to SvNVX ??
2964 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2965 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2966 (NV)UVX == NVX are both true, but the values differ. :-(
2967 Hopefully for 2s complement IV_MIN is something like
2968 0x8000000000000000 which will be exact. NWC */
2971 SvUVX(sv) = U_V(SvNVX(sv));
2973 (SvNVX(sv) == (NV) SvUVX(sv))
2974 #ifndef NV_PRESERVES_UV
2975 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2976 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2977 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2978 /* Don't flag it as "accurately an integer" if the number
2979 came from a (by definition imprecise) NV operation, and
2980 we're outside the range of NV integer precision */
2985 DEBUG_c(PerlIO_printf(Perl_debug_log,
2986 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2992 else if (SvPOKp(sv) && SvLEN(sv)) {
2994 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2996 /* We want to avoid a possible problem when we cache a UV which
2997 may be later translated to an NV, and the resulting NV is not
2998 the translation of the initial data.
3000 This means that if we cache such a UV, we need to cache the
3001 NV as well. Moreover, we trade speed for space, and do not
3002 cache the NV if not needed.
3005 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3006 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3007 == IS_NUMBER_IN_UV) {
3008 /* It's definitely an integer, only upgrade to PVIV */
3009 if (SvTYPE(sv) < SVt_PVIV)
3010 sv_upgrade(sv, SVt_PVIV);
3012 } else if (SvTYPE(sv) < SVt_PVNV)
3013 sv_upgrade(sv, SVt_PVNV);
3015 /* If NV preserves UV then we only use the UV value if we know that
3016 we aren't going to call atof() below. If NVs don't preserve UVs
3017 then the value returned may have more precision than atof() will
3018 return, even though it isn't accurate. */
3019 if ((numtype & (IS_NUMBER_IN_UV
3020 #ifdef NV_PRESERVES_UV
3023 )) == IS_NUMBER_IN_UV) {
3024 /* This won't turn off the public IOK flag if it was set above */
3025 (void)SvIOKp_on(sv);
3027 if (!(numtype & IS_NUMBER_NEG)) {
3029 if (value <= (UV)IV_MAX) {
3030 SvIVX(sv) = (IV)value;
3032 /* it didn't overflow, and it was positive. */
3037 /* 2s complement assumption */
3038 if (value <= (UV)IV_MIN) {
3039 SvIVX(sv) = -(IV)value;
3041 /* Too negative for an IV. This is a double upgrade, but
3042 I'm assuming it will be rare. */
3043 if (SvTYPE(sv) < SVt_PVNV)
3044 sv_upgrade(sv, SVt_PVNV);
3048 SvNVX(sv) = -(NV)value;
3054 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3055 != IS_NUMBER_IN_UV) {
3056 /* It wasn't an integer, or it overflowed the UV. */
3057 SvNVX(sv) = Atof(SvPVX(sv));
3059 if (! numtype && ckWARN(WARN_NUMERIC))
3062 #if defined(USE_LONG_DOUBLE)
3063 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3064 PTR2UV(sv), SvNVX(sv)));
3066 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3067 PTR2UV(sv), SvNVX(sv)));
3070 #ifdef NV_PRESERVES_UV
3071 (void)SvIOKp_on(sv);
3073 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3074 SvIVX(sv) = I_V(SvNVX(sv));
3075 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3078 /* Integer is imprecise. NOK, IOKp */
3080 /* UV will not work better than IV */
3082 if (SvNVX(sv) > (NV)UV_MAX) {
3084 /* Integer is inaccurate. NOK, IOKp, is UV */
3088 SvUVX(sv) = U_V(SvNVX(sv));
3089 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3090 NV preservse UV so can do correct comparison. */
3091 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3095 /* Integer is imprecise. NOK, IOKp, is UV */
3100 #else /* NV_PRESERVES_UV */
3101 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3102 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3103 /* The UV slot will have been set from value returned by
3104 grok_number above. The NV slot has just been set using
3107 assert (SvIOKp(sv));
3109 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3110 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3111 /* Small enough to preserve all bits. */
3112 (void)SvIOKp_on(sv);
3114 SvIVX(sv) = I_V(SvNVX(sv));
3115 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3117 /* Assumption: first non-preserved integer is < IV_MAX,
3118 this NV is in the preserved range, therefore: */
3119 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3121 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);
3124 sv_2iuv_non_preserve (sv, numtype);
3126 #endif /* NV_PRESERVES_UV */
3130 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3131 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3134 if (SvTYPE(sv) < SVt_IV)
3135 /* Typically the caller expects that sv_any is not NULL now. */
3136 sv_upgrade(sv, SVt_IV);
3140 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3141 PTR2UV(sv),SvUVX(sv)));
3142 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3148 Return the num value of an SV, doing any necessary string or integer
3149 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3156 Perl_sv_2nv(pTHX_ register SV *sv)
3160 if (SvGMAGICAL(sv)) {
3164 if (SvPOKp(sv) && SvLEN(sv)) {
3165 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3166 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3168 return Atof(SvPVX(sv));
3172 return (NV)SvUVX(sv);
3174 return (NV)SvIVX(sv);
3177 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3178 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3184 if (SvTHINKFIRST(sv)) {
3187 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3188 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3189 return SvNV(tmpstr);
3190 return PTR2NV(SvRV(sv));
3193 sv_force_normal_flags(sv, 0);
3195 if (SvREADONLY(sv) && !SvOK(sv)) {
3196 if (ckWARN(WARN_UNINITIALIZED))
3201 if (SvTYPE(sv) < SVt_NV) {
3202 if (SvTYPE(sv) == SVt_IV)
3203 sv_upgrade(sv, SVt_PVNV);
3205 sv_upgrade(sv, SVt_NV);
3206 #ifdef USE_LONG_DOUBLE
3208 STORE_NUMERIC_LOCAL_SET_STANDARD();
3209 PerlIO_printf(Perl_debug_log,
3210 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3211 PTR2UV(sv), SvNVX(sv));
3212 RESTORE_NUMERIC_LOCAL();
3216 STORE_NUMERIC_LOCAL_SET_STANDARD();
3217 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3218 PTR2UV(sv), SvNVX(sv));
3219 RESTORE_NUMERIC_LOCAL();
3223 else if (SvTYPE(sv) < SVt_PVNV)
3224 sv_upgrade(sv, SVt_PVNV);
3229 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
3230 #ifdef NV_PRESERVES_UV
3233 /* Only set the public NV OK flag if this NV preserves the IV */
3234 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3235 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3236 : (SvIVX(sv) == I_V(SvNVX(sv))))
3242 else if (SvPOKp(sv) && SvLEN(sv)) {
3244 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3245 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3247 #ifdef NV_PRESERVES_UV
3248 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3249 == IS_NUMBER_IN_UV) {
3250 /* It's definitely an integer */
3251 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
3253 SvNVX(sv) = Atof(SvPVX(sv));
3256 SvNVX(sv) = Atof(SvPVX(sv));
3257 /* Only set the public NV OK flag if this NV preserves the value in
3258 the PV at least as well as an IV/UV would.
3259 Not sure how to do this 100% reliably. */
3260 /* if that shift count is out of range then Configure's test is
3261 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3263 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3264 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3265 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3266 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3267 /* Can't use strtol etc to convert this string, so don't try.
3268 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3271 /* value has been set. It may not be precise. */
3272 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3273 /* 2s complement assumption for (UV)IV_MIN */
3274 SvNOK_on(sv); /* Integer is too negative. */
3279 if (numtype & IS_NUMBER_NEG) {
3280 SvIVX(sv) = -(IV)value;
3281 } else if (value <= (UV)IV_MAX) {
3282 SvIVX(sv) = (IV)value;
3288 if (numtype & IS_NUMBER_NOT_INT) {
3289 /* I believe that even if the original PV had decimals,
3290 they are lost beyond the limit of the FP precision.
3291 However, neither is canonical, so both only get p
3292 flags. NWC, 2000/11/25 */
3293 /* Both already have p flags, so do nothing */
3296 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3297 if (SvIVX(sv) == I_V(nv)) {
3302 /* It had no "." so it must be integer. */
3305 /* between IV_MAX and NV(UV_MAX).
3306 Could be slightly > UV_MAX */
3308 if (numtype & IS_NUMBER_NOT_INT) {
3309 /* UV and NV both imprecise. */
3311 UV nv_as_uv = U_V(nv);
3313 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3324 #endif /* NV_PRESERVES_UV */
3327 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3329 if (SvTYPE(sv) < SVt_NV)
3330 /* Typically the caller expects that sv_any is not NULL now. */
3331 /* XXX Ilya implies that this is a bug in callers that assume this
3332 and ideally should be fixed. */
3333 sv_upgrade(sv, SVt_NV);
3336 #if defined(USE_LONG_DOUBLE)
3338 STORE_NUMERIC_LOCAL_SET_STANDARD();
3339 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3340 PTR2UV(sv), SvNVX(sv));
3341 RESTORE_NUMERIC_LOCAL();
3345 STORE_NUMERIC_LOCAL_SET_STANDARD();
3346 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3347 PTR2UV(sv), SvNVX(sv));
3348 RESTORE_NUMERIC_LOCAL();
3354 /* asIV(): extract an integer from the string value of an SV.
3355 * Caller must validate PVX */
3358 S_asIV(pTHX_ SV *sv)
3361 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3363 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3364 == IS_NUMBER_IN_UV) {
3365 /* It's definitely an integer */
3366 if (numtype & IS_NUMBER_NEG) {
3367 if (value < (UV)IV_MIN)
3370 if (value < (UV)IV_MAX)
3375 if (ckWARN(WARN_NUMERIC))
3378 return I_V(Atof(SvPVX(sv)));
3381 /* asUV(): extract an unsigned integer from the string value of an SV
3382 * Caller must validate PVX */
3385 S_asUV(pTHX_ SV *sv)
3388 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3390 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3391 == IS_NUMBER_IN_UV) {
3392 /* It's definitely an integer */
3393 if (!(numtype & IS_NUMBER_NEG))
3397 if (ckWARN(WARN_NUMERIC))
3400 return U_V(Atof(SvPVX(sv)));
3404 =for apidoc sv_2pv_nolen
3406 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3407 use the macro wrapper C<SvPV_nolen(sv)> instead.
3412 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3415 return sv_2pv(sv, &n_a);
3418 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3419 * UV as a string towards the end of buf, and return pointers to start and
3422 * We assume that buf is at least TYPE_CHARS(UV) long.
3426 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3428 char *ptr = buf + TYPE_CHARS(UV);
3442 *--ptr = '0' + (char)(uv % 10);
3450 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3451 * this function provided for binary compatibility only
3455 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3457 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3461 =for apidoc sv_2pv_flags
3463 Returns a pointer to the string value of an SV, and sets *lp to its length.
3464 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3466 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3467 usually end up here too.
3473 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3478 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3479 char *tmpbuf = tbuf;
3485 if (SvGMAGICAL(sv)) {
3486 if (flags & SV_GMAGIC)
3494 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3496 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3501 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3506 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3507 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3514 if (SvTHINKFIRST(sv)) {
3517 register const char *typestr;
3518 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3519 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3520 char *pv = SvPV(tmpstr, *lp);
3530 typestr = "NULLREF";
3534 switch (SvTYPE(sv)) {
3536 if ( ((SvFLAGS(sv) &
3537 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3538 == (SVs_OBJECT|SVs_SMG))
3539 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3540 const regexp *re = (regexp *)mg->mg_obj;
3543 const char *fptr = "msix";
3548 char need_newline = 0;
3549 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3551 while((ch = *fptr++)) {
3553 reflags[left++] = ch;
3556 reflags[right--] = ch;
3561 reflags[left] = '-';
3565 mg->mg_len = re->prelen + 4 + left;
3567 * If /x was used, we have to worry about a regex
3568 * ending with a comment later being embedded
3569 * within another regex. If so, we don't want this
3570 * regex's "commentization" to leak out to the
3571 * right part of the enclosing regex, we must cap
3572 * it with a newline.
3574 * So, if /x was used, we scan backwards from the
3575 * end of the regex. If we find a '#' before we
3576 * find a newline, we need to add a newline
3577 * ourself. If we find a '\n' first (or if we
3578 * don't find '#' or '\n'), we don't need to add
3579 * anything. -jfriedl
3581 if (PMf_EXTENDED & re->reganch)
3583 const char *endptr = re->precomp + re->prelen;
3584 while (endptr >= re->precomp)
3586 const char c = *(endptr--);
3588 break; /* don't need another */
3590 /* we end while in a comment, so we
3592 mg->mg_len++; /* save space for it */
3593 need_newline = 1; /* note to add it */
3599 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3600 Copy("(?", mg->mg_ptr, 2, char);
3601 Copy(reflags, mg->mg_ptr+2, left, char);
3602 Copy(":", mg->mg_ptr+left+2, 1, char);
3603 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3605 mg->mg_ptr[mg->mg_len - 2] = '\n';
3606 mg->mg_ptr[mg->mg_len - 1] = ')';
3607 mg->mg_ptr[mg->mg_len] = 0;
3609 PL_reginterp_cnt += re->program[0].next_off;
3611 if (re->reganch & ROPT_UTF8)
3626 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3627 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3628 /* tied lvalues should appear to be
3629 * scalars for backwards compatitbility */
3630 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3631 ? "SCALAR" : "LVALUE"; break;
3632 case SVt_PVAV: typestr = "ARRAY"; break;
3633 case SVt_PVHV: typestr = "HASH"; break;
3634 case SVt_PVCV: typestr = "CODE"; break;
3635 case SVt_PVGV: typestr = "GLOB"; break;
3636 case SVt_PVFM: typestr = "FORMAT"; break;
3637 case SVt_PVIO: typestr = "IO"; break;
3638 default: typestr = "UNKNOWN"; break;
3642 const char *name = HvNAME(SvSTASH(sv));
3643 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3644 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3647 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3650 *lp = strlen(typestr);
3651 return (char *)typestr;
3653 if (SvREADONLY(sv) && !SvOK(sv)) {
3654 if (ckWARN(WARN_UNINITIALIZED))
3660 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3661 /* I'm assuming that if both IV and NV are equally valid then
3662 converting the IV is going to be more efficient */
3663 const U32 isIOK = SvIOK(sv);
3664 const U32 isUIOK = SvIsUV(sv);
3665 char buf[TYPE_CHARS(UV)];
3668 if (SvTYPE(sv) < SVt_PVIV)
3669 sv_upgrade(sv, SVt_PVIV);
3671 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3673 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3674 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3675 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3676 SvCUR_set(sv, ebuf - ptr);
3686 else if (SvNOKp(sv)) {
3687 if (SvTYPE(sv) < SVt_PVNV)
3688 sv_upgrade(sv, SVt_PVNV);
3689 /* The +20 is pure guesswork. Configure test needed. --jhi */
3690 SvGROW(sv, NV_DIG + 20);
3692 olderrno = errno; /* some Xenix systems wipe out errno here */
3694 if (SvNVX(sv) == 0.0)
3695 (void)strcpy(s,"0");
3699 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3702 #ifdef FIXNEGATIVEZERO
3703 if (*s == '-' && s[1] == '0' && !s[2])
3713 if (ckWARN(WARN_UNINITIALIZED)
3714 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3717 if (SvTYPE(sv) < SVt_PV)
3718 /* Typically the caller expects that sv_any is not NULL now. */
3719 sv_upgrade(sv, SVt_PV);
3722 *lp = s - SvPVX(sv);
3725 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3726 PTR2UV(sv),SvPVX(sv)));
3730 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3731 /* Sneaky stuff here */
3735 tsv = newSVpv(tmpbuf, 0);
3751 len = strlen(tmpbuf);
3753 #ifdef FIXNEGATIVEZERO
3754 if (len == 2 && t[0] == '-' && t[1] == '0') {
3759 (void)SvUPGRADE(sv, SVt_PV);
3761 s = SvGROW(sv, len + 1);
3764 return strcpy(s, t);
3769 =for apidoc sv_copypv
3771 Copies a stringified representation of the source SV into the
3772 destination SV. Automatically performs any necessary mg_get and
3773 coercion of numeric values into strings. Guaranteed to preserve
3774 UTF-8 flag even from overloaded objects. Similar in nature to
3775 sv_2pv[_flags] but operates directly on an SV instead of just the
3776 string. Mostly uses sv_2pv_flags to do its work, except when that
3777 would lose the UTF-8'ness of the PV.
3783 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3788 sv_setpvn(dsv,s,len);
3796 =for apidoc sv_2pvbyte_nolen
3798 Return a pointer to the byte-encoded representation of the SV.
3799 May cause the SV to be downgraded from UTF-8 as a side-effect.
3801 Usually accessed via the C<SvPVbyte_nolen> macro.
3807 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3810 return sv_2pvbyte(sv, &n_a);
3814 =for apidoc sv_2pvbyte
3816 Return a pointer to the byte-encoded representation of the SV, and set *lp
3817 to its length. May cause the SV to be downgraded from UTF-8 as a
3820 Usually accessed via the C<SvPVbyte> macro.
3826 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3828 sv_utf8_downgrade(sv,0);
3829 return SvPV(sv,*lp);
3833 =for apidoc sv_2pvutf8_nolen
3835 Return a pointer to the UTF-8-encoded representation of the SV.
3836 May cause the SV to be upgraded to UTF-8 as a side-effect.
3838 Usually accessed via the C<SvPVutf8_nolen> macro.
3844 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3847 return sv_2pvutf8(sv, &n_a);
3851 =for apidoc sv_2pvutf8
3853 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3854 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3856 Usually accessed via the C<SvPVutf8> macro.
3862 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3864 sv_utf8_upgrade(sv);
3865 return SvPV(sv,*lp);
3869 =for apidoc sv_2bool
3871 This function is only called on magical items, and is only used by
3872 sv_true() or its macro equivalent.
3878 Perl_sv_2bool(pTHX_ register SV *sv)
3887 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3888 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3889 return (bool)SvTRUE(tmpsv);
3890 return SvRV(sv) != 0;
3893 register XPV* Xpvtmp;
3894 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3895 (*Xpvtmp->xpv_pv > '0' ||
3896 Xpvtmp->xpv_cur > 1 ||
3897 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3904 return SvIVX(sv) != 0;
3907 return SvNVX(sv) != 0.0;
3914 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3915 * this function provided for binary compatibility only
3920 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3922 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3926 =for apidoc sv_utf8_upgrade
3928 Converts the PV of an SV to its UTF-8-encoded form.
3929 Forces the SV to string form if it is not already.
3930 Always sets the SvUTF8 flag to avoid future validity checks even
3931 if all the bytes have hibit clear.
3933 This is not as a general purpose byte encoding to Unicode interface:
3934 use the Encode extension for that.
3936 =for apidoc sv_utf8_upgrade_flags
3938 Converts the PV of an SV to its UTF-8-encoded form.
3939 Forces the SV to string form if it is not already.
3940 Always sets the SvUTF8 flag to avoid future validity checks even
3941 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3942 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3943 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3945 This is not as a general purpose byte encoding to Unicode interface:
3946 use the Encode extension for that.
3952 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3957 if (sv == &PL_sv_undef)
3961 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3962 (void) sv_2pv_flags(sv,&len, flags);
3966 (void) SvPV_force(sv,len);
3975 sv_force_normal_flags(sv, 0);
3978 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3979 sv_recode_to_utf8(sv, PL_encoding);
3980 else { /* Assume Latin-1/EBCDIC */
3981 /* This function could be much more efficient if we
3982 * had a FLAG in SVs to signal if there are any hibit
3983 * chars in the PV. Given that there isn't such a flag
3984 * make the loop as fast as possible. */
3985 s = (U8 *) SvPVX(sv);
3986 e = (U8 *) SvEND(sv);
3990 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3995 (void)SvOOK_off(sv);
3997 len = SvCUR(sv) + 1; /* Plus the \0 */
3998 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3999 SvCUR(sv) = len - 1;
4001 Safefree(s); /* No longer using what was there before. */
4002 SvLEN(sv) = len; /* No longer know the real size. */
4004 /* Mark as UTF-8 even if no hibit - saves scanning loop */
4011 =for apidoc sv_utf8_downgrade
4013 Attempts to convert the PV of an SV from characters to bytes.
4014 If the PV contains a character beyond byte, this conversion will fail;
4015 in this case, either returns false or, if C<fail_ok> is not
4018 This is not as a general purpose Unicode to byte encoding interface:
4019 use the Encode extension for that.
4025 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4027 if (SvPOKp(sv) && SvUTF8(sv)) {
4033 sv_force_normal_flags(sv, 0);
4035 s = (U8 *) SvPV(sv, len);
4036 if (!utf8_to_bytes(s, &len)) {
4041 Perl_croak(aTHX_ "Wide character in %s",
4044 Perl_croak(aTHX_ "Wide character");
4055 =for apidoc sv_utf8_encode
4057 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4058 flag off so that it looks like octets again.
4064 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4066 (void) sv_utf8_upgrade(sv);
4068 sv_force_normal_flags(sv, 0);
4070 if (SvREADONLY(sv)) {
4071 Perl_croak(aTHX_ PL_no_modify);
4077 =for apidoc sv_utf8_decode
4079 If the PV of the SV is an octet sequence in UTF-8
4080 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4081 so that it looks like a character. If the PV contains only single-byte
4082 characters, the C<SvUTF8> flag stays being off.
4083 Scans PV for validity and returns false if the PV is invalid UTF-8.
4089 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4095 /* The octets may have got themselves encoded - get them back as
4098 if (!sv_utf8_downgrade(sv, TRUE))
4101 /* it is actually just a matter of turning the utf8 flag on, but
4102 * we want to make sure everything inside is valid utf8 first.
4104 c = (U8 *) SvPVX(sv);
4105 if (!is_utf8_string(c, SvCUR(sv)+1))
4107 e = (U8 *) SvEND(sv);
4110 if (!UTF8_IS_INVARIANT(ch)) {
4119 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4120 * this function provided for binary compatibility only
4124 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4126 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4130 =for apidoc sv_setsv
4132 Copies the contents of the source SV C<ssv> into the destination SV
4133 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4134 function if the source SV needs to be reused. Does not handle 'set' magic.
4135 Loosely speaking, it performs a copy-by-value, obliterating any previous
4136 content of the destination.
4138 You probably want to use one of the assortment of wrappers, such as
4139 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4140 C<SvSetMagicSV_nosteal>.
4142 =for apidoc sv_setsv_flags
4144 Copies the contents of the source SV C<ssv> into the destination SV
4145 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4146 function if the source SV needs to be reused. Does not handle 'set' magic.
4147 Loosely speaking, it performs a copy-by-value, obliterating any previous
4148 content of the destination.
4149 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4150 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4151 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4152 and C<sv_setsv_nomg> are implemented in terms of this function.
4154 You probably want to use one of the assortment of wrappers, such as
4155 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4156 C<SvSetMagicSV_nosteal>.
4158 This is the primary function for copying scalars, and most other
4159 copy-ish functions and macros use this underneath.
4165 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4167 register U32 sflags;
4173 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4175 sstr = &PL_sv_undef;
4176 stype = SvTYPE(sstr);
4177 dtype = SvTYPE(dstr);
4182 /* need to nuke the magic */
4184 SvRMAGICAL_off(dstr);
4187 /* There's a lot of redundancy below but we're going for speed here */
4192 if (dtype != SVt_PVGV) {
4193 (void)SvOK_off(dstr);
4201 sv_upgrade(dstr, SVt_IV);
4204 sv_upgrade(dstr, SVt_PVNV);
4208 sv_upgrade(dstr, SVt_PVIV);
4211 (void)SvIOK_only(dstr);
4212 SvIVX(dstr) = SvIVX(sstr);
4215 if (SvTAINTED(sstr))
4226 sv_upgrade(dstr, SVt_NV);
4231 sv_upgrade(dstr, SVt_PVNV);
4234 SvNVX(dstr) = SvNVX(sstr);
4235 (void)SvNOK_only(dstr);
4236 if (SvTAINTED(sstr))
4244 sv_upgrade(dstr, SVt_RV);
4245 else if (dtype == SVt_PVGV &&
4246 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4249 if (GvIMPORTED(dstr) != GVf_IMPORTED
4250 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4252 GvIMPORTED_on(dstr);
4261 #ifdef PERL_COPY_ON_WRITE
4262 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4263 if (dtype < SVt_PVIV)
4264 sv_upgrade(dstr, SVt_PVIV);
4271 sv_upgrade(dstr, SVt_PV);
4274 if (dtype < SVt_PVIV)
4275 sv_upgrade(dstr, SVt_PVIV);
4278 if (dtype < SVt_PVNV)
4279 sv_upgrade(dstr, SVt_PVNV);
4286 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4289 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4293 if (dtype <= SVt_PVGV) {
4295 if (dtype != SVt_PVGV) {
4296 char *name = GvNAME(sstr);
4297 STRLEN len = GvNAMELEN(sstr);
4298 /* don't upgrade SVt_PVLV: it can hold a glob */
4299 if (dtype != SVt_PVLV)
4300 sv_upgrade(dstr, SVt_PVGV);
4301 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4302 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4303 GvNAME(dstr) = savepvn(name, len);
4304 GvNAMELEN(dstr) = len;
4305 SvFAKE_on(dstr); /* can coerce to non-glob */
4307 /* ahem, death to those who redefine active sort subs */
4308 else if (PL_curstackinfo->si_type == PERLSI_SORT
4309 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4310 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4313 #ifdef GV_UNIQUE_CHECK
4314 if (GvUNIQUE((GV*)dstr)) {
4315 Perl_croak(aTHX_ PL_no_modify);
4319 (void)SvOK_off(dstr);
4320 GvINTRO_off(dstr); /* one-shot flag */
4322 GvGP(dstr) = gp_ref(GvGP(sstr));
4323 if (SvTAINTED(sstr))
4325 if (GvIMPORTED(dstr) != GVf_IMPORTED
4326 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4328 GvIMPORTED_on(dstr);
4336 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4338 if ((int)SvTYPE(sstr) != stype) {
4339 stype = SvTYPE(sstr);
4340 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4344 if (stype == SVt_PVLV)
4345 (void)SvUPGRADE(dstr, SVt_PVNV);
4347 (void)SvUPGRADE(dstr, (U32)stype);
4350 sflags = SvFLAGS(sstr);
4352 if (sflags & SVf_ROK) {
4353 if (dtype >= SVt_PV) {
4354 if (dtype == SVt_PVGV) {
4355 SV *sref = SvREFCNT_inc(SvRV(sstr));
4357 int intro = GvINTRO(dstr);
4359 #ifdef GV_UNIQUE_CHECK
4360 if (GvUNIQUE((GV*)dstr)) {
4361 Perl_croak(aTHX_ PL_no_modify);
4366 GvINTRO_off(dstr); /* one-shot flag */
4367 GvLINE(dstr) = CopLINE(PL_curcop);
4368 GvEGV(dstr) = (GV*)dstr;
4371 switch (SvTYPE(sref)) {
4374 SAVEGENERICSV(GvAV(dstr));
4376 dref = (SV*)GvAV(dstr);
4377 GvAV(dstr) = (AV*)sref;
4378 if (!GvIMPORTED_AV(dstr)
4379 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4381 GvIMPORTED_AV_on(dstr);
4386 SAVEGENERICSV(GvHV(dstr));
4388 dref = (SV*)GvHV(dstr);
4389 GvHV(dstr) = (HV*)sref;
4390 if (!GvIMPORTED_HV(dstr)
4391 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4393 GvIMPORTED_HV_on(dstr);
4398 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4399 SvREFCNT_dec(GvCV(dstr));
4400 GvCV(dstr) = Nullcv;
4401 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4402 PL_sub_generation++;
4404 SAVEGENERICSV(GvCV(dstr));
4407 dref = (SV*)GvCV(dstr);
4408 if (GvCV(dstr) != (CV*)sref) {
4409 CV* cv = GvCV(dstr);
4411 if (!GvCVGEN((GV*)dstr) &&
4412 (CvROOT(cv) || CvXSUB(cv)))
4414 /* ahem, death to those who redefine
4415 * active sort subs */
4416 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4417 PL_sortcop == CvSTART(cv))
4419 "Can't redefine active sort subroutine %s",
4420 GvENAME((GV*)dstr));
4421 /* Redefining a sub - warning is mandatory if
4422 it was a const and its value changed. */
4423 if (ckWARN(WARN_REDEFINE)
4425 && (!CvCONST((CV*)sref)
4426 || sv_cmp(cv_const_sv(cv),
4427 cv_const_sv((CV*)sref)))))
4429 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4431 ? "Constant subroutine %s::%s redefined"
4432 : "Subroutine %s::%s redefined",
4433 HvNAME(GvSTASH((GV*)dstr)),
4434 GvENAME((GV*)dstr));
4438 cv_ckproto(cv, (GV*)dstr,
4439 SvPOK(sref) ? SvPVX(sref) : Nullch);
4441 GvCV(dstr) = (CV*)sref;
4442 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4443 GvASSUMECV_on(dstr);
4444 PL_sub_generation++;
4446 if (!GvIMPORTED_CV(dstr)
4447 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4449 GvIMPORTED_CV_on(dstr);
4454 SAVEGENERICSV(GvIOp(dstr));
4456 dref = (SV*)GvIOp(dstr);
4457 GvIOp(dstr) = (IO*)sref;
4461 SAVEGENERICSV(GvFORM(dstr));
4463 dref = (SV*)GvFORM(dstr);
4464 GvFORM(dstr) = (CV*)sref;
4468 SAVEGENERICSV(GvSV(dstr));
4470 dref = (SV*)GvSV(dstr);
4472 if (!GvIMPORTED_SV(dstr)
4473 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4475 GvIMPORTED_SV_on(dstr);
4481 if (SvTAINTED(sstr))
4486 (void)SvOOK_off(dstr); /* backoff */
4488 Safefree(SvPVX(dstr));
4489 SvLEN(dstr)=SvCUR(dstr)=0;
4492 (void)SvOK_off(dstr);
4493 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
4495 if (sflags & SVp_NOK) {
4497 /* Only set the public OK flag if the source has public OK. */
4498 if (sflags & SVf_NOK)
4499 SvFLAGS(dstr) |= SVf_NOK;
4500 SvNVX(dstr) = SvNVX(sstr);
4502 if (sflags & SVp_IOK) {
4503 (void)SvIOKp_on(dstr);
4504 if (sflags & SVf_IOK)
4505 SvFLAGS(dstr) |= SVf_IOK;
4506 if (sflags & SVf_IVisUV)
4508 SvIVX(dstr) = SvIVX(sstr);
4510 if (SvAMAGIC(sstr)) {
4514 else if (sflags & SVp_POK) {
4518 * Check to see if we can just swipe the string. If so, it's a
4519 * possible small lose on short strings, but a big win on long ones.
4520 * It might even be a win on short strings if SvPVX(dstr)
4521 * has to be allocated and SvPVX(sstr) has to be freed.
4524 /* Whichever path we take through the next code, we want this true,
4525 and doing it now facilitates the COW check. */
4526 (void)SvPOK_only(dstr);
4529 #ifdef PERL_COPY_ON_WRITE
4530 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4534 (sflags & SVs_TEMP) && /* slated for free anyway? */
4535 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4536 (!(flags & SV_NOSTEAL)) &&
4537 /* and we're allowed to steal temps */
4538 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4539 SvLEN(sstr) && /* and really is a string */
4540 /* and won't be needed again, potentially */
4541 !(PL_op && PL_op->op_type == OP_AASSIGN))
4542 #ifdef PERL_COPY_ON_WRITE
4543 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4544 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4545 && SvTYPE(sstr) >= SVt_PVIV)
4548 /* Failed the swipe test, and it's not a shared hash key either.
4549 Have to copy the string. */
4550 STRLEN len = SvCUR(sstr);
4551 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4552 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4553 SvCUR_set(dstr, len);
4554 *SvEND(dstr) = '\0';
4556 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4558 #ifdef PERL_COPY_ON_WRITE
4559 /* Either it's a shared hash key, or it's suitable for
4560 copy-on-write or we can swipe the string. */
4562 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4567 /* I believe I should acquire a global SV mutex if
4568 it's a COW sv (not a shared hash key) to stop
4569 it going un copy-on-write.
4570 If the source SV has gone un copy on write between up there
4571 and down here, then (assert() that) it is of the correct
4572 form to make it copy on write again */
4573 if ((sflags & (SVf_FAKE | SVf_READONLY))
4574 != (SVf_FAKE | SVf_READONLY)) {
4575 SvREADONLY_on(sstr);
4577 /* Make the source SV into a loop of 1.
4578 (about to become 2) */
4579 SV_COW_NEXT_SV_SET(sstr, sstr);
4583 /* Initial code is common. */
4584 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4586 SvFLAGS(dstr) &= ~SVf_OOK;
4587 Safefree(SvPVX(dstr) - SvIVX(dstr));
4589 else if (SvLEN(dstr))
4590 Safefree(SvPVX(dstr));
4593 #ifdef PERL_COPY_ON_WRITE
4595 /* making another shared SV. */
4596 STRLEN cur = SvCUR(sstr);
4597 STRLEN len = SvLEN(sstr);
4598 assert (SvTYPE(dstr) >= SVt_PVIV);
4600 /* SvIsCOW_normal */
4601 /* splice us in between source and next-after-source. */
4602 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4603 SV_COW_NEXT_SV_SET(sstr, dstr);
4604 SvPV_set(dstr, SvPVX(sstr));
4606 /* SvIsCOW_shared_hash */
4607 UV hash = SvUVX(sstr);
4608 DEBUG_C(PerlIO_printf(Perl_debug_log,
4609 "Copy on write: Sharing hash\n"));
4611 sharepvn(SvPVX(sstr),
4612 (sflags & SVf_UTF8?-cur:cur), hash));
4617 SvREADONLY_on(dstr);
4619 /* Relesase a global SV mutex. */
4623 { /* Passes the swipe test. */
4624 SvPV_set(dstr, SvPVX(sstr));
4625 SvLEN_set(dstr, SvLEN(sstr));
4626 SvCUR_set(dstr, SvCUR(sstr));
4629 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4630 SvPV_set(sstr, Nullch);
4636 if (sflags & SVf_UTF8)
4639 if (sflags & SVp_NOK) {
4641 if (sflags & SVf_NOK)
4642 SvFLAGS(dstr) |= SVf_NOK;
4643 SvNVX(dstr) = SvNVX(sstr);
4645 if (sflags & SVp_IOK) {
4646 (void)SvIOKp_on(dstr);
4647 if (sflags & SVf_IOK)
4648 SvFLAGS(dstr) |= SVf_IOK;
4649 if (sflags & SVf_IVisUV)
4651 SvIVX(dstr) = SvIVX(sstr);
4654 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4655 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4656 smg->mg_ptr, smg->mg_len);
4657 SvRMAGICAL_on(dstr);
4660 else if (sflags & SVp_IOK) {
4661 if (sflags & SVf_IOK)
4662 (void)SvIOK_only(dstr);
4664 (void)SvOK_off(dstr);
4665 (void)SvIOKp_on(dstr);
4667 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4668 if (sflags & SVf_IVisUV)
4670 SvIVX(dstr) = SvIVX(sstr);
4671 if (sflags & SVp_NOK) {
4672 if (sflags & SVf_NOK)
4673 (void)SvNOK_on(dstr);
4675 (void)SvNOKp_on(dstr);
4676 SvNVX(dstr) = SvNVX(sstr);
4679 else if (sflags & SVp_NOK) {
4680 if (sflags & SVf_NOK)
4681 (void)SvNOK_only(dstr);
4683 (void)SvOK_off(dstr);
4686 SvNVX(dstr) = SvNVX(sstr);
4689 if (dtype == SVt_PVGV) {
4690 if (ckWARN(WARN_MISC))
4691 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4694 (void)SvOK_off(dstr);
4696 if (SvTAINTED(sstr))
4701 =for apidoc sv_setsv_mg
4703 Like C<sv_setsv>, but also handles 'set' magic.
4709 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4711 sv_setsv(dstr,sstr);
4715 #ifdef PERL_COPY_ON_WRITE
4717 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4719 STRLEN cur = SvCUR(sstr);
4720 STRLEN len = SvLEN(sstr);
4721 register char *new_pv;
4724 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4732 if (SvTHINKFIRST(dstr))
4733 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4734 else if (SvPVX(dstr))
4735 Safefree(SvPVX(dstr));
4739 (void)SvUPGRADE (dstr, SVt_PVIV);
4741 assert (SvPOK(sstr));
4742 assert (SvPOKp(sstr));
4743 assert (!SvIOK(sstr));
4744 assert (!SvIOKp(sstr));
4745 assert (!SvNOK(sstr));
4746 assert (!SvNOKp(sstr));
4748 if (SvIsCOW(sstr)) {
4750 if (SvLEN(sstr) == 0) {
4751 /* source is a COW shared hash key. */
4752 UV hash = SvUVX(sstr);
4753 DEBUG_C(PerlIO_printf(Perl_debug_log,
4754 "Fast copy on write: Sharing hash\n"));
4756 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4759 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4761 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4762 (void)SvUPGRADE (sstr, SVt_PVIV);
4763 SvREADONLY_on(sstr);
4765 DEBUG_C(PerlIO_printf(Perl_debug_log,
4766 "Fast copy on write: Converting sstr to COW\n"));
4767 SV_COW_NEXT_SV_SET(dstr, sstr);
4769 SV_COW_NEXT_SV_SET(sstr, dstr);
4770 new_pv = SvPVX(sstr);
4773 SvPV_set(dstr, new_pv);
4774 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4787 =for apidoc sv_setpvn
4789 Copies a string into an SV. The C<len> parameter indicates the number of
4790 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4791 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4797 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4799 register char *dptr;
4801 SV_CHECK_THINKFIRST_COW_DROP(sv);
4807 /* len is STRLEN which is unsigned, need to copy to signed */
4810 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4812 (void)SvUPGRADE(sv, SVt_PV);
4814 SvGROW(sv, len + 1);
4816 Move(ptr,dptr,len,char);
4819 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4824 =for apidoc sv_setpvn_mg
4826 Like C<sv_setpvn>, but also handles 'set' magic.
4832 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4834 sv_setpvn(sv,ptr,len);
4839 =for apidoc sv_setpv
4841 Copies a string into an SV. The string must be null-terminated. Does not
4842 handle 'set' magic. See C<sv_setpv_mg>.
4848 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4850 register STRLEN len;
4852 SV_CHECK_THINKFIRST_COW_DROP(sv);
4858 (void)SvUPGRADE(sv, SVt_PV);
4860 SvGROW(sv, len + 1);
4861 Move(ptr,SvPVX(sv),len+1,char);
4863 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4868 =for apidoc sv_setpv_mg
4870 Like C<sv_setpv>, but also handles 'set' magic.
4876 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4883 =for apidoc sv_usepvn
4885 Tells an SV to use C<ptr> to find its string value. Normally the string is
4886 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4887 The C<ptr> should point to memory that was allocated by C<malloc>. The
4888 string length, C<len>, must be supplied. This function will realloc the
4889 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4890 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4891 See C<sv_usepvn_mg>.
4897 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4899 SV_CHECK_THINKFIRST_COW_DROP(sv);
4900 (void)SvUPGRADE(sv, SVt_PV);
4905 (void)SvOOK_off(sv);
4906 if (SvPVX(sv) && SvLEN(sv))
4907 Safefree(SvPVX(sv));
4908 Renew(ptr, len+1, char);
4911 SvLEN_set(sv, len+1);
4913 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4918 =for apidoc sv_usepvn_mg
4920 Like C<sv_usepvn>, but also handles 'set' magic.
4926 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4928 sv_usepvn(sv,ptr,len);
4932 #ifdef PERL_COPY_ON_WRITE
4933 /* Need to do this *after* making the SV normal, as we need the buffer
4934 pointer to remain valid until after we've copied it. If we let go too early,
4935 another thread could invalidate it by unsharing last of the same hash key
4936 (which it can do by means other than releasing copy-on-write Svs)
4937 or by changing the other copy-on-write SVs in the loop. */
4939 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4940 U32 hash, SV *after)
4942 if (len) { /* this SV was SvIsCOW_normal(sv) */
4943 /* we need to find the SV pointing to us. */
4944 SV *current = SV_COW_NEXT_SV(after);
4946 if (current == sv) {
4947 /* The SV we point to points back to us (there were only two of us
4949 Hence other SV is no longer copy on write either. */
4951 SvREADONLY_off(after);
4953 /* We need to follow the pointers around the loop. */
4955 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4958 /* don't loop forever if the structure is bust, and we have
4959 a pointer into a closed loop. */
4960 assert (current != after);
4961 assert (SvPVX(current) == pvx);
4963 /* Make the SV before us point to the SV after us. */
4964 SV_COW_NEXT_SV_SET(current, after);
4967 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4972 Perl_sv_release_IVX(pTHX_ register SV *sv)
4975 sv_force_normal_flags(sv, 0);
4981 =for apidoc sv_force_normal_flags
4983 Undo various types of fakery on an SV: if the PV is a shared string, make
4984 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4985 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4986 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4987 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4988 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4989 set to some other value.) In addition, the C<flags> parameter gets passed to
4990 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4991 with flags set to 0.
4997 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4999 #ifdef PERL_COPY_ON_WRITE
5000 if (SvREADONLY(sv)) {
5001 /* At this point I believe I should acquire a global SV mutex. */
5003 char *pvx = SvPVX(sv);
5004 STRLEN len = SvLEN(sv);
5005 STRLEN cur = SvCUR(sv);
5006 U32 hash = SvUVX(sv);
5007 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
5009 PerlIO_printf(Perl_debug_log,
5010 "Copy on write: Force normal %ld\n",
5016 /* This SV doesn't own the buffer, so need to New() a new one: */
5019 if (flags & SV_COW_DROP_PV) {
5020 /* OK, so we don't need to copy our buffer. */
5023 SvGROW(sv, cur + 1);
5024 Move(pvx,SvPVX(sv),cur,char);
5028 sv_release_COW(sv, pvx, cur, len, hash, next);
5033 else if (IN_PERL_RUNTIME)
5034 Perl_croak(aTHX_ PL_no_modify);
5035 /* At this point I believe that I can drop the global SV mutex. */
5038 if (SvREADONLY(sv)) {
5040 char *pvx = SvPVX(sv);
5041 int is_utf8 = SvUTF8(sv);
5042 STRLEN len = SvCUR(sv);
5043 U32 hash = SvUVX(sv);
5048 SvGROW(sv, len + 1);
5049 Move(pvx,SvPVX(sv),len,char);
5051 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5053 else if (IN_PERL_RUNTIME)
5054 Perl_croak(aTHX_ PL_no_modify);
5058 sv_unref_flags(sv, flags);
5059 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5064 =for apidoc sv_force_normal
5066 Undo various types of fakery on an SV: if the PV is a shared string, make
5067 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5068 an xpvmg. See also C<sv_force_normal_flags>.
5074 Perl_sv_force_normal(pTHX_ register SV *sv)
5076 sv_force_normal_flags(sv, 0);
5082 Efficient removal of characters from the beginning of the string buffer.
5083 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5084 the string buffer. The C<ptr> becomes the first character of the adjusted
5085 string. Uses the "OOK hack".
5086 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5087 refer to the same chunk of data.
5093 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
5095 register STRLEN delta;
5096 if (!ptr || !SvPOKp(sv))
5098 delta = ptr - SvPVX(sv);
5099 SV_CHECK_THINKFIRST(sv);
5100 if (SvTYPE(sv) < SVt_PVIV)
5101 sv_upgrade(sv,SVt_PVIV);
5104 if (!SvLEN(sv)) { /* make copy of shared string */
5105 char *pvx = SvPVX(sv);
5106 STRLEN len = SvCUR(sv);
5107 SvGROW(sv, len + 1);
5108 Move(pvx,SvPVX(sv),len,char);
5112 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5113 and we do that anyway inside the SvNIOK_off
5115 SvFLAGS(sv) |= SVf_OOK;
5124 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5125 * this function provided for binary compatibility only
5129 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5131 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5135 =for apidoc sv_catpvn
5137 Concatenates the string onto the end of the string which is in the SV. The
5138 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5139 status set, then the bytes appended should be valid UTF-8.
5140 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5142 =for apidoc sv_catpvn_flags
5144 Concatenates the string onto the end of the string which is in the SV. The
5145 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5146 status set, then the bytes appended should be valid UTF-8.
5147 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5148 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5149 in terms of this function.
5155 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5160 dstr = SvPV_force_flags(dsv, dlen, flags);
5161 SvGROW(dsv, dlen + slen + 1);
5164 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5167 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5172 =for apidoc sv_catpvn_mg
5174 Like C<sv_catpvn>, but also handles 'set' magic.
5180 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5182 sv_catpvn(sv,ptr,len);
5186 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5187 * this function provided for binary compatibility only
5191 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5193 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5197 =for apidoc sv_catsv
5199 Concatenates the string from SV C<ssv> onto the end of the string in
5200 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5201 not 'set' magic. See C<sv_catsv_mg>.
5203 =for apidoc sv_catsv_flags
5205 Concatenates the string from SV C<ssv> onto the end of the string in
5206 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5207 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5208 and C<sv_catsv_nomg> are implemented in terms of this function.
5213 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5219 if ((spv = SvPV(ssv, slen))) {
5220 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5221 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5222 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5223 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5224 dsv->sv_flags doesn't have that bit set.
5225 Andy Dougherty 12 Oct 2001
5227 I32 sutf8 = DO_UTF8(ssv);
5230 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5232 dutf8 = DO_UTF8(dsv);
5234 if (dutf8 != sutf8) {
5236 /* Not modifying source SV, so taking a temporary copy. */
5237 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5239 sv_utf8_upgrade(csv);
5240 spv = SvPV(csv, slen);
5243 sv_utf8_upgrade_nomg(dsv);
5245 sv_catpvn_nomg(dsv, spv, slen);
5250 =for apidoc sv_catsv_mg
5252 Like C<sv_catsv>, but also handles 'set' magic.
5258 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5265 =for apidoc sv_catpv
5267 Concatenates the string onto the end of the string which is in the SV.
5268 If the SV has the UTF-8 status set, then the bytes appended should be
5269 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5274 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5276 register STRLEN len;
5282 junk = SvPV_force(sv, tlen);
5284 SvGROW(sv, tlen + len + 1);
5287 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5289 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5294 =for apidoc sv_catpv_mg
5296 Like C<sv_catpv>, but also handles 'set' magic.
5302 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5311 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5312 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5319 Perl_newSV(pTHX_ STRLEN len)
5325 sv_upgrade(sv, SVt_PV);
5326 SvGROW(sv, len + 1);
5331 =for apidoc sv_magicext
5333 Adds magic to an SV, upgrading it if necessary. Applies the
5334 supplied vtable and returns a pointer to the magic added.
5336 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5337 In particular, you can add magic to SvREADONLY SVs, and add more than
5338 one instance of the same 'how'.
5340 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5341 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5342 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5343 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5345 (This is now used as a subroutine by C<sv_magic>.)
5350 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5351 const char* name, I32 namlen)
5355 if (SvTYPE(sv) < SVt_PVMG) {
5356 (void)SvUPGRADE(sv, SVt_PVMG);
5358 Newz(702,mg, 1, MAGIC);
5359 mg->mg_moremagic = SvMAGIC(sv);
5362 /* Sometimes a magic contains a reference loop, where the sv and
5363 object refer to each other. To prevent a reference loop that
5364 would prevent such objects being freed, we look for such loops
5365 and if we find one we avoid incrementing the object refcount.
5367 Note we cannot do this to avoid self-tie loops as intervening RV must
5368 have its REFCNT incremented to keep it in existence.
5371 if (!obj || obj == sv ||
5372 how == PERL_MAGIC_arylen ||
5373 how == PERL_MAGIC_qr ||
5374 (SvTYPE(obj) == SVt_PVGV &&
5375 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5376 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5377 GvFORM(obj) == (CV*)sv)))
5382 mg->mg_obj = SvREFCNT_inc(obj);
5383 mg->mg_flags |= MGf_REFCOUNTED;
5386 /* Normal self-ties simply pass a null object, and instead of
5387 using mg_obj directly, use the SvTIED_obj macro to produce a
5388 new RV as needed. For glob "self-ties", we are tieing the PVIO
5389 with an RV obj pointing to the glob containing the PVIO. In
5390 this case, to avoid a reference loop, we need to weaken the
5394 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5395 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5401 mg->mg_len = namlen;
5404 mg->mg_ptr = savepvn(name, namlen);
5405 else if (namlen == HEf_SVKEY)
5406 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5408 mg->mg_ptr = (char *) name;
5410 mg->mg_virtual = vtable;
5414 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5419 =for apidoc sv_magic
5421 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5422 then adds a new magic item of type C<how> to the head of the magic list.
5424 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5425 handling of the C<name> and C<namlen> arguments.
5427 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5428 to add more than one instance of the same 'how'.
5434 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5436 const MGVTBL *vtable = 0;
5439 #ifdef PERL_COPY_ON_WRITE
5441 sv_force_normal_flags(sv, 0);
5443 if (SvREADONLY(sv)) {
5445 && how != PERL_MAGIC_regex_global
5446 && how != PERL_MAGIC_bm
5447 && how != PERL_MAGIC_fm
5448 && how != PERL_MAGIC_sv
5449 && how != PERL_MAGIC_backref
5452 Perl_croak(aTHX_ PL_no_modify);
5455 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5456 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5457 /* sv_magic() refuses to add a magic of the same 'how' as an
5460 if (how == PERL_MAGIC_taint)
5468 vtable = &PL_vtbl_sv;
5470 case PERL_MAGIC_overload:
5471 vtable = &PL_vtbl_amagic;
5473 case PERL_MAGIC_overload_elem:
5474 vtable = &PL_vtbl_amagicelem;
5476 case PERL_MAGIC_overload_table:
5477 vtable = &PL_vtbl_ovrld;
5480 vtable = &PL_vtbl_bm;
5482 case PERL_MAGIC_regdata:
5483 vtable = &PL_vtbl_regdata;
5485 case PERL_MAGIC_regdatum:
5486 vtable = &PL_vtbl_regdatum;
5488 case PERL_MAGIC_env:
5489 vtable = &PL_vtbl_env;
5492 vtable = &PL_vtbl_fm;
5494 case PERL_MAGIC_envelem:
5495 vtable = &PL_vtbl_envelem;
5497 case PERL_MAGIC_regex_global:
5498 vtable = &PL_vtbl_mglob;
5500 case PERL_MAGIC_isa:
5501 vtable = &PL_vtbl_isa;
5503 case PERL_MAGIC_isaelem:
5504 vtable = &PL_vtbl_isaelem;
5506 case PERL_MAGIC_nkeys:
5507 vtable = &PL_vtbl_nkeys;
5509 case PERL_MAGIC_dbfile:
5512 case PERL_MAGIC_dbline:
5513 vtable = &PL_vtbl_dbline;
5515 #ifdef USE_LOCALE_COLLATE
5516 case PERL_MAGIC_collxfrm:
5517 vtable = &PL_vtbl_collxfrm;
5519 #endif /* USE_LOCALE_COLLATE */
5520 case PERL_MAGIC_tied:
5521 vtable = &PL_vtbl_pack;
5523 case PERL_MAGIC_tiedelem:
5524 case PERL_MAGIC_tiedscalar:
5525 vtable = &PL_vtbl_packelem;
5528 vtable = &PL_vtbl_regexp;
5530 case PERL_MAGIC_sig:
5531 vtable = &PL_vtbl_sig;
5533 case PERL_MAGIC_sigelem:
5534 vtable = &PL_vtbl_sigelem;
5536 case PERL_MAGIC_taint:
5537 vtable = &PL_vtbl_taint;
5539 case PERL_MAGIC_uvar:
5540 vtable = &PL_vtbl_uvar;
5542 case PERL_MAGIC_vec:
5543 vtable = &PL_vtbl_vec;
5545 case PERL_MAGIC_vstring:
5548 case PERL_MAGIC_utf8:
5549 vtable = &PL_vtbl_utf8;
5551 case PERL_MAGIC_substr:
5552 vtable = &PL_vtbl_substr;
5554 case PERL_MAGIC_defelem:
5555 vtable = &PL_vtbl_defelem;
5557 case PERL_MAGIC_glob:
5558 vtable = &PL_vtbl_glob;
5560 case PERL_MAGIC_arylen:
5561 vtable = &PL_vtbl_arylen;
5563 case PERL_MAGIC_pos:
5564 vtable = &PL_vtbl_pos;
5566 case PERL_MAGIC_backref:
5567 vtable = &PL_vtbl_backref;
5569 case PERL_MAGIC_ext:
5570 /* Reserved for use by extensions not perl internals. */
5571 /* Useful for attaching extension internal data to perl vars. */
5572 /* Note that multiple extensions may clash if magical scalars */
5573 /* etc holding private data from one are passed to another. */
5576 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5579 /* Rest of work is done else where */
5580 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5583 case PERL_MAGIC_taint:
5586 case PERL_MAGIC_ext:
5587 case PERL_MAGIC_dbfile:
5594 =for apidoc sv_unmagic
5596 Removes all magic of type C<type> from an SV.
5602 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5606 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5609 for (mg = *mgp; mg; mg = *mgp) {
5610 if (mg->mg_type == type) {
5611 const MGVTBL* const vtbl = mg->mg_virtual;
5612 *mgp = mg->mg_moremagic;
5613 if (vtbl && vtbl->svt_free)
5614 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5615 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5617 Safefree(mg->mg_ptr);
5618 else if (mg->mg_len == HEf_SVKEY)
5619 SvREFCNT_dec((SV*)mg->mg_ptr);
5620 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5621 Safefree(mg->mg_ptr);
5623 if (mg->mg_flags & MGf_REFCOUNTED)
5624 SvREFCNT_dec(mg->mg_obj);
5628 mgp = &mg->mg_moremagic;
5632 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5639 =for apidoc sv_rvweaken
5641 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5642 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5643 push a back-reference to this RV onto the array of backreferences
5644 associated with that magic.
5650 Perl_sv_rvweaken(pTHX_ SV *sv)
5653 if (!SvOK(sv)) /* let undefs pass */
5656 Perl_croak(aTHX_ "Can't weaken a nonreference");
5657 else if (SvWEAKREF(sv)) {
5658 if (ckWARN(WARN_MISC))
5659 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5663 sv_add_backref(tsv, sv);
5669 /* Give tsv backref magic if it hasn't already got it, then push a
5670 * back-reference to sv onto the array associated with the backref magic.
5674 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5678 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5679 av = (AV*)mg->mg_obj;
5682 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5683 /* av now has a refcnt of 2, which avoids it getting freed
5684 * before us during global cleanup. The extra ref is removed
5685 * by magic_killbackrefs() when tsv is being freed */
5687 if (AvFILLp(av) >= AvMAX(av)) {
5689 SV **svp = AvARRAY(av);
5690 for (i = AvFILLp(av); i >= 0; i--)
5692 svp[i] = sv; /* reuse the slot */
5695 av_extend(av, AvFILLp(av)+1);
5697 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5700 /* delete a back-reference to ourselves from the backref magic associated
5701 * with the SV we point to.
5705 S_sv_del_backref(pTHX_ SV *sv)
5712 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5713 Perl_croak(aTHX_ "panic: del_backref");
5714 av = (AV *)mg->mg_obj;
5716 for (i = AvFILLp(av); i >= 0; i--)
5717 if (svp[i] == sv) svp[i] = Nullsv;
5721 =for apidoc sv_insert
5723 Inserts a string at the specified offset/length within the SV. Similar to
5724 the Perl substr() function.
5730 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5734 register char *midend;
5735 register char *bigend;
5741 Perl_croak(aTHX_ "Can't modify non-existent substring");
5742 SvPV_force(bigstr, curlen);
5743 (void)SvPOK_only_UTF8(bigstr);
5744 if (offset + len > curlen) {
5745 SvGROW(bigstr, offset+len+1);
5746 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5747 SvCUR_set(bigstr, offset+len);
5751 i = littlelen - len;
5752 if (i > 0) { /* string might grow */
5753 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5754 mid = big + offset + len;
5755 midend = bigend = big + SvCUR(bigstr);
5758 while (midend > mid) /* shove everything down */
5759 *--bigend = *--midend;
5760 Move(little,big+offset,littlelen,char);
5766 Move(little,SvPVX(bigstr)+offset,len,char);
5771 big = SvPVX(bigstr);
5774 bigend = big + SvCUR(bigstr);
5776 if (midend > bigend)
5777 Perl_croak(aTHX_ "panic: sv_insert");
5779 if (mid - big > bigend - midend) { /* faster to shorten from end */
5781 Move(little, mid, littlelen,char);
5784 i = bigend - midend;
5786 Move(midend, mid, i,char);
5790 SvCUR_set(bigstr, mid - big);
5793 else if ((i = mid - big)) { /* faster from front */
5794 midend -= littlelen;
5796 sv_chop(bigstr,midend-i);
5801 Move(little, mid, littlelen,char);
5803 else if (littlelen) {
5804 midend -= littlelen;
5805 sv_chop(bigstr,midend);
5806 Move(little,midend,littlelen,char);
5809 sv_chop(bigstr,midend);
5815 =for apidoc sv_replace
5817 Make the first argument a copy of the second, then delete the original.
5818 The target SV physically takes over ownership of the body of the source SV
5819 and inherits its flags; however, the target keeps any magic it owns,
5820 and any magic in the source is discarded.
5821 Note that this is a rather specialist SV copying operation; most of the
5822 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5828 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5830 U32 refcnt = SvREFCNT(sv);
5831 SV_CHECK_THINKFIRST_COW_DROP(sv);
5832 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5833 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5834 if (SvMAGICAL(sv)) {
5838 sv_upgrade(nsv, SVt_PVMG);
5839 SvMAGIC(nsv) = SvMAGIC(sv);
5840 SvFLAGS(nsv) |= SvMAGICAL(sv);
5846 assert(!SvREFCNT(sv));
5847 #ifdef DEBUG_LEAKING_SCALARS
5848 sv->sv_flags = nsv->sv_flags;
5849 sv->sv_any = nsv->sv_any;
5850 sv->sv_refcnt = nsv->sv_refcnt;
5852 StructCopy(nsv,sv,SV);
5855 #ifdef PERL_COPY_ON_WRITE
5856 if (SvIsCOW_normal(nsv)) {
5857 /* We need to follow the pointers around the loop to make the
5858 previous SV point to sv, rather than nsv. */
5861 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5864 assert(SvPVX(current) == SvPVX(nsv));
5866 /* Make the SV before us point to the SV after us. */
5868 PerlIO_printf(Perl_debug_log, "previous is\n");
5870 PerlIO_printf(Perl_debug_log,
5871 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5872 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5874 SV_COW_NEXT_SV_SET(current, sv);
5877 SvREFCNT(sv) = refcnt;
5878 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5884 =for apidoc sv_clear
5886 Clear an SV: call any destructors, free up any memory used by the body,
5887 and free the body itself. The SV's head is I<not> freed, although
5888 its type is set to all 1's so that it won't inadvertently be assumed
5889 to be live during global destruction etc.
5890 This function should only be called when REFCNT is zero. Most of the time
5891 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5898 Perl_sv_clear(pTHX_ register SV *sv)
5902 assert(SvREFCNT(sv) == 0);
5905 if (PL_defstash) { /* Still have a symbol table? */
5912 stash = SvSTASH(sv);
5913 destructor = StashHANDLER(stash,DESTROY);
5915 SV* tmpref = newRV(sv);
5916 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5918 PUSHSTACKi(PERLSI_DESTROY);
5923 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5929 if(SvREFCNT(tmpref) < 2) {
5930 /* tmpref is not kept alive! */
5935 SvREFCNT_dec(tmpref);
5937 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5941 if (PL_in_clean_objs)
5942 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5944 /* DESTROY gave object new lease on life */
5950 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5951 SvOBJECT_off(sv); /* Curse the object. */
5952 if (SvTYPE(sv) != SVt_PVIO)
5953 --PL_sv_objcount; /* XXX Might want something more general */
5956 if (SvTYPE(sv) >= SVt_PVMG) {
5959 if (SvFLAGS(sv) & SVpad_TYPED)
5960 SvREFCNT_dec(SvSTASH(sv));
5963 switch (SvTYPE(sv)) {
5966 IoIFP(sv) != PerlIO_stdin() &&
5967 IoIFP(sv) != PerlIO_stdout() &&
5968 IoIFP(sv) != PerlIO_stderr())
5970 io_close((IO*)sv, FALSE);
5972 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5973 PerlDir_close(IoDIRP(sv));
5974 IoDIRP(sv) = (DIR*)NULL;
5975 Safefree(IoTOP_NAME(sv));
5976 Safefree(IoFMT_NAME(sv));
5977 Safefree(IoBOTTOM_NAME(sv));
5992 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5993 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5994 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5995 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5997 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5998 SvREFCNT_dec(LvTARG(sv));
6002 Safefree(GvNAME(sv));
6003 /* cannot decrease stash refcount yet, as we might recursively delete
6004 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
6005 of stash until current sv is completely gone.
6006 -- JohnPC, 27 Mar 1998 */
6007 stash = GvSTASH(sv);
6021 SvREFCNT_dec(SvRV(sv));
6023 #ifdef PERL_COPY_ON_WRITE
6024 else if (SvPVX(sv)) {
6026 /* I believe I need to grab the global SV mutex here and
6027 then recheck the COW status. */
6029 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6032 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
6033 SvUVX(sv), SV_COW_NEXT_SV(sv));
6034 /* And drop it here. */
6036 } else if (SvLEN(sv)) {
6037 Safefree(SvPVX(sv));
6041 else if (SvPVX(sv) && SvLEN(sv))
6042 Safefree(SvPVX(sv));
6043 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6044 unsharepvn(SvPVX(sv),
6045 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6059 switch (SvTYPE(sv)) {
6075 del_XPVIV(SvANY(sv));
6078 del_XPVNV(SvANY(sv));
6081 del_XPVMG(SvANY(sv));
6084 del_XPVLV(SvANY(sv));
6087 del_XPVAV(SvANY(sv));
6090 del_XPVHV(SvANY(sv));
6093 del_XPVCV(SvANY(sv));
6096 del_XPVGV(SvANY(sv));
6097 /* code duplication for increased performance. */
6098 SvFLAGS(sv) &= SVf_BREAK;
6099 SvFLAGS(sv) |= SVTYPEMASK;
6100 /* decrease refcount of the stash that owns this GV, if any */
6102 SvREFCNT_dec(stash);
6103 return; /* not break, SvFLAGS reset already happened */
6105 del_XPVBM(SvANY(sv));
6108 del_XPVFM(SvANY(sv));
6111 del_XPVIO(SvANY(sv));
6114 SvFLAGS(sv) &= SVf_BREAK;
6115 SvFLAGS(sv) |= SVTYPEMASK;
6119 =for apidoc sv_newref
6121 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6128 Perl_sv_newref(pTHX_ SV *sv)
6138 Decrement an SV's reference count, and if it drops to zero, call
6139 C<sv_clear> to invoke destructors and free up any memory used by
6140 the body; finally, deallocate the SV's head itself.
6141 Normally called via a wrapper macro C<SvREFCNT_dec>.
6147 Perl_sv_free(pTHX_ SV *sv)
6151 if (SvREFCNT(sv) == 0) {
6152 if (SvFLAGS(sv) & SVf_BREAK)
6153 /* this SV's refcnt has been artificially decremented to
6154 * trigger cleanup */
6156 if (PL_in_clean_all) /* All is fair */
6158 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6159 /* make sure SvREFCNT(sv)==0 happens very seldom */
6160 SvREFCNT(sv) = (~(U32)0)/2;
6163 if (ckWARN_d(WARN_INTERNAL))
6164 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6165 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6166 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6169 if (--(SvREFCNT(sv)) > 0)
6171 Perl_sv_free2(aTHX_ sv);
6175 Perl_sv_free2(pTHX_ SV *sv)
6179 if (ckWARN_d(WARN_DEBUGGING))
6180 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6181 "Attempt to free temp prematurely: SV 0x%"UVxf
6182 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6186 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6187 /* make sure SvREFCNT(sv)==0 happens very seldom */
6188 SvREFCNT(sv) = (~(U32)0)/2;
6199 Returns the length of the string in the SV. Handles magic and type
6200 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6206 Perl_sv_len(pTHX_ register SV *sv)
6214 len = mg_length(sv);
6216 (void)SvPV(sv, len);
6221 =for apidoc sv_len_utf8
6223 Returns the number of characters in the string in an SV, counting wide
6224 UTF-8 bytes as a single character. Handles magic and type coercion.
6230 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6231 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6232 * (Note that the mg_len is not the length of the mg_ptr field.)
6237 Perl_sv_len_utf8(pTHX_ register SV *sv)
6243 return mg_length(sv);
6247 U8 *s = (U8*)SvPV(sv, len);
6248 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6250 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6252 #ifdef PERL_UTF8_CACHE_ASSERT
6253 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6257 ulen = Perl_utf8_length(aTHX_ s, s + len);
6258 if (!mg && !SvREADONLY(sv)) {
6259 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6260 mg = mg_find(sv, PERL_MAGIC_utf8);
6270 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6271 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6272 * between UTF-8 and byte offsets. There are two (substr offset and substr
6273 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6274 * and byte offset) cache positions.
6276 * The mg_len field is used by sv_len_utf8(), see its comments.
6277 * Note that the mg_len is not the length of the mg_ptr field.
6281 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
6285 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6287 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6291 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6293 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6294 (*mgp)->mg_ptr = (char *) *cachep;
6298 (*cachep)[i] = *offsetp;
6299 (*cachep)[i+1] = s - start;
6307 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6308 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6309 * between UTF-8 and byte offsets. See also the comments of
6310 * S_utf8_mg_pos_init().
6314 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6318 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6320 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6321 if (*mgp && (*mgp)->mg_ptr) {
6322 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6323 ASSERT_UTF8_CACHE(*cachep);
6324 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6326 else { /* We will skip to the right spot. */
6331 /* The assumption is that going backward is half
6332 * the speed of going forward (that's where the
6333 * 2 * backw in the below comes from). (The real
6334 * figure of course depends on the UTF-8 data.) */
6336 if ((*cachep)[i] > (STRLEN)uoff) {
6338 backw = (*cachep)[i] - (STRLEN)uoff;
6340 if (forw < 2 * backw)
6343 p = start + (*cachep)[i+1];
6345 /* Try this only for the substr offset (i == 0),
6346 * not for the substr length (i == 2). */
6347 else if (i == 0) { /* (*cachep)[i] < uoff */
6348 STRLEN ulen = sv_len_utf8(sv);
6350 if ((STRLEN)uoff < ulen) {
6351 forw = (STRLEN)uoff - (*cachep)[i];
6352 backw = ulen - (STRLEN)uoff;
6354 if (forw < 2 * backw)
6355 p = start + (*cachep)[i+1];
6360 /* If the string is not long enough for uoff,
6361 * we could extend it, but not at this low a level. */
6365 if (forw < 2 * backw) {
6372 while (UTF8_IS_CONTINUATION(*p))
6377 /* Update the cache. */
6378 (*cachep)[i] = (STRLEN)uoff;
6379 (*cachep)[i+1] = p - start;
6381 /* Drop the stale "length" cache */
6390 if (found) { /* Setup the return values. */
6391 *offsetp = (*cachep)[i+1];
6392 *sp = start + *offsetp;
6395 *offsetp = send - start;
6397 else if (*sp < start) {
6403 #ifdef PERL_UTF8_CACHE_ASSERT
6408 while (n-- && s < send)
6412 assert(*offsetp == s - start);
6413 assert((*cachep)[0] == (STRLEN)uoff);
6414 assert((*cachep)[1] == *offsetp);
6416 ASSERT_UTF8_CACHE(*cachep);
6425 =for apidoc sv_pos_u2b
6427 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6428 the start of the string, to a count of the equivalent number of bytes; if
6429 lenp is non-zero, it does the same to lenp, but this time starting from
6430 the offset, rather than from the start of the string. Handles magic and
6437 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6438 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6439 * byte offsets. See also the comments of S_utf8_mg_pos().
6444 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6455 start = s = (U8*)SvPV(sv, len);
6457 I32 uoffset = *offsetp;
6462 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6464 if (!found && uoffset > 0) {
6465 while (s < send && uoffset--)
6469 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
6471 *offsetp = s - start;
6476 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
6480 if (!found && *lenp > 0) {
6483 while (s < send && ulen--)
6487 utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
6491 ASSERT_UTF8_CACHE(cache);
6503 =for apidoc sv_pos_b2u
6505 Converts the value pointed to by offsetp from a count of bytes from the
6506 start of the string, to a count of the equivalent number of UTF-8 chars.
6507 Handles magic and type coercion.
6513 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6514 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6515 * byte offsets. See also the comments of S_utf8_mg_pos().
6520 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6528 s = (U8*)SvPV(sv, len);
6529 if ((I32)len < *offsetp)
6530 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6532 U8* send = s + *offsetp;
6534 STRLEN *cache = NULL;
6538 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6539 mg = mg_find(sv, PERL_MAGIC_utf8);
6540 if (mg && mg->mg_ptr) {
6541 cache = (STRLEN *) mg->mg_ptr;
6542 if (cache[1] == (STRLEN)*offsetp) {
6543 /* An exact match. */
6544 *offsetp = cache[0];
6548 else if (cache[1] < (STRLEN)*offsetp) {
6549 /* We already know part of the way. */
6552 /* Let the below loop do the rest. */
6554 else { /* cache[1] > *offsetp */
6555 /* We already know all of the way, now we may
6556 * be able to walk back. The same assumption
6557 * is made as in S_utf8_mg_pos(), namely that
6558 * walking backward is twice slower than
6559 * walking forward. */
6560 STRLEN forw = *offsetp;
6561 STRLEN backw = cache[1] - *offsetp;
6563 if (!(forw < 2 * backw)) {
6564 U8 *p = s + cache[1];
6571 while (UTF8_IS_CONTINUATION(*p)) {
6579 *offsetp = cache[0];
6581 /* Drop the stale "length" cache */
6589 ASSERT_UTF8_CACHE(cache);
6595 /* Call utf8n_to_uvchr() to validate the sequence
6596 * (unless a simple non-UTF character) */
6597 if (!UTF8_IS_INVARIANT(*s))
6598 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6607 if (!SvREADONLY(sv)) {
6609 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6610 mg = mg_find(sv, PERL_MAGIC_utf8);
6615 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6616 mg->mg_ptr = (char *) cache;
6621 cache[1] = *offsetp;
6622 /* Drop the stale "length" cache */
6635 Returns a boolean indicating whether the strings in the two SVs are
6636 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6637 coerce its args to strings if necessary.
6643 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6651 SV* svrecode = Nullsv;
6658 pv1 = SvPV(sv1, cur1);
6665 pv2 = SvPV(sv2, cur2);
6667 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6668 /* Differing utf8ness.
6669 * Do not UTF8size the comparands as a side-effect. */
6672 svrecode = newSVpvn(pv2, cur2);
6673 sv_recode_to_utf8(svrecode, PL_encoding);
6674 pv2 = SvPV(svrecode, cur2);
6677 svrecode = newSVpvn(pv1, cur1);
6678 sv_recode_to_utf8(svrecode, PL_encoding);
6679 pv1 = SvPV(svrecode, cur1);
6681 /* Now both are in UTF-8. */
6683 SvREFCNT_dec(svrecode);
6688 bool is_utf8 = TRUE;
6691 /* sv1 is the UTF-8 one,
6692 * if is equal it must be downgrade-able */
6693 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6699 /* sv2 is the UTF-8 one,
6700 * if is equal it must be downgrade-able */
6701 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6707 /* Downgrade not possible - cannot be eq */
6715 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6718 SvREFCNT_dec(svrecode);
6729 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6730 string in C<sv1> is less than, equal to, or greater than the string in
6731 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6732 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6738 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6741 const char *pv1, *pv2;
6744 SV *svrecode = Nullsv;
6751 pv1 = SvPV(sv1, cur1);
6758 pv2 = SvPV(sv2, cur2);
6760 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6761 /* Differing utf8ness.
6762 * Do not UTF8size the comparands as a side-effect. */
6765 svrecode = newSVpvn(pv2, cur2);
6766 sv_recode_to_utf8(svrecode, PL_encoding);
6767 pv2 = SvPV(svrecode, cur2);
6770 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6775 svrecode = newSVpvn(pv1, cur1);
6776 sv_recode_to_utf8(svrecode, PL_encoding);
6777 pv1 = SvPV(svrecode, cur1);
6780 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6786 cmp = cur2 ? -1 : 0;
6790 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6793 cmp = retval < 0 ? -1 : 1;
6794 } else if (cur1 == cur2) {
6797 cmp = cur1 < cur2 ? -1 : 1;
6802 SvREFCNT_dec(svrecode);
6811 =for apidoc sv_cmp_locale
6813 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6814 'use bytes' aware, handles get magic, and will coerce its args to strings
6815 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6821 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6823 #ifdef USE_LOCALE_COLLATE
6829 if (PL_collation_standard)
6833 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6835 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6837 if (!pv1 || !len1) {
6848 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6851 return retval < 0 ? -1 : 1;
6854 * When the result of collation is equality, that doesn't mean
6855 * that there are no differences -- some locales exclude some
6856 * characters from consideration. So to avoid false equalities,
6857 * we use the raw string as a tiebreaker.
6863 #endif /* USE_LOCALE_COLLATE */
6865 return sv_cmp(sv1, sv2);
6869 #ifdef USE_LOCALE_COLLATE
6872 =for apidoc sv_collxfrm
6874 Add Collate Transform magic to an SV if it doesn't already have it.
6876 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6877 scalar data of the variable, but transformed to such a format that a normal
6878 memory comparison can be used to compare the data according to the locale
6885 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6889 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6890 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6895 Safefree(mg->mg_ptr);
6897 if ((xf = mem_collxfrm(s, len, &xlen))) {
6898 if (SvREADONLY(sv)) {
6901 return xf + sizeof(PL_collation_ix);
6904 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6905 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6918 if (mg && mg->mg_ptr) {
6920 return mg->mg_ptr + sizeof(PL_collation_ix);
6928 #endif /* USE_LOCALE_COLLATE */
6933 Get a line from the filehandle and store it into the SV, optionally
6934 appending to the currently-stored string.
6940 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6944 register STDCHAR rslast;
6945 register STDCHAR *bp;
6951 if (SvTHINKFIRST(sv))
6952 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6953 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6955 However, perlbench says it's slower, because the existing swipe code
6956 is faster than copy on write.
6957 Swings and roundabouts. */
6958 (void)SvUPGRADE(sv, SVt_PV);
6963 if (PerlIO_isutf8(fp)) {
6965 sv_utf8_upgrade_nomg(sv);
6966 sv_pos_u2b(sv,&append,0);
6968 } else if (SvUTF8(sv)) {
6969 SV *tsv = NEWSV(0,0);
6970 sv_gets(tsv, fp, 0);
6971 sv_utf8_upgrade_nomg(tsv);
6972 SvCUR_set(sv,append);
6975 goto return_string_or_null;
6980 if (PerlIO_isutf8(fp))
6983 if (IN_PERL_COMPILETIME) {
6984 /* we always read code in line mode */
6988 else if (RsSNARF(PL_rs)) {
6989 /* If it is a regular disk file use size from stat() as estimate
6990 of amount we are going to read - may result in malloc-ing
6991 more memory than we realy need if layers bellow reduce
6992 size we read (e.g. CRLF or a gzip layer)
6995 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6996 Off_t offset = PerlIO_tell(fp);
6997 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6998 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7004 else if (RsRECORD(PL_rs)) {
7008 /* Grab the size of the record we're getting */
7009 recsize = SvIV(SvRV(PL_rs));
7010 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7013 /* VMS wants read instead of fread, because fread doesn't respect */
7014 /* RMS record boundaries. This is not necessarily a good thing to be */
7015 /* doing, but we've got no other real choice - except avoid stdio
7016 as implementation - perhaps write a :vms layer ?
7018 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
7020 bytesread = PerlIO_read(fp, buffer, recsize);
7024 SvCUR_set(sv, bytesread += append);
7025 buffer[bytesread] = '\0';
7026 goto return_string_or_null;
7028 else if (RsPARA(PL_rs)) {
7034 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7035 if (PerlIO_isutf8(fp)) {
7036 rsptr = SvPVutf8(PL_rs, rslen);
7039 if (SvUTF8(PL_rs)) {
7040 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7041 Perl_croak(aTHX_ "Wide character in $/");
7044 rsptr = SvPV(PL_rs, rslen);
7048 rslast = rslen ? rsptr[rslen - 1] : '\0';
7050 if (rspara) { /* have to do this both before and after */
7051 do { /* to make sure file boundaries work right */
7054 i = PerlIO_getc(fp);
7058 PerlIO_ungetc(fp,i);
7064 /* See if we know enough about I/O mechanism to cheat it ! */
7066 /* This used to be #ifdef test - it is made run-time test for ease
7067 of abstracting out stdio interface. One call should be cheap
7068 enough here - and may even be a macro allowing compile
7072 if (PerlIO_fast_gets(fp)) {
7075 * We're going to steal some values from the stdio struct
7076 * and put EVERYTHING in the innermost loop into registers.
7078 register STDCHAR *ptr;
7082 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7083 /* An ungetc()d char is handled separately from the regular
7084 * buffer, so we getc() it back out and stuff it in the buffer.
7086 i = PerlIO_getc(fp);
7087 if (i == EOF) return 0;
7088 *(--((*fp)->_ptr)) = (unsigned char) i;
7092 /* Here is some breathtakingly efficient cheating */
7094 cnt = PerlIO_get_cnt(fp); /* get count into register */
7095 /* make sure we have the room */
7096 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7097 /* Not room for all of it
7098 if we are looking for a separator and room for some
7100 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7101 /* just process what we have room for */
7102 shortbuffered = cnt - SvLEN(sv) + append + 1;
7103 cnt -= shortbuffered;
7107 /* remember that cnt can be negative */
7108 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7113 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7114 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7115 DEBUG_P(PerlIO_printf(Perl_debug_log,
7116 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7117 DEBUG_P(PerlIO_printf(Perl_debug_log,
7118 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7119 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7120 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7125 while (cnt > 0) { /* this | eat */
7127 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7128 goto thats_all_folks; /* screams | sed :-) */
7132 Copy(ptr, bp, cnt, char); /* this | eat */
7133 bp += cnt; /* screams | dust */
7134 ptr += cnt; /* louder | sed :-) */
7139 if (shortbuffered) { /* oh well, must extend */
7140 cnt = shortbuffered;
7142 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7144 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7145 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7149 DEBUG_P(PerlIO_printf(Perl_debug_log,
7150 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7151 PTR2UV(ptr),(long)cnt));
7152 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7154 DEBUG_P(PerlIO_printf(Perl_debug_log,
7155 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7156 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7157 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7159 /* This used to call 'filbuf' in stdio form, but as that behaves like
7160 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7161 another abstraction. */
7162 i = PerlIO_getc(fp); /* get more characters */
7164 DEBUG_P(PerlIO_printf(Perl_debug_log,
7165 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7166 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7167 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7169 cnt = PerlIO_get_cnt(fp);
7170 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7171 DEBUG_P(PerlIO_printf(Perl_debug_log,
7172 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7174 if (i == EOF) /* all done for ever? */
7175 goto thats_really_all_folks;
7177 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7179 SvGROW(sv, bpx + cnt + 2);
7180 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7182 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7184 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7185 goto thats_all_folks;
7189 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7190 memNE((char*)bp - rslen, rsptr, rslen))
7191 goto screamer; /* go back to the fray */
7192 thats_really_all_folks:
7194 cnt += shortbuffered;
7195 DEBUG_P(PerlIO_printf(Perl_debug_log,
7196 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7197 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7198 DEBUG_P(PerlIO_printf(Perl_debug_log,
7199 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7200 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7201 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7203 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7204 DEBUG_P(PerlIO_printf(Perl_debug_log,
7205 "Screamer: done, len=%ld, string=|%.*s|\n",
7206 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7210 /*The big, slow, and stupid way. */
7212 /* Any stack-challenged places. */
7214 /* EPOC: need to work around SDK features. *
7215 * On WINS: MS VC5 generates calls to _chkstk, *
7216 * if a "large" stack frame is allocated. *
7217 * gcc on MARM does not generate calls like these. */
7218 # define USEHEAPINSTEADOFSTACK
7221 #ifdef USEHEAPINSTEADOFSTACK
7223 New(0, buf, 8192, STDCHAR);
7231 register STDCHAR *bpe = buf + sizeof(buf);
7233 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7234 ; /* keep reading */
7238 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7239 /* Accomodate broken VAXC compiler, which applies U8 cast to
7240 * both args of ?: operator, causing EOF to change into 255
7243 i = (U8)buf[cnt - 1];
7249 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7251 sv_catpvn(sv, (char *) buf, cnt);
7253 sv_setpvn(sv, (char *) buf, cnt);
7255 if (i != EOF && /* joy */
7257 SvCUR(sv) < rslen ||
7258 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7262 * If we're reading from a TTY and we get a short read,
7263 * indicating that the user hit his EOF character, we need
7264 * to notice it now, because if we try to read from the TTY
7265 * again, the EOF condition will disappear.
7267 * The comparison of cnt to sizeof(buf) is an optimization
7268 * that prevents unnecessary calls to feof().
7272 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7276 #ifdef USEHEAPINSTEADOFSTACK
7281 if (rspara) { /* have to do this both before and after */
7282 while (i != EOF) { /* to make sure file boundaries work right */
7283 i = PerlIO_getc(fp);
7285 PerlIO_ungetc(fp,i);
7291 return_string_or_null:
7292 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7298 Auto-increment of the value in the SV, doing string to numeric conversion
7299 if necessary. Handles 'get' magic.
7305 Perl_sv_inc(pTHX_ register SV *sv)
7314 if (SvTHINKFIRST(sv)) {
7316 sv_force_normal_flags(sv, 0);
7317 if (SvREADONLY(sv)) {
7318 if (IN_PERL_RUNTIME)
7319 Perl_croak(aTHX_ PL_no_modify);
7323 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7325 i = PTR2IV(SvRV(sv));
7330 flags = SvFLAGS(sv);
7331 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7332 /* It's (privately or publicly) a float, but not tested as an
7333 integer, so test it to see. */
7335 flags = SvFLAGS(sv);
7337 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7338 /* It's publicly an integer, or privately an integer-not-float */
7339 #ifdef PERL_PRESERVE_IVUV
7343 if (SvUVX(sv) == UV_MAX)
7344 sv_setnv(sv, UV_MAX_P1);
7346 (void)SvIOK_only_UV(sv);
7349 if (SvIVX(sv) == IV_MAX)
7350 sv_setuv(sv, (UV)IV_MAX + 1);
7352 (void)SvIOK_only(sv);
7358 if (flags & SVp_NOK) {
7359 (void)SvNOK_only(sv);
7364 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7365 if ((flags & SVTYPEMASK) < SVt_PVIV)
7366 sv_upgrade(sv, SVt_IV);
7367 (void)SvIOK_only(sv);
7372 while (isALPHA(*d)) d++;
7373 while (isDIGIT(*d)) d++;
7375 #ifdef PERL_PRESERVE_IVUV
7376 /* Got to punt this as an integer if needs be, but we don't issue
7377 warnings. Probably ought to make the sv_iv_please() that does
7378 the conversion if possible, and silently. */
7379 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7380 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7381 /* Need to try really hard to see if it's an integer.
7382 9.22337203685478e+18 is an integer.
7383 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7384 so $a="9.22337203685478e+18"; $a+0; $a++
7385 needs to be the same as $a="9.22337203685478e+18"; $a++
7392 /* sv_2iv *should* have made this an NV */
7393 if (flags & SVp_NOK) {
7394 (void)SvNOK_only(sv);
7398 /* I don't think we can get here. Maybe I should assert this
7399 And if we do get here I suspect that sv_setnv will croak. NWC
7401 #if defined(USE_LONG_DOUBLE)
7402 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",
7403 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7405 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7406 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7409 #endif /* PERL_PRESERVE_IVUV */
7410 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7414 while (d >= SvPVX(sv)) {
7422 /* MKS: The original code here died if letters weren't consecutive.
7423 * at least it didn't have to worry about non-C locales. The
7424 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7425 * arranged in order (although not consecutively) and that only
7426 * [A-Za-z] are accepted by isALPHA in the C locale.
7428 if (*d != 'z' && *d != 'Z') {
7429 do { ++*d; } while (!isALPHA(*d));
7432 *(d--) -= 'z' - 'a';
7437 *(d--) -= 'z' - 'a' + 1;
7441 /* oh,oh, the number grew */
7442 SvGROW(sv, SvCUR(sv) + 2);
7444 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7455 Auto-decrement of the value in the SV, doing string to numeric conversion
7456 if necessary. Handles 'get' magic.
7462 Perl_sv_dec(pTHX_ register SV *sv)
7470 if (SvTHINKFIRST(sv)) {
7472 sv_force_normal_flags(sv, 0);
7473 if (SvREADONLY(sv)) {
7474 if (IN_PERL_RUNTIME)
7475 Perl_croak(aTHX_ PL_no_modify);
7479 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7481 i = PTR2IV(SvRV(sv));
7486 /* Unlike sv_inc we don't have to worry about string-never-numbers
7487 and keeping them magic. But we mustn't warn on punting */
7488 flags = SvFLAGS(sv);
7489 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7490 /* It's publicly an integer, or privately an integer-not-float */
7491 #ifdef PERL_PRESERVE_IVUV
7495 if (SvUVX(sv) == 0) {
7496 (void)SvIOK_only(sv);
7500 (void)SvIOK_only_UV(sv);
7504 if (SvIVX(sv) == IV_MIN)
7505 sv_setnv(sv, (NV)IV_MIN - 1.0);
7507 (void)SvIOK_only(sv);
7513 if (flags & SVp_NOK) {
7515 (void)SvNOK_only(sv);
7518 if (!(flags & SVp_POK)) {
7519 if ((flags & SVTYPEMASK) < SVt_PVNV)
7520 sv_upgrade(sv, SVt_NV);
7522 (void)SvNOK_only(sv);
7525 #ifdef PERL_PRESERVE_IVUV
7527 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7528 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7529 /* Need to try really hard to see if it's an integer.
7530 9.22337203685478e+18 is an integer.
7531 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7532 so $a="9.22337203685478e+18"; $a+0; $a--
7533 needs to be the same as $a="9.22337203685478e+18"; $a--
7540 /* sv_2iv *should* have made this an NV */
7541 if (flags & SVp_NOK) {
7542 (void)SvNOK_only(sv);
7546 /* I don't think we can get here. Maybe I should assert this
7547 And if we do get here I suspect that sv_setnv will croak. NWC
7549 #if defined(USE_LONG_DOUBLE)
7550 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",
7551 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7553 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7554 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7558 #endif /* PERL_PRESERVE_IVUV */
7559 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7563 =for apidoc sv_mortalcopy
7565 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7566 The new SV is marked as mortal. It will be destroyed "soon", either by an
7567 explicit call to FREETMPS, or by an implicit call at places such as
7568 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7573 /* Make a string that will exist for the duration of the expression
7574 * evaluation. Actually, it may have to last longer than that, but
7575 * hopefully we won't free it until it has been assigned to a
7576 * permanent location. */
7579 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7584 sv_setsv(sv,oldstr);
7586 PL_tmps_stack[++PL_tmps_ix] = sv;
7592 =for apidoc sv_newmortal
7594 Creates a new null SV which is mortal. The reference count of the SV is
7595 set to 1. It will be destroyed "soon", either by an explicit call to
7596 FREETMPS, or by an implicit call at places such as statement boundaries.
7597 See also C<sv_mortalcopy> and C<sv_2mortal>.
7603 Perl_sv_newmortal(pTHX)
7608 SvFLAGS(sv) = SVs_TEMP;
7610 PL_tmps_stack[++PL_tmps_ix] = sv;
7615 =for apidoc sv_2mortal
7617 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7618 by an explicit call to FREETMPS, or by an implicit call at places such as
7619 statement boundaries. SvTEMP() is turned on which means that the SV's
7620 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7621 and C<sv_mortalcopy>.
7627 Perl_sv_2mortal(pTHX_ register SV *sv)
7631 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7634 PL_tmps_stack[++PL_tmps_ix] = sv;
7642 Creates a new SV and copies a string into it. The reference count for the
7643 SV is set to 1. If C<len> is zero, Perl will compute the length using
7644 strlen(). For efficiency, consider using C<newSVpvn> instead.
7650 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7657 sv_setpvn(sv,s,len);
7662 =for apidoc newSVpvn
7664 Creates a new SV and copies a string into it. The reference count for the
7665 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7666 string. You are responsible for ensuring that the source string is at least
7667 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7673 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7678 sv_setpvn(sv,s,len);
7683 =for apidoc newSVpvn_share
7685 Creates a new SV with its SvPVX pointing to a shared string in the string
7686 table. If the string does not already exist in the table, it is created
7687 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7688 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7689 otherwise the hash is computed. The idea here is that as the string table
7690 is used for shared hash keys these strings will have SvPVX == HeKEY and
7691 hash lookup will avoid string compare.
7697 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7700 bool is_utf8 = FALSE;
7702 STRLEN tmplen = -len;
7704 /* See the note in hv.c:hv_fetch() --jhi */
7705 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7709 PERL_HASH(hash, src, len);
7711 sv_upgrade(sv, SVt_PVIV);
7712 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7725 #if defined(PERL_IMPLICIT_CONTEXT)
7727 /* pTHX_ magic can't cope with varargs, so this is a no-context
7728 * version of the main function, (which may itself be aliased to us).
7729 * Don't access this version directly.
7733 Perl_newSVpvf_nocontext(const char* pat, ...)
7738 va_start(args, pat);
7739 sv = vnewSVpvf(pat, &args);
7746 =for apidoc newSVpvf
7748 Creates a new SV and initializes it with the string formatted like
7755 Perl_newSVpvf(pTHX_ const char* pat, ...)
7759 va_start(args, pat);
7760 sv = vnewSVpvf(pat, &args);
7765 /* backend for newSVpvf() and newSVpvf_nocontext() */
7768 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7772 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7779 Creates a new SV and copies a floating point value into it.
7780 The reference count for the SV is set to 1.
7786 Perl_newSVnv(pTHX_ NV n)
7798 Creates a new SV and copies an integer into it. The reference count for the
7805 Perl_newSViv(pTHX_ IV i)
7817 Creates a new SV and copies an unsigned integer into it.
7818 The reference count for the SV is set to 1.
7824 Perl_newSVuv(pTHX_ UV u)
7834 =for apidoc newRV_noinc
7836 Creates an RV wrapper for an SV. The reference count for the original
7837 SV is B<not> incremented.
7843 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7848 sv_upgrade(sv, SVt_RV);
7855 /* newRV_inc is the official function name to use now.
7856 * newRV_inc is in fact #defined to newRV in sv.h
7860 Perl_newRV(pTHX_ SV *tmpRef)
7862 return newRV_noinc(SvREFCNT_inc(tmpRef));
7868 Creates a new SV which is an exact duplicate of the original SV.
7875 Perl_newSVsv(pTHX_ register SV *old)
7881 if (SvTYPE(old) == SVTYPEMASK) {
7882 if (ckWARN_d(WARN_INTERNAL))
7883 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7887 /* SV_GMAGIC is the default for sv_setv()
7888 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7889 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7890 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7895 =for apidoc sv_reset
7897 Underlying implementation for the C<reset> Perl function.
7898 Note that the perl-level function is vaguely deprecated.
7904 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7912 char todo[PERL_UCHAR_MAX+1];
7917 if (!*s) { /* reset ?? searches */
7918 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7919 pm->op_pmdynflags &= ~PMdf_USED;
7924 /* reset variables */
7926 if (!HvARRAY(stash))
7929 Zero(todo, 256, char);
7931 i = (unsigned char)*s;
7935 max = (unsigned char)*s++;
7936 for ( ; i <= max; i++) {
7939 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7940 for (entry = HvARRAY(stash)[i];
7942 entry = HeNEXT(entry))
7944 if (!todo[(U8)*HeKEY(entry)])
7946 gv = (GV*)HeVAL(entry);
7948 if (SvTHINKFIRST(sv)) {
7949 if (!SvREADONLY(sv) && SvROK(sv))
7954 if (SvTYPE(sv) >= SVt_PV) {
7956 if (SvPVX(sv) != Nullch)
7963 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7966 #ifdef USE_ENVIRON_ARRAY
7968 # ifdef USE_ITHREADS
7969 && PL_curinterp == aTHX
7973 environ[0] = Nullch;
7976 #endif /* !PERL_MICRO */
7986 Using various gambits, try to get an IO from an SV: the IO slot if its a
7987 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7988 named after the PV if we're a string.
7994 Perl_sv_2io(pTHX_ SV *sv)
7999 switch (SvTYPE(sv)) {
8007 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8011 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8013 return sv_2io(SvRV(sv));
8014 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
8020 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
8029 Using various gambits, try to get a CV from an SV; in addition, try if
8030 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8036 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
8042 return *gvp = Nullgv, Nullcv;
8043 switch (SvTYPE(sv)) {
8062 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8063 tryAMAGICunDEREF(to_cv);
8066 if (SvTYPE(sv) == SVt_PVCV) {
8075 Perl_croak(aTHX_ "Not a subroutine reference");
8080 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8086 if (lref && !GvCVu(gv)) {
8089 tmpsv = NEWSV(704,0);
8090 gv_efullname3(tmpsv, gv, Nullch);
8091 /* XXX this is probably not what they think they're getting.
8092 * It has the same effect as "sub name;", i.e. just a forward
8094 newSUB(start_subparse(FALSE, 0),
8095 newSVOP(OP_CONST, 0, tmpsv),
8100 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8110 Returns true if the SV has a true value by Perl's rules.
8111 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8112 instead use an in-line version.
8118 Perl_sv_true(pTHX_ register SV *sv)
8123 const register XPV* tXpv;
8124 if ((tXpv = (XPV*)SvANY(sv)) &&
8125 (tXpv->xpv_cur > 1 ||
8126 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8133 return SvIVX(sv) != 0;
8136 return SvNVX(sv) != 0.0;
8138 return sv_2bool(sv);
8146 A private implementation of the C<SvIVx> macro for compilers which can't
8147 cope with complex macro expressions. Always use the macro instead.
8153 Perl_sv_iv(pTHX_ register SV *sv)
8157 return (IV)SvUVX(sv);
8166 A private implementation of the C<SvUVx> macro for compilers which can't
8167 cope with complex macro expressions. Always use the macro instead.
8173 Perl_sv_uv(pTHX_ register SV *sv)
8178 return (UV)SvIVX(sv);
8186 A private implementation of the C<SvNVx> macro for compilers which can't
8187 cope with complex macro expressions. Always use the macro instead.
8193 Perl_sv_nv(pTHX_ register SV *sv)
8200 /* sv_pv() is now a macro using SvPV_nolen();
8201 * this function provided for binary compatibility only
8205 Perl_sv_pv(pTHX_ SV *sv)
8212 return sv_2pv(sv, &n_a);
8218 Use the C<SvPV_nolen> macro instead
8222 A private implementation of the C<SvPV> macro for compilers which can't
8223 cope with complex macro expressions. Always use the macro instead.
8229 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8235 return sv_2pv(sv, lp);
8240 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8246 return sv_2pv_flags(sv, lp, 0);
8249 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8250 * this function provided for binary compatibility only
8254 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8256 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8260 =for apidoc sv_pvn_force
8262 Get a sensible string out of the SV somehow.
8263 A private implementation of the C<SvPV_force> macro for compilers which
8264 can't cope with complex macro expressions. Always use the macro instead.
8266 =for apidoc sv_pvn_force_flags
8268 Get a sensible string out of the SV somehow.
8269 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8270 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8271 implemented in terms of this function.
8272 You normally want to use the various wrapper macros instead: see
8273 C<SvPV_force> and C<SvPV_force_nomg>
8279 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8283 if (SvTHINKFIRST(sv) && !SvROK(sv))
8284 sv_force_normal_flags(sv, 0);
8290 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8291 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8295 s = sv_2pv_flags(sv, lp, flags);
8296 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8301 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8302 SvGROW(sv, len + 1);
8303 Move(s,SvPVX(sv),len,char);
8308 SvPOK_on(sv); /* validate pointer */
8310 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8311 PTR2UV(sv),SvPVX(sv)));
8317 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8318 * this function provided for binary compatibility only
8322 Perl_sv_pvbyte(pTHX_ SV *sv)
8324 sv_utf8_downgrade(sv,0);
8329 =for apidoc sv_pvbyte
8331 Use C<SvPVbyte_nolen> instead.
8333 =for apidoc sv_pvbyten
8335 A private implementation of the C<SvPVbyte> macro for compilers
8336 which can't cope with complex macro expressions. Always use the macro
8343 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8345 sv_utf8_downgrade(sv,0);
8346 return sv_pvn(sv,lp);
8350 =for apidoc sv_pvbyten_force
8352 A private implementation of the C<SvPVbytex_force> macro for compilers
8353 which can't cope with complex macro expressions. Always use the macro
8360 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8362 sv_pvn_force(sv,lp);
8363 sv_utf8_downgrade(sv,0);
8368 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8369 * this function provided for binary compatibility only
8373 Perl_sv_pvutf8(pTHX_ SV *sv)
8375 sv_utf8_upgrade(sv);
8380 =for apidoc sv_pvutf8
8382 Use the C<SvPVutf8_nolen> macro instead
8384 =for apidoc sv_pvutf8n
8386 A private implementation of the C<SvPVutf8> macro for compilers
8387 which can't cope with complex macro expressions. Always use the macro
8394 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8396 sv_utf8_upgrade(sv);
8397 return sv_pvn(sv,lp);
8401 =for apidoc sv_pvutf8n_force
8403 A private implementation of the C<SvPVutf8_force> macro for compilers
8404 which can't cope with complex macro expressions. Always use the macro
8411 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8413 sv_pvn_force(sv,lp);
8414 sv_utf8_upgrade(sv);
8420 =for apidoc sv_reftype
8422 Returns a string describing what the SV is a reference to.
8428 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8430 if (ob && SvOBJECT(sv)) {
8431 const char *name = HvNAME(SvSTASH(sv));
8432 return name ? name : "__ANON__";
8435 switch (SvTYPE(sv)) {
8452 case SVt_PVLV: return SvROK(sv) ? "REF"
8453 /* tied lvalues should appear to be
8454 * scalars for backwards compatitbility */
8455 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8456 ? "SCALAR" : "LVALUE";
8457 case SVt_PVAV: return "ARRAY";
8458 case SVt_PVHV: return "HASH";
8459 case SVt_PVCV: return "CODE";
8460 case SVt_PVGV: return "GLOB";
8461 case SVt_PVFM: return "FORMAT";
8462 case SVt_PVIO: return "IO";
8463 default: return "UNKNOWN";
8469 =for apidoc sv_isobject
8471 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8472 object. If the SV is not an RV, or if the object is not blessed, then this
8479 Perl_sv_isobject(pTHX_ SV *sv)
8496 Returns a boolean indicating whether the SV is blessed into the specified
8497 class. This does not check for subtypes; use C<sv_derived_from> to verify
8498 an inheritance relationship.
8504 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8515 if (!HvNAME(SvSTASH(sv)))
8518 return strEQ(HvNAME(SvSTASH(sv)), name);
8524 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8525 it will be upgraded to one. If C<classname> is non-null then the new SV will
8526 be blessed in the specified package. The new SV is returned and its
8527 reference count is 1.
8533 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8539 SV_CHECK_THINKFIRST_COW_DROP(rv);
8542 if (SvTYPE(rv) >= SVt_PVMG) {
8543 U32 refcnt = SvREFCNT(rv);
8547 SvREFCNT(rv) = refcnt;
8550 if (SvTYPE(rv) < SVt_RV)
8551 sv_upgrade(rv, SVt_RV);
8552 else if (SvTYPE(rv) > SVt_RV) {
8554 if (SvPVX(rv) && SvLEN(rv))
8555 Safefree(SvPVX(rv));
8565 HV* stash = gv_stashpv(classname, TRUE);
8566 (void)sv_bless(rv, stash);
8572 =for apidoc sv_setref_pv
8574 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8575 argument will be upgraded to an RV. That RV will be modified to point to
8576 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8577 into the SV. The C<classname> argument indicates the package for the
8578 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8579 will have a reference count of 1, and the RV will be returned.
8581 Do not use with other Perl types such as HV, AV, SV, CV, because those
8582 objects will become corrupted by the pointer copy process.
8584 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8590 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8593 sv_setsv(rv, &PL_sv_undef);
8597 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8602 =for apidoc sv_setref_iv
8604 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8605 argument will be upgraded to an RV. That RV will be modified to point to
8606 the new SV. The C<classname> argument indicates the package for the
8607 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8608 will have a reference count of 1, and the RV will be returned.
8614 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8616 sv_setiv(newSVrv(rv,classname), iv);
8621 =for apidoc sv_setref_uv
8623 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8624 argument will be upgraded to an RV. That RV will be modified to point to
8625 the new SV. The C<classname> argument indicates the package for the
8626 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8627 will have a reference count of 1, and the RV will be returned.
8633 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8635 sv_setuv(newSVrv(rv,classname), uv);
8640 =for apidoc sv_setref_nv
8642 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8643 argument will be upgraded to an RV. That RV will be modified to point to
8644 the new SV. The C<classname> argument indicates the package for the
8645 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8646 will have a reference count of 1, and the RV will be returned.
8652 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8654 sv_setnv(newSVrv(rv,classname), nv);
8659 =for apidoc sv_setref_pvn
8661 Copies a string into a new SV, optionally blessing the SV. The length of the
8662 string must be specified with C<n>. The C<rv> argument will be upgraded to
8663 an RV. That RV will be modified to point to the new SV. The C<classname>
8664 argument indicates the package for the blessing. Set C<classname> to
8665 C<Nullch> to avoid the blessing. The new SV will have a reference count
8666 of 1, and the RV will be returned.
8668 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8674 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8676 sv_setpvn(newSVrv(rv,classname), pv, n);
8681 =for apidoc sv_bless
8683 Blesses an SV into a specified package. The SV must be an RV. The package
8684 must be designated by its stash (see C<gv_stashpv()>). The reference count
8685 of the SV is unaffected.
8691 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8695 Perl_croak(aTHX_ "Can't bless non-reference value");
8697 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8698 if (SvREADONLY(tmpRef))
8699 Perl_croak(aTHX_ PL_no_modify);
8700 if (SvOBJECT(tmpRef)) {
8701 if (SvTYPE(tmpRef) != SVt_PVIO)
8703 SvREFCNT_dec(SvSTASH(tmpRef));
8706 SvOBJECT_on(tmpRef);
8707 if (SvTYPE(tmpRef) != SVt_PVIO)
8709 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8710 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8717 if(SvSMAGICAL(tmpRef))
8718 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8726 /* Downgrades a PVGV to a PVMG.
8730 S_sv_unglob(pTHX_ SV *sv)
8734 assert(SvTYPE(sv) == SVt_PVGV);
8739 SvREFCNT_dec(GvSTASH(sv));
8740 GvSTASH(sv) = Nullhv;
8742 sv_unmagic(sv, PERL_MAGIC_glob);
8743 Safefree(GvNAME(sv));
8746 /* need to keep SvANY(sv) in the right arena */
8747 xpvmg = new_XPVMG();
8748 StructCopy(SvANY(sv), xpvmg, XPVMG);
8749 del_XPVGV(SvANY(sv));
8752 SvFLAGS(sv) &= ~SVTYPEMASK;
8753 SvFLAGS(sv) |= SVt_PVMG;
8757 =for apidoc sv_unref_flags
8759 Unsets the RV status of the SV, and decrements the reference count of
8760 whatever was being referenced by the RV. This can almost be thought of
8761 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8762 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8763 (otherwise the decrementing is conditional on the reference count being
8764 different from one or the reference being a readonly SV).
8771 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8775 if (SvWEAKREF(sv)) {
8783 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8784 assigned to as BEGIN {$a = \"Foo"} will fail. */
8785 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8787 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8788 sv_2mortal(rv); /* Schedule for freeing later */
8792 =for apidoc sv_unref
8794 Unsets the RV status of the SV, and decrements the reference count of
8795 whatever was being referenced by the RV. This can almost be thought of
8796 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8797 being zero. See C<SvROK_off>.
8803 Perl_sv_unref(pTHX_ SV *sv)
8805 sv_unref_flags(sv, 0);
8809 =for apidoc sv_taint
8811 Taint an SV. Use C<SvTAINTED_on> instead.
8816 Perl_sv_taint(pTHX_ SV *sv)
8818 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8822 =for apidoc sv_untaint
8824 Untaint an SV. Use C<SvTAINTED_off> instead.
8829 Perl_sv_untaint(pTHX_ SV *sv)
8831 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8832 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8839 =for apidoc sv_tainted
8841 Test an SV for taintedness. Use C<SvTAINTED> instead.
8846 Perl_sv_tainted(pTHX_ SV *sv)
8848 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8849 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8850 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8857 =for apidoc sv_setpviv
8859 Copies an integer into the given SV, also updating its string value.
8860 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8866 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8868 char buf[TYPE_CHARS(UV)];
8870 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8872 sv_setpvn(sv, ptr, ebuf - ptr);
8876 =for apidoc sv_setpviv_mg
8878 Like C<sv_setpviv>, but also handles 'set' magic.
8884 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8886 char buf[TYPE_CHARS(UV)];
8888 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8890 sv_setpvn(sv, ptr, ebuf - ptr);
8894 #if defined(PERL_IMPLICIT_CONTEXT)
8896 /* pTHX_ magic can't cope with varargs, so this is a no-context
8897 * version of the main function, (which may itself be aliased to us).
8898 * Don't access this version directly.
8902 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8906 va_start(args, pat);
8907 sv_vsetpvf(sv, pat, &args);
8911 /* pTHX_ magic can't cope with varargs, so this is a no-context
8912 * version of the main function, (which may itself be aliased to us).
8913 * Don't access this version directly.
8917 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8921 va_start(args, pat);
8922 sv_vsetpvf_mg(sv, pat, &args);
8928 =for apidoc sv_setpvf
8930 Works like C<sv_catpvf> but copies the text into the SV instead of
8931 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8937 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8940 va_start(args, pat);
8941 sv_vsetpvf(sv, pat, &args);
8946 =for apidoc sv_vsetpvf
8948 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8949 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8951 Usually used via its frontend C<sv_setpvf>.
8957 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8959 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8963 =for apidoc sv_setpvf_mg
8965 Like C<sv_setpvf>, but also handles 'set' magic.
8971 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8974 va_start(args, pat);
8975 sv_vsetpvf_mg(sv, pat, &args);
8980 =for apidoc sv_vsetpvf_mg
8982 Like C<sv_vsetpvf>, but also handles 'set' magic.
8984 Usually used via its frontend C<sv_setpvf_mg>.
8990 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8992 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8996 #if defined(PERL_IMPLICIT_CONTEXT)
8998 /* pTHX_ magic can't cope with varargs, so this is a no-context
8999 * version of the main function, (which may itself be aliased to us).
9000 * Don't access this version directly.
9004 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
9008 va_start(args, pat);
9009 sv_vcatpvf(sv, pat, &args);
9013 /* pTHX_ magic can't cope with varargs, so this is a no-context
9014 * version of the main function, (which may itself be aliased to us).
9015 * Don't access this version directly.
9019 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
9023 va_start(args, pat);
9024 sv_vcatpvf_mg(sv, pat, &args);
9030 =for apidoc sv_catpvf
9032 Processes its arguments like C<sprintf> and appends the formatted
9033 output to an SV. If the appended data contains "wide" characters
9034 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9035 and characters >255 formatted with %c), the original SV might get
9036 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9037 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9038 valid UTF-8; if the original SV was bytes, the pattern should be too.
9043 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
9046 va_start(args, pat);
9047 sv_vcatpvf(sv, pat, &args);
9052 =for apidoc sv_vcatpvf
9054 Processes its arguments like C<vsprintf> and appends the formatted output
9055 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9057 Usually used via its frontend C<sv_catpvf>.
9063 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9065 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9069 =for apidoc sv_catpvf_mg
9071 Like C<sv_catpvf>, but also handles 'set' magic.
9077 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9080 va_start(args, pat);
9081 sv_vcatpvf_mg(sv, pat, &args);
9086 =for apidoc sv_vcatpvf_mg
9088 Like C<sv_vcatpvf>, but also handles 'set' magic.
9090 Usually used via its frontend C<sv_catpvf_mg>.
9096 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9098 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9103 =for apidoc sv_vsetpvfn
9105 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9108 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9114 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9116 sv_setpvn(sv, "", 0);
9117 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9120 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9123 S_expect_number(pTHX_ char** pattern)
9126 switch (**pattern) {
9127 case '1': case '2': case '3':
9128 case '4': case '5': case '6':
9129 case '7': case '8': case '9':
9130 while (isDIGIT(**pattern))
9131 var = var * 10 + (*(*pattern)++ - '0');
9135 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9138 F0convert(NV nv, char *endbuf, STRLEN *len)
9149 if (uv & 1 && uv == nv)
9150 uv--; /* Round to even */
9152 unsigned dig = uv % 10;
9165 =for apidoc sv_vcatpvfn
9167 Processes its arguments like C<vsprintf> and appends the formatted output
9168 to an SV. Uses an array of SVs if the C style variable argument list is
9169 missing (NULL). When running with taint checks enabled, indicates via
9170 C<maybe_tainted> if results are untrustworthy (often due to the use of
9173 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9178 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9181 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9188 static char nullstr[] = "(null)";
9190 bool has_utf8; /* has the result utf8? */
9191 bool pat_utf8; /* the pattern is in utf8? */
9193 /* Times 4: a decimal digit takes more than 3 binary digits.
9194 * NV_DIG: mantissa takes than many decimal digits.
9195 * Plus 32: Playing safe. */
9196 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9197 /* large enough for "%#.#f" --chip */
9198 /* what about long double NVs? --jhi */
9200 has_utf8 = pat_utf8 = DO_UTF8(sv);
9202 /* no matter what, this is a string now */
9203 (void)SvPV_force(sv, origlen);
9205 /* special-case "", "%s", and "%_" */
9208 if (patlen == 2 && pat[0] == '%') {
9212 const char *s = va_arg(*args, char*);
9213 sv_catpv(sv, s ? s : nullstr);
9215 else if (svix < svmax) {
9216 sv_catsv(sv, *svargs);
9217 if (DO_UTF8(*svargs))
9223 argsv = va_arg(*args, SV*);
9224 sv_catsv(sv, argsv);
9229 /* See comment on '_' below */
9234 #ifndef USE_LONG_DOUBLE
9235 /* special-case "%.<number>[gf]" */
9236 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9237 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9238 unsigned digits = 0;
9242 while (*pp >= '0' && *pp <= '9')
9243 digits = 10 * digits + (*pp++ - '0');
9244 if (pp - pat == (int)patlen - 1) {
9248 nv = (NV)va_arg(*args, double);
9249 else if (svix < svmax)
9254 /* Add check for digits != 0 because it seems that some
9255 gconverts are buggy in this case, and we don't yet have
9256 a Configure test for this. */
9257 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9258 /* 0, point, slack */
9259 Gconvert(nv, (int)digits, 0, ebuf);
9261 if (*ebuf) /* May return an empty string for digits==0 */
9264 } else if (!digits) {
9267 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9268 sv_catpvn(sv, p, l);
9274 #endif /* !USE_LONG_DOUBLE */
9276 if (!args && svix < svmax && DO_UTF8(*svargs))
9279 patend = (char*)pat + patlen;
9280 for (p = (char*)pat; p < patend; p = q) {
9283 bool vectorize = FALSE;
9284 bool vectorarg = FALSE;
9285 bool vec_utf8 = FALSE;
9291 bool has_precis = FALSE;
9294 bool is_utf8 = FALSE; /* is this item utf8? */
9295 #ifdef HAS_LDBL_SPRINTF_BUG
9296 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9297 with sfio - Allen <allens@cpan.org> */
9298 bool fix_ldbl_sprintf_bug = FALSE;
9302 U8 utf8buf[UTF8_MAXBYTES+1];
9303 STRLEN esignlen = 0;
9305 char *eptr = Nullch;
9308 U8 *vecstr = Null(U8*);
9315 /* we need a long double target in case HAS_LONG_DOUBLE but
9318 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9326 const char *dotstr = ".";
9327 STRLEN dotstrlen = 1;
9328 I32 efix = 0; /* explicit format parameter index */
9329 I32 ewix = 0; /* explicit width index */
9330 I32 epix = 0; /* explicit precision index */
9331 I32 evix = 0; /* explicit vector index */
9332 bool asterisk = FALSE;
9334 /* echo everything up to the next format specification */
9335 for (q = p; q < patend && *q != '%'; ++q) ;
9337 if (has_utf8 && !pat_utf8)
9338 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9340 sv_catpvn(sv, p, q - p);
9347 We allow format specification elements in this order:
9348 \d+\$ explicit format parameter index
9350 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9351 0 flag (as above): repeated to allow "v02"
9352 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9353 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9355 [%bcdefginopsux_DFOUX] format (mandatory)
9357 if (EXPECT_NUMBER(q, width)) {
9398 if (EXPECT_NUMBER(q, ewix))
9407 if ((vectorarg = asterisk)) {
9419 EXPECT_NUMBER(q, width);
9424 vecsv = va_arg(*args, SV*);
9426 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9427 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9428 dotstr = SvPVx(vecsv, dotstrlen);
9433 vecsv = va_arg(*args, SV*);
9434 vecstr = (U8*)SvPVx(vecsv,veclen);
9435 vec_utf8 = DO_UTF8(vecsv);
9437 else if (efix ? efix <= svmax : svix < svmax) {
9438 vecsv = svargs[efix ? efix-1 : svix++];
9439 vecstr = (U8*)SvPVx(vecsv,veclen);
9440 vec_utf8 = DO_UTF8(vecsv);
9441 /* if this is a version object, we need to return the
9442 * stringified representation (which the SvPVX has
9443 * already done for us), but not vectorize the args
9445 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9447 q++; /* skip past the rest of the %vd format */
9448 eptr = (char *) vecstr;
9449 elen = strlen(eptr);
9462 i = va_arg(*args, int);
9464 i = (ewix ? ewix <= svmax : svix < svmax) ?
9465 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9467 width = (i < 0) ? -i : i;
9477 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9479 /* XXX: todo, support specified precision parameter */
9483 i = va_arg(*args, int);
9485 i = (ewix ? ewix <= svmax : svix < svmax)
9486 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9487 precis = (i < 0) ? 0 : i;
9492 precis = precis * 10 + (*q++ - '0');
9501 case 'I': /* Ix, I32x, and I64x */
9503 if (q[1] == '6' && q[2] == '4') {
9509 if (q[1] == '3' && q[2] == '2') {
9519 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9530 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9531 if (*(q + 1) == 'l') { /* lld, llf */
9556 argsv = (efix ? efix <= svmax : svix < svmax) ?
9557 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9564 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9566 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9568 eptr = (char*)utf8buf;
9569 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9580 if (args && !vectorize) {
9581 eptr = va_arg(*args, char*);
9583 #ifdef MACOS_TRADITIONAL
9584 /* On MacOS, %#s format is used for Pascal strings */
9589 elen = strlen(eptr);
9592 elen = sizeof nullstr - 1;
9596 eptr = SvPVx(argsv, elen);
9597 if (DO_UTF8(argsv)) {
9598 if (has_precis && precis < elen) {
9600 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9603 if (width) { /* fudge width (can't fudge elen) */
9604 width += elen - sv_len_utf8(argsv);
9616 * The "%_" hack might have to be changed someday,
9617 * if ISO or ANSI decide to use '_' for something.
9618 * So we keep it hidden from users' code.
9620 if (!args || vectorize)
9622 argsv = va_arg(*args, SV*);
9623 eptr = SvPVx(argsv, elen);
9629 if (has_precis && elen > precis)
9640 goto format_sv; /* %-p -> %_ */
9644 goto format_sv; /* %-Np -> %.N_ */
9647 if (alt || vectorize)
9649 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9667 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9676 esignbuf[esignlen++] = plus;
9680 case 'h': iv = (short)va_arg(*args, int); break;
9681 case 'l': iv = va_arg(*args, long); break;
9682 case 'V': iv = va_arg(*args, IV); break;
9683 default: iv = va_arg(*args, int); break;
9685 case 'q': iv = va_arg(*args, Quad_t); break;
9690 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9692 case 'h': iv = (short)tiv; break;
9693 case 'l': iv = (long)tiv; break;
9695 default: iv = tiv; break;
9697 case 'q': iv = (Quad_t)tiv; break;
9701 if ( !vectorize ) /* we already set uv above */
9706 esignbuf[esignlen++] = plus;
9710 esignbuf[esignlen++] = '-';
9753 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9764 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9765 case 'l': uv = va_arg(*args, unsigned long); break;
9766 case 'V': uv = va_arg(*args, UV); break;
9767 default: uv = va_arg(*args, unsigned); break;
9769 case 'q': uv = va_arg(*args, Uquad_t); break;
9774 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9776 case 'h': uv = (unsigned short)tuv; break;
9777 case 'l': uv = (unsigned long)tuv; break;
9779 default: uv = tuv; break;
9781 case 'q': uv = (Uquad_t)tuv; break;
9787 eptr = ebuf + sizeof ebuf;
9793 p = (char*)((c == 'X')
9794 ? "0123456789ABCDEF" : "0123456789abcdef");
9800 esignbuf[esignlen++] = '0';
9801 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9807 *--eptr = '0' + dig;
9809 if (alt && *eptr != '0')
9815 *--eptr = '0' + dig;
9818 esignbuf[esignlen++] = '0';
9819 esignbuf[esignlen++] = 'b';
9822 default: /* it had better be ten or less */
9823 #if defined(PERL_Y2KWARN)
9824 if (ckWARN(WARN_Y2K)) {
9826 char *s = SvPV(sv,n);
9827 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9828 && (n == 2 || !isDIGIT(s[n-3])))
9830 Perl_warner(aTHX_ packWARN(WARN_Y2K),
9831 "Possible Y2K bug: %%%c %s",
9832 c, "format string following '19'");
9838 *--eptr = '0' + dig;
9839 } while (uv /= base);
9842 elen = (ebuf + sizeof ebuf) - eptr;
9845 zeros = precis - elen;
9846 else if (precis == 0 && elen == 1 && *eptr == '0')
9851 /* FLOATING POINT */
9854 c = 'f'; /* maybe %F isn't supported here */
9860 /* This is evil, but floating point is even more evil */
9862 /* for SV-style calling, we can only get NV
9863 for C-style calling, we assume %f is double;
9864 for simplicity we allow any of %Lf, %llf, %qf for long double
9868 #if defined(USE_LONG_DOUBLE)
9872 /* [perl #20339] - we should accept and ignore %lf rather than die */
9876 #if defined(USE_LONG_DOUBLE)
9877 intsize = args ? 0 : 'q';
9881 #if defined(HAS_LONG_DOUBLE)
9890 /* now we need (long double) if intsize == 'q', else (double) */
9891 nv = (args && !vectorize) ?
9892 #if LONG_DOUBLESIZE > DOUBLESIZE
9894 va_arg(*args, long double) :
9895 va_arg(*args, double)
9897 va_arg(*args, double)
9903 if (c != 'e' && c != 'E') {
9905 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9906 will cast our (long double) to (double) */
9907 (void)Perl_frexp(nv, &i);
9908 if (i == PERL_INT_MIN)
9909 Perl_die(aTHX_ "panic: frexp");
9911 need = BIT_DIGITS(i);
9913 need += has_precis ? precis : 6; /* known default */
9918 #ifdef HAS_LDBL_SPRINTF_BUG
9919 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9920 with sfio - Allen <allens@cpan.org> */
9923 # define MY_DBL_MAX DBL_MAX
9924 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9925 # if DOUBLESIZE >= 8
9926 # define MY_DBL_MAX 1.7976931348623157E+308L
9928 # define MY_DBL_MAX 3.40282347E+38L
9932 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9933 # define MY_DBL_MAX_BUG 1L
9935 # define MY_DBL_MAX_BUG MY_DBL_MAX
9939 # define MY_DBL_MIN DBL_MIN
9940 # else /* XXX guessing! -Allen */
9941 # if DOUBLESIZE >= 8
9942 # define MY_DBL_MIN 2.2250738585072014E-308L
9944 # define MY_DBL_MIN 1.17549435E-38L
9948 if ((intsize == 'q') && (c == 'f') &&
9949 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9951 /* it's going to be short enough that
9952 * long double precision is not needed */
9954 if ((nv <= 0L) && (nv >= -0L))
9955 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9957 /* would use Perl_fp_class as a double-check but not
9958 * functional on IRIX - see perl.h comments */
9960 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9961 /* It's within the range that a double can represent */
9962 #if defined(DBL_MAX) && !defined(DBL_MIN)
9963 if ((nv >= ((long double)1/DBL_MAX)) ||
9964 (nv <= (-(long double)1/DBL_MAX)))
9966 fix_ldbl_sprintf_bug = TRUE;
9969 if (fix_ldbl_sprintf_bug == TRUE) {
9979 # undef MY_DBL_MAX_BUG
9982 #endif /* HAS_LDBL_SPRINTF_BUG */
9984 need += 20; /* fudge factor */
9985 if (PL_efloatsize < need) {
9986 Safefree(PL_efloatbuf);
9987 PL_efloatsize = need + 20; /* more fudge */
9988 New(906, PL_efloatbuf, PL_efloatsize, char);
9989 PL_efloatbuf[0] = '\0';
9992 if ( !(width || left || plus || alt) && fill != '0'
9993 && has_precis && intsize != 'q' ) { /* Shortcuts */
9994 /* See earlier comment about buggy Gconvert when digits,
9996 if ( c == 'g' && precis) {
9997 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9998 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9999 goto float_converted;
10000 } else if ( c == 'f' && !precis) {
10001 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10005 eptr = ebuf + sizeof ebuf;
10008 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10009 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10010 if (intsize == 'q') {
10011 /* Copy the one or more characters in a long double
10012 * format before the 'base' ([efgEFG]) character to
10013 * the format string. */
10014 static char const prifldbl[] = PERL_PRIfldbl;
10015 char const *p = prifldbl + sizeof(prifldbl) - 3;
10016 while (p >= prifldbl) { *--eptr = *p--; }
10021 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10026 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10038 /* No taint. Otherwise we are in the strange situation
10039 * where printf() taints but print($float) doesn't.
10041 #if defined(HAS_LONG_DOUBLE)
10042 if (intsize == 'q')
10043 (void)sprintf(PL_efloatbuf, eptr, nv);
10045 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
10047 (void)sprintf(PL_efloatbuf, eptr, nv);
10050 eptr = PL_efloatbuf;
10051 elen = strlen(PL_efloatbuf);
10057 i = SvCUR(sv) - origlen;
10058 if (args && !vectorize) {
10060 case 'h': *(va_arg(*args, short*)) = i; break;
10061 default: *(va_arg(*args, int*)) = i; break;
10062 case 'l': *(va_arg(*args, long*)) = i; break;
10063 case 'V': *(va_arg(*args, IV*)) = i; break;
10065 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10070 sv_setuv_mg(argsv, (UV)i);
10072 continue; /* not "break" */
10078 if (!args && ckWARN(WARN_PRINTF) &&
10079 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10080 SV *msg = sv_newmortal();
10081 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10082 (PL_op->op_type == OP_PRTF) ? "" : "s");
10085 Perl_sv_catpvf(aTHX_ msg,
10086 "\"%%%c\"", c & 0xFF);
10088 Perl_sv_catpvf(aTHX_ msg,
10089 "\"%%\\%03"UVof"\"",
10092 sv_catpv(msg, "end of string");
10093 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10096 /* output mangled stuff ... */
10102 /* ... right here, because formatting flags should not apply */
10103 SvGROW(sv, SvCUR(sv) + elen + 1);
10105 Copy(eptr, p, elen, char);
10108 SvCUR(sv) = p - SvPVX(sv);
10110 continue; /* not "break" */
10113 /* calculate width before utf8_upgrade changes it */
10114 have = esignlen + zeros + elen;
10116 if (is_utf8 != has_utf8) {
10119 sv_utf8_upgrade(sv);
10122 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10123 sv_utf8_upgrade(nsv);
10127 SvGROW(sv, SvCUR(sv) + elen + 1);
10132 need = (have > width ? have : width);
10135 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10137 if (esignlen && fill == '0') {
10138 for (i = 0; i < (int)esignlen; i++)
10139 *p++ = esignbuf[i];
10141 if (gap && !left) {
10142 memset(p, fill, gap);
10145 if (esignlen && fill != '0') {
10146 for (i = 0; i < (int)esignlen; i++)
10147 *p++ = esignbuf[i];
10150 for (i = zeros; i; i--)
10154 Copy(eptr, p, elen, char);
10158 memset(p, ' ', gap);
10163 Copy(dotstr, p, dotstrlen, char);
10167 vectorize = FALSE; /* done iterating over vecstr */
10174 SvCUR(sv) = p - SvPVX(sv);
10182 /* =========================================================================
10184 =head1 Cloning an interpreter
10186 All the macros and functions in this section are for the private use of
10187 the main function, perl_clone().
10189 The foo_dup() functions make an exact copy of an existing foo thinngy.
10190 During the course of a cloning, a hash table is used to map old addresses
10191 to new addresses. The table is created and manipulated with the
10192 ptr_table_* functions.
10196 ============================================================================*/
10199 #if defined(USE_ITHREADS)
10201 #ifndef GpREFCNT_inc
10202 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10206 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10207 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10208 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10209 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10210 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10211 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10212 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10213 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10214 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10215 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10216 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10217 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10218 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10221 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10222 regcomp.c. AMS 20010712 */
10225 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10229 struct reg_substr_datum *s;
10232 return (REGEXP *)NULL;
10234 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10237 len = r->offsets[0];
10238 npar = r->nparens+1;
10240 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10241 Copy(r->program, ret->program, len+1, regnode);
10243 New(0, ret->startp, npar, I32);
10244 Copy(r->startp, ret->startp, npar, I32);
10245 New(0, ret->endp, npar, I32);
10246 Copy(r->startp, ret->startp, npar, I32);
10248 New(0, ret->substrs, 1, struct reg_substr_data);
10249 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10250 s->min_offset = r->substrs->data[i].min_offset;
10251 s->max_offset = r->substrs->data[i].max_offset;
10252 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10253 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10256 ret->regstclass = NULL;
10258 struct reg_data *d;
10259 const int count = r->data->count;
10261 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10262 char, struct reg_data);
10263 New(0, d->what, count, U8);
10266 for (i = 0; i < count; i++) {
10267 d->what[i] = r->data->what[i];
10268 switch (d->what[i]) {
10269 /* legal options are one of: sfpont
10270 see also regcomp.h and pregfree() */
10272 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10275 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10278 /* This is cheating. */
10279 New(0, d->data[i], 1, struct regnode_charclass_class);
10280 StructCopy(r->data->data[i], d->data[i],
10281 struct regnode_charclass_class);
10282 ret->regstclass = (regnode*)d->data[i];
10285 /* Compiled op trees are readonly, and can thus be
10286 shared without duplication. */
10288 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10292 d->data[i] = r->data->data[i];
10295 d->data[i] = r->data->data[i];
10297 ((reg_trie_data*)d->data[i])->refcount++;
10301 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10310 New(0, ret->offsets, 2*len+1, U32);
10311 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10313 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10314 ret->refcnt = r->refcnt;
10315 ret->minlen = r->minlen;
10316 ret->prelen = r->prelen;
10317 ret->nparens = r->nparens;
10318 ret->lastparen = r->lastparen;
10319 ret->lastcloseparen = r->lastcloseparen;
10320 ret->reganch = r->reganch;
10322 ret->sublen = r->sublen;
10324 if (RX_MATCH_COPIED(ret))
10325 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10327 ret->subbeg = Nullch;
10328 #ifdef PERL_COPY_ON_WRITE
10329 ret->saved_copy = Nullsv;
10332 ptr_table_store(PL_ptr_table, r, ret);
10336 /* duplicate a file handle */
10339 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10345 return (PerlIO*)NULL;
10347 /* look for it in the table first */
10348 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10352 /* create anew and remember what it is */
10353 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10354 ptr_table_store(PL_ptr_table, fp, ret);
10358 /* duplicate a directory handle */
10361 Perl_dirp_dup(pTHX_ DIR *dp)
10369 /* duplicate a typeglob */
10372 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10377 /* look for it in the table first */
10378 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10382 /* create anew and remember what it is */
10383 Newz(0, ret, 1, GP);
10384 ptr_table_store(PL_ptr_table, gp, ret);
10387 ret->gp_refcnt = 0; /* must be before any other dups! */
10388 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10389 ret->gp_io = io_dup_inc(gp->gp_io, param);
10390 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10391 ret->gp_av = av_dup_inc(gp->gp_av, param);
10392 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10393 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10394 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10395 ret->gp_cvgen = gp->gp_cvgen;
10396 ret->gp_flags = gp->gp_flags;
10397 ret->gp_line = gp->gp_line;
10398 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10402 /* duplicate a chain of magic */
10405 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10407 MAGIC *mgprev = (MAGIC*)NULL;
10410 return (MAGIC*)NULL;
10411 /* look for it in the table first */
10412 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10416 for (; mg; mg = mg->mg_moremagic) {
10418 Newz(0, nmg, 1, MAGIC);
10420 mgprev->mg_moremagic = nmg;
10423 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10424 nmg->mg_private = mg->mg_private;
10425 nmg->mg_type = mg->mg_type;
10426 nmg->mg_flags = mg->mg_flags;
10427 if (mg->mg_type == PERL_MAGIC_qr) {
10428 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10430 else if(mg->mg_type == PERL_MAGIC_backref) {
10431 const AV * const av = (AV*) mg->mg_obj;
10434 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10436 for (i = AvFILLp(av); i >= 0; i--) {
10437 if (!svp[i]) continue;
10438 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10442 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10443 ? sv_dup_inc(mg->mg_obj, param)
10444 : sv_dup(mg->mg_obj, param);
10446 nmg->mg_len = mg->mg_len;
10447 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10448 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10449 if (mg->mg_len > 0) {
10450 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10451 if (mg->mg_type == PERL_MAGIC_overload_table &&
10452 AMT_AMAGIC((AMT*)mg->mg_ptr))
10454 AMT *amtp = (AMT*)mg->mg_ptr;
10455 AMT *namtp = (AMT*)nmg->mg_ptr;
10457 for (i = 1; i < NofAMmeth; i++) {
10458 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10462 else if (mg->mg_len == HEf_SVKEY)
10463 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10465 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10466 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10473 /* create a new pointer-mapping table */
10476 Perl_ptr_table_new(pTHX)
10479 Newz(0, tbl, 1, PTR_TBL_t);
10480 tbl->tbl_max = 511;
10481 tbl->tbl_items = 0;
10482 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10487 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10489 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10492 /* map an existing pointer using a table */
10495 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10497 PTR_TBL_ENT_t *tblent;
10498 UV hash = PTR_TABLE_HASH(sv);
10500 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10501 for (; tblent; tblent = tblent->next) {
10502 if (tblent->oldval == sv)
10503 return tblent->newval;
10505 return (void*)NULL;
10508 /* add a new entry to a pointer-mapping table */
10511 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10513 PTR_TBL_ENT_t *tblent, **otblent;
10514 /* XXX this may be pessimal on platforms where pointers aren't good
10515 * hash values e.g. if they grow faster in the most significant
10517 UV hash = PTR_TABLE_HASH(oldv);
10521 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10522 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10523 if (tblent->oldval == oldv) {
10524 tblent->newval = newv;
10528 Newz(0, tblent, 1, PTR_TBL_ENT_t);
10529 tblent->oldval = oldv;
10530 tblent->newval = newv;
10531 tblent->next = *otblent;
10534 if (!empty && tbl->tbl_items > tbl->tbl_max)
10535 ptr_table_split(tbl);
10538 /* double the hash bucket size of an existing ptr table */
10541 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10543 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10544 UV oldsize = tbl->tbl_max + 1;
10545 UV newsize = oldsize * 2;
10548 Renew(ary, newsize, PTR_TBL_ENT_t*);
10549 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10550 tbl->tbl_max = --newsize;
10551 tbl->tbl_ary = ary;
10552 for (i=0; i < oldsize; i++, ary++) {
10553 PTR_TBL_ENT_t **curentp, **entp, *ent;
10556 curentp = ary + oldsize;
10557 for (entp = ary, ent = *ary; ent; ent = *entp) {
10558 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10560 ent->next = *curentp;
10570 /* remove all the entries from a ptr table */
10573 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10575 register PTR_TBL_ENT_t **array;
10576 register PTR_TBL_ENT_t *entry;
10577 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10581 if (!tbl || !tbl->tbl_items) {
10585 array = tbl->tbl_ary;
10587 max = tbl->tbl_max;
10592 entry = entry->next;
10596 if (++riter > max) {
10599 entry = array[riter];
10603 tbl->tbl_items = 0;
10606 /* clear and free a ptr table */
10609 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10614 ptr_table_clear(tbl);
10615 Safefree(tbl->tbl_ary);
10620 char *PL_watch_pvx;
10623 /* attempt to make everything in the typeglob readonly */
10626 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10628 GV *gv = (GV*)sstr;
10629 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10631 if (GvIO(gv) || GvFORM(gv)) {
10632 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10634 else if (!GvCV(gv)) {
10635 GvCV(gv) = (CV*)sv;
10638 /* CvPADLISTs cannot be shared */
10639 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10644 if (!GvUNIQUE(gv)) {
10646 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10647 HvNAME(GvSTASH(gv)), GvNAME(gv));
10653 * write attempts will die with
10654 * "Modification of a read-only value attempted"
10660 SvREADONLY_on(GvSV(gv));
10664 GvAV(gv) = (AV*)sv;
10667 SvREADONLY_on(GvAV(gv));
10671 GvHV(gv) = (HV*)sv;
10674 SvREADONLY_on(GvHV(gv));
10677 return sstr; /* he_dup() will SvREFCNT_inc() */
10680 /* duplicate an SV of any type (including AV, HV etc) */
10683 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10686 SvRV(dstr) = SvWEAKREF(sstr)
10687 ? sv_dup(SvRV(sstr), param)
10688 : sv_dup_inc(SvRV(sstr), param);
10690 else if (SvPVX(sstr)) {
10691 /* Has something there */
10693 /* Normal PV - clone whole allocated space */
10694 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
10695 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10696 /* Not that normal - actually sstr is copy on write.
10697 But we are a true, independant SV, so: */
10698 SvREADONLY_off(dstr);
10703 /* Special case - not normally malloced for some reason */
10704 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10705 /* A "shared" PV - clone it as unshared string */
10706 if(SvPADTMP(sstr)) {
10707 /* However, some of them live in the pad
10708 and they should not have these flags
10711 SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
10713 SvUVX(dstr) = SvUVX(sstr);
10716 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
10718 SvREADONLY_off(dstr);
10722 /* Some other special case - random pointer */
10723 SvPVX(dstr) = SvPVX(sstr);
10728 /* Copy the Null */
10729 SvPVX(dstr) = SvPVX(sstr);
10734 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10738 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10740 /* look for it in the table first */
10741 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10745 if(param->flags & CLONEf_JOIN_IN) {
10746 /** We are joining here so we don't want do clone
10747 something that is bad **/
10749 if(SvTYPE(sstr) == SVt_PVHV &&
10751 /** don't clone stashes if they already exist **/
10752 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10753 return (SV*) old_stash;
10757 /* create anew and remember what it is */
10760 #ifdef DEBUG_LEAKING_SCALARS
10761 dstr->sv_debug_optype = sstr->sv_debug_optype;
10762 dstr->sv_debug_line = sstr->sv_debug_line;
10763 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10764 dstr->sv_debug_cloned = 1;
10766 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10768 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10772 ptr_table_store(PL_ptr_table, sstr, dstr);
10775 SvFLAGS(dstr) = SvFLAGS(sstr);
10776 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10777 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10780 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10781 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10782 PL_watch_pvx, SvPVX(sstr));
10785 switch (SvTYPE(sstr)) {
10787 SvANY(dstr) = NULL;
10790 SvANY(dstr) = new_XIV();
10791 SvIVX(dstr) = SvIVX(sstr);
10794 SvANY(dstr) = new_XNV();
10795 SvNVX(dstr) = SvNVX(sstr);
10798 SvANY(dstr) = new_XRV();
10799 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10802 SvANY(dstr) = new_XPV();
10803 SvCUR(dstr) = SvCUR(sstr);
10804 SvLEN(dstr) = SvLEN(sstr);
10805 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10808 SvANY(dstr) = new_XPVIV();
10809 SvCUR(dstr) = SvCUR(sstr);
10810 SvLEN(dstr) = SvLEN(sstr);
10811 SvIVX(dstr) = SvIVX(sstr);
10812 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10815 SvANY(dstr) = new_XPVNV();
10816 SvCUR(dstr) = SvCUR(sstr);
10817 SvLEN(dstr) = SvLEN(sstr);
10818 SvIVX(dstr) = SvIVX(sstr);
10819 SvNVX(dstr) = SvNVX(sstr);
10820 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10823 SvANY(dstr) = new_XPVMG();
10824 SvCUR(dstr) = SvCUR(sstr);
10825 SvLEN(dstr) = SvLEN(sstr);
10826 SvIVX(dstr) = SvIVX(sstr);
10827 SvNVX(dstr) = SvNVX(sstr);
10828 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10829 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10830 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10833 SvANY(dstr) = new_XPVBM();
10834 SvCUR(dstr) = SvCUR(sstr);
10835 SvLEN(dstr) = SvLEN(sstr);
10836 SvIVX(dstr) = SvIVX(sstr);
10837 SvNVX(dstr) = SvNVX(sstr);
10838 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10839 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10840 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10841 BmRARE(dstr) = BmRARE(sstr);
10842 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10843 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10846 SvANY(dstr) = new_XPVLV();
10847 SvCUR(dstr) = SvCUR(sstr);
10848 SvLEN(dstr) = SvLEN(sstr);
10849 SvIVX(dstr) = SvIVX(sstr);
10850 SvNVX(dstr) = SvNVX(sstr);
10851 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10852 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10853 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10854 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10855 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10856 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10857 LvTARG(dstr) = dstr;
10858 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10859 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10861 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10862 LvTYPE(dstr) = LvTYPE(sstr);
10865 if (GvUNIQUE((GV*)sstr)) {
10867 if ((share = gv_share(sstr, param))) {
10870 ptr_table_store(PL_ptr_table, sstr, dstr);
10872 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10873 HvNAME(GvSTASH(share)), GvNAME(share));
10878 SvANY(dstr) = new_XPVGV();
10879 SvCUR(dstr) = SvCUR(sstr);
10880 SvLEN(dstr) = SvLEN(sstr);
10881 SvIVX(dstr) = SvIVX(sstr);
10882 SvNVX(dstr) = SvNVX(sstr);
10883 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10884 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10885 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10886 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10887 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10888 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10889 GvFLAGS(dstr) = GvFLAGS(sstr);
10890 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10891 (void)GpREFCNT_inc(GvGP(dstr));
10894 SvANY(dstr) = new_XPVIO();
10895 SvCUR(dstr) = SvCUR(sstr);
10896 SvLEN(dstr) = SvLEN(sstr);
10897 SvIVX(dstr) = SvIVX(sstr);
10898 SvNVX(dstr) = SvNVX(sstr);
10899 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10900 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10901 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10902 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10903 if (IoOFP(sstr) == IoIFP(sstr))
10904 IoOFP(dstr) = IoIFP(dstr);
10906 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10907 /* PL_rsfp_filters entries have fake IoDIRP() */
10908 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10909 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10911 IoDIRP(dstr) = IoDIRP(sstr);
10912 IoLINES(dstr) = IoLINES(sstr);
10913 IoPAGE(dstr) = IoPAGE(sstr);
10914 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10915 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10916 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10917 /* I have no idea why fake dirp (rsfps)
10918 should be treaded differently but otherwise
10919 we end up with leaks -- sky*/
10920 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10921 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10922 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10924 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10925 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10926 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10928 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10929 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10930 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10931 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10932 IoTYPE(dstr) = IoTYPE(sstr);
10933 IoFLAGS(dstr) = IoFLAGS(sstr);
10936 SvANY(dstr) = new_XPVAV();
10937 SvCUR(dstr) = SvCUR(sstr);
10938 SvLEN(dstr) = SvLEN(sstr);
10939 SvIVX(dstr) = SvIVX(sstr);
10940 SvNVX(dstr) = SvNVX(sstr);
10941 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10942 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10943 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10944 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10945 if (AvARRAY((AV*)sstr)) {
10946 SV **dst_ary, **src_ary;
10947 SSize_t items = AvFILLp((AV*)sstr) + 1;
10949 src_ary = AvARRAY((AV*)sstr);
10950 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10951 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10952 SvPVX(dstr) = (char*)dst_ary;
10953 AvALLOC((AV*)dstr) = dst_ary;
10954 if (AvREAL((AV*)sstr)) {
10955 while (items-- > 0)
10956 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10959 while (items-- > 0)
10960 *dst_ary++ = sv_dup(*src_ary++, param);
10962 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10963 while (items-- > 0) {
10964 *dst_ary++ = &PL_sv_undef;
10968 SvPVX(dstr) = Nullch;
10969 AvALLOC((AV*)dstr) = (SV**)NULL;
10973 SvANY(dstr) = new_XPVHV();
10974 SvCUR(dstr) = SvCUR(sstr);
10975 SvLEN(dstr) = SvLEN(sstr);
10976 SvIVX(dstr) = SvIVX(sstr);
10977 SvNVX(dstr) = SvNVX(sstr);
10978 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10979 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10980 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10981 if (HvARRAY((HV*)sstr)) {
10983 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10984 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10985 Newz(0, dxhv->xhv_array,
10986 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10987 while (i <= sxhv->xhv_max) {
10988 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10989 (bool)!!HvSHAREKEYS(sstr),
10993 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10994 (bool)!!HvSHAREKEYS(sstr), param);
10997 SvPVX(dstr) = Nullch;
10998 HvEITER((HV*)dstr) = (HE*)NULL;
11000 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
11001 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
11002 /* Record stashes for possible cloning in Perl_clone(). */
11003 if(HvNAME((HV*)dstr))
11004 av_push(param->stashes, dstr);
11007 SvANY(dstr) = new_XPVFM();
11008 FmLINES(dstr) = FmLINES(sstr);
11012 SvANY(dstr) = new_XPVCV();
11014 SvCUR(dstr) = SvCUR(sstr);
11015 SvLEN(dstr) = SvLEN(sstr);
11016 SvIVX(dstr) = SvIVX(sstr);
11017 SvNVX(dstr) = SvNVX(sstr);
11018 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
11019 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
11020 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11021 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11022 CvSTART(dstr) = CvSTART(sstr);
11024 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11026 CvXSUB(dstr) = CvXSUB(sstr);
11027 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11028 if (CvCONST(sstr)) {
11029 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11030 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11031 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
11033 /* don't dup if copying back - CvGV isn't refcounted, so the
11034 * duped GV may never be freed. A bit of a hack! DAPM */
11035 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11036 Nullgv : gv_dup(CvGV(sstr), param) ;
11037 if (param->flags & CLONEf_COPY_STACKS) {
11038 CvDEPTH(dstr) = CvDEPTH(sstr);
11042 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11043 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11045 CvWEAKOUTSIDE(sstr)
11046 ? cv_dup( CvOUTSIDE(sstr), param)
11047 : cv_dup_inc(CvOUTSIDE(sstr), param);
11048 CvFLAGS(dstr) = CvFLAGS(sstr);
11049 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11052 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11056 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11062 /* duplicate a context */
11065 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11067 PERL_CONTEXT *ncxs;
11070 return (PERL_CONTEXT*)NULL;
11072 /* look for it in the table first */
11073 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11077 /* create anew and remember what it is */
11078 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11079 ptr_table_store(PL_ptr_table, cxs, ncxs);
11082 PERL_CONTEXT *cx = &cxs[ix];
11083 PERL_CONTEXT *ncx = &ncxs[ix];
11084 ncx->cx_type = cx->cx_type;
11085 if (CxTYPE(cx) == CXt_SUBST) {
11086 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11089 ncx->blk_oldsp = cx->blk_oldsp;
11090 ncx->blk_oldcop = cx->blk_oldcop;
11091 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11092 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11093 ncx->blk_oldpm = cx->blk_oldpm;
11094 ncx->blk_gimme = cx->blk_gimme;
11095 switch (CxTYPE(cx)) {
11097 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11098 ? cv_dup_inc(cx->blk_sub.cv, param)
11099 : cv_dup(cx->blk_sub.cv,param));
11100 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11101 ? av_dup_inc(cx->blk_sub.argarray, param)
11103 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11104 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11105 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11106 ncx->blk_sub.lval = cx->blk_sub.lval;
11107 ncx->blk_sub.retop = cx->blk_sub.retop;
11110 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11111 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11112 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11113 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11114 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11115 ncx->blk_eval.retop = cx->blk_eval.retop;
11118 ncx->blk_loop.label = cx->blk_loop.label;
11119 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11120 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11121 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11122 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11123 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11124 ? cx->blk_loop.iterdata
11125 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11126 ncx->blk_loop.oldcomppad
11127 = (PAD*)ptr_table_fetch(PL_ptr_table,
11128 cx->blk_loop.oldcomppad);
11129 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11130 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11131 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11132 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11133 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11136 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11137 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11138 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11139 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11140 ncx->blk_sub.retop = cx->blk_sub.retop;
11152 /* duplicate a stack info structure */
11155 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11160 return (PERL_SI*)NULL;
11162 /* look for it in the table first */
11163 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11167 /* create anew and remember what it is */
11168 Newz(56, nsi, 1, PERL_SI);
11169 ptr_table_store(PL_ptr_table, si, nsi);
11171 nsi->si_stack = av_dup_inc(si->si_stack, param);
11172 nsi->si_cxix = si->si_cxix;
11173 nsi->si_cxmax = si->si_cxmax;
11174 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11175 nsi->si_type = si->si_type;
11176 nsi->si_prev = si_dup(si->si_prev, param);
11177 nsi->si_next = si_dup(si->si_next, param);
11178 nsi->si_markoff = si->si_markoff;
11183 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11184 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11185 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11186 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11187 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11188 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11189 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11190 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11191 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11192 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11193 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11194 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11195 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11196 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11199 #define pv_dup_inc(p) SAVEPV(p)
11200 #define pv_dup(p) SAVEPV(p)
11201 #define svp_dup_inc(p,pp) any_dup(p,pp)
11203 /* map any object to the new equivent - either something in the
11204 * ptr table, or something in the interpreter structure
11208 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11213 return (void*)NULL;
11215 /* look for it in the table first */
11216 ret = ptr_table_fetch(PL_ptr_table, v);
11220 /* see if it is part of the interpreter structure */
11221 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11222 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11230 /* duplicate the save stack */
11233 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11235 ANY *ss = proto_perl->Tsavestack;
11236 I32 ix = proto_perl->Tsavestack_ix;
11237 I32 max = proto_perl->Tsavestack_max;
11250 void (*dptr) (void*);
11251 void (*dxptr) (pTHX_ void*);
11254 Newz(54, nss, max, ANY);
11258 TOPINT(nss,ix) = i;
11260 case SAVEt_ITEM: /* normal string */
11261 sv = (SV*)POPPTR(ss,ix);
11262 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11263 sv = (SV*)POPPTR(ss,ix);
11264 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11266 case SAVEt_SV: /* scalar reference */
11267 sv = (SV*)POPPTR(ss,ix);
11268 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11269 gv = (GV*)POPPTR(ss,ix);
11270 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11272 case SAVEt_GENERIC_PVREF: /* generic char* */
11273 c = (char*)POPPTR(ss,ix);
11274 TOPPTR(nss,ix) = pv_dup(c);
11275 ptr = POPPTR(ss,ix);
11276 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11278 case SAVEt_SHARED_PVREF: /* char* in shared space */
11279 c = (char*)POPPTR(ss,ix);
11280 TOPPTR(nss,ix) = savesharedpv(c);
11281 ptr = POPPTR(ss,ix);
11282 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11284 case SAVEt_GENERIC_SVREF: /* generic sv */
11285 case SAVEt_SVREF: /* scalar reference */
11286 sv = (SV*)POPPTR(ss,ix);
11287 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11288 ptr = POPPTR(ss,ix);
11289 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11291 case SAVEt_AV: /* array reference */
11292 av = (AV*)POPPTR(ss,ix);
11293 TOPPTR(nss,ix) = av_dup_inc(av, param);
11294 gv = (GV*)POPPTR(ss,ix);
11295 TOPPTR(nss,ix) = gv_dup(gv, param);
11297 case SAVEt_HV: /* hash reference */
11298 hv = (HV*)POPPTR(ss,ix);
11299 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11300 gv = (GV*)POPPTR(ss,ix);
11301 TOPPTR(nss,ix) = gv_dup(gv, param);
11303 case SAVEt_INT: /* int reference */
11304 ptr = POPPTR(ss,ix);
11305 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11306 intval = (int)POPINT(ss,ix);
11307 TOPINT(nss,ix) = intval;
11309 case SAVEt_LONG: /* long reference */
11310 ptr = POPPTR(ss,ix);
11311 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11312 longval = (long)POPLONG(ss,ix);
11313 TOPLONG(nss,ix) = longval;
11315 case SAVEt_I32: /* I32 reference */
11316 case SAVEt_I16: /* I16 reference */
11317 case SAVEt_I8: /* I8 reference */
11318 ptr = POPPTR(ss,ix);
11319 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11321 TOPINT(nss,ix) = i;
11323 case SAVEt_IV: /* IV reference */
11324 ptr = POPPTR(ss,ix);
11325 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11327 TOPIV(nss,ix) = iv;
11329 case SAVEt_SPTR: /* SV* reference */
11330 ptr = POPPTR(ss,ix);
11331 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11332 sv = (SV*)POPPTR(ss,ix);
11333 TOPPTR(nss,ix) = sv_dup(sv, param);
11335 case SAVEt_VPTR: /* random* reference */
11336 ptr = POPPTR(ss,ix);
11337 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11338 ptr = POPPTR(ss,ix);
11339 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11341 case SAVEt_PPTR: /* char* reference */
11342 ptr = POPPTR(ss,ix);
11343 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11344 c = (char*)POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = pv_dup(c);
11347 case SAVEt_HPTR: /* HV* reference */
11348 ptr = POPPTR(ss,ix);
11349 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11350 hv = (HV*)POPPTR(ss,ix);
11351 TOPPTR(nss,ix) = hv_dup(hv, param);
11353 case SAVEt_APTR: /* AV* reference */
11354 ptr = POPPTR(ss,ix);
11355 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11356 av = (AV*)POPPTR(ss,ix);
11357 TOPPTR(nss,ix) = av_dup(av, param);
11360 gv = (GV*)POPPTR(ss,ix);
11361 TOPPTR(nss,ix) = gv_dup(gv, param);
11363 case SAVEt_GP: /* scalar reference */
11364 gp = (GP*)POPPTR(ss,ix);
11365 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11366 (void)GpREFCNT_inc(gp);
11367 gv = (GV*)POPPTR(ss,ix);
11368 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11369 c = (char*)POPPTR(ss,ix);
11370 TOPPTR(nss,ix) = pv_dup(c);
11372 TOPIV(nss,ix) = iv;
11374 TOPIV(nss,ix) = iv;
11377 case SAVEt_MORTALIZESV:
11378 sv = (SV*)POPPTR(ss,ix);
11379 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11382 ptr = POPPTR(ss,ix);
11383 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11384 /* these are assumed to be refcounted properly */
11385 switch (((OP*)ptr)->op_type) {
11387 case OP_LEAVESUBLV:
11391 case OP_LEAVEWRITE:
11392 TOPPTR(nss,ix) = ptr;
11397 TOPPTR(nss,ix) = Nullop;
11402 TOPPTR(nss,ix) = Nullop;
11405 c = (char*)POPPTR(ss,ix);
11406 TOPPTR(nss,ix) = pv_dup_inc(c);
11408 case SAVEt_CLEARSV:
11409 longval = POPLONG(ss,ix);
11410 TOPLONG(nss,ix) = longval;
11413 hv = (HV*)POPPTR(ss,ix);
11414 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11415 c = (char*)POPPTR(ss,ix);
11416 TOPPTR(nss,ix) = pv_dup_inc(c);
11418 TOPINT(nss,ix) = i;
11420 case SAVEt_DESTRUCTOR:
11421 ptr = POPPTR(ss,ix);
11422 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11423 dptr = POPDPTR(ss,ix);
11424 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11426 case SAVEt_DESTRUCTOR_X:
11427 ptr = POPPTR(ss,ix);
11428 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11429 dxptr = POPDXPTR(ss,ix);
11430 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11432 case SAVEt_REGCONTEXT:
11435 TOPINT(nss,ix) = i;
11438 case SAVEt_STACK_POS: /* Position on Perl stack */
11440 TOPINT(nss,ix) = i;
11442 case SAVEt_AELEM: /* array element */
11443 sv = (SV*)POPPTR(ss,ix);
11444 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11446 TOPINT(nss,ix) = i;
11447 av = (AV*)POPPTR(ss,ix);
11448 TOPPTR(nss,ix) = av_dup_inc(av, param);
11450 case SAVEt_HELEM: /* hash element */
11451 sv = (SV*)POPPTR(ss,ix);
11452 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11453 sv = (SV*)POPPTR(ss,ix);
11454 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11455 hv = (HV*)POPPTR(ss,ix);
11456 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11459 ptr = POPPTR(ss,ix);
11460 TOPPTR(nss,ix) = ptr;
11464 TOPINT(nss,ix) = i;
11466 case SAVEt_COMPPAD:
11467 av = (AV*)POPPTR(ss,ix);
11468 TOPPTR(nss,ix) = av_dup(av, param);
11471 longval = (long)POPLONG(ss,ix);
11472 TOPLONG(nss,ix) = longval;
11473 ptr = POPPTR(ss,ix);
11474 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11475 sv = (SV*)POPPTR(ss,ix);
11476 TOPPTR(nss,ix) = sv_dup(sv, param);
11479 ptr = POPPTR(ss,ix);
11480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11481 longval = (long)POPBOOL(ss,ix);
11482 TOPBOOL(nss,ix) = (bool)longval;
11484 case SAVEt_SET_SVFLAGS:
11486 TOPINT(nss,ix) = i;
11488 TOPINT(nss,ix) = i;
11489 sv = (SV*)POPPTR(ss,ix);
11490 TOPPTR(nss,ix) = sv_dup(sv, param);
11493 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11501 =for apidoc perl_clone
11503 Create and return a new interpreter by cloning the current one.
11505 perl_clone takes these flags as parameters:
11507 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11508 without it we only clone the data and zero the stacks,
11509 with it we copy the stacks and the new perl interpreter is
11510 ready to run at the exact same point as the previous one.
11511 The pseudo-fork code uses COPY_STACKS while the
11512 threads->new doesn't.
11514 CLONEf_KEEP_PTR_TABLE
11515 perl_clone keeps a ptr_table with the pointer of the old
11516 variable as a key and the new variable as a value,
11517 this allows it to check if something has been cloned and not
11518 clone it again but rather just use the value and increase the
11519 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11520 the ptr_table using the function
11521 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11522 reason to keep it around is if you want to dup some of your own
11523 variable who are outside the graph perl scans, example of this
11524 code is in threads.xs create
11527 This is a win32 thing, it is ignored on unix, it tells perls
11528 win32host code (which is c++) to clone itself, this is needed on
11529 win32 if you want to run two threads at the same time,
11530 if you just want to do some stuff in a separate perl interpreter
11531 and then throw it away and return to the original one,
11532 you don't need to do anything.
11537 /* XXX the above needs expanding by someone who actually understands it ! */
11538 EXTERN_C PerlInterpreter *
11539 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11542 perl_clone(PerlInterpreter *proto_perl, UV flags)
11544 #ifdef PERL_IMPLICIT_SYS
11546 /* perlhost.h so we need to call into it
11547 to clone the host, CPerlHost should have a c interface, sky */
11549 if (flags & CLONEf_CLONE_HOST) {
11550 return perl_clone_host(proto_perl,flags);
11552 return perl_clone_using(proto_perl, flags,
11554 proto_perl->IMemShared,
11555 proto_perl->IMemParse,
11557 proto_perl->IStdIO,
11561 proto_perl->IProc);
11565 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11566 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11567 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11568 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11569 struct IPerlDir* ipD, struct IPerlSock* ipS,
11570 struct IPerlProc* ipP)
11572 /* XXX many of the string copies here can be optimized if they're
11573 * constants; they need to be allocated as common memory and just
11574 * their pointers copied. */
11577 CLONE_PARAMS clone_params;
11578 CLONE_PARAMS* param = &clone_params;
11580 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11581 PERL_SET_THX(my_perl);
11584 Poison(my_perl, 1, PerlInterpreter);
11586 PL_curcop = Nullop;
11590 PL_savestack_ix = 0;
11591 PL_savestack_max = -1;
11592 PL_sig_pending = 0;
11593 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11594 # else /* !DEBUGGING */
11595 Zero(my_perl, 1, PerlInterpreter);
11596 # endif /* DEBUGGING */
11598 /* host pointers */
11600 PL_MemShared = ipMS;
11601 PL_MemParse = ipMP;
11608 #else /* !PERL_IMPLICIT_SYS */
11610 CLONE_PARAMS clone_params;
11611 CLONE_PARAMS* param = &clone_params;
11612 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11613 PERL_SET_THX(my_perl);
11618 Poison(my_perl, 1, PerlInterpreter);
11620 PL_curcop = Nullop;
11624 PL_savestack_ix = 0;
11625 PL_savestack_max = -1;
11626 PL_sig_pending = 0;
11627 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11628 # else /* !DEBUGGING */
11629 Zero(my_perl, 1, PerlInterpreter);
11630 # endif /* DEBUGGING */
11631 #endif /* PERL_IMPLICIT_SYS */
11632 param->flags = flags;
11633 param->proto_perl = proto_perl;
11636 PL_xiv_arenaroot = NULL;
11637 PL_xiv_root = NULL;
11638 PL_xnv_arenaroot = NULL;
11639 PL_xnv_root = NULL;
11640 PL_xrv_arenaroot = NULL;
11641 PL_xrv_root = NULL;
11642 PL_xpv_arenaroot = NULL;
11643 PL_xpv_root = NULL;
11644 PL_xpviv_arenaroot = NULL;
11645 PL_xpviv_root = NULL;
11646 PL_xpvnv_arenaroot = NULL;
11647 PL_xpvnv_root = NULL;
11648 PL_xpvcv_arenaroot = NULL;
11649 PL_xpvcv_root = NULL;
11650 PL_xpvav_arenaroot = NULL;
11651 PL_xpvav_root = NULL;
11652 PL_xpvhv_arenaroot = NULL;
11653 PL_xpvhv_root = NULL;
11654 PL_xpvmg_arenaroot = NULL;
11655 PL_xpvmg_root = NULL;
11656 PL_xpvlv_arenaroot = NULL;
11657 PL_xpvlv_root = NULL;
11658 PL_xpvbm_arenaroot = NULL;
11659 PL_xpvbm_root = NULL;
11660 PL_he_arenaroot = NULL;
11662 PL_nice_chunk = NULL;
11663 PL_nice_chunk_size = 0;
11665 PL_sv_objcount = 0;
11666 PL_sv_root = Nullsv;
11667 PL_sv_arenaroot = Nullsv;
11669 PL_debug = proto_perl->Idebug;
11671 #ifdef USE_REENTRANT_API
11672 /* XXX: things like -Dm will segfault here in perlio, but doing
11673 * PERL_SET_CONTEXT(proto_perl);
11674 * breaks too many other things
11676 Perl_reentrant_init(aTHX);
11679 /* create SV map for pointer relocation */
11680 PL_ptr_table = ptr_table_new();
11682 /* initialize these special pointers as early as possible */
11683 SvANY(&PL_sv_undef) = NULL;
11684 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11685 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11686 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11688 SvANY(&PL_sv_no) = new_XPVNV();
11689 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11690 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11691 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11692 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
11693 SvCUR(&PL_sv_no) = 0;
11694 SvLEN(&PL_sv_no) = 1;
11695 SvIVX(&PL_sv_no) = 0;
11696 SvNVX(&PL_sv_no) = 0;
11697 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11699 SvANY(&PL_sv_yes) = new_XPVNV();
11700 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11701 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11702 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11703 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
11704 SvCUR(&PL_sv_yes) = 1;
11705 SvLEN(&PL_sv_yes) = 2;
11706 SvIVX(&PL_sv_yes) = 1;
11707 SvNVX(&PL_sv_yes) = 1;
11708 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11710 /* create (a non-shared!) shared string table */
11711 PL_strtab = newHV();
11712 HvSHAREKEYS_off(PL_strtab);
11713 hv_ksplit(PL_strtab, 512);
11714 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11716 PL_compiling = proto_perl->Icompiling;
11718 /* These two PVs will be free'd special way so must set them same way op.c does */
11719 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11720 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11722 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11723 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11725 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11726 if (!specialWARN(PL_compiling.cop_warnings))
11727 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11728 if (!specialCopIO(PL_compiling.cop_io))
11729 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11730 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11732 /* pseudo environmental stuff */
11733 PL_origargc = proto_perl->Iorigargc;
11734 PL_origargv = proto_perl->Iorigargv;
11736 param->stashes = newAV(); /* Setup array of objects to call clone on */
11738 #ifdef PERLIO_LAYERS
11739 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11740 PerlIO_clone(aTHX_ proto_perl, param);
11743 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11744 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11745 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11746 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11747 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11748 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11751 PL_minus_c = proto_perl->Iminus_c;
11752 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11753 PL_localpatches = proto_perl->Ilocalpatches;
11754 PL_splitstr = proto_perl->Isplitstr;
11755 PL_preprocess = proto_perl->Ipreprocess;
11756 PL_minus_n = proto_perl->Iminus_n;
11757 PL_minus_p = proto_perl->Iminus_p;
11758 PL_minus_l = proto_perl->Iminus_l;
11759 PL_minus_a = proto_perl->Iminus_a;
11760 PL_minus_F = proto_perl->Iminus_F;
11761 PL_doswitches = proto_perl->Idoswitches;
11762 PL_dowarn = proto_perl->Idowarn;
11763 PL_doextract = proto_perl->Idoextract;
11764 PL_sawampersand = proto_perl->Isawampersand;
11765 PL_unsafe = proto_perl->Iunsafe;
11766 PL_inplace = SAVEPV(proto_perl->Iinplace);
11767 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11768 PL_perldb = proto_perl->Iperldb;
11769 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11770 PL_exit_flags = proto_perl->Iexit_flags;
11772 /* magical thingies */
11773 /* XXX time(&PL_basetime) when asked for? */
11774 PL_basetime = proto_perl->Ibasetime;
11775 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11777 PL_maxsysfd = proto_perl->Imaxsysfd;
11778 PL_multiline = proto_perl->Imultiline;
11779 PL_statusvalue = proto_perl->Istatusvalue;
11781 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11783 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11785 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11786 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11787 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11789 /* Clone the regex array */
11790 PL_regex_padav = newAV();
11792 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11793 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11794 av_push(PL_regex_padav,
11795 sv_dup_inc(regexen[0],param));
11796 for(i = 1; i <= len; i++) {
11797 if(SvREPADTMP(regexen[i])) {
11798 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11800 av_push(PL_regex_padav,
11802 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11803 SvIVX(regexen[i])), param)))
11808 PL_regex_pad = AvARRAY(PL_regex_padav);
11810 /* shortcuts to various I/O objects */
11811 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11812 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11813 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11814 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11815 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11816 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11818 /* shortcuts to regexp stuff */
11819 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11821 /* shortcuts to misc objects */
11822 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11824 /* shortcuts to debugging objects */
11825 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11826 PL_DBline = gv_dup(proto_perl->IDBline, param);
11827 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11828 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11829 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11830 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11831 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11832 PL_lineary = av_dup(proto_perl->Ilineary, param);
11833 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11835 /* symbol tables */
11836 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11837 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11838 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11839 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11840 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11842 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11843 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11844 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11845 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11846 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11847 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11849 PL_sub_generation = proto_perl->Isub_generation;
11851 /* funky return mechanisms */
11852 PL_forkprocess = proto_perl->Iforkprocess;
11854 /* subprocess state */
11855 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11857 /* internal state */
11858 PL_tainting = proto_perl->Itainting;
11859 PL_taint_warn = proto_perl->Itaint_warn;
11860 PL_maxo = proto_perl->Imaxo;
11861 if (proto_perl->Iop_mask)
11862 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11864 PL_op_mask = Nullch;
11865 /* PL_asserting = proto_perl->Iasserting; */
11867 /* current interpreter roots */
11868 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11869 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11870 PL_main_start = proto_perl->Imain_start;
11871 PL_eval_root = proto_perl->Ieval_root;
11872 PL_eval_start = proto_perl->Ieval_start;
11874 /* runtime control stuff */
11875 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11876 PL_copline = proto_perl->Icopline;
11878 PL_filemode = proto_perl->Ifilemode;
11879 PL_lastfd = proto_perl->Ilastfd;
11880 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11883 PL_gensym = proto_perl->Igensym;
11884 PL_preambled = proto_perl->Ipreambled;
11885 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11886 PL_laststatval = proto_perl->Ilaststatval;
11887 PL_laststype = proto_perl->Ilaststype;
11888 PL_mess_sv = Nullsv;
11890 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11891 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11893 /* interpreter atexit processing */
11894 PL_exitlistlen = proto_perl->Iexitlistlen;
11895 if (PL_exitlistlen) {
11896 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11897 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11900 PL_exitlist = (PerlExitListEntry*)NULL;
11901 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11902 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11903 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11905 PL_profiledata = NULL;
11906 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11907 /* PL_rsfp_filters entries have fake IoDIRP() */
11908 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11910 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11912 PAD_CLONE_VARS(proto_perl, param);
11914 #ifdef HAVE_INTERP_INTERN
11915 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11918 /* more statics moved here */
11919 PL_generation = proto_perl->Igeneration;
11920 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11922 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11923 PL_in_clean_all = proto_perl->Iin_clean_all;
11925 PL_uid = proto_perl->Iuid;
11926 PL_euid = proto_perl->Ieuid;
11927 PL_gid = proto_perl->Igid;
11928 PL_egid = proto_perl->Iegid;
11929 PL_nomemok = proto_perl->Inomemok;
11930 PL_an = proto_perl->Ian;
11931 PL_evalseq = proto_perl->Ievalseq;
11932 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11933 PL_origalen = proto_perl->Iorigalen;
11934 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11935 PL_osname = SAVEPV(proto_perl->Iosname);
11936 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11937 PL_sighandlerp = proto_perl->Isighandlerp;
11940 PL_runops = proto_perl->Irunops;
11942 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11945 PL_cshlen = proto_perl->Icshlen;
11946 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11949 PL_lex_state = proto_perl->Ilex_state;
11950 PL_lex_defer = proto_perl->Ilex_defer;
11951 PL_lex_expect = proto_perl->Ilex_expect;
11952 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11953 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11954 PL_lex_starts = proto_perl->Ilex_starts;
11955 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11956 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11957 PL_lex_op = proto_perl->Ilex_op;
11958 PL_lex_inpat = proto_perl->Ilex_inpat;
11959 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11960 PL_lex_brackets = proto_perl->Ilex_brackets;
11961 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11962 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11963 PL_lex_casemods = proto_perl->Ilex_casemods;
11964 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11965 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11967 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11968 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11969 PL_nexttoke = proto_perl->Inexttoke;
11971 /* XXX This is probably masking the deeper issue of why
11972 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11973 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11974 * (A little debugging with a watchpoint on it may help.)
11976 if (SvANY(proto_perl->Ilinestr)) {
11977 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11978 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11979 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11980 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11981 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11982 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11983 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11984 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11985 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11988 PL_linestr = NEWSV(65,79);
11989 sv_upgrade(PL_linestr,SVt_PVIV);
11990 sv_setpvn(PL_linestr,"",0);
11991 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11993 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11994 PL_pending_ident = proto_perl->Ipending_ident;
11995 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11997 PL_expect = proto_perl->Iexpect;
11999 PL_multi_start = proto_perl->Imulti_start;
12000 PL_multi_end = proto_perl->Imulti_end;
12001 PL_multi_open = proto_perl->Imulti_open;
12002 PL_multi_close = proto_perl->Imulti_close;
12004 PL_error_count = proto_perl->Ierror_count;
12005 PL_subline = proto_perl->Isubline;
12006 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12008 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12009 if (SvANY(proto_perl->Ilinestr)) {
12010 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12011 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12012 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12013 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12014 PL_last_lop_op = proto_perl->Ilast_lop_op;
12017 PL_last_uni = SvPVX(PL_linestr);
12018 PL_last_lop = SvPVX(PL_linestr);
12019 PL_last_lop_op = 0;
12021 PL_in_my = proto_perl->Iin_my;
12022 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12024 PL_cryptseen = proto_perl->Icryptseen;
12027 PL_hints = proto_perl->Ihints;
12029 PL_amagic_generation = proto_perl->Iamagic_generation;
12031 #ifdef USE_LOCALE_COLLATE
12032 PL_collation_ix = proto_perl->Icollation_ix;
12033 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12034 PL_collation_standard = proto_perl->Icollation_standard;
12035 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12036 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12037 #endif /* USE_LOCALE_COLLATE */
12039 #ifdef USE_LOCALE_NUMERIC
12040 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12041 PL_numeric_standard = proto_perl->Inumeric_standard;
12042 PL_numeric_local = proto_perl->Inumeric_local;
12043 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12044 #endif /* !USE_LOCALE_NUMERIC */
12046 /* utf8 character classes */
12047 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12048 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12049 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12050 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12051 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12052 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12053 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12054 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12055 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12056 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12057 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12058 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12059 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12060 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12061 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12062 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12063 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12064 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12065 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12066 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12068 /* Did the locale setup indicate UTF-8? */
12069 PL_utf8locale = proto_perl->Iutf8locale;
12070 /* Unicode features (see perlrun/-C) */
12071 PL_unicode = proto_perl->Iunicode;
12073 /* Pre-5.8 signals control */
12074 PL_signals = proto_perl->Isignals;
12076 /* times() ticks per second */
12077 PL_clocktick = proto_perl->Iclocktick;
12079 /* Recursion stopper for PerlIO_find_layer */
12080 PL_in_load_module = proto_perl->Iin_load_module;
12082 /* sort() routine */
12083 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12085 /* Not really needed/useful since the reenrant_retint is "volatile",
12086 * but do it for consistency's sake. */
12087 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12089 /* Hooks to shared SVs and locks. */
12090 PL_sharehook = proto_perl->Isharehook;
12091 PL_lockhook = proto_perl->Ilockhook;
12092 PL_unlockhook = proto_perl->Iunlockhook;
12093 PL_threadhook = proto_perl->Ithreadhook;
12095 PL_runops_std = proto_perl->Irunops_std;
12096 PL_runops_dbg = proto_perl->Irunops_dbg;
12098 #ifdef THREADS_HAVE_PIDS
12099 PL_ppid = proto_perl->Ippid;
12103 PL_last_swash_hv = Nullhv; /* reinits on demand */
12104 PL_last_swash_klen = 0;
12105 PL_last_swash_key[0]= '\0';
12106 PL_last_swash_tmps = (U8*)NULL;
12107 PL_last_swash_slen = 0;
12109 PL_glob_index = proto_perl->Iglob_index;
12110 PL_srand_called = proto_perl->Isrand_called;
12111 PL_hash_seed = proto_perl->Ihash_seed;
12112 PL_rehash_seed = proto_perl->Irehash_seed;
12113 PL_uudmap['M'] = 0; /* reinits on demand */
12114 PL_bitcount = Nullch; /* reinits on demand */
12116 if (proto_perl->Ipsig_pend) {
12117 Newz(0, PL_psig_pend, SIG_SIZE, int);
12120 PL_psig_pend = (int*)NULL;
12123 if (proto_perl->Ipsig_ptr) {
12124 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12125 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12126 for (i = 1; i < SIG_SIZE; i++) {
12127 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12128 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12132 PL_psig_ptr = (SV**)NULL;
12133 PL_psig_name = (SV**)NULL;
12136 /* thrdvar.h stuff */
12138 if (flags & CLONEf_COPY_STACKS) {
12139 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12140 PL_tmps_ix = proto_perl->Ttmps_ix;
12141 PL_tmps_max = proto_perl->Ttmps_max;
12142 PL_tmps_floor = proto_perl->Ttmps_floor;
12143 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12145 while (i <= PL_tmps_ix) {
12146 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12150 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12151 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12152 Newz(54, PL_markstack, i, I32);
12153 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12154 - proto_perl->Tmarkstack);
12155 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12156 - proto_perl->Tmarkstack);
12157 Copy(proto_perl->Tmarkstack, PL_markstack,
12158 PL_markstack_ptr - PL_markstack + 1, I32);
12160 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12161 * NOTE: unlike the others! */
12162 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12163 PL_scopestack_max = proto_perl->Tscopestack_max;
12164 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12165 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12167 /* NOTE: si_dup() looks at PL_markstack */
12168 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12170 /* PL_curstack = PL_curstackinfo->si_stack; */
12171 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12172 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12174 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12175 PL_stack_base = AvARRAY(PL_curstack);
12176 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12177 - proto_perl->Tstack_base);
12178 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12180 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12181 * NOTE: unlike the others! */
12182 PL_savestack_ix = proto_perl->Tsavestack_ix;
12183 PL_savestack_max = proto_perl->Tsavestack_max;
12184 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12185 PL_savestack = ss_dup(proto_perl, param);
12189 ENTER; /* perl_destruct() wants to LEAVE; */
12192 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12193 PL_top_env = &PL_start_env;
12195 PL_op = proto_perl->Top;
12198 PL_Xpv = (XPV*)NULL;
12199 PL_na = proto_perl->Tna;
12201 PL_statbuf = proto_perl->Tstatbuf;
12202 PL_statcache = proto_perl->Tstatcache;
12203 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12204 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12206 PL_timesbuf = proto_perl->Ttimesbuf;
12209 PL_tainted = proto_perl->Ttainted;
12210 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12211 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12212 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12213 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12214 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12215 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12216 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12217 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12218 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12220 PL_restartop = proto_perl->Trestartop;
12221 PL_in_eval = proto_perl->Tin_eval;
12222 PL_delaymagic = proto_perl->Tdelaymagic;
12223 PL_dirty = proto_perl->Tdirty;
12224 PL_localizing = proto_perl->Tlocalizing;
12226 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12227 PL_hv_fetch_ent_mh = Nullhe;
12228 PL_modcount = proto_perl->Tmodcount;
12229 PL_lastgotoprobe = Nullop;
12230 PL_dumpindent = proto_perl->Tdumpindent;
12232 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12233 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12234 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12235 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12236 PL_sortcxix = proto_perl->Tsortcxix;
12237 PL_efloatbuf = Nullch; /* reinits on demand */
12238 PL_efloatsize = 0; /* reinits on demand */
12242 PL_screamfirst = NULL;
12243 PL_screamnext = NULL;
12244 PL_maxscream = -1; /* reinits on demand */
12245 PL_lastscream = Nullsv;
12247 PL_watchaddr = NULL;
12248 PL_watchok = Nullch;
12250 PL_regdummy = proto_perl->Tregdummy;
12251 PL_regprecomp = Nullch;
12254 PL_colorset = 0; /* reinits PL_colors[] */
12255 /*PL_colors[6] = {0,0,0,0,0,0};*/
12256 PL_reginput = Nullch;
12257 PL_regbol = Nullch;
12258 PL_regeol = Nullch;
12259 PL_regstartp = (I32*)NULL;
12260 PL_regendp = (I32*)NULL;
12261 PL_reglastparen = (U32*)NULL;
12262 PL_reglastcloseparen = (U32*)NULL;
12263 PL_regtill = Nullch;
12264 PL_reg_start_tmp = (char**)NULL;
12265 PL_reg_start_tmpl = 0;
12266 PL_regdata = (struct reg_data*)NULL;
12269 PL_reg_eval_set = 0;
12271 PL_regprogram = (regnode*)NULL;
12273 PL_regcc = (CURCUR*)NULL;
12274 PL_reg_call_cc = (struct re_cc_state*)NULL;
12275 PL_reg_re = (regexp*)NULL;
12276 PL_reg_ganch = Nullch;
12277 PL_reg_sv = Nullsv;
12278 PL_reg_match_utf8 = FALSE;
12279 PL_reg_magic = (MAGIC*)NULL;
12281 PL_reg_oldcurpm = (PMOP*)NULL;
12282 PL_reg_curpm = (PMOP*)NULL;
12283 PL_reg_oldsaved = Nullch;
12284 PL_reg_oldsavedlen = 0;
12285 #ifdef PERL_COPY_ON_WRITE
12288 PL_reg_maxiter = 0;
12289 PL_reg_leftiter = 0;
12290 PL_reg_poscache = Nullch;
12291 PL_reg_poscache_size= 0;
12293 /* RE engine - function pointers */
12294 PL_regcompp = proto_perl->Tregcompp;
12295 PL_regexecp = proto_perl->Tregexecp;
12296 PL_regint_start = proto_perl->Tregint_start;
12297 PL_regint_string = proto_perl->Tregint_string;
12298 PL_regfree = proto_perl->Tregfree;
12300 PL_reginterp_cnt = 0;
12301 PL_reg_starttry = 0;
12303 /* Pluggable optimizer */
12304 PL_peepp = proto_perl->Tpeepp;
12306 PL_stashcache = newHV();
12308 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12309 ptr_table_free(PL_ptr_table);
12310 PL_ptr_table = NULL;
12313 /* Call the ->CLONE method, if it exists, for each of the stashes
12314 identified by sv_dup() above.
12316 while(av_len(param->stashes) != -1) {
12317 HV* stash = (HV*) av_shift(param->stashes);
12318 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12319 if (cloner && GvCV(cloner)) {
12324 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12326 call_sv((SV*)GvCV(cloner), G_DISCARD);
12332 SvREFCNT_dec(param->stashes);
12337 #endif /* USE_ITHREADS */
12340 =head1 Unicode Support
12342 =for apidoc sv_recode_to_utf8
12344 The encoding is assumed to be an Encode object, on entry the PV
12345 of the sv is assumed to be octets in that encoding, and the sv
12346 will be converted into Unicode (and UTF-8).
12348 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12349 is not a reference, nothing is done to the sv. If the encoding is not
12350 an C<Encode::XS> Encoding object, bad things will happen.
12351 (See F<lib/encoding.pm> and L<Encode>).
12353 The PV of the sv is returned.
12358 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12360 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12374 Passing sv_yes is wrong - it needs to be or'ed set of constants
12375 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12376 remove converted chars from source.
12378 Both will default the value - let them.
12380 XPUSHs(&PL_sv_yes);
12383 call_method("decode", G_SCALAR);
12387 s = SvPV(uni, len);
12388 if (s != SvPVX(sv)) {
12389 SvGROW(sv, len + 1);
12390 Move(s, SvPVX(sv), len, char);
12391 SvCUR_set(sv, len);
12392 SvPVX(sv)[len] = 0;
12399 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12403 =for apidoc sv_cat_decode
12405 The encoding is assumed to be an Encode object, the PV of the ssv is
12406 assumed to be octets in that encoding and decoding the input starts
12407 from the position which (PV + *offset) pointed to. The dsv will be
12408 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12409 when the string tstr appears in decoding output or the input ends on
12410 the PV of the ssv. The value which the offset points will be modified
12411 to the last input position on the ssv.
12413 Returns TRUE if the terminator was found, else returns FALSE.
12418 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12419 SV *ssv, int *offset, char *tstr, int tlen)
12422 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12433 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12434 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12436 call_method("cat_decode", G_SCALAR);
12438 ret = SvTRUE(TOPs);
12439 *offset = SvIV(offsv);
12445 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12451 * c-indentation-style: bsd
12452 * c-basic-offset: 4
12453 * indent-tabs-mode: t
12456 * vim: shiftwidth=4: