3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
168 #ifdef DEBUG_LEAKING_SCALARS
170 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
172 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
175 # define FREE_SV_DEBUG_FILE(sv)
178 #define plant_SV(p) \
180 FREE_SV_DEBUG_FILE(p); \
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
187 /* sv_mutex must be held while calling uproot_SV() */
188 #define uproot_SV(p) \
191 PL_sv_root = (SV*)SvANY(p); \
196 /* new_SV(): return a new, empty SV head */
198 #ifdef DEBUG_LEAKING_SCALARS
199 /* provide a real function for a debugger to play with */
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
227 # define new_SV(p) (p)=S_new_SV(aTHX)
245 /* del_SV(): return an empty SV head to the free list */
260 S_del_sv(pTHX_ SV *p)
267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
269 svend = &sva[SvREFCNT(sva)];
270 if (p >= sv && p < svend)
274 if (ckWARN_d(WARN_INTERNAL))
275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
284 #else /* ! DEBUGGING */
286 #define del_SV(p) plant_SV(p)
288 #endif /* DEBUGGING */
292 =head1 SV Manipulation Functions
294 =for apidoc sv_add_arena
296 Given a chunk of memory, link it to the head of the list of arenas,
297 and split it into a list of free SVs.
303 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
309 /* The first SV in an arena isn't an SV. */
310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
317 svend = &sva[SvREFCNT(sva) - 1];
320 SvANY(sv) = (void *)(SV*)(sv + 1);
322 SvFLAGS(sv) = SVTYPEMASK;
326 SvFLAGS(sv) = SVTYPEMASK;
329 /* make some more SVs by adding another arena */
331 /* sv_mutex must be held while calling more_sv() */
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
340 PL_nice_chunk_size = 0;
343 char *chunk; /* must use New here to match call to */
344 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
345 sv_add_arena(chunk, 1008, 0);
351 /* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
355 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 svend = &sva[SvREFCNT(sva)];
364 for (sv = sva + 1; sv < svend; ++sv) {
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
379 /* called by sv_report_used() for each live SV */
382 do_report_used(pTHX_ SV *sv)
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
392 =for apidoc sv_report_used
394 Dump the contents of all SVs not yet freed. (Debugging aid).
400 Perl_sv_report_used(pTHX)
403 visit(do_report_used, 0, 0);
407 /* called by sv_clean_objs() for each live SV */
410 do_clean_objs(pTHX_ SV *sv)
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
427 /* XXX Might want to check arrays, etc. */
430 /* called by sv_clean_objs() for each live SV */
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
434 do_clean_named_objs(pTHX_ SV *sv)
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
444 SvFLAGS(sv) |= SVf_BREAK;
452 =for apidoc sv_clean_objs
454 Attempt to destroy all objects not yet freed
460 Perl_sv_clean_objs(pTHX)
462 PL_in_clean_objs = TRUE;
463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
464 #ifndef DISABLE_DESTRUCTOR_KLUDGE
465 /* some barnacles may yet remain, clinging to typeglobs */
466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
468 PL_in_clean_objs = FALSE;
471 /* called by sv_clean_all() for each live SV */
474 do_clean_all(pTHX_ SV *sv)
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
478 if (PL_comppad == (AV*)sv) {
480 PL_curpad = Null(SV**);
486 =for apidoc sv_clean_all
488 Decrement the refcnt of each remaining SV, possibly triggering a
489 cleanup. This function may have to be called multiple times to free
490 SVs which are in complex self-referential hierarchies.
496 Perl_sv_clean_all(pTHX)
499 PL_in_clean_all = TRUE;
500 cleaned = visit(do_clean_all, 0,0);
501 PL_in_clean_all = FALSE;
506 =for apidoc sv_free_arenas
508 Deallocate the memory used by all arenas. Note that all the individual SV
509 heads and bodies within the arenas must already have been freed.
515 Perl_sv_free_arenas(pTHX)
519 XPV *arena, *arenanext;
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
530 Safefree((void *)sva);
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xiv_arenaroot = 0;
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xrv_arenaroot = 0;
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xpv_arenaroot = 0;
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpviv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpvnv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvcv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvav_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvhv_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvmg_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvbm_arenaroot = 0;
617 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
625 Safefree(PL_nice_chunk);
626 PL_nice_chunk = Nullch;
627 PL_nice_chunk_size = 0;
632 /* ---------------------------------------------------------------------
634 * support functions for report_uninit()
637 /* the maxiumum size of array or hash where we will scan looking
638 * for the undefined element that triggered the warning */
640 #define FUV_MAX_SEARCH_SIZE 1000
642 /* Look for an entry in the hash whose value has the same SV as val;
643 * If so, return a mortal copy of the key. */
646 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
652 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
653 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
658 for (i=HvMAX(hv); i>0; i--) {
659 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
660 if (HeVAL(entry) != val)
662 if ( HeVAL(entry) == &PL_sv_undef ||
663 HeVAL(entry) == &PL_sv_placeholder)
667 if (HeKLEN(entry) == HEf_SVKEY)
668 return sv_mortalcopy(HeKEY_sv(entry));
669 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
675 /* Look for an entry in the array whose value has the same SV as val;
676 * If so, return the index, otherwise return -1. */
679 S_find_array_subscript(pTHX_ AV *av, SV* val)
683 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
684 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
688 for (i=AvFILLp(av); i>=0; i--) {
689 if (svp[i] == val && svp[i] != &PL_sv_undef)
695 /* S_varname(): return the name of a variable, optionally with a subscript.
696 * If gv is non-zero, use the name of that global, along with gvtype (one
697 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
698 * targ. Depending on the value of the subscript_type flag, return:
701 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
702 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
703 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
704 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
707 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
708 SV* keyname, I32 aindex, int subscript_type)
714 name = sv_newmortal();
717 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
718 * XXX get rid of all this if gv_fullnameX() ever supports this
722 HV *hv = GvSTASH(gv);
723 sv_setpv(name, gvtype);
726 else if (!(p=HvNAME(hv)))
728 if (strNE(p, "main")) {
730 sv_catpvn(name,"::", 2);
732 if (GvNAMELEN(gv)>= 1 &&
733 ((unsigned int)*GvNAME(gv)) <= 26)
735 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
736 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
739 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
743 CV *cv = find_runcv(&u);
744 if (!cv || !CvPADLIST(cv))
746 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
747 sv = *av_fetch(av, targ, FALSE);
748 /* SvLEN in a pad name is not to be trusted */
749 sv_setpv(name, SvPV_nolen(sv));
752 if (subscript_type == FUV_SUBSCRIPT_HASH) {
755 Perl_sv_catpvf(aTHX_ name, "{%s}",
756 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
759 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
761 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
763 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
764 sv_insert(name, 0, 0, "within ", 7);
771 =for apidoc find_uninit_var
773 Find the name of the undefined variable (if any) that caused the operator o
774 to issue a "Use of uninitialized value" warning.
775 If match is true, only return a name if it's value matches uninit_sv.
776 So roughly speaking, if a unary operator (such as OP_COS) generates a
777 warning, then following the direct child of the op may yield an
778 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
779 other hand, with OP_ADD there are two branches to follow, so we only print
780 the variable name if we get an exact match.
782 The name is returned as a mortal SV.
784 Assumes that PL_op is the op that originally triggered the error, and that
785 PL_comppad/PL_curpad points to the currently executing pad.
791 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
799 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
800 uninit_sv == &PL_sv_placeholder)))
803 switch (obase->op_type) {
810 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
811 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
814 int subscript_type = FUV_SUBSCRIPT_WITHIN;
816 if (pad) { /* @lex, %lex */
817 sv = PAD_SVl(obase->op_targ);
821 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
822 /* @global, %global */
823 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
826 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
828 else /* @{expr}, %{expr} */
829 return find_uninit_var(cUNOPx(obase)->op_first,
833 /* attempt to find a match within the aggregate */
835 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
837 subscript_type = FUV_SUBSCRIPT_HASH;
840 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
842 subscript_type = FUV_SUBSCRIPT_ARRAY;
845 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
848 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
849 keysv, index, subscript_type);
853 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
855 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
856 Nullsv, 0, FUV_SUBSCRIPT_NONE);
859 gv = cGVOPx_gv(obase);
860 if (!gv || (match && GvSV(gv) != uninit_sv))
862 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
865 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
867 av = (AV*)PAD_SV(obase->op_targ);
868 if (!av || SvRMAGICAL(av))
870 svp = av_fetch(av, (I32)obase->op_private, FALSE);
871 if (!svp || *svp != uninit_sv)
874 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
875 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
878 gv = cGVOPx_gv(obase);
883 if (!av || SvRMAGICAL(av))
885 svp = av_fetch(av, (I32)obase->op_private, FALSE);
886 if (!svp || *svp != uninit_sv)
889 return S_varname(aTHX_ gv, "$", 0,
890 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
895 o = cUNOPx(obase)->op_first;
896 if (!o || o->op_type != OP_NULL ||
897 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
899 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
904 /* $a[uninit_expr] or $h{uninit_expr} */
905 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
908 o = cBINOPx(obase)->op_first;
909 kid = cBINOPx(obase)->op_last;
911 /* get the av or hv, and optionally the gv */
913 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
914 sv = PAD_SV(o->op_targ);
916 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
917 && cUNOPo->op_first->op_type == OP_GV)
919 gv = cGVOPx_gv(cUNOPo->op_first);
922 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
927 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
928 /* index is constant */
932 if (obase->op_type == OP_HELEM) {
933 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
934 if (!he || HeVAL(he) != uninit_sv)
938 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
939 if (!svp || *svp != uninit_sv)
943 if (obase->op_type == OP_HELEM)
944 return S_varname(aTHX_ gv, "%", o->op_targ,
945 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
947 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
948 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
952 /* index is an expression;
953 * attempt to find a match within the aggregate */
954 if (obase->op_type == OP_HELEM) {
955 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
957 return S_varname(aTHX_ gv, "%", o->op_targ,
958 keysv, 0, FUV_SUBSCRIPT_HASH);
961 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
963 return S_varname(aTHX_ gv, "@", o->op_targ,
964 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
968 return S_varname(aTHX_ gv,
969 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
971 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
977 /* only examine RHS */
978 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
981 o = cUNOPx(obase)->op_first;
982 if (o->op_type == OP_PUSHMARK)
985 if (!o->op_sibling) {
986 /* one-arg version of open is highly magical */
988 if (o->op_type == OP_GV) { /* open FOO; */
990 if (match && GvSV(gv) != uninit_sv)
992 return S_varname(aTHX_ gv, "$", 0,
993 Nullsv, 0, FUV_SUBSCRIPT_NONE);
995 /* other possibilities not handled are:
996 * open $x; or open my $x; should return '${*$x}'
997 * open expr; should return '$'.expr ideally
1003 /* ops where $_ may be an implicit arg */
1007 if ( !(obase->op_flags & OPf_STACKED)) {
1008 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1009 ? PAD_SVl(obase->op_targ)
1012 sv = sv_newmortal();
1021 /* skip filehandle as it can't produce 'undef' warning */
1022 o = cUNOPx(obase)->op_first;
1023 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1024 o = o->op_sibling->op_sibling;
1031 match = 1; /* XS or custom code could trigger random warnings */
1036 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1037 return sv_2mortal(newSVpv("${$/}", 0));
1042 if (!(obase->op_flags & OPf_KIDS))
1044 o = cUNOPx(obase)->op_first;
1050 /* if all except one arg are constant, or have no side-effects,
1051 * or are optimized away, then it's unambiguous */
1053 for (kid=o; kid; kid = kid->op_sibling) {
1055 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1056 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1057 || (kid->op_type == OP_PUSHMARK)
1061 if (o2) { /* more than one found */
1068 return find_uninit_var(o2, uninit_sv, match);
1072 sv = find_uninit_var(o, uninit_sv, 1);
1084 =for apidoc report_uninit
1086 Print appropriate "Use of uninitialized variable" warning
1092 Perl_report_uninit(pTHX_ SV* uninit_sv)
1095 SV* varname = Nullsv;
1097 varname = find_uninit_var(PL_op, uninit_sv,0);
1099 sv_insert(varname, 0, 0, " ", 1);
1101 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1102 varname ? SvPV_nolen(varname) : "",
1103 " in ", OP_DESC(PL_op));
1106 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1110 /* grab a new IV body from the free list, allocating more if necessary */
1121 * See comment in more_xiv() -- RAM.
1123 PL_xiv_root = *(IV**)xiv;
1125 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1128 /* return an IV body to the free list */
1131 S_del_xiv(pTHX_ XPVIV *p)
1133 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1135 *(IV**)xiv = PL_xiv_root;
1140 /* allocate another arena's worth of IV bodies */
1146 register IV* xivend;
1148 New(705, ptr, 1008/sizeof(XPV), XPV);
1149 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1150 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1153 xivend = &xiv[1008 / sizeof(IV) - 1];
1154 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1156 while (xiv < xivend) {
1157 *(IV**)xiv = (IV *)(xiv + 1);
1163 /* grab a new NV body from the free list, allocating more if necessary */
1173 PL_xnv_root = *(NV**)xnv;
1175 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1178 /* return an NV body to the free list */
1181 S_del_xnv(pTHX_ XPVNV *p)
1183 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1185 *(NV**)xnv = PL_xnv_root;
1190 /* allocate another arena's worth of NV bodies */
1196 register NV* xnvend;
1198 New(711, ptr, 1008/sizeof(XPV), XPV);
1199 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1200 PL_xnv_arenaroot = ptr;
1203 xnvend = &xnv[1008 / sizeof(NV) - 1];
1204 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1206 while (xnv < xnvend) {
1207 *(NV**)xnv = (NV*)(xnv + 1);
1213 /* grab a new struct xrv from the free list, allocating more if necessary */
1223 PL_xrv_root = (XRV*)xrv->xrv_rv;
1228 /* return a struct xrv to the free list */
1231 S_del_xrv(pTHX_ XRV *p)
1234 p->xrv_rv = (SV*)PL_xrv_root;
1239 /* allocate another arena's worth of struct xrv */
1245 register XRV* xrvend;
1247 New(712, ptr, 1008/sizeof(XPV), XPV);
1248 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1249 PL_xrv_arenaroot = ptr;
1252 xrvend = &xrv[1008 / sizeof(XRV) - 1];
1253 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1255 while (xrv < xrvend) {
1256 xrv->xrv_rv = (SV*)(xrv + 1);
1262 /* grab a new struct xpv from the free list, allocating more if necessary */
1272 PL_xpv_root = (XPV*)xpv->xpv_pv;
1277 /* return a struct xpv to the free list */
1280 S_del_xpv(pTHX_ XPV *p)
1283 p->xpv_pv = (char*)PL_xpv_root;
1288 /* allocate another arena's worth of struct xpv */
1294 register XPV* xpvend;
1295 New(713, xpv, 1008/sizeof(XPV), XPV);
1296 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1297 PL_xpv_arenaroot = xpv;
1299 xpvend = &xpv[1008 / sizeof(XPV) - 1];
1300 PL_xpv_root = ++xpv;
1301 while (xpv < xpvend) {
1302 xpv->xpv_pv = (char*)(xpv + 1);
1308 /* grab a new struct xpviv from the free list, allocating more if necessary */
1317 xpviv = PL_xpviv_root;
1318 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1323 /* return a struct xpviv to the free list */
1326 S_del_xpviv(pTHX_ XPVIV *p)
1329 p->xpv_pv = (char*)PL_xpviv_root;
1334 /* allocate another arena's worth of struct xpviv */
1339 register XPVIV* xpviv;
1340 register XPVIV* xpvivend;
1341 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
1342 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1343 PL_xpviv_arenaroot = xpviv;
1345 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
1346 PL_xpviv_root = ++xpviv;
1347 while (xpviv < xpvivend) {
1348 xpviv->xpv_pv = (char*)(xpviv + 1);
1354 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1363 xpvnv = PL_xpvnv_root;
1364 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1369 /* return a struct xpvnv to the free list */
1372 S_del_xpvnv(pTHX_ XPVNV *p)
1375 p->xpv_pv = (char*)PL_xpvnv_root;
1380 /* allocate another arena's worth of struct xpvnv */
1385 register XPVNV* xpvnv;
1386 register XPVNV* xpvnvend;
1387 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
1388 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1389 PL_xpvnv_arenaroot = xpvnv;
1391 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
1392 PL_xpvnv_root = ++xpvnv;
1393 while (xpvnv < xpvnvend) {
1394 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1400 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1409 xpvcv = PL_xpvcv_root;
1410 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1415 /* return a struct xpvcv to the free list */
1418 S_del_xpvcv(pTHX_ XPVCV *p)
1421 p->xpv_pv = (char*)PL_xpvcv_root;
1426 /* allocate another arena's worth of struct xpvcv */
1431 register XPVCV* xpvcv;
1432 register XPVCV* xpvcvend;
1433 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
1434 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1435 PL_xpvcv_arenaroot = xpvcv;
1437 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
1438 PL_xpvcv_root = ++xpvcv;
1439 while (xpvcv < xpvcvend) {
1440 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1446 /* grab a new struct xpvav from the free list, allocating more if necessary */
1455 xpvav = PL_xpvav_root;
1456 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1461 /* return a struct xpvav to the free list */
1464 S_del_xpvav(pTHX_ XPVAV *p)
1467 p->xav_array = (char*)PL_xpvav_root;
1472 /* allocate another arena's worth of struct xpvav */
1477 register XPVAV* xpvav;
1478 register XPVAV* xpvavend;
1479 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
1480 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1481 PL_xpvav_arenaroot = xpvav;
1483 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
1484 PL_xpvav_root = ++xpvav;
1485 while (xpvav < xpvavend) {
1486 xpvav->xav_array = (char*)(xpvav + 1);
1489 xpvav->xav_array = 0;
1492 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1501 xpvhv = PL_xpvhv_root;
1502 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1507 /* return a struct xpvhv to the free list */
1510 S_del_xpvhv(pTHX_ XPVHV *p)
1513 p->xhv_array = (char*)PL_xpvhv_root;
1518 /* allocate another arena's worth of struct xpvhv */
1523 register XPVHV* xpvhv;
1524 register XPVHV* xpvhvend;
1525 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1526 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1527 PL_xpvhv_arenaroot = xpvhv;
1529 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1530 PL_xpvhv_root = ++xpvhv;
1531 while (xpvhv < xpvhvend) {
1532 xpvhv->xhv_array = (char*)(xpvhv + 1);
1535 xpvhv->xhv_array = 0;
1538 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1547 xpvmg = PL_xpvmg_root;
1548 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1553 /* return a struct xpvmg to the free list */
1556 S_del_xpvmg(pTHX_ XPVMG *p)
1559 p->xpv_pv = (char*)PL_xpvmg_root;
1564 /* allocate another arena's worth of struct xpvmg */
1569 register XPVMG* xpvmg;
1570 register XPVMG* xpvmgend;
1571 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1572 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1573 PL_xpvmg_arenaroot = xpvmg;
1575 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1576 PL_xpvmg_root = ++xpvmg;
1577 while (xpvmg < xpvmgend) {
1578 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1584 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1593 xpvlv = PL_xpvlv_root;
1594 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1599 /* return a struct xpvlv to the free list */
1602 S_del_xpvlv(pTHX_ XPVLV *p)
1605 p->xpv_pv = (char*)PL_xpvlv_root;
1610 /* allocate another arena's worth of struct xpvlv */
1615 register XPVLV* xpvlv;
1616 register XPVLV* xpvlvend;
1617 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1618 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1619 PL_xpvlv_arenaroot = xpvlv;
1621 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1622 PL_xpvlv_root = ++xpvlv;
1623 while (xpvlv < xpvlvend) {
1624 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1630 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1639 xpvbm = PL_xpvbm_root;
1640 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1645 /* return a struct xpvbm to the free list */
1648 S_del_xpvbm(pTHX_ XPVBM *p)
1651 p->xpv_pv = (char*)PL_xpvbm_root;
1656 /* allocate another arena's worth of struct xpvbm */
1661 register XPVBM* xpvbm;
1662 register XPVBM* xpvbmend;
1663 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1664 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1665 PL_xpvbm_arenaroot = xpvbm;
1667 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1668 PL_xpvbm_root = ++xpvbm;
1669 while (xpvbm < xpvbmend) {
1670 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1676 #define my_safemalloc(s) (void*)safemalloc(s)
1677 #define my_safefree(p) safefree((char*)p)
1681 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1682 #define del_XIV(p) my_safefree(p)
1684 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1685 #define del_XNV(p) my_safefree(p)
1687 #define new_XRV() my_safemalloc(sizeof(XRV))
1688 #define del_XRV(p) my_safefree(p)
1690 #define new_XPV() my_safemalloc(sizeof(XPV))
1691 #define del_XPV(p) my_safefree(p)
1693 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1694 #define del_XPVIV(p) my_safefree(p)
1696 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1697 #define del_XPVNV(p) my_safefree(p)
1699 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1700 #define del_XPVCV(p) my_safefree(p)
1702 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1703 #define del_XPVAV(p) my_safefree(p)
1705 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1706 #define del_XPVHV(p) my_safefree(p)
1708 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1709 #define del_XPVMG(p) my_safefree(p)
1711 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1712 #define del_XPVLV(p) my_safefree(p)
1714 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1715 #define del_XPVBM(p) my_safefree(p)
1719 #define new_XIV() (void*)new_xiv()
1720 #define del_XIV(p) del_xiv((XPVIV*) p)
1722 #define new_XNV() (void*)new_xnv()
1723 #define del_XNV(p) del_xnv((XPVNV*) p)
1725 #define new_XRV() (void*)new_xrv()
1726 #define del_XRV(p) del_xrv((XRV*) p)
1728 #define new_XPV() (void*)new_xpv()
1729 #define del_XPV(p) del_xpv((XPV *)p)
1731 #define new_XPVIV() (void*)new_xpviv()
1732 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1734 #define new_XPVNV() (void*)new_xpvnv()
1735 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1737 #define new_XPVCV() (void*)new_xpvcv()
1738 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1740 #define new_XPVAV() (void*)new_xpvav()
1741 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1743 #define new_XPVHV() (void*)new_xpvhv()
1744 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1746 #define new_XPVMG() (void*)new_xpvmg()
1747 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1749 #define new_XPVLV() (void*)new_xpvlv()
1750 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1752 #define new_XPVBM() (void*)new_xpvbm()
1753 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1757 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1758 #define del_XPVGV(p) my_safefree(p)
1760 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1761 #define del_XPVFM(p) my_safefree(p)
1763 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1764 #define del_XPVIO(p) my_safefree(p)
1767 =for apidoc sv_upgrade
1769 Upgrade an SV to a more complex form. Generally adds a new body type to the
1770 SV, then copies across as much information as possible from the old body.
1771 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1777 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1785 MAGIC* magic = NULL;
1788 if (mt != SVt_PV && SvIsCOW(sv)) {
1789 sv_force_normal_flags(sv, 0);
1792 if (SvTYPE(sv) == mt)
1796 (void)SvOOK_off(sv);
1798 switch (SvTYPE(sv)) {
1819 else if (mt < SVt_PVIV)
1836 pv = (char*)SvRV(sv);
1856 else if (mt == SVt_NV)
1867 del_XPVIV(SvANY(sv));
1877 del_XPVNV(SvANY(sv));
1885 magic = SvMAGIC(sv);
1886 stash = SvSTASH(sv);
1887 del_XPVMG(SvANY(sv));
1890 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1893 SvFLAGS(sv) &= ~SVTYPEMASK;
1898 Perl_croak(aTHX_ "Can't upgrade to undef");
1900 SvANY(sv) = new_XIV();
1904 SvANY(sv) = new_XNV();
1908 SvANY(sv) = new_XRV();
1912 SvANY(sv) = new_XPV();
1918 SvANY(sv) = new_XPVIV();
1928 SvANY(sv) = new_XPVNV();
1936 SvANY(sv) = new_XPVMG();
1942 SvMAGIC(sv) = magic;
1943 SvSTASH(sv) = stash;
1946 SvANY(sv) = new_XPVLV();
1952 SvMAGIC(sv) = magic;
1953 SvSTASH(sv) = stash;
1965 SvANY(sv) = new_XPVAV();
1973 SvMAGIC(sv) = magic;
1974 SvSTASH(sv) = stash;
1977 AvFLAGS(sv) = AVf_REAL;
1980 SvANY(sv) = new_XPVHV();
1986 HvTOTALKEYS(sv) = 0;
1987 HvPLACEHOLDERS(sv) = 0;
1988 SvMAGIC(sv) = magic;
1989 SvSTASH(sv) = stash;
1996 SvANY(sv) = new_XPVCV();
1997 Zero(SvANY(sv), 1, XPVCV);
2003 SvMAGIC(sv) = magic;
2004 SvSTASH(sv) = stash;
2007 SvANY(sv) = new_XPVGV();
2013 SvMAGIC(sv) = magic;
2014 SvSTASH(sv) = stash;
2022 SvANY(sv) = new_XPVBM();
2028 SvMAGIC(sv) = magic;
2029 SvSTASH(sv) = stash;
2035 SvANY(sv) = new_XPVFM();
2036 Zero(SvANY(sv), 1, XPVFM);
2042 SvMAGIC(sv) = magic;
2043 SvSTASH(sv) = stash;
2046 SvANY(sv) = new_XPVIO();
2047 Zero(SvANY(sv), 1, XPVIO);
2053 SvMAGIC(sv) = magic;
2054 SvSTASH(sv) = stash;
2055 IoPAGE_LEN(sv) = 60;
2062 =for apidoc sv_backoff
2064 Remove any string offset. You should normally use the C<SvOOK_off> macro
2071 Perl_sv_backoff(pTHX_ register SV *sv)
2075 char *s = SvPVX(sv);
2076 SvLEN(sv) += SvIVX(sv);
2077 SvPVX(sv) -= SvIVX(sv);
2079 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2081 SvFLAGS(sv) &= ~SVf_OOK;
2088 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2089 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2090 Use the C<SvGROW> wrapper instead.
2096 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2100 #ifdef HAS_64K_LIMIT
2101 if (newlen >= 0x10000) {
2102 PerlIO_printf(Perl_debug_log,
2103 "Allocation too large: %"UVxf"\n", (UV)newlen);
2106 #endif /* HAS_64K_LIMIT */
2109 if (SvTYPE(sv) < SVt_PV) {
2110 sv_upgrade(sv, SVt_PV);
2113 else if (SvOOK(sv)) { /* pv is offset? */
2116 if (newlen > SvLEN(sv))
2117 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2118 #ifdef HAS_64K_LIMIT
2119 if (newlen >= 0x10000)
2126 if (newlen > SvLEN(sv)) { /* need more room? */
2127 if (SvLEN(sv) && s) {
2129 STRLEN l = malloced_size((void*)SvPVX(sv));
2135 Renew(s,newlen,char);
2138 New(703, s, newlen, char);
2139 if (SvPVX(sv) && SvCUR(sv)) {
2140 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2144 SvLEN_set(sv, newlen);
2150 =for apidoc sv_setiv
2152 Copies an integer into the given SV, upgrading first if necessary.
2153 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2159 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2161 SV_CHECK_THINKFIRST_COW_DROP(sv);
2162 switch (SvTYPE(sv)) {
2164 sv_upgrade(sv, SVt_IV);
2167 sv_upgrade(sv, SVt_PVNV);
2171 sv_upgrade(sv, SVt_PVIV);
2180 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2183 (void)SvIOK_only(sv); /* validate number */
2189 =for apidoc sv_setiv_mg
2191 Like C<sv_setiv>, but also handles 'set' magic.
2197 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2204 =for apidoc sv_setuv
2206 Copies an unsigned integer into the given SV, upgrading first if necessary.
2207 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2213 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2215 /* With these two if statements:
2216 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2219 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2221 If you wish to remove them, please benchmark to see what the effect is
2223 if (u <= (UV)IV_MAX) {
2224 sv_setiv(sv, (IV)u);
2233 =for apidoc sv_setuv_mg
2235 Like C<sv_setuv>, but also handles 'set' magic.
2241 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2243 /* With these two if statements:
2244 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2247 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2249 If you wish to remove them, please benchmark to see what the effect is
2251 if (u <= (UV)IV_MAX) {
2252 sv_setiv(sv, (IV)u);
2262 =for apidoc sv_setnv
2264 Copies a double into the given SV, upgrading first if necessary.
2265 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2271 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2273 SV_CHECK_THINKFIRST_COW_DROP(sv);
2274 switch (SvTYPE(sv)) {
2277 sv_upgrade(sv, SVt_NV);
2282 sv_upgrade(sv, SVt_PVNV);
2291 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2295 (void)SvNOK_only(sv); /* validate number */
2300 =for apidoc sv_setnv_mg
2302 Like C<sv_setnv>, but also handles 'set' magic.
2308 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2314 /* Print an "isn't numeric" warning, using a cleaned-up,
2315 * printable version of the offending string
2319 S_not_a_number(pTHX_ SV *sv)
2326 dsv = sv_2mortal(newSVpv("", 0));
2327 pv = sv_uni_display(dsv, sv, 10, 0);
2330 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2331 /* each *s can expand to 4 chars + "...\0",
2332 i.e. need room for 8 chars */
2335 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2337 if (ch & 128 && !isPRINT_LC(ch)) {
2346 else if (ch == '\r') {
2350 else if (ch == '\f') {
2354 else if (ch == '\\') {
2358 else if (ch == '\0') {
2362 else if (isPRINT_LC(ch))
2379 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2380 "Argument \"%s\" isn't numeric in %s", pv,
2383 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2384 "Argument \"%s\" isn't numeric", pv);
2388 =for apidoc looks_like_number
2390 Test if the content of an SV looks like a number (or is a number).
2391 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2392 non-numeric warning), even if your atof() doesn't grok them.
2398 Perl_looks_like_number(pTHX_ SV *sv)
2400 register char *sbegin;
2407 else if (SvPOKp(sv))
2408 sbegin = SvPV(sv, len);
2410 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2411 return grok_number(sbegin, len, NULL);
2414 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2415 until proven guilty, assume that things are not that bad... */
2420 As 64 bit platforms often have an NV that doesn't preserve all bits of
2421 an IV (an assumption perl has been based on to date) it becomes necessary
2422 to remove the assumption that the NV always carries enough precision to
2423 recreate the IV whenever needed, and that the NV is the canonical form.
2424 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2425 precision as a side effect of conversion (which would lead to insanity
2426 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2427 1) to distinguish between IV/UV/NV slots that have cached a valid
2428 conversion where precision was lost and IV/UV/NV slots that have a
2429 valid conversion which has lost no precision
2430 2) to ensure that if a numeric conversion to one form is requested that
2431 would lose precision, the precise conversion (or differently
2432 imprecise conversion) is also performed and cached, to prevent
2433 requests for different numeric formats on the same SV causing
2434 lossy conversion chains. (lossless conversion chains are perfectly
2439 SvIOKp is true if the IV slot contains a valid value
2440 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2441 SvNOKp is true if the NV slot contains a valid value
2442 SvNOK is true only if the NV value is accurate
2445 while converting from PV to NV, check to see if converting that NV to an
2446 IV(or UV) would lose accuracy over a direct conversion from PV to
2447 IV(or UV). If it would, cache both conversions, return NV, but mark
2448 SV as IOK NOKp (ie not NOK).
2450 While converting from PV to IV, check to see if converting that IV to an
2451 NV would lose accuracy over a direct conversion from PV to NV. If it
2452 would, cache both conversions, flag similarly.
2454 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2455 correctly because if IV & NV were set NV *always* overruled.
2456 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2457 changes - now IV and NV together means that the two are interchangeable:
2458 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2460 The benefit of this is that operations such as pp_add know that if
2461 SvIOK is true for both left and right operands, then integer addition
2462 can be used instead of floating point (for cases where the result won't
2463 overflow). Before, floating point was always used, which could lead to
2464 loss of precision compared with integer addition.
2466 * making IV and NV equal status should make maths accurate on 64 bit
2468 * may speed up maths somewhat if pp_add and friends start to use
2469 integers when possible instead of fp. (Hopefully the overhead in
2470 looking for SvIOK and checking for overflow will not outweigh the
2471 fp to integer speedup)
2472 * will slow down integer operations (callers of SvIV) on "inaccurate"
2473 values, as the change from SvIOK to SvIOKp will cause a call into
2474 sv_2iv each time rather than a macro access direct to the IV slot
2475 * should speed up number->string conversion on integers as IV is
2476 favoured when IV and NV are equally accurate
2478 ####################################################################
2479 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2480 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2481 On the other hand, SvUOK is true iff UV.
2482 ####################################################################
2484 Your mileage will vary depending your CPU's relative fp to integer
2488 #ifndef NV_PRESERVES_UV
2489 # define IS_NUMBER_UNDERFLOW_IV 1
2490 # define IS_NUMBER_UNDERFLOW_UV 2
2491 # define IS_NUMBER_IV_AND_UV 2
2492 # define IS_NUMBER_OVERFLOW_IV 4
2493 # define IS_NUMBER_OVERFLOW_UV 5
2495 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2497 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2499 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2501 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2502 if (SvNVX(sv) < (NV)IV_MIN) {
2503 (void)SvIOKp_on(sv);
2506 return IS_NUMBER_UNDERFLOW_IV;
2508 if (SvNVX(sv) > (NV)UV_MAX) {
2509 (void)SvIOKp_on(sv);
2513 return IS_NUMBER_OVERFLOW_UV;
2515 (void)SvIOKp_on(sv);
2517 /* Can't use strtol etc to convert this string. (See truth table in
2519 if (SvNVX(sv) <= (UV)IV_MAX) {
2520 SvIVX(sv) = I_V(SvNVX(sv));
2521 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2522 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2524 /* Integer is imprecise. NOK, IOKp */
2526 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2529 SvUVX(sv) = U_V(SvNVX(sv));
2530 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2531 if (SvUVX(sv) == UV_MAX) {
2532 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2533 possibly be preserved by NV. Hence, it must be overflow.
2535 return IS_NUMBER_OVERFLOW_UV;
2537 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2539 /* Integer is imprecise. NOK, IOKp */
2541 return IS_NUMBER_OVERFLOW_IV;
2543 #endif /* !NV_PRESERVES_UV*/
2545 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2546 * this function provided for binary compatibility only
2550 Perl_sv_2iv(pTHX_ register SV *sv)
2552 return sv_2iv_flags(sv, SV_GMAGIC);
2556 =for apidoc sv_2iv_flags
2558 Return the integer value of an SV, doing any necessary string
2559 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2560 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2566 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2570 if (SvGMAGICAL(sv)) {
2571 if (flags & SV_GMAGIC)
2576 return I_V(SvNVX(sv));
2578 if (SvPOKp(sv) && SvLEN(sv))
2581 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2588 if (SvTHINKFIRST(sv)) {
2591 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2592 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2593 return SvIV(tmpstr);
2594 return PTR2IV(SvRV(sv));
2597 sv_force_normal_flags(sv, 0);
2599 if (SvREADONLY(sv) && !SvOK(sv)) {
2600 if (ckWARN(WARN_UNINITIALIZED))
2607 return (IV)(SvUVX(sv));
2614 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2615 * without also getting a cached IV/UV from it at the same time
2616 * (ie PV->NV conversion should detect loss of accuracy and cache
2617 * IV or UV at same time to avoid this. NWC */
2619 if (SvTYPE(sv) == SVt_NV)
2620 sv_upgrade(sv, SVt_PVNV);
2622 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2623 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2624 certainly cast into the IV range at IV_MAX, whereas the correct
2625 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2627 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2628 SvIVX(sv) = I_V(SvNVX(sv));
2629 if (SvNVX(sv) == (NV) SvIVX(sv)
2630 #ifndef NV_PRESERVES_UV
2631 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2632 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2633 /* Don't flag it as "accurately an integer" if the number
2634 came from a (by definition imprecise) NV operation, and
2635 we're outside the range of NV integer precision */
2638 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2639 DEBUG_c(PerlIO_printf(Perl_debug_log,
2640 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2646 /* IV not precise. No need to convert from PV, as NV
2647 conversion would already have cached IV if it detected
2648 that PV->IV would be better than PV->NV->IV
2649 flags already correct - don't set public IOK. */
2650 DEBUG_c(PerlIO_printf(Perl_debug_log,
2651 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2656 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2657 but the cast (NV)IV_MIN rounds to a the value less (more
2658 negative) than IV_MIN which happens to be equal to SvNVX ??
2659 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2660 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2661 (NV)UVX == NVX are both true, but the values differ. :-(
2662 Hopefully for 2s complement IV_MIN is something like
2663 0x8000000000000000 which will be exact. NWC */
2666 SvUVX(sv) = U_V(SvNVX(sv));
2668 (SvNVX(sv) == (NV) SvUVX(sv))
2669 #ifndef NV_PRESERVES_UV
2670 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2671 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2672 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2673 /* Don't flag it as "accurately an integer" if the number
2674 came from a (by definition imprecise) NV operation, and
2675 we're outside the range of NV integer precision */
2681 DEBUG_c(PerlIO_printf(Perl_debug_log,
2682 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2686 return (IV)SvUVX(sv);
2689 else if (SvPOKp(sv) && SvLEN(sv)) {
2691 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2692 /* We want to avoid a possible problem when we cache an IV which
2693 may be later translated to an NV, and the resulting NV is not
2694 the same as the direct translation of the initial string
2695 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2696 be careful to ensure that the value with the .456 is around if the
2697 NV value is requested in the future).
2699 This means that if we cache such an IV, we need to cache the
2700 NV as well. Moreover, we trade speed for space, and do not
2701 cache the NV if we are sure it's not needed.
2704 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2705 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2706 == IS_NUMBER_IN_UV) {
2707 /* It's definitely an integer, only upgrade to PVIV */
2708 if (SvTYPE(sv) < SVt_PVIV)
2709 sv_upgrade(sv, SVt_PVIV);
2711 } else if (SvTYPE(sv) < SVt_PVNV)
2712 sv_upgrade(sv, SVt_PVNV);
2714 /* If NV preserves UV then we only use the UV value if we know that
2715 we aren't going to call atof() below. If NVs don't preserve UVs
2716 then the value returned may have more precision than atof() will
2717 return, even though value isn't perfectly accurate. */
2718 if ((numtype & (IS_NUMBER_IN_UV
2719 #ifdef NV_PRESERVES_UV
2722 )) == IS_NUMBER_IN_UV) {
2723 /* This won't turn off the public IOK flag if it was set above */
2724 (void)SvIOKp_on(sv);
2726 if (!(numtype & IS_NUMBER_NEG)) {
2728 if (value <= (UV)IV_MAX) {
2729 SvIVX(sv) = (IV)value;
2735 /* 2s complement assumption */
2736 if (value <= (UV)IV_MIN) {
2737 SvIVX(sv) = -(IV)value;
2739 /* Too negative for an IV. This is a double upgrade, but
2740 I'm assuming it will be rare. */
2741 if (SvTYPE(sv) < SVt_PVNV)
2742 sv_upgrade(sv, SVt_PVNV);
2746 SvNV_set(sv, -(NV)value);
2751 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2752 will be in the previous block to set the IV slot, and the next
2753 block to set the NV slot. So no else here. */
2755 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2756 != IS_NUMBER_IN_UV) {
2757 /* It wasn't an (integer that doesn't overflow the UV). */
2758 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 SvIVX(sv) = I_V(SvNVX(sv));
2777 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2780 /* Integer is imprecise. NOK, IOKp */
2782 /* UV will not work better than IV */
2784 if (SvNVX(sv) > (NV)UV_MAX) {
2786 /* Integer is inaccurate. NOK, IOKp, is UV */
2790 SvUVX(sv) = U_V(SvNVX(sv));
2791 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2792 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2796 /* Integer is imprecise. NOK, IOKp, is UV */
2802 #else /* NV_PRESERVES_UV */
2803 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2804 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2805 /* The IV slot will have been set from value returned by
2806 grok_number above. The NV slot has just been set using
2809 assert (SvIOKp(sv));
2811 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2812 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2813 /* Small enough to preserve all bits. */
2814 (void)SvIOKp_on(sv);
2816 SvIVX(sv) = I_V(SvNVX(sv));
2817 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2819 /* Assumption: first non-preserved integer is < IV_MAX,
2820 this NV is in the preserved range, therefore: */
2821 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2823 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2827 0 0 already failed to read UV.
2828 0 1 already failed to read UV.
2829 1 0 you won't get here in this case. IV/UV
2830 slot set, public IOK, Atof() unneeded.
2831 1 1 already read UV.
2832 so there's no point in sv_2iuv_non_preserve() attempting
2833 to use atol, strtol, strtoul etc. */
2834 if (sv_2iuv_non_preserve (sv, numtype)
2835 >= IS_NUMBER_OVERFLOW_IV)
2839 #endif /* NV_PRESERVES_UV */
2842 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2844 if (SvTYPE(sv) < SVt_IV)
2845 /* Typically the caller expects that sv_any is not NULL now. */
2846 sv_upgrade(sv, SVt_IV);
2849 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2850 PTR2UV(sv),SvIVX(sv)));
2851 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2854 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2855 * this function provided for binary compatibility only
2859 Perl_sv_2uv(pTHX_ register SV *sv)
2861 return sv_2uv_flags(sv, SV_GMAGIC);
2865 =for apidoc sv_2uv_flags
2867 Return the unsigned integer value of an SV, doing any necessary string
2868 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2869 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2875 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2879 if (SvGMAGICAL(sv)) {
2880 if (flags & SV_GMAGIC)
2885 return U_V(SvNVX(sv));
2886 if (SvPOKp(sv) && SvLEN(sv))
2889 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2890 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2896 if (SvTHINKFIRST(sv)) {
2899 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2900 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2901 return SvUV(tmpstr);
2902 return PTR2UV(SvRV(sv));
2905 sv_force_normal_flags(sv, 0);
2907 if (SvREADONLY(sv) && !SvOK(sv)) {
2908 if (ckWARN(WARN_UNINITIALIZED))
2918 return (UV)SvIVX(sv);
2922 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2923 * without also getting a cached IV/UV from it at the same time
2924 * (ie PV->NV conversion should detect loss of accuracy and cache
2925 * IV or UV at same time to avoid this. */
2926 /* IV-over-UV optimisation - choose to cache IV if possible */
2928 if (SvTYPE(sv) == SVt_NV)
2929 sv_upgrade(sv, SVt_PVNV);
2931 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2932 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2933 SvIVX(sv) = I_V(SvNVX(sv));
2934 if (SvNVX(sv) == (NV) SvIVX(sv)
2935 #ifndef NV_PRESERVES_UV
2936 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2937 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2938 /* Don't flag it as "accurately an integer" if the number
2939 came from a (by definition imprecise) NV operation, and
2940 we're outside the range of NV integer precision */
2943 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2944 DEBUG_c(PerlIO_printf(Perl_debug_log,
2945 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2951 /* IV not precise. No need to convert from PV, as NV
2952 conversion would already have cached IV if it detected
2953 that PV->IV would be better than PV->NV->IV
2954 flags already correct - don't set public IOK. */
2955 DEBUG_c(PerlIO_printf(Perl_debug_log,
2956 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2961 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2962 but the cast (NV)IV_MIN rounds to a the value less (more
2963 negative) than IV_MIN which happens to be equal to SvNVX ??
2964 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2965 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2966 (NV)UVX == NVX are both true, but the values differ. :-(
2967 Hopefully for 2s complement IV_MIN is something like
2968 0x8000000000000000 which will be exact. NWC */
2971 SvUVX(sv) = U_V(SvNVX(sv));
2973 (SvNVX(sv) == (NV) SvUVX(sv))
2974 #ifndef NV_PRESERVES_UV
2975 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2976 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2977 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2978 /* Don't flag it as "accurately an integer" if the number
2979 came from a (by definition imprecise) NV operation, and
2980 we're outside the range of NV integer precision */
2985 DEBUG_c(PerlIO_printf(Perl_debug_log,
2986 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2992 else if (SvPOKp(sv) && SvLEN(sv)) {
2994 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2996 /* We want to avoid a possible problem when we cache a UV which
2997 may be later translated to an NV, and the resulting NV is not
2998 the translation of the initial data.
3000 This means that if we cache such a UV, we need to cache the
3001 NV as well. Moreover, we trade speed for space, and do not
3002 cache the NV if not needed.
3005 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3006 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3007 == IS_NUMBER_IN_UV) {
3008 /* It's definitely an integer, only upgrade to PVIV */
3009 if (SvTYPE(sv) < SVt_PVIV)
3010 sv_upgrade(sv, SVt_PVIV);
3012 } else if (SvTYPE(sv) < SVt_PVNV)
3013 sv_upgrade(sv, SVt_PVNV);
3015 /* If NV preserves UV then we only use the UV value if we know that
3016 we aren't going to call atof() below. If NVs don't preserve UVs
3017 then the value returned may have more precision than atof() will
3018 return, even though it isn't accurate. */
3019 if ((numtype & (IS_NUMBER_IN_UV
3020 #ifdef NV_PRESERVES_UV
3023 )) == IS_NUMBER_IN_UV) {
3024 /* This won't turn off the public IOK flag if it was set above */
3025 (void)SvIOKp_on(sv);
3027 if (!(numtype & IS_NUMBER_NEG)) {
3029 if (value <= (UV)IV_MAX) {
3030 SvIVX(sv) = (IV)value;
3032 /* it didn't overflow, and it was positive. */
3037 /* 2s complement assumption */
3038 if (value <= (UV)IV_MIN) {
3039 SvIVX(sv) = -(IV)value;
3041 /* Too negative for an IV. This is a double upgrade, but
3042 I'm assuming it will be rare. */
3043 if (SvTYPE(sv) < SVt_PVNV)
3044 sv_upgrade(sv, SVt_PVNV);
3048 SvNV_set(sv, -(NV)value);
3054 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3055 != IS_NUMBER_IN_UV) {
3056 /* It wasn't an integer, or it overflowed the UV. */
3057 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 SvIVX(sv) = I_V(SvNVX(sv));
3075 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3078 /* Integer is imprecise. NOK, IOKp */
3080 /* UV will not work better than IV */
3082 if (SvNVX(sv) > (NV)UV_MAX) {
3084 /* Integer is inaccurate. NOK, IOKp, is UV */
3088 SvUVX(sv) = U_V(SvNVX(sv));
3089 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3090 NV preservse UV so can do correct comparison. */
3091 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3095 /* Integer is imprecise. NOK, IOKp, is UV */
3100 #else /* NV_PRESERVES_UV */
3101 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3102 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3103 /* The UV slot will have been set from value returned by
3104 grok_number above. The NV slot has just been set using
3107 assert (SvIOKp(sv));
3109 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3110 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3111 /* Small enough to preserve all bits. */
3112 (void)SvIOKp_on(sv);
3114 SvIVX(sv) = I_V(SvNVX(sv));
3115 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3117 /* Assumption: first non-preserved integer is < IV_MAX,
3118 this NV is in the preserved range, therefore: */
3119 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3121 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
3124 sv_2iuv_non_preserve (sv, numtype);
3126 #endif /* NV_PRESERVES_UV */
3130 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3131 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3134 if (SvTYPE(sv) < SVt_IV)
3135 /* Typically the caller expects that sv_any is not NULL now. */
3136 sv_upgrade(sv, SVt_IV);
3140 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3141 PTR2UV(sv),SvUVX(sv)));
3142 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3148 Return the num value of an SV, doing any necessary string or integer
3149 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3156 Perl_sv_2nv(pTHX_ register SV *sv)
3160 if (SvGMAGICAL(sv)) {
3164 if (SvPOKp(sv) && SvLEN(sv)) {
3165 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3166 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3168 return Atof(SvPVX(sv));
3172 return (NV)SvUVX(sv);
3174 return (NV)SvIVX(sv);
3177 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3178 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3184 if (SvTHINKFIRST(sv)) {
3187 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3188 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3189 return SvNV(tmpstr);
3190 return PTR2NV(SvRV(sv));
3193 sv_force_normal_flags(sv, 0);
3195 if (SvREADONLY(sv) && !SvOK(sv)) {
3196 if (ckWARN(WARN_UNINITIALIZED))
3201 if (SvTYPE(sv) < SVt_NV) {
3202 if (SvTYPE(sv) == SVt_IV)
3203 sv_upgrade(sv, SVt_PVNV);
3205 sv_upgrade(sv, SVt_NV);
3206 #ifdef USE_LONG_DOUBLE
3208 STORE_NUMERIC_LOCAL_SET_STANDARD();
3209 PerlIO_printf(Perl_debug_log,
3210 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3211 PTR2UV(sv), SvNVX(sv));
3212 RESTORE_NUMERIC_LOCAL();
3216 STORE_NUMERIC_LOCAL_SET_STANDARD();
3217 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3218 PTR2UV(sv), SvNVX(sv));
3219 RESTORE_NUMERIC_LOCAL();
3223 else if (SvTYPE(sv) < SVt_PVNV)
3224 sv_upgrade(sv, SVt_PVNV);
3229 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 SvIVX(sv) = -(IV)value;
3281 } else if (value <= (UV)IV_MAX) {
3282 SvIVX(sv) = (IV)value;
3288 if (numtype & IS_NUMBER_NOT_INT) {
3289 /* I believe that even if the original PV had decimals,
3290 they are lost beyond the limit of the FP precision.
3291 However, neither is canonical, so both only get p
3292 flags. NWC, 2000/11/25 */
3293 /* Both already have p flags, so do nothing */
3296 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3297 if (SvIVX(sv) == I_V(nv)) {
3302 /* It had no "." so it must be integer. */
3305 /* between IV_MAX and NV(UV_MAX).
3306 Could be slightly > UV_MAX */
3308 if (numtype & IS_NUMBER_NOT_INT) {
3309 /* UV and NV both imprecise. */
3311 UV nv_as_uv = U_V(nv);
3313 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3324 #endif /* NV_PRESERVES_UV */
3327 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3329 if (SvTYPE(sv) < SVt_NV)
3330 /* Typically the caller expects that sv_any is not NULL now. */
3331 /* XXX Ilya implies that this is a bug in callers that assume this
3332 and ideally should be fixed. */
3333 sv_upgrade(sv, SVt_NV);
3336 #if defined(USE_LONG_DOUBLE)
3338 STORE_NUMERIC_LOCAL_SET_STANDARD();
3339 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3340 PTR2UV(sv), SvNVX(sv));
3341 RESTORE_NUMERIC_LOCAL();
3345 STORE_NUMERIC_LOCAL_SET_STANDARD();
3346 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3347 PTR2UV(sv), SvNVX(sv));
3348 RESTORE_NUMERIC_LOCAL();
3354 /* asIV(): extract an integer from the string value of an SV.
3355 * Caller must validate PVX */
3358 S_asIV(pTHX_ SV *sv)
3361 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3363 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3364 == IS_NUMBER_IN_UV) {
3365 /* It's definitely an integer */
3366 if (numtype & IS_NUMBER_NEG) {
3367 if (value < (UV)IV_MIN)
3370 if (value < (UV)IV_MAX)
3375 if (ckWARN(WARN_NUMERIC))
3378 return I_V(Atof(SvPVX(sv)));
3381 /* asUV(): extract an unsigned integer from the string value of an SV
3382 * Caller must validate PVX */
3385 S_asUV(pTHX_ SV *sv)
3388 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3390 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3391 == IS_NUMBER_IN_UV) {
3392 /* It's definitely an integer */
3393 if (!(numtype & IS_NUMBER_NEG))
3397 if (ckWARN(WARN_NUMERIC))
3400 return U_V(Atof(SvPVX(sv)));
3404 =for apidoc sv_2pv_nolen
3406 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3407 use the macro wrapper C<SvPV_nolen(sv)> instead.
3412 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3415 return sv_2pv(sv, &n_a);
3418 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3419 * UV as a string towards the end of buf, and return pointers to start and
3422 * We assume that buf is at least TYPE_CHARS(UV) long.
3426 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3428 char *ptr = buf + TYPE_CHARS(UV);
3442 *--ptr = '0' + (char)(uv % 10);
3450 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3451 * this function provided for binary compatibility only
3455 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3457 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3461 =for apidoc sv_2pv_flags
3463 Returns a pointer to the string value of an SV, and sets *lp to its length.
3464 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3466 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3467 usually end up here too.
3473 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3478 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3479 char *tmpbuf = tbuf;
3485 if (SvGMAGICAL(sv)) {
3486 if (flags & SV_GMAGIC)
3494 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3496 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3501 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3506 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3507 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3514 if (SvTHINKFIRST(sv)) {
3517 register const char *typestr;
3518 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3519 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3520 char *pv = SvPV(tmpstr, *lp);
3530 typestr = "NULLREF";
3534 switch (SvTYPE(sv)) {
3536 if ( ((SvFLAGS(sv) &
3537 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3538 == (SVs_OBJECT|SVs_SMG))
3539 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3540 const regexp *re = (regexp *)mg->mg_obj;
3543 const char *fptr = "msix";
3548 char need_newline = 0;
3549 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3551 while((ch = *fptr++)) {
3553 reflags[left++] = ch;
3556 reflags[right--] = ch;
3561 reflags[left] = '-';
3565 mg->mg_len = re->prelen + 4 + left;
3567 * If /x was used, we have to worry about a regex
3568 * ending with a comment later being embedded
3569 * within another regex. If so, we don't want this
3570 * regex's "commentization" to leak out to the
3571 * right part of the enclosing regex, we must cap
3572 * it with a newline.
3574 * So, if /x was used, we scan backwards from the
3575 * end of the regex. If we find a '#' before we
3576 * find a newline, we need to add a newline
3577 * ourself. If we find a '\n' first (or if we
3578 * don't find '#' or '\n'), we don't need to add
3579 * anything. -jfriedl
3581 if (PMf_EXTENDED & re->reganch)
3583 const char *endptr = re->precomp + re->prelen;
3584 while (endptr >= re->precomp)
3586 const char c = *(endptr--);
3588 break; /* don't need another */
3590 /* we end while in a comment, so we
3592 mg->mg_len++; /* save space for it */
3593 need_newline = 1; /* note to add it */
3599 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3600 Copy("(?", mg->mg_ptr, 2, char);
3601 Copy(reflags, mg->mg_ptr+2, left, char);
3602 Copy(":", mg->mg_ptr+left+2, 1, char);
3603 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3605 mg->mg_ptr[mg->mg_len - 2] = '\n';
3606 mg->mg_ptr[mg->mg_len - 1] = ')';
3607 mg->mg_ptr[mg->mg_len] = 0;
3609 PL_reginterp_cnt += re->program[0].next_off;
3611 if (re->reganch & ROPT_UTF8)
3626 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3627 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3628 /* tied lvalues should appear to be
3629 * scalars for backwards compatitbility */
3630 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3631 ? "SCALAR" : "LVALUE"; break;
3632 case SVt_PVAV: typestr = "ARRAY"; break;
3633 case SVt_PVHV: typestr = "HASH"; break;
3634 case SVt_PVCV: typestr = "CODE"; break;
3635 case SVt_PVGV: typestr = "GLOB"; break;
3636 case SVt_PVFM: typestr = "FORMAT"; break;
3637 case SVt_PVIO: typestr = "IO"; break;
3638 default: typestr = "UNKNOWN"; break;
3642 const char *name = HvNAME(SvSTASH(sv));
3643 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3644 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3647 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3650 *lp = strlen(typestr);
3651 return (char *)typestr;
3653 if (SvREADONLY(sv) && !SvOK(sv)) {
3654 if (ckWARN(WARN_UNINITIALIZED))
3660 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3661 /* I'm assuming that if both IV and NV are equally valid then
3662 converting the IV is going to be more efficient */
3663 const U32 isIOK = SvIOK(sv);
3664 const U32 isUIOK = SvIsUV(sv);
3665 char buf[TYPE_CHARS(UV)];
3668 if (SvTYPE(sv) < SVt_PVIV)
3669 sv_upgrade(sv, SVt_PVIV);
3671 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3673 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3674 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3675 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3676 SvCUR_set(sv, ebuf - ptr);
3686 else if (SvNOKp(sv)) {
3687 if (SvTYPE(sv) < SVt_PVNV)
3688 sv_upgrade(sv, SVt_PVNV);
3689 /* The +20 is pure guesswork. Configure test needed. --jhi */
3690 SvGROW(sv, NV_DIG + 20);
3692 olderrno = errno; /* some Xenix systems wipe out errno here */
3694 if (SvNVX(sv) == 0.0)
3695 (void)strcpy(s,"0");
3699 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3702 #ifdef FIXNEGATIVEZERO
3703 if (*s == '-' && s[1] == '0' && !s[2])
3713 if (ckWARN(WARN_UNINITIALIZED)
3714 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3717 if (SvTYPE(sv) < SVt_PV)
3718 /* Typically the caller expects that sv_any is not NULL now. */
3719 sv_upgrade(sv, SVt_PV);
3722 *lp = s - SvPVX(sv);
3725 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3726 PTR2UV(sv),SvPVX(sv)));
3730 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3731 /* Sneaky stuff here */
3735 tsv = newSVpv(tmpbuf, 0);
3751 len = strlen(tmpbuf);
3753 #ifdef FIXNEGATIVEZERO
3754 if (len == 2 && t[0] == '-' && t[1] == '0') {
3759 (void)SvUPGRADE(sv, SVt_PV);
3761 s = SvGROW(sv, len + 1);
3764 return strcpy(s, t);
3769 =for apidoc sv_copypv
3771 Copies a stringified representation of the source SV into the
3772 destination SV. Automatically performs any necessary mg_get and
3773 coercion of numeric values into strings. Guaranteed to preserve
3774 UTF-8 flag even from overloaded objects. Similar in nature to
3775 sv_2pv[_flags] but operates directly on an SV instead of just the
3776 string. Mostly uses sv_2pv_flags to do its work, except when that
3777 would lose the UTF-8'ness of the PV.
3783 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3788 sv_setpvn(dsv,s,len);
3796 =for apidoc sv_2pvbyte_nolen
3798 Return a pointer to the byte-encoded representation of the SV.
3799 May cause the SV to be downgraded from UTF-8 as a side-effect.
3801 Usually accessed via the C<SvPVbyte_nolen> macro.
3807 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3810 return sv_2pvbyte(sv, &n_a);
3814 =for apidoc sv_2pvbyte
3816 Return a pointer to the byte-encoded representation of the SV, and set *lp
3817 to its length. May cause the SV to be downgraded from UTF-8 as a
3820 Usually accessed via the C<SvPVbyte> macro.
3826 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3828 sv_utf8_downgrade(sv,0);
3829 return SvPV(sv,*lp);
3833 =for apidoc sv_2pvutf8_nolen
3835 Return a pointer to the UTF-8-encoded representation of the SV.
3836 May cause the SV to be upgraded to UTF-8 as a side-effect.
3838 Usually accessed via the C<SvPVutf8_nolen> macro.
3844 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3847 return sv_2pvutf8(sv, &n_a);
3851 =for apidoc sv_2pvutf8
3853 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3854 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3856 Usually accessed via the C<SvPVutf8> macro.
3862 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3864 sv_utf8_upgrade(sv);
3865 return SvPV(sv,*lp);
3869 =for apidoc sv_2bool
3871 This function is only called on magical items, and is only used by
3872 sv_true() or its macro equivalent.
3878 Perl_sv_2bool(pTHX_ register SV *sv)
3887 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3888 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3889 return (bool)SvTRUE(tmpsv);
3890 return SvRV(sv) != 0;
3893 register XPV* Xpvtmp;
3894 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3895 (*Xpvtmp->xpv_pv > '0' ||
3896 Xpvtmp->xpv_cur > 1 ||
3897 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3904 return SvIVX(sv) != 0;
3907 return SvNVX(sv) != 0.0;
3914 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3915 * this function provided for binary compatibility only
3920 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3922 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3926 =for apidoc sv_utf8_upgrade
3928 Converts the PV of an SV to its UTF-8-encoded form.
3929 Forces the SV to string form if it is not already.
3930 Always sets the SvUTF8 flag to avoid future validity checks even
3931 if all the bytes have hibit clear.
3933 This is not as a general purpose byte encoding to Unicode interface:
3934 use the Encode extension for that.
3936 =for apidoc sv_utf8_upgrade_flags
3938 Converts the PV of an SV to its UTF-8-encoded form.
3939 Forces the SV to string form if it is not already.
3940 Always sets the SvUTF8 flag to avoid future validity checks even
3941 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3942 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3943 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3945 This is not as a general purpose byte encoding to Unicode interface:
3946 use the Encode extension for that.
3952 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3957 if (sv == &PL_sv_undef)
3961 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3962 (void) sv_2pv_flags(sv,&len, flags);
3966 (void) SvPV_force(sv,len);
3975 sv_force_normal_flags(sv, 0);
3978 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3979 sv_recode_to_utf8(sv, PL_encoding);
3980 else { /* Assume Latin-1/EBCDIC */
3981 /* This function could be much more efficient if we
3982 * had a FLAG in SVs to signal if there are any hibit
3983 * chars in the PV. Given that there isn't such a flag
3984 * make the loop as fast as possible. */
3985 s = (U8 *) SvPVX(sv);
3986 e = (U8 *) SvEND(sv);
3990 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3995 (void)SvOOK_off(sv);
3997 len = SvCUR(sv) + 1; /* Plus the \0 */
3998 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3999 SvCUR(sv) = len - 1;
4001 Safefree(s); /* No longer using what was there before. */
4002 SvLEN(sv) = len; /* No longer know the real size. */
4004 /* Mark as UTF-8 even if no hibit - saves scanning loop */
4011 =for apidoc sv_utf8_downgrade
4013 Attempts to convert the PV of an SV from characters to bytes.
4014 If the PV contains a character beyond byte, this conversion will fail;
4015 in this case, either returns false or, if C<fail_ok> is not
4018 This is not as a general purpose Unicode to byte encoding interface:
4019 use the Encode extension for that.
4025 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4027 if (SvPOKp(sv) && SvUTF8(sv)) {
4033 sv_force_normal_flags(sv, 0);
4035 s = (U8 *) SvPV(sv, len);
4036 if (!utf8_to_bytes(s, &len)) {
4041 Perl_croak(aTHX_ "Wide character in %s",
4044 Perl_croak(aTHX_ "Wide character");
4055 =for apidoc sv_utf8_encode
4057 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4058 flag off so that it looks like octets again.
4064 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4066 (void) sv_utf8_upgrade(sv);
4068 sv_force_normal_flags(sv, 0);
4070 if (SvREADONLY(sv)) {
4071 Perl_croak(aTHX_ PL_no_modify);
4077 =for apidoc sv_utf8_decode
4079 If the PV of the SV is an octet sequence in UTF-8
4080 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4081 so that it looks like a character. If the PV contains only single-byte
4082 characters, the C<SvUTF8> flag stays being off.
4083 Scans PV for validity and returns false if the PV is invalid UTF-8.
4089 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4095 /* The octets may have got themselves encoded - get them back as
4098 if (!sv_utf8_downgrade(sv, TRUE))
4101 /* it is actually just a matter of turning the utf8 flag on, but
4102 * we want to make sure everything inside is valid utf8 first.
4104 c = (U8 *) SvPVX(sv);
4105 if (!is_utf8_string(c, SvCUR(sv)+1))
4107 e = (U8 *) SvEND(sv);
4110 if (!UTF8_IS_INVARIANT(ch)) {
4119 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4120 * this function provided for binary compatibility only
4124 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4126 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4130 =for apidoc sv_setsv
4132 Copies the contents of the source SV C<ssv> into the destination SV
4133 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4134 function if the source SV needs to be reused. Does not handle 'set' magic.
4135 Loosely speaking, it performs a copy-by-value, obliterating any previous
4136 content of the destination.
4138 You probably want to use one of the assortment of wrappers, such as
4139 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4140 C<SvSetMagicSV_nosteal>.
4142 =for apidoc sv_setsv_flags
4144 Copies the contents of the source SV C<ssv> into the destination SV
4145 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4146 function if the source SV needs to be reused. Does not handle 'set' magic.
4147 Loosely speaking, it performs a copy-by-value, obliterating any previous
4148 content of the destination.
4149 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4150 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4151 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4152 and C<sv_setsv_nomg> are implemented in terms of this function.
4154 You probably want to use one of the assortment of wrappers, such as
4155 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4156 C<SvSetMagicSV_nosteal>.
4158 This is the primary function for copying scalars, and most other
4159 copy-ish functions and macros use this underneath.
4165 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4167 register U32 sflags;
4173 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4175 sstr = &PL_sv_undef;
4176 stype = SvTYPE(sstr);
4177 dtype = SvTYPE(dstr);
4182 /* need to nuke the magic */
4184 SvRMAGICAL_off(dstr);
4187 /* There's a lot of redundancy below but we're going for speed here */
4192 if (dtype != SVt_PVGV) {
4193 (void)SvOK_off(dstr);
4201 sv_upgrade(dstr, SVt_IV);
4204 sv_upgrade(dstr, SVt_PVNV);
4208 sv_upgrade(dstr, SVt_PVIV);
4211 (void)SvIOK_only(dstr);
4212 SvIVX(dstr) = SvIVX(sstr);
4215 if (SvTAINTED(sstr))
4226 sv_upgrade(dstr, SVt_NV);
4231 sv_upgrade(dstr, SVt_PVNV);
4234 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 SvIVX(dstr) = SvIVX(sstr);
4510 if (SvAMAGIC(sstr)) {
4514 else if (sflags & SVp_POK) {
4518 * Check to see if we can just swipe the string. If so, it's a
4519 * possible small lose on short strings, but a big win on long ones.
4520 * It might even be a win on short strings if SvPVX(dstr)
4521 * has to be allocated and SvPVX(sstr) has to be freed.
4524 /* Whichever path we take through the next code, we want this true,
4525 and doing it now facilitates the COW check. */
4526 (void)SvPOK_only(dstr);
4529 #ifdef PERL_COPY_ON_WRITE
4530 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4534 (sflags & SVs_TEMP) && /* slated for free anyway? */
4535 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4536 (!(flags & SV_NOSTEAL)) &&
4537 /* and we're allowed to steal temps */
4538 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4539 SvLEN(sstr) && /* and really is a string */
4540 /* and won't be needed again, potentially */
4541 !(PL_op && PL_op->op_type == OP_AASSIGN))
4542 #ifdef PERL_COPY_ON_WRITE
4543 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4544 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4545 && SvTYPE(sstr) >= SVt_PVIV)
4548 /* Failed the swipe test, and it's not a shared hash key either.
4549 Have to copy the string. */
4550 STRLEN len = SvCUR(sstr);
4551 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4552 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4553 SvCUR_set(dstr, len);
4554 *SvEND(dstr) = '\0';
4556 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4558 #ifdef PERL_COPY_ON_WRITE
4559 /* Either it's a shared hash key, or it's suitable for
4560 copy-on-write or we can swipe the string. */
4562 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4567 /* I believe I should acquire a global SV mutex if
4568 it's a COW sv (not a shared hash key) to stop
4569 it going un copy-on-write.
4570 If the source SV has gone un copy on write between up there
4571 and down here, then (assert() that) it is of the correct
4572 form to make it copy on write again */
4573 if ((sflags & (SVf_FAKE | SVf_READONLY))
4574 != (SVf_FAKE | SVf_READONLY)) {
4575 SvREADONLY_on(sstr);
4577 /* Make the source SV into a loop of 1.
4578 (about to become 2) */
4579 SV_COW_NEXT_SV_SET(sstr, sstr);
4583 /* Initial code is common. */
4584 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4586 SvFLAGS(dstr) &= ~SVf_OOK;
4587 Safefree(SvPVX(dstr) - SvIVX(dstr));
4589 else if (SvLEN(dstr))
4590 Safefree(SvPVX(dstr));
4593 #ifdef PERL_COPY_ON_WRITE
4595 /* making another shared SV. */
4596 STRLEN cur = SvCUR(sstr);
4597 STRLEN len = SvLEN(sstr);
4598 assert (SvTYPE(dstr) >= SVt_PVIV);
4600 /* SvIsCOW_normal */
4601 /* splice us in between source and next-after-source. */
4602 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4603 SV_COW_NEXT_SV_SET(sstr, dstr);
4604 SvPV_set(dstr, SvPVX(sstr));
4606 /* SvIsCOW_shared_hash */
4607 UV hash = SvUVX(sstr);
4608 DEBUG_C(PerlIO_printf(Perl_debug_log,
4609 "Copy on write: Sharing hash\n"));
4611 sharepvn(SvPVX(sstr),
4612 (sflags & SVf_UTF8?-cur:cur), hash));
4617 SvREADONLY_on(dstr);
4619 /* Relesase a global SV mutex. */
4623 { /* Passes the swipe test. */
4624 SvPV_set(dstr, SvPVX(sstr));
4625 SvLEN_set(dstr, SvLEN(sstr));
4626 SvCUR_set(dstr, SvCUR(sstr));
4629 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4630 SvPV_set(sstr, Nullch);
4636 if (sflags & SVf_UTF8)
4639 if (sflags & SVp_NOK) {
4641 if (sflags & SVf_NOK)
4642 SvFLAGS(dstr) |= SVf_NOK;
4643 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 SvIVX(dstr) = SvIVX(sstr);
4654 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4655 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4656 smg->mg_ptr, smg->mg_len);
4657 SvRMAGICAL_on(dstr);
4660 else if (sflags & SVp_IOK) {
4661 if (sflags & SVf_IOK)
4662 (void)SvIOK_only(dstr);
4664 (void)SvOK_off(dstr);
4665 (void)SvIOKp_on(dstr);
4667 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4668 if (sflags & SVf_IVisUV)
4670 SvIVX(dstr) = SvIVX(sstr);
4671 if (sflags & SVp_NOK) {
4672 if (sflags & SVf_NOK)
4673 (void)SvNOK_on(dstr);
4675 (void)SvNOKp_on(dstr);
4676 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"));
4756 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4759 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4761 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4762 (void)SvUPGRADE (sstr, SVt_PVIV);
4763 SvREADONLY_on(sstr);
4765 DEBUG_C(PerlIO_printf(Perl_debug_log,
4766 "Fast copy on write: Converting sstr to COW\n"));
4767 SV_COW_NEXT_SV_SET(dstr, sstr);
4769 SV_COW_NEXT_SV_SET(sstr, dstr);
4770 new_pv = SvPVX(sstr);
4773 SvPV_set(dstr, new_pv);
4774 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4787 =for apidoc sv_setpvn
4789 Copies a string into an SV. The C<len> parameter indicates the number of
4790 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4791 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4797 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4799 register char *dptr;
4801 SV_CHECK_THINKFIRST_COW_DROP(sv);
4807 /* len is STRLEN which is unsigned, need to copy to signed */
4810 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4812 (void)SvUPGRADE(sv, SVt_PV);
4814 SvGROW(sv, len + 1);
4816 Move(ptr,dptr,len,char);
4819 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4824 =for apidoc sv_setpvn_mg
4826 Like C<sv_setpvn>, but also handles 'set' magic.
4832 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4834 sv_setpvn(sv,ptr,len);
4839 =for apidoc sv_setpv
4841 Copies a string into an SV. The string must be null-terminated. Does not
4842 handle 'set' magic. See C<sv_setpv_mg>.
4848 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4850 register STRLEN len;
4852 SV_CHECK_THINKFIRST_COW_DROP(sv);
4858 (void)SvUPGRADE(sv, SVt_PV);
4860 SvGROW(sv, len + 1);
4861 Move(ptr,SvPVX(sv),len+1,char);
4863 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4868 =for apidoc sv_setpv_mg
4870 Like C<sv_setpv>, but also handles 'set' magic.
4876 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4883 =for apidoc sv_usepvn
4885 Tells an SV to use C<ptr> to find its string value. Normally the string is
4886 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4887 The C<ptr> should point to memory that was allocated by C<malloc>. The
4888 string length, C<len>, must be supplied. This function will realloc the
4889 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4890 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4891 See C<sv_usepvn_mg>.
4897 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4899 SV_CHECK_THINKFIRST_COW_DROP(sv);
4900 (void)SvUPGRADE(sv, SVt_PV);
4905 (void)SvOOK_off(sv);
4906 if (SvPVX(sv) && SvLEN(sv))
4907 Safefree(SvPVX(sv));
4908 Renew(ptr, len+1, char);
4911 SvLEN_set(sv, len+1);
4913 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4918 =for apidoc sv_usepvn_mg
4920 Like C<sv_usepvn>, but also handles 'set' magic.
4926 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4928 sv_usepvn(sv,ptr,len);
4932 #ifdef PERL_COPY_ON_WRITE
4933 /* Need to do this *after* making the SV normal, as we need the buffer
4934 pointer to remain valid until after we've copied it. If we let go too early,
4935 another thread could invalidate it by unsharing last of the same hash key
4936 (which it can do by means other than releasing copy-on-write Svs)
4937 or by changing the other copy-on-write SVs in the loop. */
4939 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4940 U32 hash, SV *after)
4942 if (len) { /* this SV was SvIsCOW_normal(sv) */
4943 /* we need to find the SV pointing to us. */
4944 SV *current = SV_COW_NEXT_SV(after);
4946 if (current == sv) {
4947 /* The SV we point to points back to us (there were only two of us
4949 Hence other SV is no longer copy on write either. */
4951 SvREADONLY_off(after);
4953 /* We need to follow the pointers around the loop. */
4955 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4958 /* don't loop forever if the structure is bust, and we have
4959 a pointer into a closed loop. */
4960 assert (current != after);
4961 assert (SvPVX(current) == pvx);
4963 /* Make the SV before us point to the SV after us. */
4964 SV_COW_NEXT_SV_SET(current, after);
4967 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4972 Perl_sv_release_IVX(pTHX_ register SV *sv)
4975 sv_force_normal_flags(sv, 0);
4981 =for apidoc sv_force_normal_flags
4983 Undo various types of fakery on an SV: if the PV is a shared string, make
4984 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4985 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4986 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4987 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4988 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4989 set to some other value.) In addition, the C<flags> parameter gets passed to
4990 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4991 with flags set to 0.
4997 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4999 #ifdef PERL_COPY_ON_WRITE
5000 if (SvREADONLY(sv)) {
5001 /* At this point I believe I should acquire a global SV mutex. */
5003 char *pvx = SvPVX(sv);
5004 STRLEN len = SvLEN(sv);
5005 STRLEN cur = SvCUR(sv);
5006 U32 hash = SvUVX(sv);
5007 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
5009 PerlIO_printf(Perl_debug_log,
5010 "Copy on write: Force normal %ld\n",
5016 /* This SV doesn't own the buffer, so need to New() a new one: */
5019 if (flags & SV_COW_DROP_PV) {
5020 /* OK, so we don't need to copy our buffer. */
5023 SvGROW(sv, cur + 1);
5024 Move(pvx,SvPVX(sv),cur,char);
5028 sv_release_COW(sv, pvx, cur, len, hash, next);
5033 else if (IN_PERL_RUNTIME)
5034 Perl_croak(aTHX_ PL_no_modify);
5035 /* At this point I believe that I can drop the global SV mutex. */
5038 if (SvREADONLY(sv)) {
5040 char *pvx = SvPVX(sv);
5041 int is_utf8 = SvUTF8(sv);
5042 STRLEN len = SvCUR(sv);
5043 U32 hash = SvUVX(sv);
5048 SvGROW(sv, len + 1);
5049 Move(pvx,SvPVX(sv),len,char);
5051 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5053 else if (IN_PERL_RUNTIME)
5054 Perl_croak(aTHX_ PL_no_modify);
5058 sv_unref_flags(sv, flags);
5059 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5064 =for apidoc sv_force_normal
5066 Undo various types of fakery on an SV: if the PV is a shared string, make
5067 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5068 an xpvmg. See also C<sv_force_normal_flags>.
5074 Perl_sv_force_normal(pTHX_ register SV *sv)
5076 sv_force_normal_flags(sv, 0);
5082 Efficient removal of characters from the beginning of the string buffer.
5083 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5084 the string buffer. The C<ptr> becomes the first character of the adjusted
5085 string. Uses the "OOK hack".
5086 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5087 refer to the same chunk of data.
5093 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
5095 register STRLEN delta;
5096 if (!ptr || !SvPOKp(sv))
5098 delta = ptr - SvPVX(sv);
5099 SV_CHECK_THINKFIRST(sv);
5100 if (SvTYPE(sv) < SVt_PVIV)
5101 sv_upgrade(sv,SVt_PVIV);
5104 if (!SvLEN(sv)) { /* make copy of shared string */
5105 char *pvx = SvPVX(sv);
5106 STRLEN len = SvCUR(sv);
5107 SvGROW(sv, len + 1);
5108 Move(pvx,SvPVX(sv),len,char);
5112 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5113 and we do that anyway inside the SvNIOK_off
5115 SvFLAGS(sv) |= SVf_OOK;
5124 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5125 * this function provided for binary compatibility only
5129 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5131 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5135 =for apidoc sv_catpvn
5137 Concatenates the string onto the end of the string which is in the SV. The
5138 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5139 status set, then the bytes appended should be valid UTF-8.
5140 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5142 =for apidoc sv_catpvn_flags
5144 Concatenates the string onto the end of the string which is in the SV. The
5145 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5146 status set, then the bytes appended should be valid UTF-8.
5147 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5148 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5149 in terms of this function.
5155 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5160 dstr = SvPV_force_flags(dsv, dlen, flags);
5161 SvGROW(dsv, dlen + slen + 1);
5164 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5167 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5172 =for apidoc sv_catpvn_mg
5174 Like C<sv_catpvn>, but also handles 'set' magic.
5180 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5182 sv_catpvn(sv,ptr,len);
5186 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5187 * this function provided for binary compatibility only
5191 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5193 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5197 =for apidoc sv_catsv
5199 Concatenates the string from SV C<ssv> onto the end of the string in
5200 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5201 not 'set' magic. See C<sv_catsv_mg>.
5203 =for apidoc sv_catsv_flags
5205 Concatenates the string from SV C<ssv> onto the end of the string in
5206 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5207 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5208 and C<sv_catsv_nomg> are implemented in terms of this function.
5213 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5219 if ((spv = SvPV(ssv, slen))) {
5220 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5221 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5222 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5223 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5224 dsv->sv_flags doesn't have that bit set.
5225 Andy Dougherty 12 Oct 2001
5227 I32 sutf8 = DO_UTF8(ssv);
5230 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5232 dutf8 = DO_UTF8(dsv);
5234 if (dutf8 != sutf8) {
5236 /* Not modifying source SV, so taking a temporary copy. */
5237 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5239 sv_utf8_upgrade(csv);
5240 spv = SvPV(csv, slen);
5243 sv_utf8_upgrade_nomg(dsv);
5245 sv_catpvn_nomg(dsv, spv, slen);
5250 =for apidoc sv_catsv_mg
5252 Like C<sv_catsv>, but also handles 'set' magic.
5258 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5265 =for apidoc sv_catpv
5267 Concatenates the string onto the end of the string which is in the SV.
5268 If the SV has the UTF-8 status set, then the bytes appended should be
5269 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5274 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5276 register STRLEN len;
5282 junk = SvPV_force(sv, tlen);
5284 SvGROW(sv, tlen + len + 1);
5287 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5289 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5294 =for apidoc sv_catpv_mg
5296 Like C<sv_catpv>, but also handles 'set' magic.
5302 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5311 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5312 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5319 Perl_newSV(pTHX_ STRLEN len)
5325 sv_upgrade(sv, SVt_PV);
5326 SvGROW(sv, len + 1);
5331 =for apidoc sv_magicext
5333 Adds magic to an SV, upgrading it if necessary. Applies the
5334 supplied vtable and returns a pointer to the magic added.
5336 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5337 In particular, you can add magic to SvREADONLY SVs, and add more than
5338 one instance of the same 'how'.
5340 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5341 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5342 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5343 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5345 (This is now used as a subroutine by C<sv_magic>.)
5350 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5351 const char* name, I32 namlen)
5355 if (SvTYPE(sv) < SVt_PVMG) {
5356 (void)SvUPGRADE(sv, SVt_PVMG);
5358 Newz(702,mg, 1, MAGIC);
5359 mg->mg_moremagic = SvMAGIC(sv);
5362 /* Sometimes a magic contains a reference loop, where the sv and
5363 object refer to each other. To prevent a reference loop that
5364 would prevent such objects being freed, we look for such loops
5365 and if we find one we avoid incrementing the object refcount.
5367 Note we cannot do this to avoid self-tie loops as intervening RV must
5368 have its REFCNT incremented to keep it in existence.
5371 if (!obj || obj == sv ||
5372 how == PERL_MAGIC_arylen ||
5373 how == PERL_MAGIC_qr ||
5374 (SvTYPE(obj) == SVt_PVGV &&
5375 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5376 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5377 GvFORM(obj) == (CV*)sv)))
5382 mg->mg_obj = SvREFCNT_inc(obj);
5383 mg->mg_flags |= MGf_REFCOUNTED;
5386 /* Normal self-ties simply pass a null object, and instead of
5387 using mg_obj directly, use the SvTIED_obj macro to produce a
5388 new RV as needed. For glob "self-ties", we are tieing the PVIO
5389 with an RV obj pointing to the glob containing the PVIO. In
5390 this case, to avoid a reference loop, we need to weaken the
5394 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5395 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5401 mg->mg_len = namlen;
5404 mg->mg_ptr = savepvn(name, namlen);
5405 else if (namlen == HEf_SVKEY)
5406 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5408 mg->mg_ptr = (char *) name;
5410 mg->mg_virtual = vtable;
5414 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5419 =for apidoc sv_magic
5421 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5422 then adds a new magic item of type C<how> to the head of the magic list.
5424 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5425 handling of the C<name> and C<namlen> arguments.
5427 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5428 to add more than one instance of the same 'how'.
5434 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5436 const MGVTBL *vtable = 0;
5439 #ifdef PERL_COPY_ON_WRITE
5441 sv_force_normal_flags(sv, 0);
5443 if (SvREADONLY(sv)) {
5445 && how != PERL_MAGIC_regex_global
5446 && how != PERL_MAGIC_bm
5447 && how != PERL_MAGIC_fm
5448 && how != PERL_MAGIC_sv
5449 && how != PERL_MAGIC_backref
5452 Perl_croak(aTHX_ PL_no_modify);
5455 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5456 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5457 /* sv_magic() refuses to add a magic of the same 'how' as an
5460 if (how == PERL_MAGIC_taint)
5468 vtable = &PL_vtbl_sv;
5470 case PERL_MAGIC_overload:
5471 vtable = &PL_vtbl_amagic;
5473 case PERL_MAGIC_overload_elem:
5474 vtable = &PL_vtbl_amagicelem;
5476 case PERL_MAGIC_overload_table:
5477 vtable = &PL_vtbl_ovrld;
5480 vtable = &PL_vtbl_bm;
5482 case PERL_MAGIC_regdata:
5483 vtable = &PL_vtbl_regdata;
5485 case PERL_MAGIC_regdatum:
5486 vtable = &PL_vtbl_regdatum;
5488 case PERL_MAGIC_env:
5489 vtable = &PL_vtbl_env;
5492 vtable = &PL_vtbl_fm;
5494 case PERL_MAGIC_envelem:
5495 vtable = &PL_vtbl_envelem;
5497 case PERL_MAGIC_regex_global:
5498 vtable = &PL_vtbl_mglob;
5500 case PERL_MAGIC_isa:
5501 vtable = &PL_vtbl_isa;
5503 case PERL_MAGIC_isaelem:
5504 vtable = &PL_vtbl_isaelem;
5506 case PERL_MAGIC_nkeys:
5507 vtable = &PL_vtbl_nkeys;
5509 case PERL_MAGIC_dbfile:
5512 case PERL_MAGIC_dbline:
5513 vtable = &PL_vtbl_dbline;
5515 #ifdef USE_LOCALE_COLLATE
5516 case PERL_MAGIC_collxfrm:
5517 vtable = &PL_vtbl_collxfrm;
5519 #endif /* USE_LOCALE_COLLATE */
5520 case PERL_MAGIC_tied:
5521 vtable = &PL_vtbl_pack;
5523 case PERL_MAGIC_tiedelem:
5524 case PERL_MAGIC_tiedscalar:
5525 vtable = &PL_vtbl_packelem;
5528 vtable = &PL_vtbl_regexp;
5530 case PERL_MAGIC_sig:
5531 vtable = &PL_vtbl_sig;
5533 case PERL_MAGIC_sigelem:
5534 vtable = &PL_vtbl_sigelem;
5536 case PERL_MAGIC_taint:
5537 vtable = &PL_vtbl_taint;
5539 case PERL_MAGIC_uvar:
5540 vtable = &PL_vtbl_uvar;
5542 case PERL_MAGIC_vec:
5543 vtable = &PL_vtbl_vec;
5545 case PERL_MAGIC_vstring:
5548 case PERL_MAGIC_utf8:
5549 vtable = &PL_vtbl_utf8;
5551 case PERL_MAGIC_substr:
5552 vtable = &PL_vtbl_substr;
5554 case PERL_MAGIC_defelem:
5555 vtable = &PL_vtbl_defelem;
5557 case PERL_MAGIC_glob:
5558 vtable = &PL_vtbl_glob;
5560 case PERL_MAGIC_arylen:
5561 vtable = &PL_vtbl_arylen;
5563 case PERL_MAGIC_pos:
5564 vtable = &PL_vtbl_pos;
5566 case PERL_MAGIC_backref:
5567 vtable = &PL_vtbl_backref;
5569 case PERL_MAGIC_ext:
5570 /* Reserved for use by extensions not perl internals. */
5571 /* Useful for attaching extension internal data to perl vars. */
5572 /* Note that multiple extensions may clash if magical scalars */
5573 /* etc holding private data from one are passed to another. */
5576 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5579 /* Rest of work is done else where */
5580 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5583 case PERL_MAGIC_taint:
5586 case PERL_MAGIC_ext:
5587 case PERL_MAGIC_dbfile:
5594 =for apidoc sv_unmagic
5596 Removes all magic of type C<type> from an SV.
5602 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5606 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5609 for (mg = *mgp; mg; mg = *mgp) {
5610 if (mg->mg_type == type) {
5611 const MGVTBL* const vtbl = mg->mg_virtual;
5612 *mgp = mg->mg_moremagic;
5613 if (vtbl && vtbl->svt_free)
5614 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5615 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5617 Safefree(mg->mg_ptr);
5618 else if (mg->mg_len == HEf_SVKEY)
5619 SvREFCNT_dec((SV*)mg->mg_ptr);
5620 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5621 Safefree(mg->mg_ptr);
5623 if (mg->mg_flags & MGf_REFCOUNTED)
5624 SvREFCNT_dec(mg->mg_obj);
5628 mgp = &mg->mg_moremagic;
5632 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5639 =for apidoc sv_rvweaken
5641 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5642 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5643 push a back-reference to this RV onto the array of backreferences
5644 associated with that magic.
5650 Perl_sv_rvweaken(pTHX_ SV *sv)
5653 if (!SvOK(sv)) /* let undefs pass */
5656 Perl_croak(aTHX_ "Can't weaken a nonreference");
5657 else if (SvWEAKREF(sv)) {
5658 if (ckWARN(WARN_MISC))
5659 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5663 sv_add_backref(tsv, sv);
5669 /* Give tsv backref magic if it hasn't already got it, then push a
5670 * back-reference to sv onto the array associated with the backref magic.
5674 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5678 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5679 av = (AV*)mg->mg_obj;
5682 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5683 /* av now has a refcnt of 2, which avoids it getting freed
5684 * before us during global cleanup. The extra ref is removed
5685 * by magic_killbackrefs() when tsv is being freed */
5687 if (AvFILLp(av) >= AvMAX(av)) {
5689 SV **svp = AvARRAY(av);
5690 for (i = AvFILLp(av); i >= 0; i--)
5692 svp[i] = sv; /* reuse the slot */
5695 av_extend(av, AvFILLp(av)+1);
5697 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5700 /* delete a back-reference to ourselves from the backref magic associated
5701 * with the SV we point to.
5705 S_sv_del_backref(pTHX_ SV *sv)
5712 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5713 Perl_croak(aTHX_ "panic: del_backref");
5714 av = (AV *)mg->mg_obj;
5716 for (i = AvFILLp(av); i >= 0; i--)
5717 if (svp[i] == sv) svp[i] = Nullsv;
5721 =for apidoc sv_insert
5723 Inserts a string at the specified offset/length within the SV. Similar to
5724 the Perl substr() function.
5730 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5734 register char *midend;
5735 register char *bigend;
5741 Perl_croak(aTHX_ "Can't modify non-existent substring");
5742 SvPV_force(bigstr, curlen);
5743 (void)SvPOK_only_UTF8(bigstr);
5744 if (offset + len > curlen) {
5745 SvGROW(bigstr, offset+len+1);
5746 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5747 SvCUR_set(bigstr, offset+len);
5751 i = littlelen - len;
5752 if (i > 0) { /* string might grow */
5753 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5754 mid = big + offset + len;
5755 midend = bigend = big + SvCUR(bigstr);
5758 while (midend > mid) /* shove everything down */
5759 *--bigend = *--midend;
5760 Move(little,big+offset,littlelen,char);
5766 Move(little,SvPVX(bigstr)+offset,len,char);
5771 big = SvPVX(bigstr);
5774 bigend = big + SvCUR(bigstr);
5776 if (midend > bigend)
5777 Perl_croak(aTHX_ "panic: sv_insert");
5779 if (mid - big > bigend - midend) { /* faster to shorten from end */
5781 Move(little, mid, littlelen,char);
5784 i = bigend - midend;
5786 Move(midend, mid, i,char);
5790 SvCUR_set(bigstr, mid - big);
5793 else if ((i = mid - big)) { /* faster from front */
5794 midend -= littlelen;
5796 sv_chop(bigstr,midend-i);
5801 Move(little, mid, littlelen,char);
5803 else if (littlelen) {
5804 midend -= littlelen;
5805 sv_chop(bigstr,midend);
5806 Move(little,midend,littlelen,char);
5809 sv_chop(bigstr,midend);
5815 =for apidoc sv_replace
5817 Make the first argument a copy of the second, then delete the original.
5818 The target SV physically takes over ownership of the body of the source SV
5819 and inherits its flags; however, the target keeps any magic it owns,
5820 and any magic in the source is discarded.
5821 Note that this is a rather specialist SV copying operation; most of the
5822 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5828 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5830 U32 refcnt = SvREFCNT(sv);
5831 SV_CHECK_THINKFIRST_COW_DROP(sv);
5832 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5833 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5834 if (SvMAGICAL(sv)) {
5838 sv_upgrade(nsv, SVt_PVMG);
5839 SvMAGIC(nsv) = SvMAGIC(sv);
5840 SvFLAGS(nsv) |= SvMAGICAL(sv);
5846 assert(!SvREFCNT(sv));
5847 #ifdef DEBUG_LEAKING_SCALARS
5848 sv->sv_flags = nsv->sv_flags;
5849 sv->sv_any = nsv->sv_any;
5850 sv->sv_refcnt = nsv->sv_refcnt;
5852 StructCopy(nsv,sv,SV);
5855 #ifdef PERL_COPY_ON_WRITE
5856 if (SvIsCOW_normal(nsv)) {
5857 /* We need to follow the pointers around the loop to make the
5858 previous SV point to sv, rather than nsv. */
5861 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5864 assert(SvPVX(current) == SvPVX(nsv));
5866 /* Make the SV before us point to the SV after us. */
5868 PerlIO_printf(Perl_debug_log, "previous is\n");
5870 PerlIO_printf(Perl_debug_log,
5871 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5872 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5874 SV_COW_NEXT_SV_SET(current, sv);
5877 SvREFCNT(sv) = refcnt;
5878 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5884 =for apidoc sv_clear
5886 Clear an SV: call any destructors, free up any memory used by the body,
5887 and free the body itself. The SV's head is I<not> freed, although
5888 its type is set to all 1's so that it won't inadvertently be assumed
5889 to be live during global destruction etc.
5890 This function should only be called when REFCNT is zero. Most of the time
5891 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5898 Perl_sv_clear(pTHX_ register SV *sv)
5902 assert(SvREFCNT(sv) == 0);
5905 if (PL_defstash) { /* Still have a symbol table? */
5912 stash = SvSTASH(sv);
5913 destructor = StashHANDLER(stash,DESTROY);
5915 SV* tmpref = newRV(sv);
5916 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5918 PUSHSTACKi(PERLSI_DESTROY);
5923 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5929 if(SvREFCNT(tmpref) < 2) {
5930 /* tmpref is not kept alive! */
5935 SvREFCNT_dec(tmpref);
5937 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5941 if (PL_in_clean_objs)
5942 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5944 /* DESTROY gave object new lease on life */
5950 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5951 SvOBJECT_off(sv); /* Curse the object. */
5952 if (SvTYPE(sv) != SVt_PVIO)
5953 --PL_sv_objcount; /* XXX Might want something more general */
5956 if (SvTYPE(sv) >= SVt_PVMG) {
5959 if (SvFLAGS(sv) & SVpad_TYPED)
5960 SvREFCNT_dec(SvSTASH(sv));
5963 switch (SvTYPE(sv)) {
5966 IoIFP(sv) != PerlIO_stdin() &&
5967 IoIFP(sv) != PerlIO_stdout() &&
5968 IoIFP(sv) != PerlIO_stderr())
5970 io_close((IO*)sv, FALSE);
5972 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5973 PerlDir_close(IoDIRP(sv));
5974 IoDIRP(sv) = (DIR*)NULL;
5975 Safefree(IoTOP_NAME(sv));
5976 Safefree(IoFMT_NAME(sv));
5977 Safefree(IoBOTTOM_NAME(sv));
5992 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5993 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5994 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5995 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5997 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5998 SvREFCNT_dec(LvTARG(sv));
6002 Safefree(GvNAME(sv));
6003 /* cannot decrease stash refcount yet, as we might recursively delete
6004 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
6005 of stash until current sv is completely gone.
6006 -- JohnPC, 27 Mar 1998 */
6007 stash = GvSTASH(sv);
6021 SvREFCNT_dec(SvRV(sv));
6023 #ifdef PERL_COPY_ON_WRITE
6024 else if (SvPVX(sv)) {
6026 /* I believe I need to grab the global SV mutex here and
6027 then recheck the COW status. */
6029 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6032 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
6033 SvUVX(sv), SV_COW_NEXT_SV(sv));
6034 /* And drop it here. */
6036 } else if (SvLEN(sv)) {
6037 Safefree(SvPVX(sv));
6041 else if (SvPVX(sv) && SvLEN(sv))
6042 Safefree(SvPVX(sv));
6043 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6044 unsharepvn(SvPVX(sv),
6045 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6059 switch (SvTYPE(sv)) {
6075 del_XPVIV(SvANY(sv));
6078 del_XPVNV(SvANY(sv));
6081 del_XPVMG(SvANY(sv));
6084 del_XPVLV(SvANY(sv));
6087 del_XPVAV(SvANY(sv));
6090 del_XPVHV(SvANY(sv));
6093 del_XPVCV(SvANY(sv));
6096 del_XPVGV(SvANY(sv));
6097 /* code duplication for increased performance. */
6098 SvFLAGS(sv) &= SVf_BREAK;
6099 SvFLAGS(sv) |= SVTYPEMASK;
6100 /* decrease refcount of the stash that owns this GV, if any */
6102 SvREFCNT_dec(stash);
6103 return; /* not break, SvFLAGS reset already happened */
6105 del_XPVBM(SvANY(sv));
6108 del_XPVFM(SvANY(sv));
6111 del_XPVIO(SvANY(sv));
6114 SvFLAGS(sv) &= SVf_BREAK;
6115 SvFLAGS(sv) |= SVTYPEMASK;
6119 =for apidoc sv_newref
6121 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6128 Perl_sv_newref(pTHX_ SV *sv)
6138 Decrement an SV's reference count, and if it drops to zero, call
6139 C<sv_clear> to invoke destructors and free up any memory used by
6140 the body; finally, deallocate the SV's head itself.
6141 Normally called via a wrapper macro C<SvREFCNT_dec>.
6147 Perl_sv_free(pTHX_ SV *sv)
6151 if (SvREFCNT(sv) == 0) {
6152 if (SvFLAGS(sv) & SVf_BREAK)
6153 /* this SV's refcnt has been artificially decremented to
6154 * trigger cleanup */
6156 if (PL_in_clean_all) /* All is fair */
6158 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6159 /* make sure SvREFCNT(sv)==0 happens very seldom */
6160 SvREFCNT(sv) = (~(U32)0)/2;
6163 if (ckWARN_d(WARN_INTERNAL))
6164 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6165 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6166 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6169 if (--(SvREFCNT(sv)) > 0)
6171 Perl_sv_free2(aTHX_ sv);
6175 Perl_sv_free2(pTHX_ SV *sv)
6179 if (ckWARN_d(WARN_DEBUGGING))
6180 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6181 "Attempt to free temp prematurely: SV 0x%"UVxf
6182 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6186 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6187 /* make sure SvREFCNT(sv)==0 happens very seldom */
6188 SvREFCNT(sv) = (~(U32)0)/2;
6199 Returns the length of the string in the SV. Handles magic and type
6200 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6206 Perl_sv_len(pTHX_ register SV *sv)
6214 len = mg_length(sv);
6216 (void)SvPV(sv, len);
6221 =for apidoc sv_len_utf8
6223 Returns the number of characters in the string in an SV, counting wide
6224 UTF-8 bytes as a single character. Handles magic and type coercion.
6230 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6231 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6232 * (Note that the mg_len is not the length of the mg_ptr field.)
6237 Perl_sv_len_utf8(pTHX_ register SV *sv)
6243 return mg_length(sv);
6247 U8 *s = (U8*)SvPV(sv, len);
6248 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6250 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6252 #ifdef PERL_UTF8_CACHE_ASSERT
6253 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6257 ulen = Perl_utf8_length(aTHX_ s, s + len);
6258 if (!mg && !SvREADONLY(sv)) {
6259 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6260 mg = mg_find(sv, PERL_MAGIC_utf8);
6270 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6271 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6272 * between UTF-8 and byte offsets. There are two (substr offset and substr
6273 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6274 * and byte offset) cache positions.
6276 * The mg_len field is used by sv_len_utf8(), see its comments.
6277 * Note that the mg_len is not the length of the mg_ptr field.
6281 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
6285 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6287 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6291 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6293 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6294 (*mgp)->mg_ptr = (char *) *cachep;
6298 (*cachep)[i] = *offsetp;
6299 (*cachep)[i+1] = s - start;
6307 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6308 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6309 * between UTF-8 and byte offsets. See also the comments of
6310 * S_utf8_mg_pos_init().
6314 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6318 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6320 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6321 if (*mgp && (*mgp)->mg_ptr) {
6322 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6323 ASSERT_UTF8_CACHE(*cachep);
6324 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6326 else { /* We will skip to the right spot. */
6331 /* The assumption is that going backward is half
6332 * the speed of going forward (that's where the
6333 * 2 * backw in the below comes from). (The real
6334 * figure of course depends on the UTF-8 data.) */
6336 if ((*cachep)[i] > (STRLEN)uoff) {
6338 backw = (*cachep)[i] - (STRLEN)uoff;
6340 if (forw < 2 * backw)
6343 p = start + (*cachep)[i+1];
6345 /* Try this only for the substr offset (i == 0),
6346 * not for the substr length (i == 2). */
6347 else if (i == 0) { /* (*cachep)[i] < uoff */
6348 STRLEN ulen = sv_len_utf8(sv);
6350 if ((STRLEN)uoff < ulen) {
6351 forw = (STRLEN)uoff - (*cachep)[i];
6352 backw = ulen - (STRLEN)uoff;
6354 if (forw < 2 * backw)
6355 p = start + (*cachep)[i+1];
6360 /* If the string is not long enough for uoff,
6361 * we could extend it, but not at this low a level. */
6365 if (forw < 2 * backw) {
6372 while (UTF8_IS_CONTINUATION(*p))
6377 /* Update the cache. */
6378 (*cachep)[i] = (STRLEN)uoff;
6379 (*cachep)[i+1] = p - start;
6381 /* Drop the stale "length" cache */
6390 if (found) { /* Setup the return values. */
6391 *offsetp = (*cachep)[i+1];
6392 *sp = start + *offsetp;
6395 *offsetp = send - start;
6397 else if (*sp < start) {
6403 #ifdef PERL_UTF8_CACHE_ASSERT
6408 while (n-- && s < send)
6412 assert(*offsetp == s - start);
6413 assert((*cachep)[0] == (STRLEN)uoff);
6414 assert((*cachep)[1] == *offsetp);
6416 ASSERT_UTF8_CACHE(*cachep);
6425 =for apidoc sv_pos_u2b
6427 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6428 the start of the string, to a count of the equivalent number of bytes; if
6429 lenp is non-zero, it does the same to lenp, but this time starting from
6430 the offset, rather than from the start of the string. Handles magic and
6437 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6438 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6439 * byte offsets. See also the comments of S_utf8_mg_pos().
6444 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6455 start = s = (U8*)SvPV(sv, len);
6457 I32 uoffset = *offsetp;
6462 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6464 if (!found && uoffset > 0) {
6465 while (s < send && uoffset--)
6469 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
6471 *offsetp = s - start;
6476 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
6480 if (!found && *lenp > 0) {
6483 while (s < send && ulen--)
6487 utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
6491 ASSERT_UTF8_CACHE(cache);
6503 =for apidoc sv_pos_b2u
6505 Converts the value pointed to by offsetp from a count of bytes from the
6506 start of the string, to a count of the equivalent number of UTF-8 chars.
6507 Handles magic and type coercion.
6513 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6514 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6515 * byte offsets. See also the comments of S_utf8_mg_pos().
6520 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6528 s = (U8*)SvPV(sv, len);
6529 if ((I32)len < *offsetp)
6530 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6532 U8* send = s + *offsetp;
6534 STRLEN *cache = NULL;
6538 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6539 mg = mg_find(sv, PERL_MAGIC_utf8);
6540 if (mg && mg->mg_ptr) {
6541 cache = (STRLEN *) mg->mg_ptr;
6542 if (cache[1] == (STRLEN)*offsetp) {
6543 /* An exact match. */
6544 *offsetp = cache[0];
6548 else if (cache[1] < (STRLEN)*offsetp) {
6549 /* We already know part of the way. */
6552 /* Let the below loop do the rest. */
6554 else { /* cache[1] > *offsetp */
6555 /* We already know all of the way, now we may
6556 * be able to walk back. The same assumption
6557 * is made as in S_utf8_mg_pos(), namely that
6558 * walking backward is twice slower than
6559 * walking forward. */
6560 STRLEN forw = *offsetp;
6561 STRLEN backw = cache[1] - *offsetp;
6563 if (!(forw < 2 * backw)) {
6564 U8 *p = s + cache[1];
6571 while (UTF8_IS_CONTINUATION(*p)) {
6579 *offsetp = cache[0];
6581 /* Drop the stale "length" cache */
6589 ASSERT_UTF8_CACHE(cache);
6595 /* Call utf8n_to_uvchr() to validate the sequence
6596 * (unless a simple non-UTF character) */
6597 if (!UTF8_IS_INVARIANT(*s))
6598 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6607 if (!SvREADONLY(sv)) {
6609 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6610 mg = mg_find(sv, PERL_MAGIC_utf8);
6615 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6616 mg->mg_ptr = (char *) cache;
6621 cache[1] = *offsetp;
6622 /* Drop the stale "length" cache */
6635 Returns a boolean indicating whether the strings in the two SVs are
6636 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6637 coerce its args to strings if necessary.
6643 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6651 SV* svrecode = Nullsv;
6658 pv1 = SvPV(sv1, cur1);
6665 pv2 = SvPV(sv2, cur2);
6667 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6668 /* Differing utf8ness.
6669 * Do not UTF8size the comparands as a side-effect. */
6672 svrecode = newSVpvn(pv2, cur2);
6673 sv_recode_to_utf8(svrecode, PL_encoding);
6674 pv2 = SvPV(svrecode, cur2);
6677 svrecode = newSVpvn(pv1, cur1);
6678 sv_recode_to_utf8(svrecode, PL_encoding);
6679 pv1 = SvPV(svrecode, cur1);
6681 /* Now both are in UTF-8. */
6683 SvREFCNT_dec(svrecode);
6688 bool is_utf8 = TRUE;
6691 /* sv1 is the UTF-8 one,
6692 * if is equal it must be downgrade-able */
6693 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6699 /* sv2 is the UTF-8 one,
6700 * if is equal it must be downgrade-able */
6701 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6707 /* Downgrade not possible - cannot be eq */
6715 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6718 SvREFCNT_dec(svrecode);
6729 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6730 string in C<sv1> is less than, equal to, or greater than the string in
6731 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6732 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6738 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6741 const char *pv1, *pv2;
6744 SV *svrecode = Nullsv;
6751 pv1 = SvPV(sv1, cur1);
6758 pv2 = SvPV(sv2, cur2);
6760 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6761 /* Differing utf8ness.
6762 * Do not UTF8size the comparands as a side-effect. */
6765 svrecode = newSVpvn(pv2, cur2);
6766 sv_recode_to_utf8(svrecode, PL_encoding);
6767 pv2 = SvPV(svrecode, cur2);
6770 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6775 svrecode = newSVpvn(pv1, cur1);
6776 sv_recode_to_utf8(svrecode, PL_encoding);
6777 pv1 = SvPV(svrecode, cur1);
6780 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6786 cmp = cur2 ? -1 : 0;
6790 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6793 cmp = retval < 0 ? -1 : 1;
6794 } else if (cur1 == cur2) {
6797 cmp = cur1 < cur2 ? -1 : 1;
6802 SvREFCNT_dec(svrecode);
6811 =for apidoc sv_cmp_locale
6813 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6814 'use bytes' aware, handles get magic, and will coerce its args to strings
6815 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6821 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6823 #ifdef USE_LOCALE_COLLATE
6829 if (PL_collation_standard)
6833 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6835 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6837 if (!pv1 || !len1) {
6848 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6851 return retval < 0 ? -1 : 1;
6854 * When the result of collation is equality, that doesn't mean
6855 * that there are no differences -- some locales exclude some
6856 * characters from consideration. So to avoid false equalities,
6857 * we use the raw string as a tiebreaker.
6863 #endif /* USE_LOCALE_COLLATE */
6865 return sv_cmp(sv1, sv2);
6869 #ifdef USE_LOCALE_COLLATE
6872 =for apidoc sv_collxfrm
6874 Add Collate Transform magic to an SV if it doesn't already have it.
6876 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6877 scalar data of the variable, but transformed to such a format that a normal
6878 memory comparison can be used to compare the data according to the locale
6885 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6889 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6890 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6895 Safefree(mg->mg_ptr);
6897 if ((xf = mem_collxfrm(s, len, &xlen))) {
6898 if (SvREADONLY(sv)) {
6901 return xf + sizeof(PL_collation_ix);
6904 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6905 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6918 if (mg && mg->mg_ptr) {
6920 return mg->mg_ptr + sizeof(PL_collation_ix);
6928 #endif /* USE_LOCALE_COLLATE */
6933 Get a line from the filehandle and store it into the SV, optionally
6934 appending to the currently-stored string.
6940 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6944 register STDCHAR rslast;
6945 register STDCHAR *bp;
6951 if (SvTHINKFIRST(sv))
6952 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6953 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6955 However, perlbench says it's slower, because the existing swipe code
6956 is faster than copy on write.
6957 Swings and roundabouts. */
6958 (void)SvUPGRADE(sv, SVt_PV);
6963 if (PerlIO_isutf8(fp)) {
6965 sv_utf8_upgrade_nomg(sv);
6966 sv_pos_u2b(sv,&append,0);
6968 } else if (SvUTF8(sv)) {
6969 SV *tsv = NEWSV(0,0);
6970 sv_gets(tsv, fp, 0);
6971 sv_utf8_upgrade_nomg(tsv);
6972 SvCUR_set(sv,append);
6975 goto return_string_or_null;
6980 if (PerlIO_isutf8(fp))
6983 if (IN_PERL_COMPILETIME) {
6984 /* we always read code in line mode */
6988 else if (RsSNARF(PL_rs)) {
6989 /* If it is a regular disk file use size from stat() as estimate
6990 of amount we are going to read - may result in malloc-ing
6991 more memory than we realy need if layers bellow reduce
6992 size we read (e.g. CRLF or a gzip layer)
6995 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6996 Off_t offset = PerlIO_tell(fp);
6997 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6998 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7004 else if (RsRECORD(PL_rs)) {
7008 /* Grab the size of the record we're getting */
7009 recsize = SvIV(SvRV(PL_rs));
7010 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7013 /* VMS wants read instead of fread, because fread doesn't respect */
7014 /* RMS record boundaries. This is not necessarily a good thing to be */
7015 /* doing, but we've got no other real choice - except avoid stdio
7016 as implementation - perhaps write a :vms layer ?
7018 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
7020 bytesread = PerlIO_read(fp, buffer, recsize);
7024 SvCUR_set(sv, bytesread += append);
7025 buffer[bytesread] = '\0';
7026 goto return_string_or_null;
7028 else if (RsPARA(PL_rs)) {
7034 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7035 if (PerlIO_isutf8(fp)) {
7036 rsptr = SvPVutf8(PL_rs, rslen);
7039 if (SvUTF8(PL_rs)) {
7040 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7041 Perl_croak(aTHX_ "Wide character in $/");
7044 rsptr = SvPV(PL_rs, rslen);
7048 rslast = rslen ? rsptr[rslen - 1] : '\0';
7050 if (rspara) { /* have to do this both before and after */
7051 do { /* to make sure file boundaries work right */
7054 i = PerlIO_getc(fp);
7058 PerlIO_ungetc(fp,i);
7064 /* See if we know enough about I/O mechanism to cheat it ! */
7066 /* This used to be #ifdef test - it is made run-time test for ease
7067 of abstracting out stdio interface. One call should be cheap
7068 enough here - and may even be a macro allowing compile
7072 if (PerlIO_fast_gets(fp)) {
7075 * We're going to steal some values from the stdio struct
7076 * and put EVERYTHING in the innermost loop into registers.
7078 register STDCHAR *ptr;
7082 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7083 /* An ungetc()d char is handled separately from the regular
7084 * buffer, so we getc() it back out and stuff it in the buffer.
7086 i = PerlIO_getc(fp);
7087 if (i == EOF) return 0;
7088 *(--((*fp)->_ptr)) = (unsigned char) i;
7092 /* Here is some breathtakingly efficient cheating */
7094 cnt = PerlIO_get_cnt(fp); /* get count into register */
7095 /* make sure we have the room */
7096 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7097 /* Not room for all of it
7098 if we are looking for a separator and room for some
7100 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7101 /* just process what we have room for */
7102 shortbuffered = cnt - SvLEN(sv) + append + 1;
7103 cnt -= shortbuffered;
7107 /* remember that cnt can be negative */
7108 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7113 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7114 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7115 DEBUG_P(PerlIO_printf(Perl_debug_log,
7116 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7117 DEBUG_P(PerlIO_printf(Perl_debug_log,
7118 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7119 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7120 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7125 while (cnt > 0) { /* this | eat */
7127 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7128 goto thats_all_folks; /* screams | sed :-) */
7132 Copy(ptr, bp, cnt, char); /* this | eat */
7133 bp += cnt; /* screams | dust */
7134 ptr += cnt; /* louder | sed :-) */
7139 if (shortbuffered) { /* oh well, must extend */
7140 cnt = shortbuffered;
7142 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7144 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7145 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7149 DEBUG_P(PerlIO_printf(Perl_debug_log,
7150 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7151 PTR2UV(ptr),(long)cnt));
7152 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7154 DEBUG_P(PerlIO_printf(Perl_debug_log,
7155 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7156 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7157 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7159 /* This used to call 'filbuf' in stdio form, but as that behaves like
7160 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7161 another abstraction. */
7162 i = PerlIO_getc(fp); /* get more characters */
7164 DEBUG_P(PerlIO_printf(Perl_debug_log,
7165 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7166 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7167 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7169 cnt = PerlIO_get_cnt(fp);
7170 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7171 DEBUG_P(PerlIO_printf(Perl_debug_log,
7172 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7174 if (i == EOF) /* all done for ever? */
7175 goto thats_really_all_folks;
7177 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7179 SvGROW(sv, bpx + cnt + 2);
7180 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7182 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7184 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7185 goto thats_all_folks;
7189 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7190 memNE((char*)bp - rslen, rsptr, rslen))
7191 goto screamer; /* go back to the fray */
7192 thats_really_all_folks:
7194 cnt += shortbuffered;
7195 DEBUG_P(PerlIO_printf(Perl_debug_log,
7196 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7197 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7198 DEBUG_P(PerlIO_printf(Perl_debug_log,
7199 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7200 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7201 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7203 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7204 DEBUG_P(PerlIO_printf(Perl_debug_log,
7205 "Screamer: done, len=%ld, string=|%.*s|\n",
7206 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7210 /*The big, slow, and stupid way. */
7212 /* Any stack-challenged places. */
7214 /* EPOC: need to work around SDK features. *
7215 * On WINS: MS VC5 generates calls to _chkstk, *
7216 * if a "large" stack frame is allocated. *
7217 * gcc on MARM does not generate calls like these. */
7218 # define USEHEAPINSTEADOFSTACK
7221 #ifdef USEHEAPINSTEADOFSTACK
7223 New(0, buf, 8192, STDCHAR);
7231 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);
7349 if (SvIVX(sv) == IV_MAX)
7350 sv_setuv(sv, (UV)IV_MAX + 1);
7352 (void)SvIOK_only(sv);
7358 if (flags & SVp_NOK) {
7359 (void)SvNOK_only(sv);
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);
7504 if (SvIVX(sv) == IV_MIN)
7505 sv_setnv(sv, (NV)IV_MIN - 1.0);
7507 (void)SvIOK_only(sv);
7513 if (flags & SVp_NOK) {
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 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7725 #if defined(PERL_IMPLICIT_CONTEXT)
7727 /* pTHX_ magic can't cope with varargs, so this is a no-context
7728 * version of the main function, (which may itself be aliased to us).
7729 * Don't access this version directly.
7733 Perl_newSVpvf_nocontext(const char* pat, ...)
7738 va_start(args, pat);
7739 sv = vnewSVpvf(pat, &args);
7746 =for apidoc newSVpvf
7748 Creates a new SV and initializes it with the string formatted like
7755 Perl_newSVpvf(pTHX_ const char* pat, ...)
7759 va_start(args, pat);
7760 sv = vnewSVpvf(pat, &args);
7765 /* backend for newSVpvf() and newSVpvf_nocontext() */
7768 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7772 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7779 Creates a new SV and copies a floating point value into it.
7780 The reference count for the SV is set to 1.
7786 Perl_newSVnv(pTHX_ NV n)
7798 Creates a new SV and copies an integer into it. The reference count for the
7805 Perl_newSViv(pTHX_ IV i)
7817 Creates a new SV and copies an unsigned integer into it.
7818 The reference count for the SV is set to 1.
7824 Perl_newSVuv(pTHX_ UV u)
7834 =for apidoc newRV_noinc
7836 Creates an RV wrapper for an SV. The reference count for the original
7837 SV is B<not> incremented.
7843 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7848 sv_upgrade(sv, SVt_RV);
7855 /* newRV_inc is the official function name to use now.
7856 * newRV_inc is in fact #defined to newRV in sv.h
7860 Perl_newRV(pTHX_ SV *tmpRef)
7862 return newRV_noinc(SvREFCNT_inc(tmpRef));
7868 Creates a new SV which is an exact duplicate of the original SV.
7875 Perl_newSVsv(pTHX_ register SV *old)
7881 if (SvTYPE(old) == SVTYPEMASK) {
7882 if (ckWARN_d(WARN_INTERNAL))
7883 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7887 /* SV_GMAGIC is the default for sv_setv()
7888 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7889 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7890 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7895 =for apidoc sv_reset
7897 Underlying implementation for the C<reset> Perl function.
7898 Note that the perl-level function is vaguely deprecated.
7904 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7912 char todo[PERL_UCHAR_MAX+1];
7917 if (!*s) { /* reset ?? searches */
7918 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7919 pm->op_pmdynflags &= ~PMdf_USED;
7924 /* reset variables */
7926 if (!HvARRAY(stash))
7929 Zero(todo, 256, char);
7931 i = (unsigned char)*s;
7935 max = (unsigned char)*s++;
7936 for ( ; i <= max; i++) {
7939 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7940 for (entry = HvARRAY(stash)[i];
7942 entry = HeNEXT(entry))
7944 if (!todo[(U8)*HeKEY(entry)])
7946 gv = (GV*)HeVAL(entry);
7948 if (SvTHINKFIRST(sv)) {
7949 if (!SvREADONLY(sv) && SvROK(sv))
7954 if (SvTYPE(sv) >= SVt_PV) {
7956 if (SvPVX(sv) != Nullch)
7963 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7966 #ifdef USE_ENVIRON_ARRAY
7968 # ifdef USE_ITHREADS
7969 && PL_curinterp == aTHX
7973 environ[0] = Nullch;
7976 #endif /* !PERL_MICRO */
7986 Using various gambits, try to get an IO from an SV: the IO slot if its a
7987 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7988 named after the PV if we're a string.
7994 Perl_sv_2io(pTHX_ SV *sv)
7999 switch (SvTYPE(sv)) {
8007 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8011 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8013 return sv_2io(SvRV(sv));
8014 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
8020 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
8029 Using various gambits, try to get a CV from an SV; in addition, try if
8030 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8036 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
8042 return *gvp = Nullgv, Nullcv;
8043 switch (SvTYPE(sv)) {
8062 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8063 tryAMAGICunDEREF(to_cv);
8066 if (SvTYPE(sv) == SVt_PVCV) {
8075 Perl_croak(aTHX_ "Not a subroutine reference");
8080 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8086 if (lref && !GvCVu(gv)) {
8089 tmpsv = NEWSV(704,0);
8090 gv_efullname3(tmpsv, gv, Nullch);
8091 /* XXX this is probably not what they think they're getting.
8092 * It has the same effect as "sub name;", i.e. just a forward
8094 newSUB(start_subparse(FALSE, 0),
8095 newSVOP(OP_CONST, 0, tmpsv),
8100 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8110 Returns true if the SV has a true value by Perl's rules.
8111 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8112 instead use an in-line version.
8118 Perl_sv_true(pTHX_ register SV *sv)
8123 const register XPV* tXpv;
8124 if ((tXpv = (XPV*)SvANY(sv)) &&
8125 (tXpv->xpv_cur > 1 ||
8126 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8133 return SvIVX(sv) != 0;
8136 return SvNVX(sv) != 0.0;
8138 return sv_2bool(sv);
8146 A private implementation of the C<SvIVx> macro for compilers which can't
8147 cope with complex macro expressions. Always use the macro instead.
8153 Perl_sv_iv(pTHX_ register SV *sv)
8157 return (IV)SvUVX(sv);
8166 A private implementation of the C<SvUVx> macro for compilers which can't
8167 cope with complex macro expressions. Always use the macro instead.
8173 Perl_sv_uv(pTHX_ register SV *sv)
8178 return (UV)SvIVX(sv);
8186 A private implementation of the C<SvNVx> macro for compilers which can't
8187 cope with complex macro expressions. Always use the macro instead.
8193 Perl_sv_nv(pTHX_ register SV *sv)
8200 /* sv_pv() is now a macro using SvPV_nolen();
8201 * this function provided for binary compatibility only
8205 Perl_sv_pv(pTHX_ SV *sv)
8212 return sv_2pv(sv, &n_a);
8218 Use the C<SvPV_nolen> macro instead
8222 A private implementation of the C<SvPV> macro for compilers which can't
8223 cope with complex macro expressions. Always use the macro instead.
8229 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8235 return sv_2pv(sv, lp);
8240 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8246 return sv_2pv_flags(sv, lp, 0);
8249 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8250 * this function provided for binary compatibility only
8254 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8256 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8260 =for apidoc sv_pvn_force
8262 Get a sensible string out of the SV somehow.
8263 A private implementation of the C<SvPV_force> macro for compilers which
8264 can't cope with complex macro expressions. Always use the macro instead.
8266 =for apidoc sv_pvn_force_flags
8268 Get a sensible string out of the SV somehow.
8269 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8270 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8271 implemented in terms of this function.
8272 You normally want to use the various wrapper macros instead: see
8273 C<SvPV_force> and C<SvPV_force_nomg>
8279 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8283 if (SvTHINKFIRST(sv) && !SvROK(sv))
8284 sv_force_normal_flags(sv, 0);
8290 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8291 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8295 s = sv_2pv_flags(sv, lp, flags);
8296 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8301 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8302 SvGROW(sv, len + 1);
8303 Move(s,SvPVX(sv),len,char);
8308 SvPOK_on(sv); /* validate pointer */
8310 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8311 PTR2UV(sv),SvPVX(sv)));
8317 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8318 * this function provided for binary compatibility only
8322 Perl_sv_pvbyte(pTHX_ SV *sv)
8324 sv_utf8_downgrade(sv,0);
8329 =for apidoc sv_pvbyte
8331 Use C<SvPVbyte_nolen> instead.
8333 =for apidoc sv_pvbyten
8335 A private implementation of the C<SvPVbyte> macro for compilers
8336 which can't cope with complex macro expressions. Always use the macro
8343 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8345 sv_utf8_downgrade(sv,0);
8346 return sv_pvn(sv,lp);
8350 =for apidoc sv_pvbyten_force
8352 A private implementation of the C<SvPVbytex_force> macro for compilers
8353 which can't cope with complex macro expressions. Always use the macro
8360 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8362 sv_pvn_force(sv,lp);
8363 sv_utf8_downgrade(sv,0);
8368 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8369 * this function provided for binary compatibility only
8373 Perl_sv_pvutf8(pTHX_ SV *sv)
8375 sv_utf8_upgrade(sv);
8380 =for apidoc sv_pvutf8
8382 Use the C<SvPVutf8_nolen> macro instead
8384 =for apidoc sv_pvutf8n
8386 A private implementation of the C<SvPVutf8> macro for compilers
8387 which can't cope with complex macro expressions. Always use the macro
8394 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8396 sv_utf8_upgrade(sv);
8397 return sv_pvn(sv,lp);
8401 =for apidoc sv_pvutf8n_force
8403 A private implementation of the C<SvPVutf8_force> macro for compilers
8404 which can't cope with complex macro expressions. Always use the macro
8411 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8413 sv_pvn_force(sv,lp);
8414 sv_utf8_upgrade(sv);
8420 =for apidoc sv_reftype
8422 Returns a string describing what the SV is a reference to.
8428 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8430 /* 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 */
9825 #if defined(PERL_Y2KWARN)
9826 if (ckWARN(WARN_Y2K)) {
9828 char *s = SvPV(sv,n);
9829 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9830 && (n == 2 || !isDIGIT(s[n-3])))
9832 Perl_warner(aTHX_ packWARN(WARN_Y2K),
9833 "Possible Y2K bug: %%%c %s",
9834 c, "format string following '19'");
9840 *--eptr = '0' + dig;
9841 } while (uv /= base);
9844 elen = (ebuf + sizeof ebuf) - eptr;
9847 zeros = precis - elen;
9848 else if (precis == 0 && elen == 1 && *eptr == '0')
9853 /* FLOATING POINT */
9856 c = 'f'; /* maybe %F isn't supported here */
9862 /* This is evil, but floating point is even more evil */
9864 /* for SV-style calling, we can only get NV
9865 for C-style calling, we assume %f is double;
9866 for simplicity we allow any of %Lf, %llf, %qf for long double
9870 #if defined(USE_LONG_DOUBLE)
9874 /* [perl #20339] - we should accept and ignore %lf rather than die */
9878 #if defined(USE_LONG_DOUBLE)
9879 intsize = args ? 0 : 'q';
9883 #if defined(HAS_LONG_DOUBLE)
9892 /* now we need (long double) if intsize == 'q', else (double) */
9893 nv = (args && !vectorize) ?
9894 #if LONG_DOUBLESIZE > DOUBLESIZE
9896 va_arg(*args, long double) :
9897 va_arg(*args, double)
9899 va_arg(*args, double)
9905 if (c != 'e' && c != 'E') {
9907 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9908 will cast our (long double) to (double) */
9909 (void)Perl_frexp(nv, &i);
9910 if (i == PERL_INT_MIN)
9911 Perl_die(aTHX_ "panic: frexp");
9913 need = BIT_DIGITS(i);
9915 need += has_precis ? precis : 6; /* known default */
9920 #ifdef HAS_LDBL_SPRINTF_BUG
9921 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9922 with sfio - Allen <allens@cpan.org> */
9925 # define MY_DBL_MAX DBL_MAX
9926 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9927 # if DOUBLESIZE >= 8
9928 # define MY_DBL_MAX 1.7976931348623157E+308L
9930 # define MY_DBL_MAX 3.40282347E+38L
9934 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9935 # define MY_DBL_MAX_BUG 1L
9937 # define MY_DBL_MAX_BUG MY_DBL_MAX
9941 # define MY_DBL_MIN DBL_MIN
9942 # else /* XXX guessing! -Allen */
9943 # if DOUBLESIZE >= 8
9944 # define MY_DBL_MIN 2.2250738585072014E-308L
9946 # define MY_DBL_MIN 1.17549435E-38L
9950 if ((intsize == 'q') && (c == 'f') &&
9951 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9953 /* it's going to be short enough that
9954 * long double precision is not needed */
9956 if ((nv <= 0L) && (nv >= -0L))
9957 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9959 /* would use Perl_fp_class as a double-check but not
9960 * functional on IRIX - see perl.h comments */
9962 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9963 /* It's within the range that a double can represent */
9964 #if defined(DBL_MAX) && !defined(DBL_MIN)
9965 if ((nv >= ((long double)1/DBL_MAX)) ||
9966 (nv <= (-(long double)1/DBL_MAX)))
9968 fix_ldbl_sprintf_bug = TRUE;
9971 if (fix_ldbl_sprintf_bug == TRUE) {
9981 # undef MY_DBL_MAX_BUG
9984 #endif /* HAS_LDBL_SPRINTF_BUG */
9986 need += 20; /* fudge factor */
9987 if (PL_efloatsize < need) {
9988 Safefree(PL_efloatbuf);
9989 PL_efloatsize = need + 20; /* more fudge */
9990 New(906, PL_efloatbuf, PL_efloatsize, char);
9991 PL_efloatbuf[0] = '\0';
9994 if ( !(width || left || plus || alt) && fill != '0'
9995 && has_precis && intsize != 'q' ) { /* Shortcuts */
9996 /* See earlier comment about buggy Gconvert when digits,
9998 if ( c == 'g' && precis) {
9999 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10000 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
10001 goto float_converted;
10002 } else if ( c == 'f' && !precis) {
10003 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10007 eptr = ebuf + sizeof ebuf;
10010 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10011 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10012 if (intsize == 'q') {
10013 /* Copy the one or more characters in a long double
10014 * format before the 'base' ([efgEFG]) character to
10015 * the format string. */
10016 static char const prifldbl[] = PERL_PRIfldbl;
10017 char const *p = prifldbl + sizeof(prifldbl) - 3;
10018 while (p >= prifldbl) { *--eptr = *p--; }
10023 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10028 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10040 /* No taint. Otherwise we are in the strange situation
10041 * where printf() taints but print($float) doesn't.
10043 #if defined(HAS_LONG_DOUBLE)
10044 if (intsize == 'q')
10045 (void)sprintf(PL_efloatbuf, eptr, nv);
10047 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
10049 (void)sprintf(PL_efloatbuf, eptr, nv);
10052 eptr = PL_efloatbuf;
10053 elen = strlen(PL_efloatbuf);
10059 i = SvCUR(sv) - origlen;
10060 if (args && !vectorize) {
10062 case 'h': *(va_arg(*args, short*)) = i; break;
10063 default: *(va_arg(*args, int*)) = i; break;
10064 case 'l': *(va_arg(*args, long*)) = i; break;
10065 case 'V': *(va_arg(*args, IV*)) = i; break;
10067 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10072 sv_setuv_mg(argsv, (UV)i);
10074 continue; /* not "break" */
10080 if (!args && ckWARN(WARN_PRINTF) &&
10081 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10082 SV *msg = sv_newmortal();
10083 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10084 (PL_op->op_type == OP_PRTF) ? "" : "s");
10087 Perl_sv_catpvf(aTHX_ msg,
10088 "\"%%%c\"", c & 0xFF);
10090 Perl_sv_catpvf(aTHX_ msg,
10091 "\"%%\\%03"UVof"\"",
10094 sv_catpv(msg, "end of string");
10095 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10098 /* output mangled stuff ... */
10104 /* ... right here, because formatting flags should not apply */
10105 SvGROW(sv, SvCUR(sv) + elen + 1);
10107 Copy(eptr, p, elen, char);
10110 SvCUR(sv) = p - SvPVX(sv);
10112 continue; /* not "break" */
10115 /* calculate width before utf8_upgrade changes it */
10116 have = esignlen + zeros + elen;
10118 if (is_utf8 != has_utf8) {
10121 sv_utf8_upgrade(sv);
10124 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10125 sv_utf8_upgrade(nsv);
10129 SvGROW(sv, SvCUR(sv) + elen + 1);
10134 need = (have > width ? have : width);
10137 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10139 if (esignlen && fill == '0') {
10140 for (i = 0; i < (int)esignlen; i++)
10141 *p++ = esignbuf[i];
10143 if (gap && !left) {
10144 memset(p, fill, gap);
10147 if (esignlen && fill != '0') {
10148 for (i = 0; i < (int)esignlen; i++)
10149 *p++ = esignbuf[i];
10152 for (i = zeros; i; i--)
10156 Copy(eptr, p, elen, char);
10160 memset(p, ' ', gap);
10165 Copy(dotstr, p, dotstrlen, char);
10169 vectorize = FALSE; /* done iterating over vecstr */
10176 SvCUR(sv) = p - SvPVX(sv);
10184 /* =========================================================================
10186 =head1 Cloning an interpreter
10188 All the macros and functions in this section are for the private use of
10189 the main function, perl_clone().
10191 The foo_dup() functions make an exact copy of an existing foo thinngy.
10192 During the course of a cloning, a hash table is used to map old addresses
10193 to new addresses. The table is created and manipulated with the
10194 ptr_table_* functions.
10198 ============================================================================*/
10201 #if defined(USE_ITHREADS)
10203 #ifndef GpREFCNT_inc
10204 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10208 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10209 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10210 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10211 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10212 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10213 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10214 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10215 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10216 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10217 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10218 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10219 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10220 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10223 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10224 regcomp.c. AMS 20010712 */
10227 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10231 struct reg_substr_datum *s;
10234 return (REGEXP *)NULL;
10236 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10239 len = r->offsets[0];
10240 npar = r->nparens+1;
10242 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10243 Copy(r->program, ret->program, len+1, regnode);
10245 New(0, ret->startp, npar, I32);
10246 Copy(r->startp, ret->startp, npar, I32);
10247 New(0, ret->endp, npar, I32);
10248 Copy(r->startp, ret->startp, npar, I32);
10250 New(0, ret->substrs, 1, struct reg_substr_data);
10251 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10252 s->min_offset = r->substrs->data[i].min_offset;
10253 s->max_offset = r->substrs->data[i].max_offset;
10254 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10255 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10258 ret->regstclass = NULL;
10260 struct reg_data *d;
10261 const int count = r->data->count;
10263 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10264 char, struct reg_data);
10265 New(0, d->what, count, U8);
10268 for (i = 0; i < count; i++) {
10269 d->what[i] = r->data->what[i];
10270 switch (d->what[i]) {
10271 /* legal options are one of: sfpont
10272 see also regcomp.h and pregfree() */
10274 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10277 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10280 /* This is cheating. */
10281 New(0, d->data[i], 1, struct regnode_charclass_class);
10282 StructCopy(r->data->data[i], d->data[i],
10283 struct regnode_charclass_class);
10284 ret->regstclass = (regnode*)d->data[i];
10287 /* Compiled op trees are readonly, and can thus be
10288 shared without duplication. */
10290 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10294 d->data[i] = r->data->data[i];
10297 d->data[i] = r->data->data[i];
10299 ((reg_trie_data*)d->data[i])->refcount++;
10303 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10312 New(0, ret->offsets, 2*len+1, U32);
10313 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10315 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10316 ret->refcnt = r->refcnt;
10317 ret->minlen = r->minlen;
10318 ret->prelen = r->prelen;
10319 ret->nparens = r->nparens;
10320 ret->lastparen = r->lastparen;
10321 ret->lastcloseparen = r->lastcloseparen;
10322 ret->reganch = r->reganch;
10324 ret->sublen = r->sublen;
10326 if (RX_MATCH_COPIED(ret))
10327 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10329 ret->subbeg = Nullch;
10330 #ifdef PERL_COPY_ON_WRITE
10331 ret->saved_copy = Nullsv;
10334 ptr_table_store(PL_ptr_table, r, ret);
10338 /* duplicate a file handle */
10341 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10347 return (PerlIO*)NULL;
10349 /* look for it in the table first */
10350 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10354 /* create anew and remember what it is */
10355 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10356 ptr_table_store(PL_ptr_table, fp, ret);
10360 /* duplicate a directory handle */
10363 Perl_dirp_dup(pTHX_ DIR *dp)
10371 /* duplicate a typeglob */
10374 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10379 /* look for it in the table first */
10380 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10384 /* create anew and remember what it is */
10385 Newz(0, ret, 1, GP);
10386 ptr_table_store(PL_ptr_table, gp, ret);
10389 ret->gp_refcnt = 0; /* must be before any other dups! */
10390 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10391 ret->gp_io = io_dup_inc(gp->gp_io, param);
10392 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10393 ret->gp_av = av_dup_inc(gp->gp_av, param);
10394 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10395 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10396 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10397 ret->gp_cvgen = gp->gp_cvgen;
10398 ret->gp_flags = gp->gp_flags;
10399 ret->gp_line = gp->gp_line;
10400 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10404 /* duplicate a chain of magic */
10407 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10409 MAGIC *mgprev = (MAGIC*)NULL;
10412 return (MAGIC*)NULL;
10413 /* look for it in the table first */
10414 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10418 for (; mg; mg = mg->mg_moremagic) {
10420 Newz(0, nmg, 1, MAGIC);
10422 mgprev->mg_moremagic = nmg;
10425 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10426 nmg->mg_private = mg->mg_private;
10427 nmg->mg_type = mg->mg_type;
10428 nmg->mg_flags = mg->mg_flags;
10429 if (mg->mg_type == PERL_MAGIC_qr) {
10430 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10432 else if(mg->mg_type == PERL_MAGIC_backref) {
10433 const AV * const av = (AV*) mg->mg_obj;
10436 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10438 for (i = AvFILLp(av); i >= 0; i--) {
10439 if (!svp[i]) continue;
10440 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10444 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10445 ? sv_dup_inc(mg->mg_obj, param)
10446 : sv_dup(mg->mg_obj, param);
10448 nmg->mg_len = mg->mg_len;
10449 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10450 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10451 if (mg->mg_len > 0) {
10452 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10453 if (mg->mg_type == PERL_MAGIC_overload_table &&
10454 AMT_AMAGIC((AMT*)mg->mg_ptr))
10456 AMT *amtp = (AMT*)mg->mg_ptr;
10457 AMT *namtp = (AMT*)nmg->mg_ptr;
10459 for (i = 1; i < NofAMmeth; i++) {
10460 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10464 else if (mg->mg_len == HEf_SVKEY)
10465 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10467 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10468 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10475 /* create a new pointer-mapping table */
10478 Perl_ptr_table_new(pTHX)
10481 Newz(0, tbl, 1, PTR_TBL_t);
10482 tbl->tbl_max = 511;
10483 tbl->tbl_items = 0;
10484 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10489 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10491 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10494 /* map an existing pointer using a table */
10497 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10499 PTR_TBL_ENT_t *tblent;
10500 UV hash = PTR_TABLE_HASH(sv);
10502 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10503 for (; tblent; tblent = tblent->next) {
10504 if (tblent->oldval == sv)
10505 return tblent->newval;
10507 return (void*)NULL;
10510 /* add a new entry to a pointer-mapping table */
10513 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10515 PTR_TBL_ENT_t *tblent, **otblent;
10516 /* XXX this may be pessimal on platforms where pointers aren't good
10517 * hash values e.g. if they grow faster in the most significant
10519 UV hash = PTR_TABLE_HASH(oldv);
10523 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10524 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10525 if (tblent->oldval == oldv) {
10526 tblent->newval = newv;
10530 Newz(0, tblent, 1, PTR_TBL_ENT_t);
10531 tblent->oldval = oldv;
10532 tblent->newval = newv;
10533 tblent->next = *otblent;
10536 if (!empty && tbl->tbl_items > tbl->tbl_max)
10537 ptr_table_split(tbl);
10540 /* double the hash bucket size of an existing ptr table */
10543 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10545 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10546 UV oldsize = tbl->tbl_max + 1;
10547 UV newsize = oldsize * 2;
10550 Renew(ary, newsize, PTR_TBL_ENT_t*);
10551 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10552 tbl->tbl_max = --newsize;
10553 tbl->tbl_ary = ary;
10554 for (i=0; i < oldsize; i++, ary++) {
10555 PTR_TBL_ENT_t **curentp, **entp, *ent;
10558 curentp = ary + oldsize;
10559 for (entp = ary, ent = *ary; ent; ent = *entp) {
10560 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10562 ent->next = *curentp;
10572 /* remove all the entries from a ptr table */
10575 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10577 register PTR_TBL_ENT_t **array;
10578 register PTR_TBL_ENT_t *entry;
10579 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10583 if (!tbl || !tbl->tbl_items) {
10587 array = tbl->tbl_ary;
10589 max = tbl->tbl_max;
10594 entry = entry->next;
10598 if (++riter > max) {
10601 entry = array[riter];
10605 tbl->tbl_items = 0;
10608 /* clear and free a ptr table */
10611 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10616 ptr_table_clear(tbl);
10617 Safefree(tbl->tbl_ary);
10622 char *PL_watch_pvx;
10625 /* attempt to make everything in the typeglob readonly */
10628 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10630 GV *gv = (GV*)sstr;
10631 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10633 if (GvIO(gv) || GvFORM(gv)) {
10634 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10636 else if (!GvCV(gv)) {
10637 GvCV(gv) = (CV*)sv;
10640 /* CvPADLISTs cannot be shared */
10641 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10646 if (!GvUNIQUE(gv)) {
10648 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10649 HvNAME(GvSTASH(gv)), GvNAME(gv));
10655 * write attempts will die with
10656 * "Modification of a read-only value attempted"
10662 SvREADONLY_on(GvSV(gv));
10666 GvAV(gv) = (AV*)sv;
10669 SvREADONLY_on(GvAV(gv));
10673 GvHV(gv) = (HV*)sv;
10676 SvREADONLY_on(GvHV(gv));
10679 return sstr; /* he_dup() will SvREFCNT_inc() */
10682 /* duplicate an SV of any type (including AV, HV etc) */
10685 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10688 SvRV(dstr) = SvWEAKREF(sstr)
10689 ? sv_dup(SvRV(sstr), param)
10690 : sv_dup_inc(SvRV(sstr), param);
10692 else if (SvPVX(sstr)) {
10693 /* Has something there */
10695 /* Normal PV - clone whole allocated space */
10696 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
10697 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10698 /* Not that normal - actually sstr is copy on write.
10699 But we are a true, independant SV, so: */
10700 SvREADONLY_off(dstr);
10705 /* Special case - not normally malloced for some reason */
10706 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10707 /* A "shared" PV - clone it as unshared string */
10708 if(SvPADTMP(sstr)) {
10709 /* However, some of them live in the pad
10710 and they should not have these flags
10713 SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
10715 SvUVX(dstr) = SvUVX(sstr);
10718 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
10720 SvREADONLY_off(dstr);
10724 /* Some other special case - random pointer */
10725 SvPVX(dstr) = SvPVX(sstr);
10730 /* Copy the Null */
10731 SvPVX(dstr) = SvPVX(sstr);
10736 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10740 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10742 /* look for it in the table first */
10743 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10747 if(param->flags & CLONEf_JOIN_IN) {
10748 /** We are joining here so we don't want do clone
10749 something that is bad **/
10751 if(SvTYPE(sstr) == SVt_PVHV &&
10753 /** don't clone stashes if they already exist **/
10754 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10755 return (SV*) old_stash;
10759 /* create anew and remember what it is */
10762 #ifdef DEBUG_LEAKING_SCALARS
10763 dstr->sv_debug_optype = sstr->sv_debug_optype;
10764 dstr->sv_debug_line = sstr->sv_debug_line;
10765 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10766 dstr->sv_debug_cloned = 1;
10768 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10770 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10774 ptr_table_store(PL_ptr_table, sstr, dstr);
10777 SvFLAGS(dstr) = SvFLAGS(sstr);
10778 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10779 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10782 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10783 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10784 PL_watch_pvx, SvPVX(sstr));
10787 switch (SvTYPE(sstr)) {
10789 SvANY(dstr) = NULL;
10792 SvANY(dstr) = new_XIV();
10793 SvIVX(dstr) = SvIVX(sstr);
10796 SvANY(dstr) = new_XNV();
10797 SvNV_set(dstr, SvNVX(sstr));
10800 SvANY(dstr) = new_XRV();
10801 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10804 SvANY(dstr) = new_XPV();
10805 SvCUR(dstr) = SvCUR(sstr);
10806 SvLEN(dstr) = SvLEN(sstr);
10807 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10810 SvANY(dstr) = new_XPVIV();
10811 SvCUR(dstr) = SvCUR(sstr);
10812 SvLEN(dstr) = SvLEN(sstr);
10813 SvIVX(dstr) = SvIVX(sstr);
10814 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10817 SvANY(dstr) = new_XPVNV();
10818 SvCUR(dstr) = SvCUR(sstr);
10819 SvLEN(dstr) = SvLEN(sstr);
10820 SvIVX(dstr) = SvIVX(sstr);
10821 SvNV_set(dstr, SvNVX(sstr));
10822 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10825 SvANY(dstr) = new_XPVMG();
10826 SvCUR(dstr) = SvCUR(sstr);
10827 SvLEN(dstr) = SvLEN(sstr);
10828 SvIVX(dstr) = SvIVX(sstr);
10829 SvNV_set(dstr, SvNVX(sstr));
10830 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10831 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10832 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10835 SvANY(dstr) = new_XPVBM();
10836 SvCUR(dstr) = SvCUR(sstr);
10837 SvLEN(dstr) = SvLEN(sstr);
10838 SvIVX(dstr) = SvIVX(sstr);
10839 SvNV_set(dstr, SvNVX(sstr));
10840 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10841 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10842 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10843 BmRARE(dstr) = BmRARE(sstr);
10844 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10845 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10848 SvANY(dstr) = new_XPVLV();
10849 SvCUR(dstr) = SvCUR(sstr);
10850 SvLEN(dstr) = SvLEN(sstr);
10851 SvIVX(dstr) = SvIVX(sstr);
10852 SvNV_set(dstr, SvNVX(sstr));
10853 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10854 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10855 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10856 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10857 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10858 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10859 LvTARG(dstr) = dstr;
10860 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10861 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10863 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10864 LvTYPE(dstr) = LvTYPE(sstr);
10867 if (GvUNIQUE((GV*)sstr)) {
10869 if ((share = gv_share(sstr, param))) {
10872 ptr_table_store(PL_ptr_table, sstr, dstr);
10874 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10875 HvNAME(GvSTASH(share)), GvNAME(share));
10880 SvANY(dstr) = new_XPVGV();
10881 SvCUR(dstr) = SvCUR(sstr);
10882 SvLEN(dstr) = SvLEN(sstr);
10883 SvIVX(dstr) = SvIVX(sstr);
10884 SvNV_set(dstr, SvNVX(sstr));
10885 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10886 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10887 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10888 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10889 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10890 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10891 GvFLAGS(dstr) = GvFLAGS(sstr);
10892 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10893 (void)GpREFCNT_inc(GvGP(dstr));
10896 SvANY(dstr) = new_XPVIO();
10897 SvCUR(dstr) = SvCUR(sstr);
10898 SvLEN(dstr) = SvLEN(sstr);
10899 SvIVX(dstr) = SvIVX(sstr);
10900 SvNV_set(dstr, SvNVX(sstr));
10901 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10902 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10903 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10904 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10905 if (IoOFP(sstr) == IoIFP(sstr))
10906 IoOFP(dstr) = IoIFP(dstr);
10908 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10909 /* PL_rsfp_filters entries have fake IoDIRP() */
10910 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10911 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10913 IoDIRP(dstr) = IoDIRP(sstr);
10914 IoLINES(dstr) = IoLINES(sstr);
10915 IoPAGE(dstr) = IoPAGE(sstr);
10916 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10917 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10918 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10919 /* I have no idea why fake dirp (rsfps)
10920 should be treaded differently but otherwise
10921 we end up with leaks -- sky*/
10922 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10923 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10924 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10926 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10927 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10928 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10930 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10931 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10932 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10933 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10934 IoTYPE(dstr) = IoTYPE(sstr);
10935 IoFLAGS(dstr) = IoFLAGS(sstr);
10938 SvANY(dstr) = new_XPVAV();
10939 SvCUR(dstr) = SvCUR(sstr);
10940 SvLEN(dstr) = SvLEN(sstr);
10941 SvIVX(dstr) = SvIVX(sstr);
10942 SvNV_set(dstr, SvNVX(sstr));
10943 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10944 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10945 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10946 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10947 if (AvARRAY((AV*)sstr)) {
10948 SV **dst_ary, **src_ary;
10949 SSize_t items = AvFILLp((AV*)sstr) + 1;
10951 src_ary = AvARRAY((AV*)sstr);
10952 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10953 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10954 SvPVX(dstr) = (char*)dst_ary;
10955 AvALLOC((AV*)dstr) = dst_ary;
10956 if (AvREAL((AV*)sstr)) {
10957 while (items-- > 0)
10958 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10961 while (items-- > 0)
10962 *dst_ary++ = sv_dup(*src_ary++, param);
10964 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10965 while (items-- > 0) {
10966 *dst_ary++ = &PL_sv_undef;
10970 SvPVX(dstr) = Nullch;
10971 AvALLOC((AV*)dstr) = (SV**)NULL;
10975 SvANY(dstr) = new_XPVHV();
10976 SvCUR(dstr) = SvCUR(sstr);
10977 SvLEN(dstr) = SvLEN(sstr);
10978 SvIVX(dstr) = SvIVX(sstr);
10979 SvNV_set(dstr, SvNVX(sstr));
10980 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10981 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10982 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10983 if (HvARRAY((HV*)sstr)) {
10985 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10986 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10987 Newz(0, dxhv->xhv_array,
10988 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10989 while (i <= sxhv->xhv_max) {
10990 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10991 (bool)!!HvSHAREKEYS(sstr),
10995 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10996 (bool)!!HvSHAREKEYS(sstr), param);
10999 SvPVX(dstr) = Nullch;
11000 HvEITER((HV*)dstr) = (HE*)NULL;
11002 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
11003 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
11004 /* Record stashes for possible cloning in Perl_clone(). */
11005 if(HvNAME((HV*)dstr))
11006 av_push(param->stashes, dstr);
11009 SvANY(dstr) = new_XPVFM();
11010 FmLINES(dstr) = FmLINES(sstr);
11014 SvANY(dstr) = new_XPVCV();
11016 SvCUR(dstr) = SvCUR(sstr);
11017 SvLEN(dstr) = SvLEN(sstr);
11018 SvIVX(dstr) = SvIVX(sstr);
11019 SvNV_set(dstr, SvNVX(sstr));
11020 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
11021 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
11022 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11023 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11024 CvSTART(dstr) = CvSTART(sstr);
11026 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11028 CvXSUB(dstr) = CvXSUB(sstr);
11029 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11030 if (CvCONST(sstr)) {
11031 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11032 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11033 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
11035 /* don't dup if copying back - CvGV isn't refcounted, so the
11036 * duped GV may never be freed. A bit of a hack! DAPM */
11037 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11038 Nullgv : gv_dup(CvGV(sstr), param) ;
11039 if (param->flags & CLONEf_COPY_STACKS) {
11040 CvDEPTH(dstr) = CvDEPTH(sstr);
11044 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11045 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11047 CvWEAKOUTSIDE(sstr)
11048 ? cv_dup( CvOUTSIDE(sstr), param)
11049 : cv_dup_inc(CvOUTSIDE(sstr), param);
11050 CvFLAGS(dstr) = CvFLAGS(sstr);
11051 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11054 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11058 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11064 /* duplicate a context */
11067 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11069 PERL_CONTEXT *ncxs;
11072 return (PERL_CONTEXT*)NULL;
11074 /* look for it in the table first */
11075 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11079 /* create anew and remember what it is */
11080 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11081 ptr_table_store(PL_ptr_table, cxs, ncxs);
11084 PERL_CONTEXT *cx = &cxs[ix];
11085 PERL_CONTEXT *ncx = &ncxs[ix];
11086 ncx->cx_type = cx->cx_type;
11087 if (CxTYPE(cx) == CXt_SUBST) {
11088 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11091 ncx->blk_oldsp = cx->blk_oldsp;
11092 ncx->blk_oldcop = cx->blk_oldcop;
11093 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11094 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11095 ncx->blk_oldpm = cx->blk_oldpm;
11096 ncx->blk_gimme = cx->blk_gimme;
11097 switch (CxTYPE(cx)) {
11099 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11100 ? cv_dup_inc(cx->blk_sub.cv, param)
11101 : cv_dup(cx->blk_sub.cv,param));
11102 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11103 ? av_dup_inc(cx->blk_sub.argarray, param)
11105 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11106 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11107 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11108 ncx->blk_sub.lval = cx->blk_sub.lval;
11109 ncx->blk_sub.retop = cx->blk_sub.retop;
11112 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11113 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11114 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11115 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11116 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11117 ncx->blk_eval.retop = cx->blk_eval.retop;
11120 ncx->blk_loop.label = cx->blk_loop.label;
11121 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11122 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11123 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11124 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11125 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11126 ? cx->blk_loop.iterdata
11127 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11128 ncx->blk_loop.oldcomppad
11129 = (PAD*)ptr_table_fetch(PL_ptr_table,
11130 cx->blk_loop.oldcomppad);
11131 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11132 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11133 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11134 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11135 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11138 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11139 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11140 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11141 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11142 ncx->blk_sub.retop = cx->blk_sub.retop;
11154 /* duplicate a stack info structure */
11157 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11162 return (PERL_SI*)NULL;
11164 /* look for it in the table first */
11165 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11169 /* create anew and remember what it is */
11170 Newz(56, nsi, 1, PERL_SI);
11171 ptr_table_store(PL_ptr_table, si, nsi);
11173 nsi->si_stack = av_dup_inc(si->si_stack, param);
11174 nsi->si_cxix = si->si_cxix;
11175 nsi->si_cxmax = si->si_cxmax;
11176 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11177 nsi->si_type = si->si_type;
11178 nsi->si_prev = si_dup(si->si_prev, param);
11179 nsi->si_next = si_dup(si->si_next, param);
11180 nsi->si_markoff = si->si_markoff;
11185 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11186 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11187 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11188 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11189 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11190 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11191 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11192 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11193 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11194 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11195 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11196 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11197 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11198 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11201 #define pv_dup_inc(p) SAVEPV(p)
11202 #define pv_dup(p) SAVEPV(p)
11203 #define svp_dup_inc(p,pp) any_dup(p,pp)
11205 /* map any object to the new equivent - either something in the
11206 * ptr table, or something in the interpreter structure
11210 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11215 return (void*)NULL;
11217 /* look for it in the table first */
11218 ret = ptr_table_fetch(PL_ptr_table, v);
11222 /* see if it is part of the interpreter structure */
11223 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11224 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11232 /* duplicate the save stack */
11235 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11237 ANY *ss = proto_perl->Tsavestack;
11238 I32 ix = proto_perl->Tsavestack_ix;
11239 I32 max = proto_perl->Tsavestack_max;
11252 void (*dptr) (void*);
11253 void (*dxptr) (pTHX_ void*);
11256 Newz(54, nss, max, ANY);
11260 TOPINT(nss,ix) = i;
11262 case SAVEt_ITEM: /* normal string */
11263 sv = (SV*)POPPTR(ss,ix);
11264 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11265 sv = (SV*)POPPTR(ss,ix);
11266 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11268 case SAVEt_SV: /* scalar reference */
11269 sv = (SV*)POPPTR(ss,ix);
11270 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11271 gv = (GV*)POPPTR(ss,ix);
11272 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11274 case SAVEt_GENERIC_PVREF: /* generic char* */
11275 c = (char*)POPPTR(ss,ix);
11276 TOPPTR(nss,ix) = pv_dup(c);
11277 ptr = POPPTR(ss,ix);
11278 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11280 case SAVEt_SHARED_PVREF: /* char* in shared space */
11281 c = (char*)POPPTR(ss,ix);
11282 TOPPTR(nss,ix) = savesharedpv(c);
11283 ptr = POPPTR(ss,ix);
11284 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11286 case SAVEt_GENERIC_SVREF: /* generic sv */
11287 case SAVEt_SVREF: /* scalar reference */
11288 sv = (SV*)POPPTR(ss,ix);
11289 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11290 ptr = POPPTR(ss,ix);
11291 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11293 case SAVEt_AV: /* array reference */
11294 av = (AV*)POPPTR(ss,ix);
11295 TOPPTR(nss,ix) = av_dup_inc(av, param);
11296 gv = (GV*)POPPTR(ss,ix);
11297 TOPPTR(nss,ix) = gv_dup(gv, param);
11299 case SAVEt_HV: /* hash reference */
11300 hv = (HV*)POPPTR(ss,ix);
11301 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11302 gv = (GV*)POPPTR(ss,ix);
11303 TOPPTR(nss,ix) = gv_dup(gv, param);
11305 case SAVEt_INT: /* int reference */
11306 ptr = POPPTR(ss,ix);
11307 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11308 intval = (int)POPINT(ss,ix);
11309 TOPINT(nss,ix) = intval;
11311 case SAVEt_LONG: /* long reference */
11312 ptr = POPPTR(ss,ix);
11313 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11314 longval = (long)POPLONG(ss,ix);
11315 TOPLONG(nss,ix) = longval;
11317 case SAVEt_I32: /* I32 reference */
11318 case SAVEt_I16: /* I16 reference */
11319 case SAVEt_I8: /* I8 reference */
11320 ptr = POPPTR(ss,ix);
11321 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11323 TOPINT(nss,ix) = i;
11325 case SAVEt_IV: /* IV reference */
11326 ptr = POPPTR(ss,ix);
11327 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11329 TOPIV(nss,ix) = iv;
11331 case SAVEt_SPTR: /* SV* reference */
11332 ptr = POPPTR(ss,ix);
11333 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11334 sv = (SV*)POPPTR(ss,ix);
11335 TOPPTR(nss,ix) = sv_dup(sv, param);
11337 case SAVEt_VPTR: /* random* reference */
11338 ptr = POPPTR(ss,ix);
11339 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11340 ptr = POPPTR(ss,ix);
11341 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11343 case SAVEt_PPTR: /* char* reference */
11344 ptr = POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11346 c = (char*)POPPTR(ss,ix);
11347 TOPPTR(nss,ix) = pv_dup(c);
11349 case SAVEt_HPTR: /* HV* reference */
11350 ptr = POPPTR(ss,ix);
11351 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11352 hv = (HV*)POPPTR(ss,ix);
11353 TOPPTR(nss,ix) = hv_dup(hv, param);
11355 case SAVEt_APTR: /* AV* reference */
11356 ptr = POPPTR(ss,ix);
11357 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11358 av = (AV*)POPPTR(ss,ix);
11359 TOPPTR(nss,ix) = av_dup(av, param);
11362 gv = (GV*)POPPTR(ss,ix);
11363 TOPPTR(nss,ix) = gv_dup(gv, param);
11365 case SAVEt_GP: /* scalar reference */
11366 gp = (GP*)POPPTR(ss,ix);
11367 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11368 (void)GpREFCNT_inc(gp);
11369 gv = (GV*)POPPTR(ss,ix);
11370 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11371 c = (char*)POPPTR(ss,ix);
11372 TOPPTR(nss,ix) = pv_dup(c);
11374 TOPIV(nss,ix) = iv;
11376 TOPIV(nss,ix) = iv;
11379 case SAVEt_MORTALIZESV:
11380 sv = (SV*)POPPTR(ss,ix);
11381 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11384 ptr = POPPTR(ss,ix);
11385 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11386 /* these are assumed to be refcounted properly */
11387 switch (((OP*)ptr)->op_type) {
11389 case OP_LEAVESUBLV:
11393 case OP_LEAVEWRITE:
11394 TOPPTR(nss,ix) = ptr;
11399 TOPPTR(nss,ix) = Nullop;
11404 TOPPTR(nss,ix) = Nullop;
11407 c = (char*)POPPTR(ss,ix);
11408 TOPPTR(nss,ix) = pv_dup_inc(c);
11410 case SAVEt_CLEARSV:
11411 longval = POPLONG(ss,ix);
11412 TOPLONG(nss,ix) = longval;
11415 hv = (HV*)POPPTR(ss,ix);
11416 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11417 c = (char*)POPPTR(ss,ix);
11418 TOPPTR(nss,ix) = pv_dup_inc(c);
11420 TOPINT(nss,ix) = i;
11422 case SAVEt_DESTRUCTOR:
11423 ptr = POPPTR(ss,ix);
11424 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11425 dptr = POPDPTR(ss,ix);
11426 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11428 case SAVEt_DESTRUCTOR_X:
11429 ptr = POPPTR(ss,ix);
11430 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11431 dxptr = POPDXPTR(ss,ix);
11432 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11434 case SAVEt_REGCONTEXT:
11437 TOPINT(nss,ix) = i;
11440 case SAVEt_STACK_POS: /* Position on Perl stack */
11442 TOPINT(nss,ix) = i;
11444 case SAVEt_AELEM: /* array element */
11445 sv = (SV*)POPPTR(ss,ix);
11446 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11448 TOPINT(nss,ix) = i;
11449 av = (AV*)POPPTR(ss,ix);
11450 TOPPTR(nss,ix) = av_dup_inc(av, param);
11452 case SAVEt_HELEM: /* hash element */
11453 sv = (SV*)POPPTR(ss,ix);
11454 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11455 sv = (SV*)POPPTR(ss,ix);
11456 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11457 hv = (HV*)POPPTR(ss,ix);
11458 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11461 ptr = POPPTR(ss,ix);
11462 TOPPTR(nss,ix) = ptr;
11466 TOPINT(nss,ix) = i;
11468 case SAVEt_COMPPAD:
11469 av = (AV*)POPPTR(ss,ix);
11470 TOPPTR(nss,ix) = av_dup(av, param);
11473 longval = (long)POPLONG(ss,ix);
11474 TOPLONG(nss,ix) = longval;
11475 ptr = POPPTR(ss,ix);
11476 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11477 sv = (SV*)POPPTR(ss,ix);
11478 TOPPTR(nss,ix) = sv_dup(sv, param);
11481 ptr = POPPTR(ss,ix);
11482 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11483 longval = (long)POPBOOL(ss,ix);
11484 TOPBOOL(nss,ix) = (bool)longval;
11486 case SAVEt_SET_SVFLAGS:
11488 TOPINT(nss,ix) = i;
11490 TOPINT(nss,ix) = i;
11491 sv = (SV*)POPPTR(ss,ix);
11492 TOPPTR(nss,ix) = sv_dup(sv, param);
11495 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11503 =for apidoc perl_clone
11505 Create and return a new interpreter by cloning the current one.
11507 perl_clone takes these flags as parameters:
11509 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11510 without it we only clone the data and zero the stacks,
11511 with it we copy the stacks and the new perl interpreter is
11512 ready to run at the exact same point as the previous one.
11513 The pseudo-fork code uses COPY_STACKS while the
11514 threads->new doesn't.
11516 CLONEf_KEEP_PTR_TABLE
11517 perl_clone keeps a ptr_table with the pointer of the old
11518 variable as a key and the new variable as a value,
11519 this allows it to check if something has been cloned and not
11520 clone it again but rather just use the value and increase the
11521 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11522 the ptr_table using the function
11523 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11524 reason to keep it around is if you want to dup some of your own
11525 variable who are outside the graph perl scans, example of this
11526 code is in threads.xs create
11529 This is a win32 thing, it is ignored on unix, it tells perls
11530 win32host code (which is c++) to clone itself, this is needed on
11531 win32 if you want to run two threads at the same time,
11532 if you just want to do some stuff in a separate perl interpreter
11533 and then throw it away and return to the original one,
11534 you don't need to do anything.
11539 /* XXX the above needs expanding by someone who actually understands it ! */
11540 EXTERN_C PerlInterpreter *
11541 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11544 perl_clone(PerlInterpreter *proto_perl, UV flags)
11546 #ifdef PERL_IMPLICIT_SYS
11548 /* perlhost.h so we need to call into it
11549 to clone the host, CPerlHost should have a c interface, sky */
11551 if (flags & CLONEf_CLONE_HOST) {
11552 return perl_clone_host(proto_perl,flags);
11554 return perl_clone_using(proto_perl, flags,
11556 proto_perl->IMemShared,
11557 proto_perl->IMemParse,
11559 proto_perl->IStdIO,
11563 proto_perl->IProc);
11567 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11568 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11569 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11570 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11571 struct IPerlDir* ipD, struct IPerlSock* ipS,
11572 struct IPerlProc* ipP)
11574 /* XXX many of the string copies here can be optimized if they're
11575 * constants; they need to be allocated as common memory and just
11576 * their pointers copied. */
11579 CLONE_PARAMS clone_params;
11580 CLONE_PARAMS* param = &clone_params;
11582 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11583 PERL_SET_THX(my_perl);
11586 Poison(my_perl, 1, PerlInterpreter);
11588 PL_curcop = (COP *)Nullop;
11592 PL_savestack_ix = 0;
11593 PL_savestack_max = -1;
11594 PL_sig_pending = 0;
11595 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11596 # else /* !DEBUGGING */
11597 Zero(my_perl, 1, PerlInterpreter);
11598 # endif /* DEBUGGING */
11600 /* host pointers */
11602 PL_MemShared = ipMS;
11603 PL_MemParse = ipMP;
11610 #else /* !PERL_IMPLICIT_SYS */
11612 CLONE_PARAMS clone_params;
11613 CLONE_PARAMS* param = &clone_params;
11614 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11615 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 */
11633 #endif /* PERL_IMPLICIT_SYS */
11634 param->flags = flags;
11635 param->proto_perl = proto_perl;
11638 PL_xiv_arenaroot = NULL;
11639 PL_xiv_root = NULL;
11640 PL_xnv_arenaroot = NULL;
11641 PL_xnv_root = NULL;
11642 PL_xrv_arenaroot = NULL;
11643 PL_xrv_root = NULL;
11644 PL_xpv_arenaroot = NULL;
11645 PL_xpv_root = NULL;
11646 PL_xpviv_arenaroot = NULL;
11647 PL_xpviv_root = NULL;
11648 PL_xpvnv_arenaroot = NULL;
11649 PL_xpvnv_root = NULL;
11650 PL_xpvcv_arenaroot = NULL;
11651 PL_xpvcv_root = NULL;
11652 PL_xpvav_arenaroot = NULL;
11653 PL_xpvav_root = NULL;
11654 PL_xpvhv_arenaroot = NULL;
11655 PL_xpvhv_root = NULL;
11656 PL_xpvmg_arenaroot = NULL;
11657 PL_xpvmg_root = NULL;
11658 PL_xpvlv_arenaroot = NULL;
11659 PL_xpvlv_root = NULL;
11660 PL_xpvbm_arenaroot = NULL;
11661 PL_xpvbm_root = NULL;
11662 PL_he_arenaroot = NULL;
11664 PL_nice_chunk = NULL;
11665 PL_nice_chunk_size = 0;
11667 PL_sv_objcount = 0;
11668 PL_sv_root = Nullsv;
11669 PL_sv_arenaroot = Nullsv;
11671 PL_debug = proto_perl->Idebug;
11673 #ifdef USE_REENTRANT_API
11674 /* XXX: things like -Dm will segfault here in perlio, but doing
11675 * PERL_SET_CONTEXT(proto_perl);
11676 * breaks too many other things
11678 Perl_reentrant_init(aTHX);
11681 /* create SV map for pointer relocation */
11682 PL_ptr_table = ptr_table_new();
11684 /* initialize these special pointers as early as possible */
11685 SvANY(&PL_sv_undef) = NULL;
11686 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11687 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11688 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11690 SvANY(&PL_sv_no) = new_XPVNV();
11691 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11692 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11693 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11694 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
11695 SvCUR(&PL_sv_no) = 0;
11696 SvLEN(&PL_sv_no) = 1;
11697 SvIVX(&PL_sv_no) = 0;
11698 SvNV_set(&PL_sv_no, 0);
11699 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11701 SvANY(&PL_sv_yes) = new_XPVNV();
11702 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11703 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11704 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11705 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
11706 SvCUR(&PL_sv_yes) = 1;
11707 SvLEN(&PL_sv_yes) = 2;
11708 SvIVX(&PL_sv_yes) = 1;
11709 SvNV_set(&PL_sv_yes, 1);
11710 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11712 /* create (a non-shared!) shared string table */
11713 PL_strtab = newHV();
11714 HvSHAREKEYS_off(PL_strtab);
11715 hv_ksplit(PL_strtab, 512);
11716 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11718 PL_compiling = proto_perl->Icompiling;
11720 /* These two PVs will be free'd special way so must set them same way op.c does */
11721 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11722 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11724 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11725 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11727 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11728 if (!specialWARN(PL_compiling.cop_warnings))
11729 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11730 if (!specialCopIO(PL_compiling.cop_io))
11731 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11732 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11734 /* pseudo environmental stuff */
11735 PL_origargc = proto_perl->Iorigargc;
11736 PL_origargv = proto_perl->Iorigargv;
11738 param->stashes = newAV(); /* Setup array of objects to call clone on */
11740 #ifdef PERLIO_LAYERS
11741 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11742 PerlIO_clone(aTHX_ proto_perl, param);
11745 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11746 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11747 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11748 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11749 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11750 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11753 PL_minus_c = proto_perl->Iminus_c;
11754 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11755 PL_localpatches = proto_perl->Ilocalpatches;
11756 PL_splitstr = proto_perl->Isplitstr;
11757 PL_preprocess = proto_perl->Ipreprocess;
11758 PL_minus_n = proto_perl->Iminus_n;
11759 PL_minus_p = proto_perl->Iminus_p;
11760 PL_minus_l = proto_perl->Iminus_l;
11761 PL_minus_a = proto_perl->Iminus_a;
11762 PL_minus_F = proto_perl->Iminus_F;
11763 PL_doswitches = proto_perl->Idoswitches;
11764 PL_dowarn = proto_perl->Idowarn;
11765 PL_doextract = proto_perl->Idoextract;
11766 PL_sawampersand = proto_perl->Isawampersand;
11767 PL_unsafe = proto_perl->Iunsafe;
11768 PL_inplace = SAVEPV(proto_perl->Iinplace);
11769 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11770 PL_perldb = proto_perl->Iperldb;
11771 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11772 PL_exit_flags = proto_perl->Iexit_flags;
11774 /* magical thingies */
11775 /* XXX time(&PL_basetime) when asked for? */
11776 PL_basetime = proto_perl->Ibasetime;
11777 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11779 PL_maxsysfd = proto_perl->Imaxsysfd;
11780 PL_multiline = proto_perl->Imultiline;
11781 PL_statusvalue = proto_perl->Istatusvalue;
11783 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11785 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11787 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11788 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11789 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11791 /* Clone the regex array */
11792 PL_regex_padav = newAV();
11794 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11795 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11796 av_push(PL_regex_padav,
11797 sv_dup_inc(regexen[0],param));
11798 for(i = 1; i <= len; i++) {
11799 if(SvREPADTMP(regexen[i])) {
11800 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11802 av_push(PL_regex_padav,
11804 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11805 SvIVX(regexen[i])), param)))
11810 PL_regex_pad = AvARRAY(PL_regex_padav);
11812 /* shortcuts to various I/O objects */
11813 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11814 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11815 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11816 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11817 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11818 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11820 /* shortcuts to regexp stuff */
11821 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11823 /* shortcuts to misc objects */
11824 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11826 /* shortcuts to debugging objects */
11827 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11828 PL_DBline = gv_dup(proto_perl->IDBline, param);
11829 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11830 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11831 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11832 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11833 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11834 PL_lineary = av_dup(proto_perl->Ilineary, param);
11835 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11837 /* symbol tables */
11838 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11839 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11840 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11841 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11842 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11844 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11845 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11846 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11847 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11848 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11849 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11851 PL_sub_generation = proto_perl->Isub_generation;
11853 /* funky return mechanisms */
11854 PL_forkprocess = proto_perl->Iforkprocess;
11856 /* subprocess state */
11857 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11859 /* internal state */
11860 PL_tainting = proto_perl->Itainting;
11861 PL_taint_warn = proto_perl->Itaint_warn;
11862 PL_maxo = proto_perl->Imaxo;
11863 if (proto_perl->Iop_mask)
11864 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11866 PL_op_mask = Nullch;
11867 /* PL_asserting = proto_perl->Iasserting; */
11869 /* current interpreter roots */
11870 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11871 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11872 PL_main_start = proto_perl->Imain_start;
11873 PL_eval_root = proto_perl->Ieval_root;
11874 PL_eval_start = proto_perl->Ieval_start;
11876 /* runtime control stuff */
11877 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11878 PL_copline = proto_perl->Icopline;
11880 PL_filemode = proto_perl->Ifilemode;
11881 PL_lastfd = proto_perl->Ilastfd;
11882 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11885 PL_gensym = proto_perl->Igensym;
11886 PL_preambled = proto_perl->Ipreambled;
11887 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11888 PL_laststatval = proto_perl->Ilaststatval;
11889 PL_laststype = proto_perl->Ilaststype;
11890 PL_mess_sv = Nullsv;
11892 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11893 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11895 /* interpreter atexit processing */
11896 PL_exitlistlen = proto_perl->Iexitlistlen;
11897 if (PL_exitlistlen) {
11898 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11899 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11902 PL_exitlist = (PerlExitListEntry*)NULL;
11903 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11904 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11905 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11907 PL_profiledata = NULL;
11908 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11909 /* PL_rsfp_filters entries have fake IoDIRP() */
11910 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11912 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11914 PAD_CLONE_VARS(proto_perl, param);
11916 #ifdef HAVE_INTERP_INTERN
11917 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11920 /* more statics moved here */
11921 PL_generation = proto_perl->Igeneration;
11922 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11924 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11925 PL_in_clean_all = proto_perl->Iin_clean_all;
11927 PL_uid = proto_perl->Iuid;
11928 PL_euid = proto_perl->Ieuid;
11929 PL_gid = proto_perl->Igid;
11930 PL_egid = proto_perl->Iegid;
11931 PL_nomemok = proto_perl->Inomemok;
11932 PL_an = proto_perl->Ian;
11933 PL_evalseq = proto_perl->Ievalseq;
11934 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11935 PL_origalen = proto_perl->Iorigalen;
11936 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11937 PL_osname = SAVEPV(proto_perl->Iosname);
11938 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11939 PL_sighandlerp = proto_perl->Isighandlerp;
11942 PL_runops = proto_perl->Irunops;
11944 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11947 PL_cshlen = proto_perl->Icshlen;
11948 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11951 PL_lex_state = proto_perl->Ilex_state;
11952 PL_lex_defer = proto_perl->Ilex_defer;
11953 PL_lex_expect = proto_perl->Ilex_expect;
11954 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11955 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11956 PL_lex_starts = proto_perl->Ilex_starts;
11957 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11958 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11959 PL_lex_op = proto_perl->Ilex_op;
11960 PL_lex_inpat = proto_perl->Ilex_inpat;
11961 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11962 PL_lex_brackets = proto_perl->Ilex_brackets;
11963 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11964 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11965 PL_lex_casemods = proto_perl->Ilex_casemods;
11966 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11967 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11969 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11970 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11971 PL_nexttoke = proto_perl->Inexttoke;
11973 /* XXX This is probably masking the deeper issue of why
11974 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11975 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11976 * (A little debugging with a watchpoint on it may help.)
11978 if (SvANY(proto_perl->Ilinestr)) {
11979 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11980 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11981 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11982 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11983 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11984 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11985 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11986 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11987 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11990 PL_linestr = NEWSV(65,79);
11991 sv_upgrade(PL_linestr,SVt_PVIV);
11992 sv_setpvn(PL_linestr,"",0);
11993 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11995 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11996 PL_pending_ident = proto_perl->Ipending_ident;
11997 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11999 PL_expect = proto_perl->Iexpect;
12001 PL_multi_start = proto_perl->Imulti_start;
12002 PL_multi_end = proto_perl->Imulti_end;
12003 PL_multi_open = proto_perl->Imulti_open;
12004 PL_multi_close = proto_perl->Imulti_close;
12006 PL_error_count = proto_perl->Ierror_count;
12007 PL_subline = proto_perl->Isubline;
12008 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12010 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12011 if (SvANY(proto_perl->Ilinestr)) {
12012 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12013 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12014 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12015 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12016 PL_last_lop_op = proto_perl->Ilast_lop_op;
12019 PL_last_uni = SvPVX(PL_linestr);
12020 PL_last_lop = SvPVX(PL_linestr);
12021 PL_last_lop_op = 0;
12023 PL_in_my = proto_perl->Iin_my;
12024 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12026 PL_cryptseen = proto_perl->Icryptseen;
12029 PL_hints = proto_perl->Ihints;
12031 PL_amagic_generation = proto_perl->Iamagic_generation;
12033 #ifdef USE_LOCALE_COLLATE
12034 PL_collation_ix = proto_perl->Icollation_ix;
12035 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12036 PL_collation_standard = proto_perl->Icollation_standard;
12037 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12038 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12039 #endif /* USE_LOCALE_COLLATE */
12041 #ifdef USE_LOCALE_NUMERIC
12042 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12043 PL_numeric_standard = proto_perl->Inumeric_standard;
12044 PL_numeric_local = proto_perl->Inumeric_local;
12045 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12046 #endif /* !USE_LOCALE_NUMERIC */
12048 /* utf8 character classes */
12049 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12050 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12051 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12052 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12053 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12054 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12055 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12056 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12057 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12058 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12059 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12060 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12061 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12062 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12063 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12064 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12065 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12066 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12067 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12068 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12070 /* Did the locale setup indicate UTF-8? */
12071 PL_utf8locale = proto_perl->Iutf8locale;
12072 /* Unicode features (see perlrun/-C) */
12073 PL_unicode = proto_perl->Iunicode;
12075 /* Pre-5.8 signals control */
12076 PL_signals = proto_perl->Isignals;
12078 /* times() ticks per second */
12079 PL_clocktick = proto_perl->Iclocktick;
12081 /* Recursion stopper for PerlIO_find_layer */
12082 PL_in_load_module = proto_perl->Iin_load_module;
12084 /* sort() routine */
12085 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12087 /* Not really needed/useful since the reenrant_retint is "volatile",
12088 * but do it for consistency's sake. */
12089 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12091 /* Hooks to shared SVs and locks. */
12092 PL_sharehook = proto_perl->Isharehook;
12093 PL_lockhook = proto_perl->Ilockhook;
12094 PL_unlockhook = proto_perl->Iunlockhook;
12095 PL_threadhook = proto_perl->Ithreadhook;
12097 PL_runops_std = proto_perl->Irunops_std;
12098 PL_runops_dbg = proto_perl->Irunops_dbg;
12100 #ifdef THREADS_HAVE_PIDS
12101 PL_ppid = proto_perl->Ippid;
12105 PL_last_swash_hv = Nullhv; /* reinits on demand */
12106 PL_last_swash_klen = 0;
12107 PL_last_swash_key[0]= '\0';
12108 PL_last_swash_tmps = (U8*)NULL;
12109 PL_last_swash_slen = 0;
12111 PL_glob_index = proto_perl->Iglob_index;
12112 PL_srand_called = proto_perl->Isrand_called;
12113 PL_hash_seed = proto_perl->Ihash_seed;
12114 PL_rehash_seed = proto_perl->Irehash_seed;
12115 PL_uudmap['M'] = 0; /* reinits on demand */
12116 PL_bitcount = Nullch; /* reinits on demand */
12118 if (proto_perl->Ipsig_pend) {
12119 Newz(0, PL_psig_pend, SIG_SIZE, int);
12122 PL_psig_pend = (int*)NULL;
12125 if (proto_perl->Ipsig_ptr) {
12126 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12127 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12128 for (i = 1; i < SIG_SIZE; i++) {
12129 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12130 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12134 PL_psig_ptr = (SV**)NULL;
12135 PL_psig_name = (SV**)NULL;
12138 /* thrdvar.h stuff */
12140 if (flags & CLONEf_COPY_STACKS) {
12141 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12142 PL_tmps_ix = proto_perl->Ttmps_ix;
12143 PL_tmps_max = proto_perl->Ttmps_max;
12144 PL_tmps_floor = proto_perl->Ttmps_floor;
12145 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12147 while (i <= PL_tmps_ix) {
12148 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12152 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12153 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12154 Newz(54, PL_markstack, i, I32);
12155 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12156 - proto_perl->Tmarkstack);
12157 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12158 - proto_perl->Tmarkstack);
12159 Copy(proto_perl->Tmarkstack, PL_markstack,
12160 PL_markstack_ptr - PL_markstack + 1, I32);
12162 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12163 * NOTE: unlike the others! */
12164 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12165 PL_scopestack_max = proto_perl->Tscopestack_max;
12166 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12167 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12169 /* NOTE: si_dup() looks at PL_markstack */
12170 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12172 /* PL_curstack = PL_curstackinfo->si_stack; */
12173 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12174 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12176 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12177 PL_stack_base = AvARRAY(PL_curstack);
12178 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12179 - proto_perl->Tstack_base);
12180 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12182 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12183 * NOTE: unlike the others! */
12184 PL_savestack_ix = proto_perl->Tsavestack_ix;
12185 PL_savestack_max = proto_perl->Tsavestack_max;
12186 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12187 PL_savestack = ss_dup(proto_perl, param);
12191 ENTER; /* perl_destruct() wants to LEAVE; */
12194 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12195 PL_top_env = &PL_start_env;
12197 PL_op = proto_perl->Top;
12200 PL_Xpv = (XPV*)NULL;
12201 PL_na = proto_perl->Tna;
12203 PL_statbuf = proto_perl->Tstatbuf;
12204 PL_statcache = proto_perl->Tstatcache;
12205 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12206 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12208 PL_timesbuf = proto_perl->Ttimesbuf;
12211 PL_tainted = proto_perl->Ttainted;
12212 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12213 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12214 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12215 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12216 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12217 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12218 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12219 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12220 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12222 PL_restartop = proto_perl->Trestartop;
12223 PL_in_eval = proto_perl->Tin_eval;
12224 PL_delaymagic = proto_perl->Tdelaymagic;
12225 PL_dirty = proto_perl->Tdirty;
12226 PL_localizing = proto_perl->Tlocalizing;
12228 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12229 PL_hv_fetch_ent_mh = Nullhe;
12230 PL_modcount = proto_perl->Tmodcount;
12231 PL_lastgotoprobe = Nullop;
12232 PL_dumpindent = proto_perl->Tdumpindent;
12234 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12235 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12236 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12237 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12238 PL_sortcxix = proto_perl->Tsortcxix;
12239 PL_efloatbuf = Nullch; /* reinits on demand */
12240 PL_efloatsize = 0; /* reinits on demand */
12244 PL_screamfirst = NULL;
12245 PL_screamnext = NULL;
12246 PL_maxscream = -1; /* reinits on demand */
12247 PL_lastscream = Nullsv;
12249 PL_watchaddr = NULL;
12250 PL_watchok = Nullch;
12252 PL_regdummy = proto_perl->Tregdummy;
12253 PL_regprecomp = Nullch;
12256 PL_colorset = 0; /* reinits PL_colors[] */
12257 /*PL_colors[6] = {0,0,0,0,0,0};*/
12258 PL_reginput = Nullch;
12259 PL_regbol = Nullch;
12260 PL_regeol = Nullch;
12261 PL_regstartp = (I32*)NULL;
12262 PL_regendp = (I32*)NULL;
12263 PL_reglastparen = (U32*)NULL;
12264 PL_reglastcloseparen = (U32*)NULL;
12265 PL_regtill = Nullch;
12266 PL_reg_start_tmp = (char**)NULL;
12267 PL_reg_start_tmpl = 0;
12268 PL_regdata = (struct reg_data*)NULL;
12271 PL_reg_eval_set = 0;
12273 PL_regprogram = (regnode*)NULL;
12275 PL_regcc = (CURCUR*)NULL;
12276 PL_reg_call_cc = (struct re_cc_state*)NULL;
12277 PL_reg_re = (regexp*)NULL;
12278 PL_reg_ganch = Nullch;
12279 PL_reg_sv = Nullsv;
12280 PL_reg_match_utf8 = FALSE;
12281 PL_reg_magic = (MAGIC*)NULL;
12283 PL_reg_oldcurpm = (PMOP*)NULL;
12284 PL_reg_curpm = (PMOP*)NULL;
12285 PL_reg_oldsaved = Nullch;
12286 PL_reg_oldsavedlen = 0;
12287 #ifdef PERL_COPY_ON_WRITE
12290 PL_reg_maxiter = 0;
12291 PL_reg_leftiter = 0;
12292 PL_reg_poscache = Nullch;
12293 PL_reg_poscache_size= 0;
12295 /* RE engine - function pointers */
12296 PL_regcompp = proto_perl->Tregcompp;
12297 PL_regexecp = proto_perl->Tregexecp;
12298 PL_regint_start = proto_perl->Tregint_start;
12299 PL_regint_string = proto_perl->Tregint_string;
12300 PL_regfree = proto_perl->Tregfree;
12302 PL_reginterp_cnt = 0;
12303 PL_reg_starttry = 0;
12305 /* Pluggable optimizer */
12306 PL_peepp = proto_perl->Tpeepp;
12308 PL_stashcache = newHV();
12310 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12311 ptr_table_free(PL_ptr_table);
12312 PL_ptr_table = NULL;
12315 /* Call the ->CLONE method, if it exists, for each of the stashes
12316 identified by sv_dup() above.
12318 while(av_len(param->stashes) != -1) {
12319 HV* stash = (HV*) av_shift(param->stashes);
12320 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12321 if (cloner && GvCV(cloner)) {
12326 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12328 call_sv((SV*)GvCV(cloner), G_DISCARD);
12334 SvREFCNT_dec(param->stashes);
12339 #endif /* USE_ITHREADS */
12342 =head1 Unicode Support
12344 =for apidoc sv_recode_to_utf8
12346 The encoding is assumed to be an Encode object, on entry the PV
12347 of the sv is assumed to be octets in that encoding, and the sv
12348 will be converted into Unicode (and UTF-8).
12350 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12351 is not a reference, nothing is done to the sv. If the encoding is not
12352 an C<Encode::XS> Encoding object, bad things will happen.
12353 (See F<lib/encoding.pm> and L<Encode>).
12355 The PV of the sv is returned.
12360 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12362 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12376 Passing sv_yes is wrong - it needs to be or'ed set of constants
12377 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12378 remove converted chars from source.
12380 Both will default the value - let them.
12382 XPUSHs(&PL_sv_yes);
12385 call_method("decode", G_SCALAR);
12389 s = SvPV(uni, len);
12390 if (s != SvPVX(sv)) {
12391 SvGROW(sv, len + 1);
12392 Move(s, SvPVX(sv), len, char);
12393 SvCUR_set(sv, len);
12394 SvPVX(sv)[len] = 0;
12401 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12405 =for apidoc sv_cat_decode
12407 The encoding is assumed to be an Encode object, the PV of the ssv is
12408 assumed to be octets in that encoding and decoding the input starts
12409 from the position which (PV + *offset) pointed to. The dsv will be
12410 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12411 when the string tstr appears in decoding output or the input ends on
12412 the PV of the ssv. The value which the offset points will be modified
12413 to the last input position on the ssv.
12415 Returns TRUE if the terminator was found, else returns FALSE.
12420 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12421 SV *ssv, int *offset, char *tstr, int tlen)
12424 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12435 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12436 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12438 call_method("cat_decode", G_SCALAR);
12440 ret = SvTRUE(TOPs);
12441 *offset = SvIV(offsv);
12447 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12453 * c-indentation-style: bsd
12454 * c-basic-offset: 4
12455 * indent-tabs-mode: t
12458 * vim: shiftwidth=4: