3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which 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();
1968 SvPV_set(sv, (char*)0);
1973 SvMAGIC(sv) = magic;
1974 SvSTASH(sv) = stash;
1977 AvFLAGS(sv) = AVf_REAL;
1980 SvANY(sv) = new_XPVHV();
1983 SvPV_set(sv, (char*)0);
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 SvPV_set(sv, 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);
2505 SvIV_set(sv, IV_MIN);
2506 return IS_NUMBER_UNDERFLOW_IV;
2508 if (SvNVX(sv) > (NV)UV_MAX) {
2509 (void)SvIOKp_on(sv);
2512 SvUV_set(sv, UV_MAX);
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 SvIV_set(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 SvUV_set(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 SvIV_set(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 SvUV_set(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 SvIV_set(sv, (IV)value);
2731 SvUV_set(sv, value);
2735 /* 2s complement assumption */
2736 if (value <= (UV)IV_MIN) {
2737 SvIV_set(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 SvNV_set(sv, -(NV)value);
2747 SvIV_set(sv, IV_MIN);
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 SvNV_set(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 SvIV_set(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 */
2787 SvUV_set(sv, UV_MAX);
2790 SvUV_set(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 SvIV_set(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 SvIV_set(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 SvUV_set(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 SvIV_set(sv, (IV)value);
3032 /* it didn't overflow, and it was positive. */
3033 SvUV_set(sv, value);
3037 /* 2s complement assumption */
3038 if (value <= (UV)IV_MIN) {
3039 SvIV_set(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 SvNV_set(sv, -(NV)value);
3049 SvIV_set(sv, IV_MIN);
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 SvNV_set(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 SvIV_set(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 */
3085 SvUV_set(sv, UV_MAX);
3088 SvUV_set(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 SvIV_set(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 SvNV_set(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 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3253 SvNV_set(sv, Atof(SvPVX(sv)));
3256 SvNV_set(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 SvIV_set(sv, -(IV)value);
3281 } else if (value <= (UV)IV_MAX) {
3282 SvIV_set(sv, (IV)value);
3284 SvUV_set(sv, 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 SvPV_set(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 SvIV_set(dstr, SvIVX(sstr));
4215 if (SvTAINTED(sstr))
4226 sv_upgrade(dstr, SVt_NV);
4231 sv_upgrade(dstr, SVt_PVNV);
4234 SvNV_set(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 SvNV_set(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 SvIV_set(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));
4613 SvUV_set(dstr, 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 SvNV_set(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 SvIV_set(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 SvIV_set(dstr, SvIVX(sstr));
4671 if (sflags & SVp_NOK) {
4672 if (sflags & SVf_NOK)
4673 (void)SvNOK_on(dstr);
4675 (void)SvNOKp_on(dstr);
4676 SvNV_set(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 SvNV_set(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"));
4755 SvUV_set(dstr, hash);
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: */
5017 SvPV_set(sv, (char*)0);
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);
5046 SvPV_set(sv, (char*)0);
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;
5120 SvPV_set(sv, SvPVX(sv) + delta);
5121 SvIV_set(sv, SvIVX(sv) + delta);
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 const 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);
7347 SvUV_set(sv, SvUVX(sv) + 1);
7349 if (SvIVX(sv) == IV_MAX)
7350 sv_setuv(sv, (UV)IV_MAX + 1);
7352 (void)SvIOK_only(sv);
7353 SvIV_set(sv, SvIVX(sv) + 1);
7358 if (flags & SVp_NOK) {
7359 (void)SvNOK_only(sv);
7360 SvNV_set(sv, SvNVX(sv) + 1.0);
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);
7395 SvNV_set(sv, SvNVX(sv) + 1.0);
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);
7501 SvUV_set(sv, SvUVX(sv) + 1);
7504 if (SvIVX(sv) == IV_MIN)
7505 sv_setnv(sv, (NV)IV_MIN - 1.0);
7507 (void)SvIOK_only(sv);
7508 SvIV_set(sv, SvIVX(sv) - 1);
7513 if (flags & SVp_NOK) {
7514 SvNV_set(sv, SvNVX(sv) - 1.0);
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);
7543 SvNV_set(sv, SvNVX(sv) - 1.0);
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 SvPV_set(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 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8431 inside return suggests a const propagation bug in g++. */
8432 if (ob && SvOBJECT(sv)) {
8433 char *name = HvNAME(SvSTASH(sv));
8434 return name ? name : (char *) "__ANON__";
8437 switch (SvTYPE(sv)) {
8454 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8455 /* tied lvalues should appear to be
8456 * scalars for backwards compatitbility */
8457 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8458 ? "SCALAR" : "LVALUE");
8459 case SVt_PVAV: return "ARRAY";
8460 case SVt_PVHV: return "HASH";
8461 case SVt_PVCV: return "CODE";
8462 case SVt_PVGV: return "GLOB";
8463 case SVt_PVFM: return "FORMAT";
8464 case SVt_PVIO: return "IO";
8465 default: return "UNKNOWN";
8471 =for apidoc sv_isobject
8473 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8474 object. If the SV is not an RV, or if the object is not blessed, then this
8481 Perl_sv_isobject(pTHX_ SV *sv)
8498 Returns a boolean indicating whether the SV is blessed into the specified
8499 class. This does not check for subtypes; use C<sv_derived_from> to verify
8500 an inheritance relationship.
8506 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8517 if (!HvNAME(SvSTASH(sv)))
8520 return strEQ(HvNAME(SvSTASH(sv)), name);
8526 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8527 it will be upgraded to one. If C<classname> is non-null then the new SV will
8528 be blessed in the specified package. The new SV is returned and its
8529 reference count is 1.
8535 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8541 SV_CHECK_THINKFIRST_COW_DROP(rv);
8544 if (SvTYPE(rv) >= SVt_PVMG) {
8545 U32 refcnt = SvREFCNT(rv);
8549 SvREFCNT(rv) = refcnt;
8552 if (SvTYPE(rv) < SVt_RV)
8553 sv_upgrade(rv, SVt_RV);
8554 else if (SvTYPE(rv) > SVt_RV) {
8556 if (SvPVX(rv) && SvLEN(rv))
8557 Safefree(SvPVX(rv));
8567 HV* stash = gv_stashpv(classname, TRUE);
8568 (void)sv_bless(rv, stash);
8574 =for apidoc sv_setref_pv
8576 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8577 argument will be upgraded to an RV. That RV will be modified to point to
8578 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8579 into the SV. The C<classname> argument indicates the package for the
8580 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8581 will have a reference count of 1, and the RV will be returned.
8583 Do not use with other Perl types such as HV, AV, SV, CV, because those
8584 objects will become corrupted by the pointer copy process.
8586 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8592 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8595 sv_setsv(rv, &PL_sv_undef);
8599 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8604 =for apidoc sv_setref_iv
8606 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8607 argument will be upgraded to an RV. That RV will be modified to point to
8608 the new SV. The C<classname> argument indicates the package for the
8609 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8610 will have a reference count of 1, and the RV will be returned.
8616 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8618 sv_setiv(newSVrv(rv,classname), iv);
8623 =for apidoc sv_setref_uv
8625 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8626 argument will be upgraded to an RV. That RV will be modified to point to
8627 the new SV. The C<classname> argument indicates the package for the
8628 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8629 will have a reference count of 1, and the RV will be returned.
8635 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8637 sv_setuv(newSVrv(rv,classname), uv);
8642 =for apidoc sv_setref_nv
8644 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8645 argument will be upgraded to an RV. That RV will be modified to point to
8646 the new SV. The C<classname> argument indicates the package for the
8647 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8648 will have a reference count of 1, and the RV will be returned.
8654 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8656 sv_setnv(newSVrv(rv,classname), nv);
8661 =for apidoc sv_setref_pvn
8663 Copies a string into a new SV, optionally blessing the SV. The length of the
8664 string must be specified with C<n>. The C<rv> argument will be upgraded to
8665 an RV. That RV will be modified to point to the new SV. The C<classname>
8666 argument indicates the package for the blessing. Set C<classname> to
8667 C<Nullch> to avoid the blessing. The new SV will have a reference count
8668 of 1, and the RV will be returned.
8670 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8676 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8678 sv_setpvn(newSVrv(rv,classname), pv, n);
8683 =for apidoc sv_bless
8685 Blesses an SV into a specified package. The SV must be an RV. The package
8686 must be designated by its stash (see C<gv_stashpv()>). The reference count
8687 of the SV is unaffected.
8693 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8697 Perl_croak(aTHX_ "Can't bless non-reference value");
8699 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8700 if (SvREADONLY(tmpRef))
8701 Perl_croak(aTHX_ PL_no_modify);
8702 if (SvOBJECT(tmpRef)) {
8703 if (SvTYPE(tmpRef) != SVt_PVIO)
8705 SvREFCNT_dec(SvSTASH(tmpRef));
8708 SvOBJECT_on(tmpRef);
8709 if (SvTYPE(tmpRef) != SVt_PVIO)
8711 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8712 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8719 if(SvSMAGICAL(tmpRef))
8720 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8728 /* Downgrades a PVGV to a PVMG.
8732 S_sv_unglob(pTHX_ SV *sv)
8736 assert(SvTYPE(sv) == SVt_PVGV);
8741 SvREFCNT_dec(GvSTASH(sv));
8742 GvSTASH(sv) = Nullhv;
8744 sv_unmagic(sv, PERL_MAGIC_glob);
8745 Safefree(GvNAME(sv));
8748 /* need to keep SvANY(sv) in the right arena */
8749 xpvmg = new_XPVMG();
8750 StructCopy(SvANY(sv), xpvmg, XPVMG);
8751 del_XPVGV(SvANY(sv));
8754 SvFLAGS(sv) &= ~SVTYPEMASK;
8755 SvFLAGS(sv) |= SVt_PVMG;
8759 =for apidoc sv_unref_flags
8761 Unsets the RV status of the SV, and decrements the reference count of
8762 whatever was being referenced by the RV. This can almost be thought of
8763 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8764 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8765 (otherwise the decrementing is conditional on the reference count being
8766 different from one or the reference being a readonly SV).
8773 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8777 if (SvWEAKREF(sv)) {
8785 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8786 assigned to as BEGIN {$a = \"Foo"} will fail. */
8787 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8789 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8790 sv_2mortal(rv); /* Schedule for freeing later */
8794 =for apidoc sv_unref
8796 Unsets the RV status of the SV, and decrements the reference count of
8797 whatever was being referenced by the RV. This can almost be thought of
8798 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8799 being zero. See C<SvROK_off>.
8805 Perl_sv_unref(pTHX_ SV *sv)
8807 sv_unref_flags(sv, 0);
8811 =for apidoc sv_taint
8813 Taint an SV. Use C<SvTAINTED_on> instead.
8818 Perl_sv_taint(pTHX_ SV *sv)
8820 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8824 =for apidoc sv_untaint
8826 Untaint an SV. Use C<SvTAINTED_off> instead.
8831 Perl_sv_untaint(pTHX_ SV *sv)
8833 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8834 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8841 =for apidoc sv_tainted
8843 Test an SV for taintedness. Use C<SvTAINTED> instead.
8848 Perl_sv_tainted(pTHX_ SV *sv)
8850 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8851 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8852 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8859 =for apidoc sv_setpviv
8861 Copies an integer into the given SV, also updating its string value.
8862 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8868 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8870 char buf[TYPE_CHARS(UV)];
8872 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8874 sv_setpvn(sv, ptr, ebuf - ptr);
8878 =for apidoc sv_setpviv_mg
8880 Like C<sv_setpviv>, but also handles 'set' magic.
8886 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8888 char buf[TYPE_CHARS(UV)];
8890 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8892 sv_setpvn(sv, ptr, ebuf - ptr);
8896 #if defined(PERL_IMPLICIT_CONTEXT)
8898 /* pTHX_ magic can't cope with varargs, so this is a no-context
8899 * version of the main function, (which may itself be aliased to us).
8900 * Don't access this version directly.
8904 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8908 va_start(args, pat);
8909 sv_vsetpvf(sv, pat, &args);
8913 /* pTHX_ magic can't cope with varargs, so this is a no-context
8914 * version of the main function, (which may itself be aliased to us).
8915 * Don't access this version directly.
8919 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8923 va_start(args, pat);
8924 sv_vsetpvf_mg(sv, pat, &args);
8930 =for apidoc sv_setpvf
8932 Works like C<sv_catpvf> but copies the text into the SV instead of
8933 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8939 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8942 va_start(args, pat);
8943 sv_vsetpvf(sv, pat, &args);
8948 =for apidoc sv_vsetpvf
8950 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8951 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8953 Usually used via its frontend C<sv_setpvf>.
8959 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8961 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8965 =for apidoc sv_setpvf_mg
8967 Like C<sv_setpvf>, but also handles 'set' magic.
8973 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8976 va_start(args, pat);
8977 sv_vsetpvf_mg(sv, pat, &args);
8982 =for apidoc sv_vsetpvf_mg
8984 Like C<sv_vsetpvf>, but also handles 'set' magic.
8986 Usually used via its frontend C<sv_setpvf_mg>.
8992 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8994 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8998 #if defined(PERL_IMPLICIT_CONTEXT)
9000 /* pTHX_ magic can't cope with varargs, so this is a no-context
9001 * version of the main function, (which may itself be aliased to us).
9002 * Don't access this version directly.
9006 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
9010 va_start(args, pat);
9011 sv_vcatpvf(sv, pat, &args);
9015 /* pTHX_ magic can't cope with varargs, so this is a no-context
9016 * version of the main function, (which may itself be aliased to us).
9017 * Don't access this version directly.
9021 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
9025 va_start(args, pat);
9026 sv_vcatpvf_mg(sv, pat, &args);
9032 =for apidoc sv_catpvf
9034 Processes its arguments like C<sprintf> and appends the formatted
9035 output to an SV. If the appended data contains "wide" characters
9036 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9037 and characters >255 formatted with %c), the original SV might get
9038 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9039 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9040 valid UTF-8; if the original SV was bytes, the pattern should be too.
9045 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
9048 va_start(args, pat);
9049 sv_vcatpvf(sv, pat, &args);
9054 =for apidoc sv_vcatpvf
9056 Processes its arguments like C<vsprintf> and appends the formatted output
9057 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9059 Usually used via its frontend C<sv_catpvf>.
9065 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9067 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9071 =for apidoc sv_catpvf_mg
9073 Like C<sv_catpvf>, but also handles 'set' magic.
9079 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9082 va_start(args, pat);
9083 sv_vcatpvf_mg(sv, pat, &args);
9088 =for apidoc sv_vcatpvf_mg
9090 Like C<sv_vcatpvf>, but also handles 'set' magic.
9092 Usually used via its frontend C<sv_catpvf_mg>.
9098 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9100 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9105 =for apidoc sv_vsetpvfn
9107 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9110 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9116 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9118 sv_setpvn(sv, "", 0);
9119 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9122 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9125 S_expect_number(pTHX_ char** pattern)
9128 switch (**pattern) {
9129 case '1': case '2': case '3':
9130 case '4': case '5': case '6':
9131 case '7': case '8': case '9':
9132 while (isDIGIT(**pattern))
9133 var = var * 10 + (*(*pattern)++ - '0');
9137 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9140 F0convert(NV nv, char *endbuf, STRLEN *len)
9151 if (uv & 1 && uv == nv)
9152 uv--; /* Round to even */
9154 unsigned dig = uv % 10;
9167 =for apidoc sv_vcatpvfn
9169 Processes its arguments like C<vsprintf> and appends the formatted output
9170 to an SV. Uses an array of SVs if the C style variable argument list is
9171 missing (NULL). When running with taint checks enabled, indicates via
9172 C<maybe_tainted> if results are untrustworthy (often due to the use of
9175 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9180 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9183 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9190 static char nullstr[] = "(null)";
9192 bool has_utf8; /* has the result utf8? */
9193 bool pat_utf8; /* the pattern is in utf8? */
9195 /* Times 4: a decimal digit takes more than 3 binary digits.
9196 * NV_DIG: mantissa takes than many decimal digits.
9197 * Plus 32: Playing safe. */
9198 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9199 /* large enough for "%#.#f" --chip */
9200 /* what about long double NVs? --jhi */
9202 has_utf8 = pat_utf8 = DO_UTF8(sv);
9204 /* no matter what, this is a string now */
9205 (void)SvPV_force(sv, origlen);
9207 /* special-case "", "%s", and "%_" */
9210 if (patlen == 2 && pat[0] == '%') {
9214 const char *s = va_arg(*args, char*);
9215 sv_catpv(sv, s ? s : nullstr);
9217 else if (svix < svmax) {
9218 sv_catsv(sv, *svargs);
9219 if (DO_UTF8(*svargs))
9225 argsv = va_arg(*args, SV*);
9226 sv_catsv(sv, argsv);
9231 /* See comment on '_' below */
9236 #ifndef USE_LONG_DOUBLE
9237 /* special-case "%.<number>[gf]" */
9238 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9239 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9240 unsigned digits = 0;
9244 while (*pp >= '0' && *pp <= '9')
9245 digits = 10 * digits + (*pp++ - '0');
9246 if (pp - pat == (int)patlen - 1) {
9250 nv = (NV)va_arg(*args, double);
9251 else if (svix < svmax)
9256 /* Add check for digits != 0 because it seems that some
9257 gconverts are buggy in this case, and we don't yet have
9258 a Configure test for this. */
9259 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9260 /* 0, point, slack */
9261 Gconvert(nv, (int)digits, 0, ebuf);
9263 if (*ebuf) /* May return an empty string for digits==0 */
9266 } else if (!digits) {
9269 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9270 sv_catpvn(sv, p, l);
9276 #endif /* !USE_LONG_DOUBLE */
9278 if (!args && svix < svmax && DO_UTF8(*svargs))
9281 patend = (char*)pat + patlen;
9282 for (p = (char*)pat; p < patend; p = q) {
9285 bool vectorize = FALSE;
9286 bool vectorarg = FALSE;
9287 bool vec_utf8 = FALSE;
9293 bool has_precis = FALSE;
9296 bool is_utf8 = FALSE; /* is this item utf8? */
9297 #ifdef HAS_LDBL_SPRINTF_BUG
9298 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9299 with sfio - Allen <allens@cpan.org> */
9300 bool fix_ldbl_sprintf_bug = FALSE;
9304 U8 utf8buf[UTF8_MAXBYTES+1];
9305 STRLEN esignlen = 0;
9307 char *eptr = Nullch;
9310 U8 *vecstr = Null(U8*);
9317 /* we need a long double target in case HAS_LONG_DOUBLE but
9320 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9328 const char *dotstr = ".";
9329 STRLEN dotstrlen = 1;
9330 I32 efix = 0; /* explicit format parameter index */
9331 I32 ewix = 0; /* explicit width index */
9332 I32 epix = 0; /* explicit precision index */
9333 I32 evix = 0; /* explicit vector index */
9334 bool asterisk = FALSE;
9336 /* echo everything up to the next format specification */
9337 for (q = p; q < patend && *q != '%'; ++q) ;
9339 if (has_utf8 && !pat_utf8)
9340 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9342 sv_catpvn(sv, p, q - p);
9349 We allow format specification elements in this order:
9350 \d+\$ explicit format parameter index
9352 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9353 0 flag (as above): repeated to allow "v02"
9354 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9355 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9357 [%bcdefginopsux_DFOUX] format (mandatory)
9359 if (EXPECT_NUMBER(q, width)) {
9400 if (EXPECT_NUMBER(q, ewix))
9409 if ((vectorarg = asterisk)) {
9421 EXPECT_NUMBER(q, width);
9426 vecsv = va_arg(*args, SV*);
9428 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9429 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9430 dotstr = SvPVx(vecsv, dotstrlen);
9435 vecsv = va_arg(*args, SV*);
9436 vecstr = (U8*)SvPVx(vecsv,veclen);
9437 vec_utf8 = DO_UTF8(vecsv);
9439 else if (efix ? efix <= svmax : svix < svmax) {
9440 vecsv = svargs[efix ? efix-1 : svix++];
9441 vecstr = (U8*)SvPVx(vecsv,veclen);
9442 vec_utf8 = DO_UTF8(vecsv);
9443 /* if this is a version object, we need to return the
9444 * stringified representation (which the SvPVX has
9445 * already done for us), but not vectorize the args
9447 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9449 q++; /* skip past the rest of the %vd format */
9450 eptr = (char *) vecstr;
9451 elen = strlen(eptr);
9464 i = va_arg(*args, int);
9466 i = (ewix ? ewix <= svmax : svix < svmax) ?
9467 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9469 width = (i < 0) ? -i : i;
9479 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9481 /* XXX: todo, support specified precision parameter */
9485 i = va_arg(*args, int);
9487 i = (ewix ? ewix <= svmax : svix < svmax)
9488 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9489 precis = (i < 0) ? 0 : i;
9494 precis = precis * 10 + (*q++ - '0');
9503 case 'I': /* Ix, I32x, and I64x */
9505 if (q[1] == '6' && q[2] == '4') {
9511 if (q[1] == '3' && q[2] == '2') {
9521 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9532 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9533 if (*(q + 1) == 'l') { /* lld, llf */
9558 argsv = (efix ? efix <= svmax : svix < svmax) ?
9559 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9566 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9568 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9570 eptr = (char*)utf8buf;
9571 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9582 if (args && !vectorize) {
9583 eptr = va_arg(*args, char*);
9585 #ifdef MACOS_TRADITIONAL
9586 /* On MacOS, %#s format is used for Pascal strings */
9591 elen = strlen(eptr);
9594 elen = sizeof nullstr - 1;
9598 eptr = SvPVx(argsv, elen);
9599 if (DO_UTF8(argsv)) {
9600 if (has_precis && precis < elen) {
9602 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9605 if (width) { /* fudge width (can't fudge elen) */
9606 width += elen - sv_len_utf8(argsv);
9618 * The "%_" hack might have to be changed someday,
9619 * if ISO or ANSI decide to use '_' for something.
9620 * So we keep it hidden from users' code.
9622 if (!args || vectorize)
9624 argsv = va_arg(*args, SV*);
9625 eptr = SvPVx(argsv, elen);
9631 if (has_precis && elen > precis)
9642 goto format_sv; /* %-p -> %_ */
9646 goto format_sv; /* %-Np -> %.N_ */
9649 if (alt || vectorize)
9651 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9669 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9678 esignbuf[esignlen++] = plus;
9682 case 'h': iv = (short)va_arg(*args, int); break;
9683 case 'l': iv = va_arg(*args, long); break;
9684 case 'V': iv = va_arg(*args, IV); break;
9685 default: iv = va_arg(*args, int); break;
9687 case 'q': iv = va_arg(*args, Quad_t); break;
9692 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9694 case 'h': iv = (short)tiv; break;
9695 case 'l': iv = (long)tiv; break;
9697 default: iv = tiv; break;
9699 case 'q': iv = (Quad_t)tiv; break;
9703 if ( !vectorize ) /* we already set uv above */
9708 esignbuf[esignlen++] = plus;
9712 esignbuf[esignlen++] = '-';
9755 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9766 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9767 case 'l': uv = va_arg(*args, unsigned long); break;
9768 case 'V': uv = va_arg(*args, UV); break;
9769 default: uv = va_arg(*args, unsigned); break;
9771 case 'q': uv = va_arg(*args, Uquad_t); break;
9776 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9778 case 'h': uv = (unsigned short)tuv; break;
9779 case 'l': uv = (unsigned long)tuv; break;
9781 default: uv = tuv; break;
9783 case 'q': uv = (Uquad_t)tuv; break;
9789 eptr = ebuf + sizeof ebuf;
9795 p = (char*)((c == 'X')
9796 ? "0123456789ABCDEF" : "0123456789abcdef");
9802 esignbuf[esignlen++] = '0';
9803 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9809 *--eptr = '0' + dig;
9811 if (alt && *eptr != '0')
9817 *--eptr = '0' + dig;
9820 esignbuf[esignlen++] = '0';
9821 esignbuf[esignlen++] = 'b';
9824 default: /* it had better be ten or less */
9827 *--eptr = '0' + dig;
9828 } while (uv /= base);
9831 elen = (ebuf + sizeof ebuf) - eptr;
9834 zeros = precis - elen;
9835 else if (precis == 0 && elen == 1 && *eptr == '0')
9840 /* FLOATING POINT */
9843 c = 'f'; /* maybe %F isn't supported here */
9849 /* This is evil, but floating point is even more evil */
9851 /* for SV-style calling, we can only get NV
9852 for C-style calling, we assume %f is double;
9853 for simplicity we allow any of %Lf, %llf, %qf for long double
9857 #if defined(USE_LONG_DOUBLE)
9861 /* [perl #20339] - we should accept and ignore %lf rather than die */
9865 #if defined(USE_LONG_DOUBLE)
9866 intsize = args ? 0 : 'q';
9870 #if defined(HAS_LONG_DOUBLE)
9879 /* now we need (long double) if intsize == 'q', else (double) */
9880 nv = (args && !vectorize) ?
9881 #if LONG_DOUBLESIZE > DOUBLESIZE
9883 va_arg(*args, long double) :
9884 va_arg(*args, double)
9886 va_arg(*args, double)
9892 if (c != 'e' && c != 'E') {
9894 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9895 will cast our (long double) to (double) */
9896 (void)Perl_frexp(nv, &i);
9897 if (i == PERL_INT_MIN)
9898 Perl_die(aTHX_ "panic: frexp");
9900 need = BIT_DIGITS(i);
9902 need += has_precis ? precis : 6; /* known default */
9907 #ifdef HAS_LDBL_SPRINTF_BUG
9908 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9909 with sfio - Allen <allens@cpan.org> */
9912 # define MY_DBL_MAX DBL_MAX
9913 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9914 # if DOUBLESIZE >= 8
9915 # define MY_DBL_MAX 1.7976931348623157E+308L
9917 # define MY_DBL_MAX 3.40282347E+38L
9921 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9922 # define MY_DBL_MAX_BUG 1L
9924 # define MY_DBL_MAX_BUG MY_DBL_MAX
9928 # define MY_DBL_MIN DBL_MIN
9929 # else /* XXX guessing! -Allen */
9930 # if DOUBLESIZE >= 8
9931 # define MY_DBL_MIN 2.2250738585072014E-308L
9933 # define MY_DBL_MIN 1.17549435E-38L
9937 if ((intsize == 'q') && (c == 'f') &&
9938 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9940 /* it's going to be short enough that
9941 * long double precision is not needed */
9943 if ((nv <= 0L) && (nv >= -0L))
9944 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9946 /* would use Perl_fp_class as a double-check but not
9947 * functional on IRIX - see perl.h comments */
9949 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9950 /* It's within the range that a double can represent */
9951 #if defined(DBL_MAX) && !defined(DBL_MIN)
9952 if ((nv >= ((long double)1/DBL_MAX)) ||
9953 (nv <= (-(long double)1/DBL_MAX)))
9955 fix_ldbl_sprintf_bug = TRUE;
9958 if (fix_ldbl_sprintf_bug == TRUE) {
9968 # undef MY_DBL_MAX_BUG
9971 #endif /* HAS_LDBL_SPRINTF_BUG */
9973 need += 20; /* fudge factor */
9974 if (PL_efloatsize < need) {
9975 Safefree(PL_efloatbuf);
9976 PL_efloatsize = need + 20; /* more fudge */
9977 New(906, PL_efloatbuf, PL_efloatsize, char);
9978 PL_efloatbuf[0] = '\0';
9981 if ( !(width || left || plus || alt) && fill != '0'
9982 && has_precis && intsize != 'q' ) { /* Shortcuts */
9983 /* See earlier comment about buggy Gconvert when digits,
9985 if ( c == 'g' && precis) {
9986 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9987 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9988 goto float_converted;
9989 } else if ( c == 'f' && !precis) {
9990 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9994 eptr = ebuf + sizeof ebuf;
9997 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9998 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9999 if (intsize == 'q') {
10000 /* Copy the one or more characters in a long double
10001 * format before the 'base' ([efgEFG]) character to
10002 * the format string. */
10003 static char const prifldbl[] = PERL_PRIfldbl;
10004 char const *p = prifldbl + sizeof(prifldbl) - 3;
10005 while (p >= prifldbl) { *--eptr = *p--; }
10010 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10015 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10027 /* No taint. Otherwise we are in the strange situation
10028 * where printf() taints but print($float) doesn't.
10030 #if defined(HAS_LONG_DOUBLE)
10031 if (intsize == 'q')
10032 (void)sprintf(PL_efloatbuf, eptr, nv);
10034 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
10036 (void)sprintf(PL_efloatbuf, eptr, nv);
10039 eptr = PL_efloatbuf;
10040 elen = strlen(PL_efloatbuf);
10046 i = SvCUR(sv) - origlen;
10047 if (args && !vectorize) {
10049 case 'h': *(va_arg(*args, short*)) = i; break;
10050 default: *(va_arg(*args, int*)) = i; break;
10051 case 'l': *(va_arg(*args, long*)) = i; break;
10052 case 'V': *(va_arg(*args, IV*)) = i; break;
10054 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10059 sv_setuv_mg(argsv, (UV)i);
10061 continue; /* not "break" */
10067 if (!args && ckWARN(WARN_PRINTF) &&
10068 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10069 SV *msg = sv_newmortal();
10070 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10071 (PL_op->op_type == OP_PRTF) ? "" : "s");
10074 Perl_sv_catpvf(aTHX_ msg,
10075 "\"%%%c\"", c & 0xFF);
10077 Perl_sv_catpvf(aTHX_ msg,
10078 "\"%%\\%03"UVof"\"",
10081 sv_catpv(msg, "end of string");
10082 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10085 /* output mangled stuff ... */
10091 /* ... right here, because formatting flags should not apply */
10092 SvGROW(sv, SvCUR(sv) + elen + 1);
10094 Copy(eptr, p, elen, char);
10097 SvCUR(sv) = p - SvPVX(sv);
10099 continue; /* not "break" */
10102 /* calculate width before utf8_upgrade changes it */
10103 have = esignlen + zeros + elen;
10105 if (is_utf8 != has_utf8) {
10108 sv_utf8_upgrade(sv);
10111 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10112 sv_utf8_upgrade(nsv);
10116 SvGROW(sv, SvCUR(sv) + elen + 1);
10121 need = (have > width ? have : width);
10124 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10126 if (esignlen && fill == '0') {
10127 for (i = 0; i < (int)esignlen; i++)
10128 *p++ = esignbuf[i];
10130 if (gap && !left) {
10131 memset(p, fill, gap);
10134 if (esignlen && fill != '0') {
10135 for (i = 0; i < (int)esignlen; i++)
10136 *p++ = esignbuf[i];
10139 for (i = zeros; i; i--)
10143 Copy(eptr, p, elen, char);
10147 memset(p, ' ', gap);
10152 Copy(dotstr, p, dotstrlen, char);
10156 vectorize = FALSE; /* done iterating over vecstr */
10163 SvCUR(sv) = p - SvPVX(sv);
10171 /* =========================================================================
10173 =head1 Cloning an interpreter
10175 All the macros and functions in this section are for the private use of
10176 the main function, perl_clone().
10178 The foo_dup() functions make an exact copy of an existing foo thinngy.
10179 During the course of a cloning, a hash table is used to map old addresses
10180 to new addresses. The table is created and manipulated with the
10181 ptr_table_* functions.
10185 ============================================================================*/
10188 #if defined(USE_ITHREADS)
10190 #ifndef GpREFCNT_inc
10191 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10195 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10196 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10197 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10198 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10199 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10200 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10201 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10202 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10203 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10204 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10205 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10206 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10207 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10210 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10211 regcomp.c. AMS 20010712 */
10214 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10218 struct reg_substr_datum *s;
10221 return (REGEXP *)NULL;
10223 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10226 len = r->offsets[0];
10227 npar = r->nparens+1;
10229 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10230 Copy(r->program, ret->program, len+1, regnode);
10232 New(0, ret->startp, npar, I32);
10233 Copy(r->startp, ret->startp, npar, I32);
10234 New(0, ret->endp, npar, I32);
10235 Copy(r->startp, ret->startp, npar, I32);
10237 New(0, ret->substrs, 1, struct reg_substr_data);
10238 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10239 s->min_offset = r->substrs->data[i].min_offset;
10240 s->max_offset = r->substrs->data[i].max_offset;
10241 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10242 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10245 ret->regstclass = NULL;
10247 struct reg_data *d;
10248 const int count = r->data->count;
10250 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10251 char, struct reg_data);
10252 New(0, d->what, count, U8);
10255 for (i = 0; i < count; i++) {
10256 d->what[i] = r->data->what[i];
10257 switch (d->what[i]) {
10258 /* legal options are one of: sfpont
10259 see also regcomp.h and pregfree() */
10261 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10264 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10267 /* This is cheating. */
10268 New(0, d->data[i], 1, struct regnode_charclass_class);
10269 StructCopy(r->data->data[i], d->data[i],
10270 struct regnode_charclass_class);
10271 ret->regstclass = (regnode*)d->data[i];
10274 /* Compiled op trees are readonly, and can thus be
10275 shared without duplication. */
10277 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10281 d->data[i] = r->data->data[i];
10284 d->data[i] = r->data->data[i];
10286 ((reg_trie_data*)d->data[i])->refcount++;
10290 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10299 New(0, ret->offsets, 2*len+1, U32);
10300 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10302 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10303 ret->refcnt = r->refcnt;
10304 ret->minlen = r->minlen;
10305 ret->prelen = r->prelen;
10306 ret->nparens = r->nparens;
10307 ret->lastparen = r->lastparen;
10308 ret->lastcloseparen = r->lastcloseparen;
10309 ret->reganch = r->reganch;
10311 ret->sublen = r->sublen;
10313 if (RX_MATCH_COPIED(ret))
10314 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10316 ret->subbeg = Nullch;
10317 #ifdef PERL_COPY_ON_WRITE
10318 ret->saved_copy = Nullsv;
10321 ptr_table_store(PL_ptr_table, r, ret);
10325 /* duplicate a file handle */
10328 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10334 return (PerlIO*)NULL;
10336 /* look for it in the table first */
10337 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10341 /* create anew and remember what it is */
10342 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10343 ptr_table_store(PL_ptr_table, fp, ret);
10347 /* duplicate a directory handle */
10350 Perl_dirp_dup(pTHX_ DIR *dp)
10358 /* duplicate a typeglob */
10361 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10366 /* look for it in the table first */
10367 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10371 /* create anew and remember what it is */
10372 Newz(0, ret, 1, GP);
10373 ptr_table_store(PL_ptr_table, gp, ret);
10376 ret->gp_refcnt = 0; /* must be before any other dups! */
10377 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10378 ret->gp_io = io_dup_inc(gp->gp_io, param);
10379 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10380 ret->gp_av = av_dup_inc(gp->gp_av, param);
10381 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10382 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10383 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10384 ret->gp_cvgen = gp->gp_cvgen;
10385 ret->gp_flags = gp->gp_flags;
10386 ret->gp_line = gp->gp_line;
10387 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10391 /* duplicate a chain of magic */
10394 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10396 MAGIC *mgprev = (MAGIC*)NULL;
10399 return (MAGIC*)NULL;
10400 /* look for it in the table first */
10401 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10405 for (; mg; mg = mg->mg_moremagic) {
10407 Newz(0, nmg, 1, MAGIC);
10409 mgprev->mg_moremagic = nmg;
10412 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10413 nmg->mg_private = mg->mg_private;
10414 nmg->mg_type = mg->mg_type;
10415 nmg->mg_flags = mg->mg_flags;
10416 if (mg->mg_type == PERL_MAGIC_qr) {
10417 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10419 else if(mg->mg_type == PERL_MAGIC_backref) {
10420 const AV * const av = (AV*) mg->mg_obj;
10423 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10425 for (i = AvFILLp(av); i >= 0; i--) {
10426 if (!svp[i]) continue;
10427 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10431 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10432 ? sv_dup_inc(mg->mg_obj, param)
10433 : sv_dup(mg->mg_obj, param);
10435 nmg->mg_len = mg->mg_len;
10436 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10437 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10438 if (mg->mg_len > 0) {
10439 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10440 if (mg->mg_type == PERL_MAGIC_overload_table &&
10441 AMT_AMAGIC((AMT*)mg->mg_ptr))
10443 AMT *amtp = (AMT*)mg->mg_ptr;
10444 AMT *namtp = (AMT*)nmg->mg_ptr;
10446 for (i = 1; i < NofAMmeth; i++) {
10447 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10451 else if (mg->mg_len == HEf_SVKEY)
10452 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10454 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10455 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10462 /* create a new pointer-mapping table */
10465 Perl_ptr_table_new(pTHX)
10468 Newz(0, tbl, 1, PTR_TBL_t);
10469 tbl->tbl_max = 511;
10470 tbl->tbl_items = 0;
10471 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10476 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10478 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10481 /* map an existing pointer using a table */
10484 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10486 PTR_TBL_ENT_t *tblent;
10487 UV hash = PTR_TABLE_HASH(sv);
10489 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10490 for (; tblent; tblent = tblent->next) {
10491 if (tblent->oldval == sv)
10492 return tblent->newval;
10494 return (void*)NULL;
10497 /* add a new entry to a pointer-mapping table */
10500 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10502 PTR_TBL_ENT_t *tblent, **otblent;
10503 /* XXX this may be pessimal on platforms where pointers aren't good
10504 * hash values e.g. if they grow faster in the most significant
10506 UV hash = PTR_TABLE_HASH(oldv);
10510 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10511 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10512 if (tblent->oldval == oldv) {
10513 tblent->newval = newv;
10517 Newz(0, tblent, 1, PTR_TBL_ENT_t);
10518 tblent->oldval = oldv;
10519 tblent->newval = newv;
10520 tblent->next = *otblent;
10523 if (!empty && tbl->tbl_items > tbl->tbl_max)
10524 ptr_table_split(tbl);
10527 /* double the hash bucket size of an existing ptr table */
10530 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10532 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10533 UV oldsize = tbl->tbl_max + 1;
10534 UV newsize = oldsize * 2;
10537 Renew(ary, newsize, PTR_TBL_ENT_t*);
10538 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10539 tbl->tbl_max = --newsize;
10540 tbl->tbl_ary = ary;
10541 for (i=0; i < oldsize; i++, ary++) {
10542 PTR_TBL_ENT_t **curentp, **entp, *ent;
10545 curentp = ary + oldsize;
10546 for (entp = ary, ent = *ary; ent; ent = *entp) {
10547 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10549 ent->next = *curentp;
10559 /* remove all the entries from a ptr table */
10562 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10564 register PTR_TBL_ENT_t **array;
10565 register PTR_TBL_ENT_t *entry;
10566 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10570 if (!tbl || !tbl->tbl_items) {
10574 array = tbl->tbl_ary;
10576 max = tbl->tbl_max;
10581 entry = entry->next;
10585 if (++riter > max) {
10588 entry = array[riter];
10592 tbl->tbl_items = 0;
10595 /* clear and free a ptr table */
10598 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10603 ptr_table_clear(tbl);
10604 Safefree(tbl->tbl_ary);
10609 char *PL_watch_pvx;
10612 /* attempt to make everything in the typeglob readonly */
10615 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10617 GV *gv = (GV*)sstr;
10618 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10620 if (GvIO(gv) || GvFORM(gv)) {
10621 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10623 else if (!GvCV(gv)) {
10624 GvCV(gv) = (CV*)sv;
10627 /* CvPADLISTs cannot be shared */
10628 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10633 if (!GvUNIQUE(gv)) {
10635 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10636 HvNAME(GvSTASH(gv)), GvNAME(gv));
10642 * write attempts will die with
10643 * "Modification of a read-only value attempted"
10649 SvREADONLY_on(GvSV(gv));
10653 GvAV(gv) = (AV*)sv;
10656 SvREADONLY_on(GvAV(gv));
10660 GvHV(gv) = (HV*)sv;
10663 SvREADONLY_on(GvHV(gv));
10666 return sstr; /* he_dup() will SvREFCNT_inc() */
10669 /* duplicate an SV of any type (including AV, HV etc) */
10672 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10675 SvRV(dstr) = SvWEAKREF(sstr)
10676 ? sv_dup(SvRV(sstr), param)
10677 : sv_dup_inc(SvRV(sstr), param);
10680 else if (SvPVX(sstr)) {
10681 /* Has something there */
10683 /* Normal PV - clone whole allocated space */
10684 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
10685 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10686 /* Not that normal - actually sstr is copy on write.
10687 But we are a true, independant SV, so: */
10688 SvREADONLY_off(dstr);
10693 /* Special case - not normally malloced for some reason */
10694 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10695 /* A "shared" PV - clone it as unshared string */
10696 if(SvPADTMP(sstr)) {
10697 /* However, some of them live in the pad
10698 and they should not have these flags
10701 SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
10703 SvUV_set(dstr, SvUVX(sstr));
10706 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
10708 SvREADONLY_off(dstr);
10712 /* Some other special case - random pointer */
10713 SvPV_set(dstr, SvPVX(sstr));
10718 /* Copy the Null */
10719 if (SvTYPE(dstr) == SVt_RV)
10727 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10731 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10733 /* look for it in the table first */
10734 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10738 if(param->flags & CLONEf_JOIN_IN) {
10739 /** We are joining here so we don't want do clone
10740 something that is bad **/
10742 if(SvTYPE(sstr) == SVt_PVHV &&
10744 /** don't clone stashes if they already exist **/
10745 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10746 return (SV*) old_stash;
10750 /* create anew and remember what it is */
10753 #ifdef DEBUG_LEAKING_SCALARS
10754 dstr->sv_debug_optype = sstr->sv_debug_optype;
10755 dstr->sv_debug_line = sstr->sv_debug_line;
10756 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10757 dstr->sv_debug_cloned = 1;
10759 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10761 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10765 ptr_table_store(PL_ptr_table, sstr, dstr);
10768 SvFLAGS(dstr) = SvFLAGS(sstr);
10769 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10770 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10773 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10774 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10775 PL_watch_pvx, SvPVX(sstr));
10778 /* don't clone objects whose class has asked us not to */
10779 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10780 SvFLAGS(dstr) &= ~SVTYPEMASK;
10781 SvOBJECT_off(dstr);
10785 switch (SvTYPE(sstr)) {
10787 SvANY(dstr) = NULL;
10790 SvANY(dstr) = new_XIV();
10791 SvIV_set(dstr, SvIVX(sstr));
10794 SvANY(dstr) = new_XNV();
10795 SvNV_set(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 SvIV_set(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 SvIV_set(dstr, SvIVX(sstr));
10819 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10827 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10837 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10850 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10882 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10898 SvNV_set(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 SvIV_set(dstr, SvIVX(sstr));
10940 SvNV_set(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 SvPV_set(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 SvPV_set(dstr, Nullch);
10969 AvALLOC((AV*)dstr) = (SV**)NULL;
10973 SvANY(dstr) = new_XPVHV();
10974 SvCUR(dstr) = SvCUR(sstr);
10975 SvLEN(dstr) = SvLEN(sstr);
10976 SvIV_set(dstr, SvIVX(sstr));
10977 SvNV_set(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 SvPV_set(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 SvIV_set(dstr, SvIVX(sstr));
11017 SvNV_set(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((SV *)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 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11502 * flag to the result. This is done for each stash before cloning starts,
11503 * so we know which stashes want their objects cloned */
11506 do_mark_cloneable_stash(pTHX_ SV *sv)
11508 if (HvNAME((HV*)sv)) {
11509 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11510 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11511 if (cloner && GvCV(cloner)) {
11518 XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
11520 call_sv((SV*)GvCV(cloner), G_SCALAR);
11527 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11535 =for apidoc perl_clone
11537 Create and return a new interpreter by cloning the current one.
11539 perl_clone takes these flags as parameters:
11541 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11542 without it we only clone the data and zero the stacks,
11543 with it we copy the stacks and the new perl interpreter is
11544 ready to run at the exact same point as the previous one.
11545 The pseudo-fork code uses COPY_STACKS while the
11546 threads->new doesn't.
11548 CLONEf_KEEP_PTR_TABLE
11549 perl_clone keeps a ptr_table with the pointer of the old
11550 variable as a key and the new variable as a value,
11551 this allows it to check if something has been cloned and not
11552 clone it again but rather just use the value and increase the
11553 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11554 the ptr_table using the function
11555 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11556 reason to keep it around is if you want to dup some of your own
11557 variable who are outside the graph perl scans, example of this
11558 code is in threads.xs create
11561 This is a win32 thing, it is ignored on unix, it tells perls
11562 win32host code (which is c++) to clone itself, this is needed on
11563 win32 if you want to run two threads at the same time,
11564 if you just want to do some stuff in a separate perl interpreter
11565 and then throw it away and return to the original one,
11566 you don't need to do anything.
11571 /* XXX the above needs expanding by someone who actually understands it ! */
11572 EXTERN_C PerlInterpreter *
11573 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11576 perl_clone(PerlInterpreter *proto_perl, UV flags)
11578 #ifdef PERL_IMPLICIT_SYS
11580 /* perlhost.h so we need to call into it
11581 to clone the host, CPerlHost should have a c interface, sky */
11583 if (flags & CLONEf_CLONE_HOST) {
11584 return perl_clone_host(proto_perl,flags);
11586 return perl_clone_using(proto_perl, flags,
11588 proto_perl->IMemShared,
11589 proto_perl->IMemParse,
11591 proto_perl->IStdIO,
11595 proto_perl->IProc);
11599 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11600 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11601 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11602 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11603 struct IPerlDir* ipD, struct IPerlSock* ipS,
11604 struct IPerlProc* ipP)
11606 /* XXX many of the string copies here can be optimized if they're
11607 * constants; they need to be allocated as common memory and just
11608 * their pointers copied. */
11611 CLONE_PARAMS clone_params;
11612 CLONE_PARAMS* param = &clone_params;
11614 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11615 /* for each stash, determine whether its objects should be cloned */
11616 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11617 PERL_SET_THX(my_perl);
11620 Poison(my_perl, 1, PerlInterpreter);
11622 PL_curcop = (COP *)Nullop;
11626 PL_savestack_ix = 0;
11627 PL_savestack_max = -1;
11628 PL_sig_pending = 0;
11629 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11630 # else /* !DEBUGGING */
11631 Zero(my_perl, 1, PerlInterpreter);
11632 # endif /* DEBUGGING */
11634 /* host pointers */
11636 PL_MemShared = ipMS;
11637 PL_MemParse = ipMP;
11644 #else /* !PERL_IMPLICIT_SYS */
11646 CLONE_PARAMS clone_params;
11647 CLONE_PARAMS* param = &clone_params;
11648 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11649 /* for each stash, determine whether its objects should be cloned */
11650 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11651 PERL_SET_THX(my_perl);
11654 Poison(my_perl, 1, PerlInterpreter);
11656 PL_curcop = (COP *)Nullop;
11660 PL_savestack_ix = 0;
11661 PL_savestack_max = -1;
11662 PL_sig_pending = 0;
11663 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11664 # else /* !DEBUGGING */
11665 Zero(my_perl, 1, PerlInterpreter);
11666 # endif /* DEBUGGING */
11667 #endif /* PERL_IMPLICIT_SYS */
11668 param->flags = flags;
11669 param->proto_perl = proto_perl;
11672 PL_xiv_arenaroot = NULL;
11673 PL_xiv_root = NULL;
11674 PL_xnv_arenaroot = NULL;
11675 PL_xnv_root = NULL;
11676 PL_xrv_arenaroot = NULL;
11677 PL_xrv_root = NULL;
11678 PL_xpv_arenaroot = NULL;
11679 PL_xpv_root = NULL;
11680 PL_xpviv_arenaroot = NULL;
11681 PL_xpviv_root = NULL;
11682 PL_xpvnv_arenaroot = NULL;
11683 PL_xpvnv_root = NULL;
11684 PL_xpvcv_arenaroot = NULL;
11685 PL_xpvcv_root = NULL;
11686 PL_xpvav_arenaroot = NULL;
11687 PL_xpvav_root = NULL;
11688 PL_xpvhv_arenaroot = NULL;
11689 PL_xpvhv_root = NULL;
11690 PL_xpvmg_arenaroot = NULL;
11691 PL_xpvmg_root = NULL;
11692 PL_xpvlv_arenaroot = NULL;
11693 PL_xpvlv_root = NULL;
11694 PL_xpvbm_arenaroot = NULL;
11695 PL_xpvbm_root = NULL;
11696 PL_he_arenaroot = NULL;
11698 PL_nice_chunk = NULL;
11699 PL_nice_chunk_size = 0;
11701 PL_sv_objcount = 0;
11702 PL_sv_root = Nullsv;
11703 PL_sv_arenaroot = Nullsv;
11705 PL_debug = proto_perl->Idebug;
11707 #ifdef USE_REENTRANT_API
11708 /* XXX: things like -Dm will segfault here in perlio, but doing
11709 * PERL_SET_CONTEXT(proto_perl);
11710 * breaks too many other things
11712 Perl_reentrant_init(aTHX);
11715 /* create SV map for pointer relocation */
11716 PL_ptr_table = ptr_table_new();
11718 /* initialize these special pointers as early as possible */
11719 SvANY(&PL_sv_undef) = NULL;
11720 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11721 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11722 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11724 SvANY(&PL_sv_no) = new_XPVNV();
11725 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11726 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11727 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11728 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11729 SvCUR(&PL_sv_no) = 0;
11730 SvLEN(&PL_sv_no) = 1;
11731 SvIV_set(&PL_sv_no, 0);
11732 SvNV_set(&PL_sv_no, 0);
11733 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11735 SvANY(&PL_sv_yes) = new_XPVNV();
11736 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11737 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11738 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11739 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11740 SvCUR(&PL_sv_yes) = 1;
11741 SvLEN(&PL_sv_yes) = 2;
11742 SvIV_set(&PL_sv_yes, 1);
11743 SvNV_set(&PL_sv_yes, 1);
11744 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11746 /* create (a non-shared!) shared string table */
11747 PL_strtab = newHV();
11748 HvSHAREKEYS_off(PL_strtab);
11749 hv_ksplit(PL_strtab, 512);
11750 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11752 PL_compiling = proto_perl->Icompiling;
11754 /* These two PVs will be free'd special way so must set them same way op.c does */
11755 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11756 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11758 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11759 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11761 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11762 if (!specialWARN(PL_compiling.cop_warnings))
11763 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11764 if (!specialCopIO(PL_compiling.cop_io))
11765 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11766 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11768 /* pseudo environmental stuff */
11769 PL_origargc = proto_perl->Iorigargc;
11770 PL_origargv = proto_perl->Iorigargv;
11772 param->stashes = newAV(); /* Setup array of objects to call clone on */
11774 #ifdef PERLIO_LAYERS
11775 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11776 PerlIO_clone(aTHX_ proto_perl, param);
11779 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11780 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11781 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11782 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11783 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11784 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11787 PL_minus_c = proto_perl->Iminus_c;
11788 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11789 PL_localpatches = proto_perl->Ilocalpatches;
11790 PL_splitstr = proto_perl->Isplitstr;
11791 PL_preprocess = proto_perl->Ipreprocess;
11792 PL_minus_n = proto_perl->Iminus_n;
11793 PL_minus_p = proto_perl->Iminus_p;
11794 PL_minus_l = proto_perl->Iminus_l;
11795 PL_minus_a = proto_perl->Iminus_a;
11796 PL_minus_F = proto_perl->Iminus_F;
11797 PL_doswitches = proto_perl->Idoswitches;
11798 PL_dowarn = proto_perl->Idowarn;
11799 PL_doextract = proto_perl->Idoextract;
11800 PL_sawampersand = proto_perl->Isawampersand;
11801 PL_unsafe = proto_perl->Iunsafe;
11802 PL_inplace = SAVEPV(proto_perl->Iinplace);
11803 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11804 PL_perldb = proto_perl->Iperldb;
11805 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11806 PL_exit_flags = proto_perl->Iexit_flags;
11808 /* magical thingies */
11809 /* XXX time(&PL_basetime) when asked for? */
11810 PL_basetime = proto_perl->Ibasetime;
11811 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11813 PL_maxsysfd = proto_perl->Imaxsysfd;
11814 PL_multiline = proto_perl->Imultiline;
11815 PL_statusvalue = proto_perl->Istatusvalue;
11817 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11819 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11821 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11822 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11823 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11825 /* Clone the regex array */
11826 PL_regex_padav = newAV();
11828 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11829 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11830 av_push(PL_regex_padav,
11831 sv_dup_inc(regexen[0],param));
11832 for(i = 1; i <= len; i++) {
11833 if(SvREPADTMP(regexen[i])) {
11834 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11836 av_push(PL_regex_padav,
11838 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11839 SvIVX(regexen[i])), param)))
11844 PL_regex_pad = AvARRAY(PL_regex_padav);
11846 /* shortcuts to various I/O objects */
11847 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11848 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11849 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11850 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11851 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11852 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11854 /* shortcuts to regexp stuff */
11855 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11857 /* shortcuts to misc objects */
11858 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11860 /* shortcuts to debugging objects */
11861 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11862 PL_DBline = gv_dup(proto_perl->IDBline, param);
11863 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11864 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11865 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11866 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11867 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11868 PL_lineary = av_dup(proto_perl->Ilineary, param);
11869 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11871 /* symbol tables */
11872 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11873 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11874 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11875 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11876 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11878 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11879 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11880 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11881 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11882 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11883 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11885 PL_sub_generation = proto_perl->Isub_generation;
11887 /* funky return mechanisms */
11888 PL_forkprocess = proto_perl->Iforkprocess;
11890 /* subprocess state */
11891 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11893 /* internal state */
11894 PL_tainting = proto_perl->Itainting;
11895 PL_taint_warn = proto_perl->Itaint_warn;
11896 PL_maxo = proto_perl->Imaxo;
11897 if (proto_perl->Iop_mask)
11898 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11900 PL_op_mask = Nullch;
11901 /* PL_asserting = proto_perl->Iasserting; */
11903 /* current interpreter roots */
11904 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11905 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11906 PL_main_start = proto_perl->Imain_start;
11907 PL_eval_root = proto_perl->Ieval_root;
11908 PL_eval_start = proto_perl->Ieval_start;
11910 /* runtime control stuff */
11911 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11912 PL_copline = proto_perl->Icopline;
11914 PL_filemode = proto_perl->Ifilemode;
11915 PL_lastfd = proto_perl->Ilastfd;
11916 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11919 PL_gensym = proto_perl->Igensym;
11920 PL_preambled = proto_perl->Ipreambled;
11921 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11922 PL_laststatval = proto_perl->Ilaststatval;
11923 PL_laststype = proto_perl->Ilaststype;
11924 PL_mess_sv = Nullsv;
11926 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11927 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11929 /* interpreter atexit processing */
11930 PL_exitlistlen = proto_perl->Iexitlistlen;
11931 if (PL_exitlistlen) {
11932 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11933 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11936 PL_exitlist = (PerlExitListEntry*)NULL;
11937 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11938 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11939 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11941 PL_profiledata = NULL;
11942 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11943 /* PL_rsfp_filters entries have fake IoDIRP() */
11944 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11946 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11948 PAD_CLONE_VARS(proto_perl, param);
11950 #ifdef HAVE_INTERP_INTERN
11951 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11954 /* more statics moved here */
11955 PL_generation = proto_perl->Igeneration;
11956 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11958 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11959 PL_in_clean_all = proto_perl->Iin_clean_all;
11961 PL_uid = proto_perl->Iuid;
11962 PL_euid = proto_perl->Ieuid;
11963 PL_gid = proto_perl->Igid;
11964 PL_egid = proto_perl->Iegid;
11965 PL_nomemok = proto_perl->Inomemok;
11966 PL_an = proto_perl->Ian;
11967 PL_evalseq = proto_perl->Ievalseq;
11968 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11969 PL_origalen = proto_perl->Iorigalen;
11970 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11971 PL_osname = SAVEPV(proto_perl->Iosname);
11972 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11973 PL_sighandlerp = proto_perl->Isighandlerp;
11976 PL_runops = proto_perl->Irunops;
11978 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11981 PL_cshlen = proto_perl->Icshlen;
11982 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11985 PL_lex_state = proto_perl->Ilex_state;
11986 PL_lex_defer = proto_perl->Ilex_defer;
11987 PL_lex_expect = proto_perl->Ilex_expect;
11988 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11989 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11990 PL_lex_starts = proto_perl->Ilex_starts;
11991 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11992 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11993 PL_lex_op = proto_perl->Ilex_op;
11994 PL_lex_inpat = proto_perl->Ilex_inpat;
11995 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11996 PL_lex_brackets = proto_perl->Ilex_brackets;
11997 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11998 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11999 PL_lex_casemods = proto_perl->Ilex_casemods;
12000 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
12001 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
12003 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
12004 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
12005 PL_nexttoke = proto_perl->Inexttoke;
12007 /* XXX This is probably masking the deeper issue of why
12008 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
12009 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
12010 * (A little debugging with a watchpoint on it may help.)
12012 if (SvANY(proto_perl->Ilinestr)) {
12013 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
12014 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
12015 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12016 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
12017 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12018 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
12019 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12020 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
12021 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12024 PL_linestr = NEWSV(65,79);
12025 sv_upgrade(PL_linestr,SVt_PVIV);
12026 sv_setpvn(PL_linestr,"",0);
12027 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
12029 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12030 PL_pending_ident = proto_perl->Ipending_ident;
12031 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
12033 PL_expect = proto_perl->Iexpect;
12035 PL_multi_start = proto_perl->Imulti_start;
12036 PL_multi_end = proto_perl->Imulti_end;
12037 PL_multi_open = proto_perl->Imulti_open;
12038 PL_multi_close = proto_perl->Imulti_close;
12040 PL_error_count = proto_perl->Ierror_count;
12041 PL_subline = proto_perl->Isubline;
12042 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12044 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12045 if (SvANY(proto_perl->Ilinestr)) {
12046 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12047 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12048 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12049 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12050 PL_last_lop_op = proto_perl->Ilast_lop_op;
12053 PL_last_uni = SvPVX(PL_linestr);
12054 PL_last_lop = SvPVX(PL_linestr);
12055 PL_last_lop_op = 0;
12057 PL_in_my = proto_perl->Iin_my;
12058 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12060 PL_cryptseen = proto_perl->Icryptseen;
12063 PL_hints = proto_perl->Ihints;
12065 PL_amagic_generation = proto_perl->Iamagic_generation;
12067 #ifdef USE_LOCALE_COLLATE
12068 PL_collation_ix = proto_perl->Icollation_ix;
12069 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12070 PL_collation_standard = proto_perl->Icollation_standard;
12071 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12072 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12073 #endif /* USE_LOCALE_COLLATE */
12075 #ifdef USE_LOCALE_NUMERIC
12076 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12077 PL_numeric_standard = proto_perl->Inumeric_standard;
12078 PL_numeric_local = proto_perl->Inumeric_local;
12079 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12080 #endif /* !USE_LOCALE_NUMERIC */
12082 /* utf8 character classes */
12083 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12084 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12085 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12086 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12087 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12088 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12089 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12090 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12091 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12092 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12093 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12094 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12095 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12096 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12097 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12098 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12099 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12100 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12101 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12102 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12104 /* Did the locale setup indicate UTF-8? */
12105 PL_utf8locale = proto_perl->Iutf8locale;
12106 /* Unicode features (see perlrun/-C) */
12107 PL_unicode = proto_perl->Iunicode;
12109 /* Pre-5.8 signals control */
12110 PL_signals = proto_perl->Isignals;
12112 /* times() ticks per second */
12113 PL_clocktick = proto_perl->Iclocktick;
12115 /* Recursion stopper for PerlIO_find_layer */
12116 PL_in_load_module = proto_perl->Iin_load_module;
12118 /* sort() routine */
12119 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12121 /* Not really needed/useful since the reenrant_retint is "volatile",
12122 * but do it for consistency's sake. */
12123 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12125 /* Hooks to shared SVs and locks. */
12126 PL_sharehook = proto_perl->Isharehook;
12127 PL_lockhook = proto_perl->Ilockhook;
12128 PL_unlockhook = proto_perl->Iunlockhook;
12129 PL_threadhook = proto_perl->Ithreadhook;
12131 PL_runops_std = proto_perl->Irunops_std;
12132 PL_runops_dbg = proto_perl->Irunops_dbg;
12134 #ifdef THREADS_HAVE_PIDS
12135 PL_ppid = proto_perl->Ippid;
12139 PL_last_swash_hv = Nullhv; /* reinits on demand */
12140 PL_last_swash_klen = 0;
12141 PL_last_swash_key[0]= '\0';
12142 PL_last_swash_tmps = (U8*)NULL;
12143 PL_last_swash_slen = 0;
12145 PL_glob_index = proto_perl->Iglob_index;
12146 PL_srand_called = proto_perl->Isrand_called;
12147 PL_hash_seed = proto_perl->Ihash_seed;
12148 PL_rehash_seed = proto_perl->Irehash_seed;
12149 PL_uudmap['M'] = 0; /* reinits on demand */
12150 PL_bitcount = Nullch; /* reinits on demand */
12152 if (proto_perl->Ipsig_pend) {
12153 Newz(0, PL_psig_pend, SIG_SIZE, int);
12156 PL_psig_pend = (int*)NULL;
12159 if (proto_perl->Ipsig_ptr) {
12160 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12161 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12162 for (i = 1; i < SIG_SIZE; i++) {
12163 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12164 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12168 PL_psig_ptr = (SV**)NULL;
12169 PL_psig_name = (SV**)NULL;
12172 /* thrdvar.h stuff */
12174 if (flags & CLONEf_COPY_STACKS) {
12175 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12176 PL_tmps_ix = proto_perl->Ttmps_ix;
12177 PL_tmps_max = proto_perl->Ttmps_max;
12178 PL_tmps_floor = proto_perl->Ttmps_floor;
12179 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12181 while (i <= PL_tmps_ix) {
12182 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12186 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12187 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12188 Newz(54, PL_markstack, i, I32);
12189 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12190 - proto_perl->Tmarkstack);
12191 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12192 - proto_perl->Tmarkstack);
12193 Copy(proto_perl->Tmarkstack, PL_markstack,
12194 PL_markstack_ptr - PL_markstack + 1, I32);
12196 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12197 * NOTE: unlike the others! */
12198 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12199 PL_scopestack_max = proto_perl->Tscopestack_max;
12200 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12201 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12203 /* NOTE: si_dup() looks at PL_markstack */
12204 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12206 /* PL_curstack = PL_curstackinfo->si_stack; */
12207 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12208 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12210 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12211 PL_stack_base = AvARRAY(PL_curstack);
12212 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12213 - proto_perl->Tstack_base);
12214 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12216 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12217 * NOTE: unlike the others! */
12218 PL_savestack_ix = proto_perl->Tsavestack_ix;
12219 PL_savestack_max = proto_perl->Tsavestack_max;
12220 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12221 PL_savestack = ss_dup(proto_perl, param);
12225 ENTER; /* perl_destruct() wants to LEAVE; */
12228 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12229 PL_top_env = &PL_start_env;
12231 PL_op = proto_perl->Top;
12234 PL_Xpv = (XPV*)NULL;
12235 PL_na = proto_perl->Tna;
12237 PL_statbuf = proto_perl->Tstatbuf;
12238 PL_statcache = proto_perl->Tstatcache;
12239 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12240 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12242 PL_timesbuf = proto_perl->Ttimesbuf;
12245 PL_tainted = proto_perl->Ttainted;
12246 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12247 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12248 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12249 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12250 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12251 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12252 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12253 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12254 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12256 PL_restartop = proto_perl->Trestartop;
12257 PL_in_eval = proto_perl->Tin_eval;
12258 PL_delaymagic = proto_perl->Tdelaymagic;
12259 PL_dirty = proto_perl->Tdirty;
12260 PL_localizing = proto_perl->Tlocalizing;
12262 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12263 PL_hv_fetch_ent_mh = Nullhe;
12264 PL_modcount = proto_perl->Tmodcount;
12265 PL_lastgotoprobe = Nullop;
12266 PL_dumpindent = proto_perl->Tdumpindent;
12268 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12269 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12270 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12271 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12272 PL_sortcxix = proto_perl->Tsortcxix;
12273 PL_efloatbuf = Nullch; /* reinits on demand */
12274 PL_efloatsize = 0; /* reinits on demand */
12278 PL_screamfirst = NULL;
12279 PL_screamnext = NULL;
12280 PL_maxscream = -1; /* reinits on demand */
12281 PL_lastscream = Nullsv;
12283 PL_watchaddr = NULL;
12284 PL_watchok = Nullch;
12286 PL_regdummy = proto_perl->Tregdummy;
12287 PL_regprecomp = Nullch;
12290 PL_colorset = 0; /* reinits PL_colors[] */
12291 /*PL_colors[6] = {0,0,0,0,0,0};*/
12292 PL_reginput = Nullch;
12293 PL_regbol = Nullch;
12294 PL_regeol = Nullch;
12295 PL_regstartp = (I32*)NULL;
12296 PL_regendp = (I32*)NULL;
12297 PL_reglastparen = (U32*)NULL;
12298 PL_reglastcloseparen = (U32*)NULL;
12299 PL_regtill = Nullch;
12300 PL_reg_start_tmp = (char**)NULL;
12301 PL_reg_start_tmpl = 0;
12302 PL_regdata = (struct reg_data*)NULL;
12305 PL_reg_eval_set = 0;
12307 PL_regprogram = (regnode*)NULL;
12309 PL_regcc = (CURCUR*)NULL;
12310 PL_reg_call_cc = (struct re_cc_state*)NULL;
12311 PL_reg_re = (regexp*)NULL;
12312 PL_reg_ganch = Nullch;
12313 PL_reg_sv = Nullsv;
12314 PL_reg_match_utf8 = FALSE;
12315 PL_reg_magic = (MAGIC*)NULL;
12317 PL_reg_oldcurpm = (PMOP*)NULL;
12318 PL_reg_curpm = (PMOP*)NULL;
12319 PL_reg_oldsaved = Nullch;
12320 PL_reg_oldsavedlen = 0;
12321 #ifdef PERL_COPY_ON_WRITE
12324 PL_reg_maxiter = 0;
12325 PL_reg_leftiter = 0;
12326 PL_reg_poscache = Nullch;
12327 PL_reg_poscache_size= 0;
12329 /* RE engine - function pointers */
12330 PL_regcompp = proto_perl->Tregcompp;
12331 PL_regexecp = proto_perl->Tregexecp;
12332 PL_regint_start = proto_perl->Tregint_start;
12333 PL_regint_string = proto_perl->Tregint_string;
12334 PL_regfree = proto_perl->Tregfree;
12336 PL_reginterp_cnt = 0;
12337 PL_reg_starttry = 0;
12339 /* Pluggable optimizer */
12340 PL_peepp = proto_perl->Tpeepp;
12342 PL_stashcache = newHV();
12344 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12345 ptr_table_free(PL_ptr_table);
12346 PL_ptr_table = NULL;
12349 /* Call the ->CLONE method, if it exists, for each of the stashes
12350 identified by sv_dup() above.
12352 while(av_len(param->stashes) != -1) {
12353 HV* stash = (HV*) av_shift(param->stashes);
12354 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12355 if (cloner && GvCV(cloner)) {
12360 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12362 call_sv((SV*)GvCV(cloner), G_DISCARD);
12368 SvREFCNT_dec(param->stashes);
12373 #endif /* USE_ITHREADS */
12376 =head1 Unicode Support
12378 =for apidoc sv_recode_to_utf8
12380 The encoding is assumed to be an Encode object, on entry the PV
12381 of the sv is assumed to be octets in that encoding, and the sv
12382 will be converted into Unicode (and UTF-8).
12384 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12385 is not a reference, nothing is done to the sv. If the encoding is not
12386 an C<Encode::XS> Encoding object, bad things will happen.
12387 (See F<lib/encoding.pm> and L<Encode>).
12389 The PV of the sv is returned.
12394 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12396 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12410 Passing sv_yes is wrong - it needs to be or'ed set of constants
12411 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12412 remove converted chars from source.
12414 Both will default the value - let them.
12416 XPUSHs(&PL_sv_yes);
12419 call_method("decode", G_SCALAR);
12423 s = SvPV(uni, len);
12424 if (s != SvPVX(sv)) {
12425 SvGROW(sv, len + 1);
12426 Move(s, SvPVX(sv), len, char);
12427 SvCUR_set(sv, len);
12428 SvPVX(sv)[len] = 0;
12435 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12439 =for apidoc sv_cat_decode
12441 The encoding is assumed to be an Encode object, the PV of the ssv is
12442 assumed to be octets in that encoding and decoding the input starts
12443 from the position which (PV + *offset) pointed to. The dsv will be
12444 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12445 when the string tstr appears in decoding output or the input ends on
12446 the PV of the ssv. The value which the offset points will be modified
12447 to the last input position on the ssv.
12449 Returns TRUE if the terminator was found, else returns FALSE.
12454 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12455 SV *ssv, int *offset, char *tstr, int tlen)
12458 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12469 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12470 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12472 call_method("cat_decode", G_SCALAR);
12474 ret = SvTRUE(TOPs);
12475 *offset = SvIV(offsv);
12481 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12487 * c-indentation-style: bsd
12488 * c-basic-offset: 4
12489 * indent-tabs-mode: t
12492 * vim: shiftwidth=4: