3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
168 #ifdef DEBUG_LEAKING_SCALARS
170 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
172 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
175 # define FREE_SV_DEBUG_FILE(sv)
178 #define plant_SV(p) \
180 FREE_SV_DEBUG_FILE(p); \
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
187 /* sv_mutex must be held while calling uproot_SV() */
188 #define uproot_SV(p) \
191 PL_sv_root = (SV*)SvANY(p); \
196 /* new_SV(): return a new, empty SV head */
198 #ifdef DEBUG_LEAKING_SCALARS
199 /* provide a real function for a debugger to play with */
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
227 # define new_SV(p) (p)=S_new_SV(aTHX)
245 /* del_SV(): return an empty SV head to the free list */
260 S_del_sv(pTHX_ SV *p)
267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
269 svend = &sva[SvREFCNT(sva)];
270 if (p >= sv && p < svend)
274 if (ckWARN_d(WARN_INTERNAL))
275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
284 #else /* ! DEBUGGING */
286 #define del_SV(p) plant_SV(p)
288 #endif /* DEBUGGING */
292 =head1 SV Manipulation Functions
294 =for apidoc sv_add_arena
296 Given a chunk of memory, link it to the head of the list of arenas,
297 and split it into a list of free SVs.
303 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
309 /* The first SV in an arena isn't an SV. */
310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
317 svend = &sva[SvREFCNT(sva) - 1];
320 SvANY(sv) = (void *)(SV*)(sv + 1);
322 SvFLAGS(sv) = SVTYPEMASK;
326 SvFLAGS(sv) = SVTYPEMASK;
329 /* make some more SVs by adding another arena */
331 /* sv_mutex must be held while calling more_sv() */
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
340 PL_nice_chunk_size = 0;
343 char *chunk; /* must use New here to match call to */
344 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
345 sv_add_arena(chunk, 1008, 0);
351 /* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
355 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 svend = &sva[SvREFCNT(sva)];
364 for (sv = sva + 1; sv < svend; ++sv) {
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
379 /* called by sv_report_used() for each live SV */
382 do_report_used(pTHX_ SV *sv)
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
392 =for apidoc sv_report_used
394 Dump the contents of all SVs not yet freed. (Debugging aid).
400 Perl_sv_report_used(pTHX)
403 visit(do_report_used, 0, 0);
407 /* called by sv_clean_objs() for each live SV */
410 do_clean_objs(pTHX_ SV *sv)
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
427 /* XXX Might want to check arrays, etc. */
430 /* called by sv_clean_objs() for each live SV */
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
434 do_clean_named_objs(pTHX_ SV *sv)
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
444 SvFLAGS(sv) |= SVf_BREAK;
452 =for apidoc sv_clean_objs
454 Attempt to destroy all objects not yet freed
460 Perl_sv_clean_objs(pTHX)
462 PL_in_clean_objs = TRUE;
463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
464 #ifndef DISABLE_DESTRUCTOR_KLUDGE
465 /* some barnacles may yet remain, clinging to typeglobs */
466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
468 PL_in_clean_objs = FALSE;
471 /* called by sv_clean_all() for each live SV */
474 do_clean_all(pTHX_ SV *sv)
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
478 if (PL_comppad == (AV*)sv) {
480 PL_curpad = Null(SV**);
486 =for apidoc sv_clean_all
488 Decrement the refcnt of each remaining SV, possibly triggering a
489 cleanup. This function may have to be called multiple times to free
490 SVs which are in complex self-referential hierarchies.
496 Perl_sv_clean_all(pTHX)
499 PL_in_clean_all = TRUE;
500 cleaned = visit(do_clean_all, 0,0);
501 PL_in_clean_all = FALSE;
506 =for apidoc sv_free_arenas
508 Deallocate the memory used by all arenas. Note that all the individual SV
509 heads and bodies within the arenas must already have been freed.
515 Perl_sv_free_arenas(pTHX)
519 XPV *arena, *arenanext;
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
530 Safefree((void *)sva);
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xiv_arenaroot = 0;
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xrv_arenaroot = 0;
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xpv_arenaroot = 0;
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpviv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpvnv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvcv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvav_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvhv_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvmg_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvbm_arenaroot = 0;
617 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
625 Safefree(PL_nice_chunk);
626 PL_nice_chunk = Nullch;
627 PL_nice_chunk_size = 0;
632 /* ---------------------------------------------------------------------
634 * support functions for report_uninit()
637 /* the maxiumum size of array or hash where we will scan looking
638 * for the undefined element that triggered the warning */
640 #define FUV_MAX_SEARCH_SIZE 1000
642 /* Look for an entry in the hash whose value has the same SV as val;
643 * If so, return a mortal copy of the key. */
646 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
653 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
654 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
659 for (i=HvMAX(hv); i>0; i--) {
660 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
661 if (HeVAL(entry) != val)
663 if ( HeVAL(entry) == &PL_sv_undef ||
664 HeVAL(entry) == &PL_sv_placeholder)
668 if (HeKLEN(entry) == HEf_SVKEY)
669 return sv_mortalcopy(HeKEY_sv(entry));
670 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
676 /* Look for an entry in the array whose value has the same SV as val;
677 * If so, return the index, otherwise return -1. */
680 S_find_array_subscript(pTHX_ AV *av, SV* val)
684 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
685 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
689 for (i=AvFILLp(av); i>=0; i--) {
690 if (svp[i] == val && svp[i] != &PL_sv_undef)
696 /* S_varname(): return the name of a variable, optionally with a subscript.
697 * If gv is non-zero, use the name of that global, along with gvtype (one
698 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
699 * targ. Depending on the value of the subscript_type flag, return:
702 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
703 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
704 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
705 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
708 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
709 SV* keyname, I32 aindex, int subscript_type)
715 name = sv_newmortal();
718 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
719 * XXX get rid of all this if gv_fullnameX() ever supports this
723 HV *hv = GvSTASH(gv);
724 sv_setpv(name, gvtype);
727 else if (!(p=HvNAME(hv)))
729 if (strNE(p, "main")) {
731 sv_catpvn(name,"::", 2);
733 if (GvNAMELEN(gv)>= 1 &&
734 ((unsigned int)*GvNAME(gv)) <= 26)
736 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
737 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
740 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
744 CV *cv = find_runcv(&u);
745 if (!cv || !CvPADLIST(cv))
747 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
748 sv = *av_fetch(av, targ, FALSE);
749 /* SvLEN in a pad name is not to be trusted */
750 sv_setpv(name, SvPV_nolen(sv));
753 if (subscript_type == FUV_SUBSCRIPT_HASH) {
756 Perl_sv_catpvf(aTHX_ name, "{%s}",
757 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
760 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
762 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
764 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
765 sv_insert(name, 0, 0, "within ", 7);
772 =for apidoc find_uninit_var
774 Find the name of the undefined variable (if any) that caused the operator o
775 to issue a "Use of uninitialized value" warning.
776 If match is true, only return a name if it's value matches uninit_sv.
777 So roughly speaking, if a unary operator (such as OP_COS) generates a
778 warning, then following the direct child of the op may yield an
779 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
780 other hand, with OP_ADD there are two branches to follow, so we only print
781 the variable name if we get an exact match.
783 The name is returned as a mortal SV.
785 Assumes that PL_op is the op that originally triggered the error, and that
786 PL_comppad/PL_curpad points to the currently executing pad.
792 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
801 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
802 uninit_sv == &PL_sv_placeholder)))
805 switch (obase->op_type) {
812 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
813 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
816 int subscript_type = FUV_SUBSCRIPT_WITHIN;
818 if (pad) { /* @lex, %lex */
819 sv = PAD_SVl(obase->op_targ);
823 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
824 /* @global, %global */
825 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
828 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
830 else /* @{expr}, %{expr} */
831 return find_uninit_var(cUNOPx(obase)->op_first,
835 /* attempt to find a match within the aggregate */
837 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
839 subscript_type = FUV_SUBSCRIPT_HASH;
842 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
844 subscript_type = FUV_SUBSCRIPT_ARRAY;
847 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
850 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
851 keysv, index, subscript_type);
855 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
857 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
858 Nullsv, 0, FUV_SUBSCRIPT_NONE);
861 gv = cGVOPx_gv(obase);
862 if (!gv || (match && GvSV(gv) != uninit_sv))
864 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
867 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
869 av = (AV*)PAD_SV(obase->op_targ);
870 if (!av || SvRMAGICAL(av))
872 svp = av_fetch(av, (I32)obase->op_private, FALSE);
873 if (!svp || *svp != uninit_sv)
876 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
877 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
880 gv = cGVOPx_gv(obase);
885 if (!av || SvRMAGICAL(av))
887 svp = av_fetch(av, (I32)obase->op_private, FALSE);
888 if (!svp || *svp != uninit_sv)
891 return S_varname(aTHX_ gv, "$", 0,
892 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
897 o = cUNOPx(obase)->op_first;
898 if (!o || o->op_type != OP_NULL ||
899 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
901 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
906 /* $a[uninit_expr] or $h{uninit_expr} */
907 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
910 o = cBINOPx(obase)->op_first;
911 kid = cBINOPx(obase)->op_last;
913 /* get the av or hv, and optionally the gv */
915 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
916 sv = PAD_SV(o->op_targ);
918 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
919 && cUNOPo->op_first->op_type == OP_GV)
921 gv = cGVOPx_gv(cUNOPo->op_first);
924 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
929 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
930 /* index is constant */
934 if (obase->op_type == OP_HELEM) {
935 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
936 if (!he || HeVAL(he) != uninit_sv)
940 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
941 if (!svp || *svp != uninit_sv)
945 if (obase->op_type == OP_HELEM)
946 return S_varname(aTHX_ gv, "%", o->op_targ,
947 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
949 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
950 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
954 /* index is an expression;
955 * attempt to find a match within the aggregate */
956 if (obase->op_type == OP_HELEM) {
957 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
959 return S_varname(aTHX_ gv, "%", o->op_targ,
960 keysv, 0, FUV_SUBSCRIPT_HASH);
963 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
965 return S_varname(aTHX_ gv, "@", o->op_targ,
966 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
970 return S_varname(aTHX_ gv,
971 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
973 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
979 /* only examine RHS */
980 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
983 o = cUNOPx(obase)->op_first;
984 if (o->op_type == OP_PUSHMARK)
987 if (!o->op_sibling) {
988 /* one-arg version of open is highly magical */
990 if (o->op_type == OP_GV) { /* open FOO; */
992 if (match && GvSV(gv) != uninit_sv)
994 return S_varname(aTHX_ gv, "$", 0,
995 Nullsv, 0, FUV_SUBSCRIPT_NONE);
997 /* other possibilities not handled are:
998 * open $x; or open my $x; should return '${*$x}'
999 * open expr; should return '$'.expr ideally
1005 /* ops where $_ may be an implicit arg */
1009 if ( !(obase->op_flags & OPf_STACKED)) {
1010 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1011 ? PAD_SVl(obase->op_targ)
1014 sv = sv_newmortal();
1023 /* skip filehandle as it can't produce 'undef' warning */
1024 o = cUNOPx(obase)->op_first;
1025 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1026 o = o->op_sibling->op_sibling;
1033 match = 1; /* XS or custom code could trigger random warnings */
1038 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1039 return sv_2mortal(newSVpv("${$/}", 0));
1044 if (!(obase->op_flags & OPf_KIDS))
1046 o = cUNOPx(obase)->op_first;
1052 /* if all except one arg are constant, or have no side-effects,
1053 * or are optimized away, then it's unambiguous */
1055 for (kid=o; kid; kid = kid->op_sibling) {
1057 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1058 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1059 || (kid->op_type == OP_PUSHMARK)
1063 if (o2) { /* more than one found */
1070 return find_uninit_var(o2, uninit_sv, match);
1074 sv = find_uninit_var(o, uninit_sv, 1);
1086 =for apidoc report_uninit
1088 Print appropriate "Use of uninitialized variable" warning
1094 Perl_report_uninit(pTHX_ SV* uninit_sv)
1097 SV* varname = Nullsv;
1099 varname = find_uninit_var(PL_op, uninit_sv,0);
1101 sv_insert(varname, 0, 0, " ", 1);
1103 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1104 varname ? SvPV_nolen(varname) : "",
1105 " in ", OP_DESC(PL_op));
1108 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1112 /* grab a new IV body from the free list, allocating more if necessary */
1123 * See comment in more_xiv() -- RAM.
1125 PL_xiv_root = *(IV**)xiv;
1127 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1130 /* return an IV body to the free list */
1133 S_del_xiv(pTHX_ XPVIV *p)
1135 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1137 *(IV**)xiv = PL_xiv_root;
1142 /* allocate another arena's worth of IV bodies */
1148 register IV* xivend;
1150 New(705, ptr, 1008/sizeof(XPV), XPV);
1151 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1152 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1155 xivend = &xiv[1008 / sizeof(IV) - 1];
1156 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1158 while (xiv < xivend) {
1159 *(IV**)xiv = (IV *)(xiv + 1);
1165 /* grab a new NV body from the free list, allocating more if necessary */
1175 PL_xnv_root = *(NV**)xnv;
1177 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1180 /* return an NV body to the free list */
1183 S_del_xnv(pTHX_ XPVNV *p)
1185 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1187 *(NV**)xnv = PL_xnv_root;
1192 /* allocate another arena's worth of NV bodies */
1198 register NV* xnvend;
1200 New(711, ptr, 1008/sizeof(XPV), XPV);
1201 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1202 PL_xnv_arenaroot = ptr;
1205 xnvend = &xnv[1008 / sizeof(NV) - 1];
1206 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1208 while (xnv < xnvend) {
1209 *(NV**)xnv = (NV*)(xnv + 1);
1215 /* grab a new struct xrv from the free list, allocating more if necessary */
1225 PL_xrv_root = (XRV*)xrv->xrv_rv;
1230 /* return a struct xrv to the free list */
1233 S_del_xrv(pTHX_ XRV *p)
1236 p->xrv_rv = (SV*)PL_xrv_root;
1241 /* allocate another arena's worth of struct xrv */
1247 register XRV* xrvend;
1249 New(712, ptr, 1008/sizeof(XPV), XPV);
1250 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1251 PL_xrv_arenaroot = ptr;
1254 xrvend = &xrv[1008 / sizeof(XRV) - 1];
1255 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1257 while (xrv < xrvend) {
1258 xrv->xrv_rv = (SV*)(xrv + 1);
1264 /* grab a new struct xpv from the free list, allocating more if necessary */
1274 PL_xpv_root = (XPV*)xpv->xpv_pv;
1279 /* return a struct xpv to the free list */
1282 S_del_xpv(pTHX_ XPV *p)
1285 p->xpv_pv = (char*)PL_xpv_root;
1290 /* allocate another arena's worth of struct xpv */
1296 register XPV* xpvend;
1297 New(713, xpv, 1008/sizeof(XPV), XPV);
1298 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1299 PL_xpv_arenaroot = xpv;
1301 xpvend = &xpv[1008 / sizeof(XPV) - 1];
1302 PL_xpv_root = ++xpv;
1303 while (xpv < xpvend) {
1304 xpv->xpv_pv = (char*)(xpv + 1);
1310 /* grab a new struct xpviv from the free list, allocating more if necessary */
1319 xpviv = PL_xpviv_root;
1320 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1325 /* return a struct xpviv to the free list */
1328 S_del_xpviv(pTHX_ XPVIV *p)
1331 p->xpv_pv = (char*)PL_xpviv_root;
1336 /* allocate another arena's worth of struct xpviv */
1341 register XPVIV* xpviv;
1342 register XPVIV* xpvivend;
1343 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
1344 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1345 PL_xpviv_arenaroot = xpviv;
1347 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
1348 PL_xpviv_root = ++xpviv;
1349 while (xpviv < xpvivend) {
1350 xpviv->xpv_pv = (char*)(xpviv + 1);
1356 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1365 xpvnv = PL_xpvnv_root;
1366 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1371 /* return a struct xpvnv to the free list */
1374 S_del_xpvnv(pTHX_ XPVNV *p)
1377 p->xpv_pv = (char*)PL_xpvnv_root;
1382 /* allocate another arena's worth of struct xpvnv */
1387 register XPVNV* xpvnv;
1388 register XPVNV* xpvnvend;
1389 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
1390 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1391 PL_xpvnv_arenaroot = xpvnv;
1393 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
1394 PL_xpvnv_root = ++xpvnv;
1395 while (xpvnv < xpvnvend) {
1396 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1402 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1411 xpvcv = PL_xpvcv_root;
1412 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1417 /* return a struct xpvcv to the free list */
1420 S_del_xpvcv(pTHX_ XPVCV *p)
1423 p->xpv_pv = (char*)PL_xpvcv_root;
1428 /* allocate another arena's worth of struct xpvcv */
1433 register XPVCV* xpvcv;
1434 register XPVCV* xpvcvend;
1435 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
1436 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1437 PL_xpvcv_arenaroot = xpvcv;
1439 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
1440 PL_xpvcv_root = ++xpvcv;
1441 while (xpvcv < xpvcvend) {
1442 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1448 /* grab a new struct xpvav from the free list, allocating more if necessary */
1457 xpvav = PL_xpvav_root;
1458 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1463 /* return a struct xpvav to the free list */
1466 S_del_xpvav(pTHX_ XPVAV *p)
1469 p->xav_array = (char*)PL_xpvav_root;
1474 /* allocate another arena's worth of struct xpvav */
1479 register XPVAV* xpvav;
1480 register XPVAV* xpvavend;
1481 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
1482 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1483 PL_xpvav_arenaroot = xpvav;
1485 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
1486 PL_xpvav_root = ++xpvav;
1487 while (xpvav < xpvavend) {
1488 xpvav->xav_array = (char*)(xpvav + 1);
1491 xpvav->xav_array = 0;
1494 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1503 xpvhv = PL_xpvhv_root;
1504 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1509 /* return a struct xpvhv to the free list */
1512 S_del_xpvhv(pTHX_ XPVHV *p)
1515 p->xhv_array = (char*)PL_xpvhv_root;
1520 /* allocate another arena's worth of struct xpvhv */
1525 register XPVHV* xpvhv;
1526 register XPVHV* xpvhvend;
1527 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1528 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1529 PL_xpvhv_arenaroot = xpvhv;
1531 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1532 PL_xpvhv_root = ++xpvhv;
1533 while (xpvhv < xpvhvend) {
1534 xpvhv->xhv_array = (char*)(xpvhv + 1);
1537 xpvhv->xhv_array = 0;
1540 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1549 xpvmg = PL_xpvmg_root;
1550 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1555 /* return a struct xpvmg to the free list */
1558 S_del_xpvmg(pTHX_ XPVMG *p)
1561 p->xpv_pv = (char*)PL_xpvmg_root;
1566 /* allocate another arena's worth of struct xpvmg */
1571 register XPVMG* xpvmg;
1572 register XPVMG* xpvmgend;
1573 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1574 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1575 PL_xpvmg_arenaroot = xpvmg;
1577 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1578 PL_xpvmg_root = ++xpvmg;
1579 while (xpvmg < xpvmgend) {
1580 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1586 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1595 xpvlv = PL_xpvlv_root;
1596 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1601 /* return a struct xpvlv to the free list */
1604 S_del_xpvlv(pTHX_ XPVLV *p)
1607 p->xpv_pv = (char*)PL_xpvlv_root;
1612 /* allocate another arena's worth of struct xpvlv */
1617 register XPVLV* xpvlv;
1618 register XPVLV* xpvlvend;
1619 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1620 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1621 PL_xpvlv_arenaroot = xpvlv;
1623 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1624 PL_xpvlv_root = ++xpvlv;
1625 while (xpvlv < xpvlvend) {
1626 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1632 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1641 xpvbm = PL_xpvbm_root;
1642 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1647 /* return a struct xpvbm to the free list */
1650 S_del_xpvbm(pTHX_ XPVBM *p)
1653 p->xpv_pv = (char*)PL_xpvbm_root;
1658 /* allocate another arena's worth of struct xpvbm */
1663 register XPVBM* xpvbm;
1664 register XPVBM* xpvbmend;
1665 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1666 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1667 PL_xpvbm_arenaroot = xpvbm;
1669 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1670 PL_xpvbm_root = ++xpvbm;
1671 while (xpvbm < xpvbmend) {
1672 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1678 #define my_safemalloc(s) (void*)safemalloc(s)
1679 #define my_safefree(p) safefree((char*)p)
1683 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1684 #define del_XIV(p) my_safefree(p)
1686 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1687 #define del_XNV(p) my_safefree(p)
1689 #define new_XRV() my_safemalloc(sizeof(XRV))
1690 #define del_XRV(p) my_safefree(p)
1692 #define new_XPV() my_safemalloc(sizeof(XPV))
1693 #define del_XPV(p) my_safefree(p)
1695 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1696 #define del_XPVIV(p) my_safefree(p)
1698 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1699 #define del_XPVNV(p) my_safefree(p)
1701 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1702 #define del_XPVCV(p) my_safefree(p)
1704 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1705 #define del_XPVAV(p) my_safefree(p)
1707 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1708 #define del_XPVHV(p) my_safefree(p)
1710 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1711 #define del_XPVMG(p) my_safefree(p)
1713 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1714 #define del_XPVLV(p) my_safefree(p)
1716 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1717 #define del_XPVBM(p) my_safefree(p)
1721 #define new_XIV() (void*)new_xiv()
1722 #define del_XIV(p) del_xiv((XPVIV*) p)
1724 #define new_XNV() (void*)new_xnv()
1725 #define del_XNV(p) del_xnv((XPVNV*) p)
1727 #define new_XRV() (void*)new_xrv()
1728 #define del_XRV(p) del_xrv((XRV*) p)
1730 #define new_XPV() (void*)new_xpv()
1731 #define del_XPV(p) del_xpv((XPV *)p)
1733 #define new_XPVIV() (void*)new_xpviv()
1734 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1736 #define new_XPVNV() (void*)new_xpvnv()
1737 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1739 #define new_XPVCV() (void*)new_xpvcv()
1740 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1742 #define new_XPVAV() (void*)new_xpvav()
1743 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1745 #define new_XPVHV() (void*)new_xpvhv()
1746 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1748 #define new_XPVMG() (void*)new_xpvmg()
1749 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1751 #define new_XPVLV() (void*)new_xpvlv()
1752 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1754 #define new_XPVBM() (void*)new_xpvbm()
1755 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1759 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1760 #define del_XPVGV(p) my_safefree(p)
1762 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1763 #define del_XPVFM(p) my_safefree(p)
1765 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1766 #define del_XPVIO(p) my_safefree(p)
1769 =for apidoc sv_upgrade
1771 Upgrade an SV to a more complex form. Generally adds a new body type to the
1772 SV, then copies across as much information as possible from the old body.
1773 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1779 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1790 if (mt != SVt_PV && SvIsCOW(sv)) {
1791 sv_force_normal_flags(sv, 0);
1794 if (SvTYPE(sv) == mt)
1805 switch (SvTYPE(sv)) {
1813 else if (mt < SVt_PVIV)
1823 pv = (char*)SvRV(sv);
1833 else if (mt == SVt_NV)
1841 del_XPVIV(SvANY(sv));
1849 del_XPVNV(SvANY(sv));
1852 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1853 there's no way that it can be safely upgraded, because perl.c
1854 expects to Safefree(SvANY(PL_mess_sv)) */
1855 assert(sv != PL_mess_sv);
1861 magic = SvMAGIC(sv);
1862 stash = SvSTASH(sv);
1863 del_XPVMG(SvANY(sv));
1866 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1869 SvFLAGS(sv) &= ~SVTYPEMASK;
1874 Perl_croak(aTHX_ "Can't upgrade to undef");
1876 SvANY(sv) = new_XIV();
1880 SvANY(sv) = new_XNV();
1884 SvANY(sv) = new_XRV();
1885 SvRV_set(sv, (SV*)pv);
1888 SvANY(sv) = new_XPVHV();
1895 HvTOTALKEYS(sv) = 0;
1896 HvPLACEHOLDERS(sv) = 0;
1898 /* Fall through... */
1901 SvANY(sv) = new_XPVAV();
1906 AvFLAGS(sv) = AVf_REAL;
1911 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1913 /* FIXME. Should be able to remove all this if()... if the above
1914 assertion is genuinely always true. */
1917 SvFLAGS(sv) &= ~SVf_OOK;
1920 SvPV_set(sv, (char*)0);
1921 SvMAGIC_set(sv, magic);
1922 SvSTASH_set(sv, stash);
1926 SvANY(sv) = new_XPVIO();
1927 Zero(SvANY(sv), 1, XPVIO);
1928 IoPAGE_LEN(sv) = 60;
1929 goto set_magic_common;
1931 SvANY(sv) = new_XPVFM();
1932 Zero(SvANY(sv), 1, XPVFM);
1933 goto set_magic_common;
1935 SvANY(sv) = new_XPVBM();
1939 goto set_magic_common;
1941 SvANY(sv) = new_XPVGV();
1947 goto set_magic_common;
1949 SvANY(sv) = new_XPVCV();
1950 Zero(SvANY(sv), 1, XPVCV);
1951 goto set_magic_common;
1953 SvANY(sv) = new_XPVLV();
1966 SvANY(sv) = new_XPVMG();
1969 SvMAGIC_set(sv, magic);
1970 SvSTASH_set(sv, stash);
1974 SvANY(sv) = new_XPVNV();
1980 SvANY(sv) = new_XPVIV();
1989 SvANY(sv) = new_XPV();
2000 =for apidoc sv_backoff
2002 Remove any string offset. You should normally use the C<SvOOK_off> macro
2009 Perl_sv_backoff(pTHX_ register SV *sv)
2013 char *s = SvPVX(sv);
2014 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2015 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2017 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2019 SvFLAGS(sv) &= ~SVf_OOK;
2026 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2027 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2028 Use the C<SvGROW> wrapper instead.
2034 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2038 #ifdef HAS_64K_LIMIT
2039 if (newlen >= 0x10000) {
2040 PerlIO_printf(Perl_debug_log,
2041 "Allocation too large: %"UVxf"\n", (UV)newlen);
2044 #endif /* HAS_64K_LIMIT */
2047 if (SvTYPE(sv) < SVt_PV) {
2048 sv_upgrade(sv, SVt_PV);
2051 else if (SvOOK(sv)) { /* pv is offset? */
2054 if (newlen > SvLEN(sv))
2055 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2056 #ifdef HAS_64K_LIMIT
2057 if (newlen >= 0x10000)
2064 if (newlen > SvLEN(sv)) { /* need more room? */
2065 if (SvLEN(sv) && s) {
2067 STRLEN l = malloced_size((void*)SvPVX(sv));
2073 Renew(s,newlen,char);
2076 New(703, s, newlen, char);
2077 if (SvPVX(sv) && SvCUR(sv)) {
2078 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2082 SvLEN_set(sv, newlen);
2088 =for apidoc sv_setiv
2090 Copies an integer into the given SV, upgrading first if necessary.
2091 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2097 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2099 SV_CHECK_THINKFIRST_COW_DROP(sv);
2100 switch (SvTYPE(sv)) {
2102 sv_upgrade(sv, SVt_IV);
2105 sv_upgrade(sv, SVt_PVNV);
2109 sv_upgrade(sv, SVt_PVIV);
2118 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2121 (void)SvIOK_only(sv); /* validate number */
2127 =for apidoc sv_setiv_mg
2129 Like C<sv_setiv>, but also handles 'set' magic.
2135 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2142 =for apidoc sv_setuv
2144 Copies an unsigned integer into the given SV, upgrading first if necessary.
2145 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2151 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2153 /* With these two if statements:
2154 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2157 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2159 If you wish to remove them, please benchmark to see what the effect is
2161 if (u <= (UV)IV_MAX) {
2162 sv_setiv(sv, (IV)u);
2171 =for apidoc sv_setuv_mg
2173 Like C<sv_setuv>, but also handles 'set' magic.
2179 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2181 /* With these two if statements:
2182 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2185 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2187 If you wish to remove them, please benchmark to see what the effect is
2189 if (u <= (UV)IV_MAX) {
2190 sv_setiv(sv, (IV)u);
2200 =for apidoc sv_setnv
2202 Copies a double into the given SV, upgrading first if necessary.
2203 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2209 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2211 SV_CHECK_THINKFIRST_COW_DROP(sv);
2212 switch (SvTYPE(sv)) {
2215 sv_upgrade(sv, SVt_NV);
2220 sv_upgrade(sv, SVt_PVNV);
2229 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2233 (void)SvNOK_only(sv); /* validate number */
2238 =for apidoc sv_setnv_mg
2240 Like C<sv_setnv>, but also handles 'set' magic.
2246 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2252 /* Print an "isn't numeric" warning, using a cleaned-up,
2253 * printable version of the offending string
2257 S_not_a_number(pTHX_ SV *sv)
2264 dsv = sv_2mortal(newSVpv("", 0));
2265 pv = sv_uni_display(dsv, sv, 10, 0);
2268 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2269 /* each *s can expand to 4 chars + "...\0",
2270 i.e. need room for 8 chars */
2273 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2275 if (ch & 128 && !isPRINT_LC(ch)) {
2284 else if (ch == '\r') {
2288 else if (ch == '\f') {
2292 else if (ch == '\\') {
2296 else if (ch == '\0') {
2300 else if (isPRINT_LC(ch))
2317 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2318 "Argument \"%s\" isn't numeric in %s", pv,
2321 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2322 "Argument \"%s\" isn't numeric", pv);
2326 =for apidoc looks_like_number
2328 Test if the content of an SV looks like a number (or is a number).
2329 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2330 non-numeric warning), even if your atof() doesn't grok them.
2336 Perl_looks_like_number(pTHX_ SV *sv)
2338 register char *sbegin;
2345 else if (SvPOKp(sv))
2346 sbegin = SvPV(sv, len);
2348 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2349 return grok_number(sbegin, len, NULL);
2352 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2353 until proven guilty, assume that things are not that bad... */
2358 As 64 bit platforms often have an NV that doesn't preserve all bits of
2359 an IV (an assumption perl has been based on to date) it becomes necessary
2360 to remove the assumption that the NV always carries enough precision to
2361 recreate the IV whenever needed, and that the NV is the canonical form.
2362 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2363 precision as a side effect of conversion (which would lead to insanity
2364 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2365 1) to distinguish between IV/UV/NV slots that have cached a valid
2366 conversion where precision was lost and IV/UV/NV slots that have a
2367 valid conversion which has lost no precision
2368 2) to ensure that if a numeric conversion to one form is requested that
2369 would lose precision, the precise conversion (or differently
2370 imprecise conversion) is also performed and cached, to prevent
2371 requests for different numeric formats on the same SV causing
2372 lossy conversion chains. (lossless conversion chains are perfectly
2377 SvIOKp is true if the IV slot contains a valid value
2378 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2379 SvNOKp is true if the NV slot contains a valid value
2380 SvNOK is true only if the NV value is accurate
2383 while converting from PV to NV, check to see if converting that NV to an
2384 IV(or UV) would lose accuracy over a direct conversion from PV to
2385 IV(or UV). If it would, cache both conversions, return NV, but mark
2386 SV as IOK NOKp (ie not NOK).
2388 While converting from PV to IV, check to see if converting that IV to an
2389 NV would lose accuracy over a direct conversion from PV to NV. If it
2390 would, cache both conversions, flag similarly.
2392 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2393 correctly because if IV & NV were set NV *always* overruled.
2394 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2395 changes - now IV and NV together means that the two are interchangeable:
2396 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2398 The benefit of this is that operations such as pp_add know that if
2399 SvIOK is true for both left and right operands, then integer addition
2400 can be used instead of floating point (for cases where the result won't
2401 overflow). Before, floating point was always used, which could lead to
2402 loss of precision compared with integer addition.
2404 * making IV and NV equal status should make maths accurate on 64 bit
2406 * may speed up maths somewhat if pp_add and friends start to use
2407 integers when possible instead of fp. (Hopefully the overhead in
2408 looking for SvIOK and checking for overflow will not outweigh the
2409 fp to integer speedup)
2410 * will slow down integer operations (callers of SvIV) on "inaccurate"
2411 values, as the change from SvIOK to SvIOKp will cause a call into
2412 sv_2iv each time rather than a macro access direct to the IV slot
2413 * should speed up number->string conversion on integers as IV is
2414 favoured when IV and NV are equally accurate
2416 ####################################################################
2417 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2418 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2419 On the other hand, SvUOK is true iff UV.
2420 ####################################################################
2422 Your mileage will vary depending your CPU's relative fp to integer
2426 #ifndef NV_PRESERVES_UV
2427 # define IS_NUMBER_UNDERFLOW_IV 1
2428 # define IS_NUMBER_UNDERFLOW_UV 2
2429 # define IS_NUMBER_IV_AND_UV 2
2430 # define IS_NUMBER_OVERFLOW_IV 4
2431 # define IS_NUMBER_OVERFLOW_UV 5
2433 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2435 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2437 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2439 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));
2440 if (SvNVX(sv) < (NV)IV_MIN) {
2441 (void)SvIOKp_on(sv);
2443 SvIV_set(sv, IV_MIN);
2444 return IS_NUMBER_UNDERFLOW_IV;
2446 if (SvNVX(sv) > (NV)UV_MAX) {
2447 (void)SvIOKp_on(sv);
2450 SvUV_set(sv, UV_MAX);
2451 return IS_NUMBER_OVERFLOW_UV;
2453 (void)SvIOKp_on(sv);
2455 /* Can't use strtol etc to convert this string. (See truth table in
2457 if (SvNVX(sv) <= (UV)IV_MAX) {
2458 SvIV_set(sv, I_V(SvNVX(sv)));
2459 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2460 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2462 /* Integer is imprecise. NOK, IOKp */
2464 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2467 SvUV_set(sv, U_V(SvNVX(sv)));
2468 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2469 if (SvUVX(sv) == UV_MAX) {
2470 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2471 possibly be preserved by NV. Hence, it must be overflow.
2473 return IS_NUMBER_OVERFLOW_UV;
2475 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2477 /* Integer is imprecise. NOK, IOKp */
2479 return IS_NUMBER_OVERFLOW_IV;
2481 #endif /* !NV_PRESERVES_UV*/
2483 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2484 * this function provided for binary compatibility only
2488 Perl_sv_2iv(pTHX_ register SV *sv)
2490 return sv_2iv_flags(sv, SV_GMAGIC);
2494 =for apidoc sv_2iv_flags
2496 Return the integer value of an SV, doing any necessary string
2497 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2498 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2504 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2508 if (SvGMAGICAL(sv)) {
2509 if (flags & SV_GMAGIC)
2514 return I_V(SvNVX(sv));
2516 if (SvPOKp(sv) && SvLEN(sv))
2519 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2520 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2526 if (SvTHINKFIRST(sv)) {
2529 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2530 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2531 return SvIV(tmpstr);
2532 return PTR2IV(SvRV(sv));
2535 sv_force_normal_flags(sv, 0);
2537 if (SvREADONLY(sv) && !SvOK(sv)) {
2538 if (ckWARN(WARN_UNINITIALIZED))
2545 return (IV)(SvUVX(sv));
2552 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2553 * without also getting a cached IV/UV from it at the same time
2554 * (ie PV->NV conversion should detect loss of accuracy and cache
2555 * IV or UV at same time to avoid this. NWC */
2557 if (SvTYPE(sv) == SVt_NV)
2558 sv_upgrade(sv, SVt_PVNV);
2560 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2561 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2562 certainly cast into the IV range at IV_MAX, whereas the correct
2563 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2565 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2566 SvIV_set(sv, I_V(SvNVX(sv)));
2567 if (SvNVX(sv) == (NV) SvIVX(sv)
2568 #ifndef NV_PRESERVES_UV
2569 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2570 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2571 /* Don't flag it as "accurately an integer" if the number
2572 came from a (by definition imprecise) NV operation, and
2573 we're outside the range of NV integer precision */
2576 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2577 DEBUG_c(PerlIO_printf(Perl_debug_log,
2578 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2584 /* IV not precise. No need to convert from PV, as NV
2585 conversion would already have cached IV if it detected
2586 that PV->IV would be better than PV->NV->IV
2587 flags already correct - don't set public IOK. */
2588 DEBUG_c(PerlIO_printf(Perl_debug_log,
2589 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2594 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2595 but the cast (NV)IV_MIN rounds to a the value less (more
2596 negative) than IV_MIN which happens to be equal to SvNVX ??
2597 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2598 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2599 (NV)UVX == NVX are both true, but the values differ. :-(
2600 Hopefully for 2s complement IV_MIN is something like
2601 0x8000000000000000 which will be exact. NWC */
2604 SvUV_set(sv, U_V(SvNVX(sv)));
2606 (SvNVX(sv) == (NV) SvUVX(sv))
2607 #ifndef NV_PRESERVES_UV
2608 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2609 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2610 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2611 /* Don't flag it as "accurately an integer" if the number
2612 came from a (by definition imprecise) NV operation, and
2613 we're outside the range of NV integer precision */
2619 DEBUG_c(PerlIO_printf(Perl_debug_log,
2620 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2624 return (IV)SvUVX(sv);
2627 else if (SvPOKp(sv) && SvLEN(sv)) {
2629 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2630 /* We want to avoid a possible problem when we cache an IV which
2631 may be later translated to an NV, and the resulting NV is not
2632 the same as the direct translation of the initial string
2633 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2634 be careful to ensure that the value with the .456 is around if the
2635 NV value is requested in the future).
2637 This means that if we cache such an IV, we need to cache the
2638 NV as well. Moreover, we trade speed for space, and do not
2639 cache the NV if we are sure it's not needed.
2642 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2643 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2644 == IS_NUMBER_IN_UV) {
2645 /* It's definitely an integer, only upgrade to PVIV */
2646 if (SvTYPE(sv) < SVt_PVIV)
2647 sv_upgrade(sv, SVt_PVIV);
2649 } else if (SvTYPE(sv) < SVt_PVNV)
2650 sv_upgrade(sv, SVt_PVNV);
2652 /* If NV preserves UV then we only use the UV value if we know that
2653 we aren't going to call atof() below. If NVs don't preserve UVs
2654 then the value returned may have more precision than atof() will
2655 return, even though value isn't perfectly accurate. */
2656 if ((numtype & (IS_NUMBER_IN_UV
2657 #ifdef NV_PRESERVES_UV
2660 )) == IS_NUMBER_IN_UV) {
2661 /* This won't turn off the public IOK flag if it was set above */
2662 (void)SvIOKp_on(sv);
2664 if (!(numtype & IS_NUMBER_NEG)) {
2666 if (value <= (UV)IV_MAX) {
2667 SvIV_set(sv, (IV)value);
2669 SvUV_set(sv, value);
2673 /* 2s complement assumption */
2674 if (value <= (UV)IV_MIN) {
2675 SvIV_set(sv, -(IV)value);
2677 /* Too negative for an IV. This is a double upgrade, but
2678 I'm assuming it will be rare. */
2679 if (SvTYPE(sv) < SVt_PVNV)
2680 sv_upgrade(sv, SVt_PVNV);
2684 SvNV_set(sv, -(NV)value);
2685 SvIV_set(sv, IV_MIN);
2689 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2690 will be in the previous block to set the IV slot, and the next
2691 block to set the NV slot. So no else here. */
2693 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2694 != IS_NUMBER_IN_UV) {
2695 /* It wasn't an (integer that doesn't overflow the UV). */
2696 SvNV_set(sv, Atof(SvPVX(sv)));
2698 if (! numtype && ckWARN(WARN_NUMERIC))
2701 #if defined(USE_LONG_DOUBLE)
2702 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2703 PTR2UV(sv), SvNVX(sv)));
2705 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2706 PTR2UV(sv), SvNVX(sv)));
2710 #ifdef NV_PRESERVES_UV
2711 (void)SvIOKp_on(sv);
2713 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2714 SvIV_set(sv, I_V(SvNVX(sv)));
2715 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2718 /* Integer is imprecise. NOK, IOKp */
2720 /* UV will not work better than IV */
2722 if (SvNVX(sv) > (NV)UV_MAX) {
2724 /* Integer is inaccurate. NOK, IOKp, is UV */
2725 SvUV_set(sv, UV_MAX);
2728 SvUV_set(sv, U_V(SvNVX(sv)));
2729 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2730 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2734 /* Integer is imprecise. NOK, IOKp, is UV */
2740 #else /* NV_PRESERVES_UV */
2741 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2742 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2743 /* The IV slot will have been set from value returned by
2744 grok_number above. The NV slot has just been set using
2747 assert (SvIOKp(sv));
2749 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2750 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2751 /* Small enough to preserve all bits. */
2752 (void)SvIOKp_on(sv);
2754 SvIV_set(sv, I_V(SvNVX(sv)));
2755 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2757 /* Assumption: first non-preserved integer is < IV_MAX,
2758 this NV is in the preserved range, therefore: */
2759 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2761 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);
2765 0 0 already failed to read UV.
2766 0 1 already failed to read UV.
2767 1 0 you won't get here in this case. IV/UV
2768 slot set, public IOK, Atof() unneeded.
2769 1 1 already read UV.
2770 so there's no point in sv_2iuv_non_preserve() attempting
2771 to use atol, strtol, strtoul etc. */
2772 if (sv_2iuv_non_preserve (sv, numtype)
2773 >= IS_NUMBER_OVERFLOW_IV)
2777 #endif /* NV_PRESERVES_UV */
2780 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2782 if (SvTYPE(sv) < SVt_IV)
2783 /* Typically the caller expects that sv_any is not NULL now. */
2784 sv_upgrade(sv, SVt_IV);
2787 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2788 PTR2UV(sv),SvIVX(sv)));
2789 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2792 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2793 * this function provided for binary compatibility only
2797 Perl_sv_2uv(pTHX_ register SV *sv)
2799 return sv_2uv_flags(sv, SV_GMAGIC);
2803 =for apidoc sv_2uv_flags
2805 Return the unsigned integer value of an SV, doing any necessary string
2806 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2807 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2813 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2817 if (SvGMAGICAL(sv)) {
2818 if (flags & SV_GMAGIC)
2823 return U_V(SvNVX(sv));
2824 if (SvPOKp(sv) && SvLEN(sv))
2827 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2828 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2834 if (SvTHINKFIRST(sv)) {
2837 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2838 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2839 return SvUV(tmpstr);
2840 return PTR2UV(SvRV(sv));
2843 sv_force_normal_flags(sv, 0);
2845 if (SvREADONLY(sv) && !SvOK(sv)) {
2846 if (ckWARN(WARN_UNINITIALIZED))
2856 return (UV)SvIVX(sv);
2860 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2861 * without also getting a cached IV/UV from it at the same time
2862 * (ie PV->NV conversion should detect loss of accuracy and cache
2863 * IV or UV at same time to avoid this. */
2864 /* IV-over-UV optimisation - choose to cache IV if possible */
2866 if (SvTYPE(sv) == SVt_NV)
2867 sv_upgrade(sv, SVt_PVNV);
2869 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2870 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2871 SvIV_set(sv, I_V(SvNVX(sv)));
2872 if (SvNVX(sv) == (NV) SvIVX(sv)
2873 #ifndef NV_PRESERVES_UV
2874 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2875 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2876 /* Don't flag it as "accurately an integer" if the number
2877 came from a (by definition imprecise) NV operation, and
2878 we're outside the range of NV integer precision */
2881 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2882 DEBUG_c(PerlIO_printf(Perl_debug_log,
2883 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2889 /* IV not precise. No need to convert from PV, as NV
2890 conversion would already have cached IV if it detected
2891 that PV->IV would be better than PV->NV->IV
2892 flags already correct - don't set public IOK. */
2893 DEBUG_c(PerlIO_printf(Perl_debug_log,
2894 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2899 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2900 but the cast (NV)IV_MIN rounds to a the value less (more
2901 negative) than IV_MIN which happens to be equal to SvNVX ??
2902 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2903 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2904 (NV)UVX == NVX are both true, but the values differ. :-(
2905 Hopefully for 2s complement IV_MIN is something like
2906 0x8000000000000000 which will be exact. NWC */
2909 SvUV_set(sv, U_V(SvNVX(sv)));
2911 (SvNVX(sv) == (NV) SvUVX(sv))
2912 #ifndef NV_PRESERVES_UV
2913 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2914 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2915 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2916 /* Don't flag it as "accurately an integer" if the number
2917 came from a (by definition imprecise) NV operation, and
2918 we're outside the range of NV integer precision */
2923 DEBUG_c(PerlIO_printf(Perl_debug_log,
2924 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2930 else if (SvPOKp(sv) && SvLEN(sv)) {
2932 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2934 /* We want to avoid a possible problem when we cache a UV which
2935 may be later translated to an NV, and the resulting NV is not
2936 the translation of the initial data.
2938 This means that if we cache such a UV, we need to cache the
2939 NV as well. Moreover, we trade speed for space, and do not
2940 cache the NV if not needed.
2943 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2944 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2945 == IS_NUMBER_IN_UV) {
2946 /* It's definitely an integer, only upgrade to PVIV */
2947 if (SvTYPE(sv) < SVt_PVIV)
2948 sv_upgrade(sv, SVt_PVIV);
2950 } else if (SvTYPE(sv) < SVt_PVNV)
2951 sv_upgrade(sv, SVt_PVNV);
2953 /* If NV preserves UV then we only use the UV value if we know that
2954 we aren't going to call atof() below. If NVs don't preserve UVs
2955 then the value returned may have more precision than atof() will
2956 return, even though it isn't accurate. */
2957 if ((numtype & (IS_NUMBER_IN_UV
2958 #ifdef NV_PRESERVES_UV
2961 )) == IS_NUMBER_IN_UV) {
2962 /* This won't turn off the public IOK flag if it was set above */
2963 (void)SvIOKp_on(sv);
2965 if (!(numtype & IS_NUMBER_NEG)) {
2967 if (value <= (UV)IV_MAX) {
2968 SvIV_set(sv, (IV)value);
2970 /* it didn't overflow, and it was positive. */
2971 SvUV_set(sv, value);
2975 /* 2s complement assumption */
2976 if (value <= (UV)IV_MIN) {
2977 SvIV_set(sv, -(IV)value);
2979 /* Too negative for an IV. This is a double upgrade, but
2980 I'm assuming it will be rare. */
2981 if (SvTYPE(sv) < SVt_PVNV)
2982 sv_upgrade(sv, SVt_PVNV);
2986 SvNV_set(sv, -(NV)value);
2987 SvIV_set(sv, IV_MIN);
2992 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2993 != IS_NUMBER_IN_UV) {
2994 /* It wasn't an integer, or it overflowed the UV. */
2995 SvNV_set(sv, Atof(SvPVX(sv)));
2997 if (! numtype && ckWARN(WARN_NUMERIC))
3000 #if defined(USE_LONG_DOUBLE)
3001 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3002 PTR2UV(sv), SvNVX(sv)));
3004 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3005 PTR2UV(sv), SvNVX(sv)));
3008 #ifdef NV_PRESERVES_UV
3009 (void)SvIOKp_on(sv);
3011 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3012 SvIV_set(sv, I_V(SvNVX(sv)));
3013 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3016 /* Integer is imprecise. NOK, IOKp */
3018 /* UV will not work better than IV */
3020 if (SvNVX(sv) > (NV)UV_MAX) {
3022 /* Integer is inaccurate. NOK, IOKp, is UV */
3023 SvUV_set(sv, UV_MAX);
3026 SvUV_set(sv, U_V(SvNVX(sv)));
3027 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3028 NV preservse UV so can do correct comparison. */
3029 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3033 /* Integer is imprecise. NOK, IOKp, is UV */
3038 #else /* NV_PRESERVES_UV */
3039 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3040 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3041 /* The UV slot will have been set from value returned by
3042 grok_number above. The NV slot has just been set using
3045 assert (SvIOKp(sv));
3047 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3048 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3049 /* Small enough to preserve all bits. */
3050 (void)SvIOKp_on(sv);
3052 SvIV_set(sv, I_V(SvNVX(sv)));
3053 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3055 /* Assumption: first non-preserved integer is < IV_MAX,
3056 this NV is in the preserved range, therefore: */
3057 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3059 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);
3062 sv_2iuv_non_preserve (sv, numtype);
3064 #endif /* NV_PRESERVES_UV */
3068 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3069 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3072 if (SvTYPE(sv) < SVt_IV)
3073 /* Typically the caller expects that sv_any is not NULL now. */
3074 sv_upgrade(sv, SVt_IV);
3078 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3079 PTR2UV(sv),SvUVX(sv)));
3080 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3086 Return the num value of an SV, doing any necessary string or integer
3087 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3094 Perl_sv_2nv(pTHX_ register SV *sv)
3098 if (SvGMAGICAL(sv)) {
3102 if (SvPOKp(sv) && SvLEN(sv)) {
3103 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3104 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3106 return Atof(SvPVX(sv));
3110 return (NV)SvUVX(sv);
3112 return (NV)SvIVX(sv);
3115 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3116 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3122 if (SvTHINKFIRST(sv)) {
3125 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3126 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3127 return SvNV(tmpstr);
3128 return PTR2NV(SvRV(sv));
3131 sv_force_normal_flags(sv, 0);
3133 if (SvREADONLY(sv) && !SvOK(sv)) {
3134 if (ckWARN(WARN_UNINITIALIZED))
3139 if (SvTYPE(sv) < SVt_NV) {
3140 if (SvTYPE(sv) == SVt_IV)
3141 sv_upgrade(sv, SVt_PVNV);
3143 sv_upgrade(sv, SVt_NV);
3144 #ifdef USE_LONG_DOUBLE
3146 STORE_NUMERIC_LOCAL_SET_STANDARD();
3147 PerlIO_printf(Perl_debug_log,
3148 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3149 PTR2UV(sv), SvNVX(sv));
3150 RESTORE_NUMERIC_LOCAL();
3154 STORE_NUMERIC_LOCAL_SET_STANDARD();
3155 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3156 PTR2UV(sv), SvNVX(sv));
3157 RESTORE_NUMERIC_LOCAL();
3161 else if (SvTYPE(sv) < SVt_PVNV)
3162 sv_upgrade(sv, SVt_PVNV);
3167 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3168 #ifdef NV_PRESERVES_UV
3171 /* Only set the public NV OK flag if this NV preserves the IV */
3172 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3173 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3174 : (SvIVX(sv) == I_V(SvNVX(sv))))
3180 else if (SvPOKp(sv) && SvLEN(sv)) {
3182 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3183 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3185 #ifdef NV_PRESERVES_UV
3186 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3187 == IS_NUMBER_IN_UV) {
3188 /* It's definitely an integer */
3189 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3191 SvNV_set(sv, Atof(SvPVX(sv)));
3194 SvNV_set(sv, Atof(SvPVX(sv)));
3195 /* Only set the public NV OK flag if this NV preserves the value in
3196 the PV at least as well as an IV/UV would.
3197 Not sure how to do this 100% reliably. */
3198 /* if that shift count is out of range then Configure's test is
3199 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3201 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3202 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3203 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3204 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3205 /* Can't use strtol etc to convert this string, so don't try.
3206 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3209 /* value has been set. It may not be precise. */
3210 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3211 /* 2s complement assumption for (UV)IV_MIN */
3212 SvNOK_on(sv); /* Integer is too negative. */
3217 if (numtype & IS_NUMBER_NEG) {
3218 SvIV_set(sv, -(IV)value);
3219 } else if (value <= (UV)IV_MAX) {
3220 SvIV_set(sv, (IV)value);
3222 SvUV_set(sv, value);
3226 if (numtype & IS_NUMBER_NOT_INT) {
3227 /* I believe that even if the original PV had decimals,
3228 they are lost beyond the limit of the FP precision.
3229 However, neither is canonical, so both only get p
3230 flags. NWC, 2000/11/25 */
3231 /* Both already have p flags, so do nothing */
3234 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3235 if (SvIVX(sv) == I_V(nv)) {
3240 /* It had no "." so it must be integer. */
3243 /* between IV_MAX and NV(UV_MAX).
3244 Could be slightly > UV_MAX */
3246 if (numtype & IS_NUMBER_NOT_INT) {
3247 /* UV and NV both imprecise. */
3249 UV nv_as_uv = U_V(nv);
3251 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3262 #endif /* NV_PRESERVES_UV */
3265 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3267 if (SvTYPE(sv) < SVt_NV)
3268 /* Typically the caller expects that sv_any is not NULL now. */
3269 /* XXX Ilya implies that this is a bug in callers that assume this
3270 and ideally should be fixed. */
3271 sv_upgrade(sv, SVt_NV);
3274 #if defined(USE_LONG_DOUBLE)
3276 STORE_NUMERIC_LOCAL_SET_STANDARD();
3277 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3278 PTR2UV(sv), SvNVX(sv));
3279 RESTORE_NUMERIC_LOCAL();
3283 STORE_NUMERIC_LOCAL_SET_STANDARD();
3284 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3285 PTR2UV(sv), SvNVX(sv));
3286 RESTORE_NUMERIC_LOCAL();
3292 /* asIV(): extract an integer from the string value of an SV.
3293 * Caller must validate PVX */
3296 S_asIV(pTHX_ SV *sv)
3299 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3301 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3302 == IS_NUMBER_IN_UV) {
3303 /* It's definitely an integer */
3304 if (numtype & IS_NUMBER_NEG) {
3305 if (value < (UV)IV_MIN)
3308 if (value < (UV)IV_MAX)
3313 if (ckWARN(WARN_NUMERIC))
3316 return I_V(Atof(SvPVX(sv)));
3319 /* asUV(): extract an unsigned integer from the string value of an SV
3320 * Caller must validate PVX */
3323 S_asUV(pTHX_ SV *sv)
3326 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3328 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3329 == IS_NUMBER_IN_UV) {
3330 /* It's definitely an integer */
3331 if (!(numtype & IS_NUMBER_NEG))
3335 if (ckWARN(WARN_NUMERIC))
3338 return U_V(Atof(SvPVX(sv)));
3342 =for apidoc sv_2pv_nolen
3344 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3345 use the macro wrapper C<SvPV_nolen(sv)> instead.
3350 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3353 return sv_2pv(sv, &n_a);
3356 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3357 * UV as a string towards the end of buf, and return pointers to start and
3360 * We assume that buf is at least TYPE_CHARS(UV) long.
3364 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3366 char *ptr = buf + TYPE_CHARS(UV);
3380 *--ptr = '0' + (char)(uv % 10);
3388 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3389 * this function provided for binary compatibility only
3393 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3395 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3399 =for apidoc sv_2pv_flags
3401 Returns a pointer to the string value of an SV, and sets *lp to its length.
3402 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3404 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3405 usually end up here too.
3411 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3416 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3417 char *tmpbuf = tbuf;
3423 if (SvGMAGICAL(sv)) {
3424 if (flags & SV_GMAGIC)
3432 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3434 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3439 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3444 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3445 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3452 if (SvTHINKFIRST(sv)) {
3455 register const char *typestr;
3456 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3457 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3458 char *pv = SvPV(tmpstr, *lp);
3468 typestr = "NULLREF";
3472 switch (SvTYPE(sv)) {
3474 if ( ((SvFLAGS(sv) &
3475 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3476 == (SVs_OBJECT|SVs_SMG))
3477 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3478 const regexp *re = (regexp *)mg->mg_obj;
3481 const char *fptr = "msix";
3486 char need_newline = 0;
3487 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3489 while((ch = *fptr++)) {
3491 reflags[left++] = ch;
3494 reflags[right--] = ch;
3499 reflags[left] = '-';
3503 mg->mg_len = re->prelen + 4 + left;
3505 * If /x was used, we have to worry about a regex
3506 * ending with a comment later being embedded
3507 * within another regex. If so, we don't want this
3508 * regex's "commentization" to leak out to the
3509 * right part of the enclosing regex, we must cap
3510 * it with a newline.
3512 * So, if /x was used, we scan backwards from the
3513 * end of the regex. If we find a '#' before we
3514 * find a newline, we need to add a newline
3515 * ourself. If we find a '\n' first (or if we
3516 * don't find '#' or '\n'), we don't need to add
3517 * anything. -jfriedl
3519 if (PMf_EXTENDED & re->reganch)
3521 const char *endptr = re->precomp + re->prelen;
3522 while (endptr >= re->precomp)
3524 const char c = *(endptr--);
3526 break; /* don't need another */
3528 /* we end while in a comment, so we
3530 mg->mg_len++; /* save space for it */
3531 need_newline = 1; /* note to add it */
3537 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3538 Copy("(?", mg->mg_ptr, 2, char);
3539 Copy(reflags, mg->mg_ptr+2, left, char);
3540 Copy(":", mg->mg_ptr+left+2, 1, char);
3541 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3543 mg->mg_ptr[mg->mg_len - 2] = '\n';
3544 mg->mg_ptr[mg->mg_len - 1] = ')';
3545 mg->mg_ptr[mg->mg_len] = 0;
3547 PL_reginterp_cnt += re->program[0].next_off;
3549 if (re->reganch & ROPT_UTF8)
3564 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3565 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3566 /* tied lvalues should appear to be
3567 * scalars for backwards compatitbility */
3568 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3569 ? "SCALAR" : "LVALUE"; break;
3570 case SVt_PVAV: typestr = "ARRAY"; break;
3571 case SVt_PVHV: typestr = "HASH"; break;
3572 case SVt_PVCV: typestr = "CODE"; break;
3573 case SVt_PVGV: typestr = "GLOB"; break;
3574 case SVt_PVFM: typestr = "FORMAT"; break;
3575 case SVt_PVIO: typestr = "IO"; break;
3576 default: typestr = "UNKNOWN"; break;
3580 const char *name = HvNAME(SvSTASH(sv));
3581 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3582 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3585 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3588 *lp = strlen(typestr);
3589 return (char *)typestr;
3591 if (SvREADONLY(sv) && !SvOK(sv)) {
3592 if (ckWARN(WARN_UNINITIALIZED))
3598 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3599 /* I'm assuming that if both IV and NV are equally valid then
3600 converting the IV is going to be more efficient */
3601 const U32 isIOK = SvIOK(sv);
3602 const U32 isUIOK = SvIsUV(sv);
3603 char buf[TYPE_CHARS(UV)];
3606 if (SvTYPE(sv) < SVt_PVIV)
3607 sv_upgrade(sv, SVt_PVIV);
3609 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3611 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3612 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3613 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3614 SvCUR_set(sv, ebuf - ptr);
3624 else if (SvNOKp(sv)) {
3625 if (SvTYPE(sv) < SVt_PVNV)
3626 sv_upgrade(sv, SVt_PVNV);
3627 /* The +20 is pure guesswork. Configure test needed. --jhi */
3628 SvGROW(sv, NV_DIG + 20);
3630 olderrno = errno; /* some Xenix systems wipe out errno here */
3632 if (SvNVX(sv) == 0.0)
3633 (void)strcpy(s,"0");
3637 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3640 #ifdef FIXNEGATIVEZERO
3641 if (*s == '-' && s[1] == '0' && !s[2])
3651 if (ckWARN(WARN_UNINITIALIZED)
3652 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3655 if (SvTYPE(sv) < SVt_PV)
3656 /* Typically the caller expects that sv_any is not NULL now. */
3657 sv_upgrade(sv, SVt_PV);
3660 *lp = s - SvPVX(sv);
3663 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3664 PTR2UV(sv),SvPVX(sv)));
3668 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3669 /* Sneaky stuff here */
3673 tsv = newSVpv(tmpbuf, 0);
3690 len = strlen(tmpbuf);
3692 #ifdef FIXNEGATIVEZERO
3693 if (len == 2 && t[0] == '-' && t[1] == '0') {
3698 (void)SvUPGRADE(sv, SVt_PV);
3700 s = SvGROW(sv, len + 1);
3703 return strcpy(s, t);
3708 =for apidoc sv_copypv
3710 Copies a stringified representation of the source SV into the
3711 destination SV. Automatically performs any necessary mg_get and
3712 coercion of numeric values into strings. Guaranteed to preserve
3713 UTF-8 flag even from overloaded objects. Similar in nature to
3714 sv_2pv[_flags] but operates directly on an SV instead of just the
3715 string. Mostly uses sv_2pv_flags to do its work, except when that
3716 would lose the UTF-8'ness of the PV.
3722 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3727 sv_setpvn(dsv,s,len);
3735 =for apidoc sv_2pvbyte_nolen
3737 Return a pointer to the byte-encoded representation of the SV.
3738 May cause the SV to be downgraded from UTF-8 as a side-effect.
3740 Usually accessed via the C<SvPVbyte_nolen> macro.
3746 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3749 return sv_2pvbyte(sv, &n_a);
3753 =for apidoc sv_2pvbyte
3755 Return a pointer to the byte-encoded representation of the SV, and set *lp
3756 to its length. May cause the SV to be downgraded from UTF-8 as a
3759 Usually accessed via the C<SvPVbyte> macro.
3765 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3767 sv_utf8_downgrade(sv,0);
3768 return SvPV(sv,*lp);
3772 =for apidoc sv_2pvutf8_nolen
3774 Return a pointer to the UTF-8-encoded representation of the SV.
3775 May cause the SV to be upgraded to UTF-8 as a side-effect.
3777 Usually accessed via the C<SvPVutf8_nolen> macro.
3783 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3786 return sv_2pvutf8(sv, &n_a);
3790 =for apidoc sv_2pvutf8
3792 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3793 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3795 Usually accessed via the C<SvPVutf8> macro.
3801 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3803 sv_utf8_upgrade(sv);
3804 return SvPV(sv,*lp);
3808 =for apidoc sv_2bool
3810 This function is only called on magical items, and is only used by
3811 sv_true() or its macro equivalent.
3817 Perl_sv_2bool(pTHX_ register SV *sv)
3826 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3827 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3828 return (bool)SvTRUE(tmpsv);
3829 return SvRV(sv) != 0;
3832 register XPV* Xpvtmp;
3833 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3834 (*Xpvtmp->xpv_pv > '0' ||
3835 Xpvtmp->xpv_cur > 1 ||
3836 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3843 return SvIVX(sv) != 0;
3846 return SvNVX(sv) != 0.0;
3853 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3854 * this function provided for binary compatibility only
3859 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3861 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3865 =for apidoc sv_utf8_upgrade
3867 Converts the PV of an SV to its UTF-8-encoded form.
3868 Forces the SV to string form if it is not already.
3869 Always sets the SvUTF8 flag to avoid future validity checks even
3870 if all the bytes have hibit clear.
3872 This is not as a general purpose byte encoding to Unicode interface:
3873 use the Encode extension for that.
3875 =for apidoc sv_utf8_upgrade_flags
3877 Converts the PV of an SV to its UTF-8-encoded form.
3878 Forces the SV to string form if it is not already.
3879 Always sets the SvUTF8 flag to avoid future validity checks even
3880 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3881 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3882 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3884 This is not as a general purpose byte encoding to Unicode interface:
3885 use the Encode extension for that.
3891 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3893 if (sv == &PL_sv_undef)
3897 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3898 (void) sv_2pv_flags(sv,&len, flags);
3902 (void) SvPV_force(sv,len);
3911 sv_force_normal_flags(sv, 0);
3914 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3915 sv_recode_to_utf8(sv, PL_encoding);
3916 else { /* Assume Latin-1/EBCDIC */
3917 /* This function could be much more efficient if we
3918 * had a FLAG in SVs to signal if there are any hibit
3919 * chars in the PV. Given that there isn't such a flag
3920 * make the loop as fast as possible. */
3921 U8 *s = (U8 *) SvPVX(sv);
3922 U8 *e = (U8 *) SvEND(sv);
3928 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3932 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3933 s = bytes_to_utf8((U8*)s, &len);
3935 SvPV_free(sv); /* No longer using what was there before. */
3937 SvPV_set(sv, (char*)s);
3938 SvCUR_set(sv, len - 1);
3939 SvLEN_set(sv, len); /* No longer know the real size. */
3941 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3948 =for apidoc sv_utf8_downgrade
3950 Attempts to convert the PV of an SV from characters to bytes.
3951 If the PV contains a character beyond byte, this conversion will fail;
3952 in this case, either returns false or, if C<fail_ok> is not
3955 This is not as a general purpose Unicode to byte encoding interface:
3956 use the Encode extension for that.
3962 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3964 if (SvPOKp(sv) && SvUTF8(sv)) {
3970 sv_force_normal_flags(sv, 0);
3972 s = (U8 *) SvPV(sv, len);
3973 if (!utf8_to_bytes(s, &len)) {
3978 Perl_croak(aTHX_ "Wide character in %s",
3981 Perl_croak(aTHX_ "Wide character");
3992 =for apidoc sv_utf8_encode
3994 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3995 flag off so that it looks like octets again.
4001 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4003 (void) sv_utf8_upgrade(sv);
4005 sv_force_normal_flags(sv, 0);
4007 if (SvREADONLY(sv)) {
4008 Perl_croak(aTHX_ PL_no_modify);
4014 =for apidoc sv_utf8_decode
4016 If the PV of the SV is an octet sequence in UTF-8
4017 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4018 so that it looks like a character. If the PV contains only single-byte
4019 characters, the C<SvUTF8> flag stays being off.
4020 Scans PV for validity and returns false if the PV is invalid UTF-8.
4026 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4032 /* The octets may have got themselves encoded - get them back as
4035 if (!sv_utf8_downgrade(sv, TRUE))
4038 /* it is actually just a matter of turning the utf8 flag on, but
4039 * we want to make sure everything inside is valid utf8 first.
4041 c = (U8 *) SvPVX(sv);
4042 if (!is_utf8_string(c, SvCUR(sv)+1))
4044 e = (U8 *) SvEND(sv);
4047 if (!UTF8_IS_INVARIANT(ch)) {
4056 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4057 * this function provided for binary compatibility only
4061 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4063 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4067 =for apidoc sv_setsv
4069 Copies the contents of the source SV C<ssv> into the destination SV
4070 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4071 function if the source SV needs to be reused. Does not handle 'set' magic.
4072 Loosely speaking, it performs a copy-by-value, obliterating any previous
4073 content of the destination.
4075 You probably want to use one of the assortment of wrappers, such as
4076 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4077 C<SvSetMagicSV_nosteal>.
4079 =for apidoc sv_setsv_flags
4081 Copies the contents of the source SV C<ssv> into the destination SV
4082 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4083 function if the source SV needs to be reused. Does not handle 'set' magic.
4084 Loosely speaking, it performs a copy-by-value, obliterating any previous
4085 content of the destination.
4086 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4087 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4088 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4089 and C<sv_setsv_nomg> are implemented in terms of this function.
4091 You probably want to use one of the assortment of wrappers, such as
4092 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4093 C<SvSetMagicSV_nosteal>.
4095 This is the primary function for copying scalars, and most other
4096 copy-ish functions and macros use this underneath.
4102 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4104 register U32 sflags;
4110 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4112 sstr = &PL_sv_undef;
4113 stype = SvTYPE(sstr);
4114 dtype = SvTYPE(dstr);
4119 /* need to nuke the magic */
4121 SvRMAGICAL_off(dstr);
4124 /* There's a lot of redundancy below but we're going for speed here */
4129 if (dtype != SVt_PVGV) {
4130 (void)SvOK_off(dstr);
4138 sv_upgrade(dstr, SVt_IV);
4141 sv_upgrade(dstr, SVt_PVNV);
4145 sv_upgrade(dstr, SVt_PVIV);
4148 (void)SvIOK_only(dstr);
4149 SvIV_set(dstr, SvIVX(sstr));
4152 if (SvTAINTED(sstr))
4163 sv_upgrade(dstr, SVt_NV);
4168 sv_upgrade(dstr, SVt_PVNV);
4171 SvNV_set(dstr, SvNVX(sstr));
4172 (void)SvNOK_only(dstr);
4173 if (SvTAINTED(sstr))
4181 sv_upgrade(dstr, SVt_RV);
4182 else if (dtype == SVt_PVGV &&
4183 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4186 if (GvIMPORTED(dstr) != GVf_IMPORTED
4187 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4189 GvIMPORTED_on(dstr);
4198 #ifdef PERL_COPY_ON_WRITE
4199 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4200 if (dtype < SVt_PVIV)
4201 sv_upgrade(dstr, SVt_PVIV);
4208 sv_upgrade(dstr, SVt_PV);
4211 if (dtype < SVt_PVIV)
4212 sv_upgrade(dstr, SVt_PVIV);
4215 if (dtype < SVt_PVNV)
4216 sv_upgrade(dstr, SVt_PVNV);
4223 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4226 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4230 if (dtype <= SVt_PVGV) {
4232 if (dtype != SVt_PVGV) {
4233 char *name = GvNAME(sstr);
4234 STRLEN len = GvNAMELEN(sstr);
4235 /* don't upgrade SVt_PVLV: it can hold a glob */
4236 if (dtype != SVt_PVLV)
4237 sv_upgrade(dstr, SVt_PVGV);
4238 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4239 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4240 GvNAME(dstr) = savepvn(name, len);
4241 GvNAMELEN(dstr) = len;
4242 SvFAKE_on(dstr); /* can coerce to non-glob */
4244 /* ahem, death to those who redefine active sort subs */
4245 else if (PL_curstackinfo->si_type == PERLSI_SORT
4246 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4247 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4250 #ifdef GV_UNIQUE_CHECK
4251 if (GvUNIQUE((GV*)dstr)) {
4252 Perl_croak(aTHX_ PL_no_modify);
4256 (void)SvOK_off(dstr);
4257 GvINTRO_off(dstr); /* one-shot flag */
4259 GvGP(dstr) = gp_ref(GvGP(sstr));
4260 if (SvTAINTED(sstr))
4262 if (GvIMPORTED(dstr) != GVf_IMPORTED
4263 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4265 GvIMPORTED_on(dstr);
4273 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4275 if ((int)SvTYPE(sstr) != stype) {
4276 stype = SvTYPE(sstr);
4277 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4281 if (stype == SVt_PVLV)
4282 (void)SvUPGRADE(dstr, SVt_PVNV);
4284 (void)SvUPGRADE(dstr, (U32)stype);
4287 sflags = SvFLAGS(sstr);
4289 if (sflags & SVf_ROK) {
4290 if (dtype >= SVt_PV) {
4291 if (dtype == SVt_PVGV) {
4292 SV *sref = SvREFCNT_inc(SvRV(sstr));
4294 int intro = GvINTRO(dstr);
4296 #ifdef GV_UNIQUE_CHECK
4297 if (GvUNIQUE((GV*)dstr)) {
4298 Perl_croak(aTHX_ PL_no_modify);
4303 GvINTRO_off(dstr); /* one-shot flag */
4304 GvLINE(dstr) = CopLINE(PL_curcop);
4305 GvEGV(dstr) = (GV*)dstr;
4308 switch (SvTYPE(sref)) {
4311 SAVEGENERICSV(GvAV(dstr));
4313 dref = (SV*)GvAV(dstr);
4314 GvAV(dstr) = (AV*)sref;
4315 if (!GvIMPORTED_AV(dstr)
4316 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4318 GvIMPORTED_AV_on(dstr);
4323 SAVEGENERICSV(GvHV(dstr));
4325 dref = (SV*)GvHV(dstr);
4326 GvHV(dstr) = (HV*)sref;
4327 if (!GvIMPORTED_HV(dstr)
4328 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4330 GvIMPORTED_HV_on(dstr);
4335 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4336 SvREFCNT_dec(GvCV(dstr));
4337 GvCV(dstr) = Nullcv;
4338 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4339 PL_sub_generation++;
4341 SAVEGENERICSV(GvCV(dstr));
4344 dref = (SV*)GvCV(dstr);
4345 if (GvCV(dstr) != (CV*)sref) {
4346 CV* cv = GvCV(dstr);
4348 if (!GvCVGEN((GV*)dstr) &&
4349 (CvROOT(cv) || CvXSUB(cv)))
4351 /* ahem, death to those who redefine
4352 * active sort subs */
4353 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4354 PL_sortcop == CvSTART(cv))
4356 "Can't redefine active sort subroutine %s",
4357 GvENAME((GV*)dstr));
4358 /* Redefining a sub - warning is mandatory if
4359 it was a const and its value changed. */
4360 if (ckWARN(WARN_REDEFINE)
4362 && (!CvCONST((CV*)sref)
4363 || sv_cmp(cv_const_sv(cv),
4364 cv_const_sv((CV*)sref)))))
4366 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4368 ? "Constant subroutine %s::%s redefined"
4369 : "Subroutine %s::%s redefined",
4370 HvNAME(GvSTASH((GV*)dstr)),
4371 GvENAME((GV*)dstr));
4375 cv_ckproto(cv, (GV*)dstr,
4376 SvPOK(sref) ? SvPVX(sref) : Nullch);
4378 GvCV(dstr) = (CV*)sref;
4379 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4380 GvASSUMECV_on(dstr);
4381 PL_sub_generation++;
4383 if (!GvIMPORTED_CV(dstr)
4384 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4386 GvIMPORTED_CV_on(dstr);
4391 SAVEGENERICSV(GvIOp(dstr));
4393 dref = (SV*)GvIOp(dstr);
4394 GvIOp(dstr) = (IO*)sref;
4398 SAVEGENERICSV(GvFORM(dstr));
4400 dref = (SV*)GvFORM(dstr);
4401 GvFORM(dstr) = (CV*)sref;
4405 SAVEGENERICSV(GvSV(dstr));
4407 dref = (SV*)GvSV(dstr);
4409 if (!GvIMPORTED_SV(dstr)
4410 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4412 GvIMPORTED_SV_on(dstr);
4418 if (SvTAINTED(sstr))
4428 (void)SvOK_off(dstr);
4429 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4431 if (sflags & SVp_NOK) {
4433 /* Only set the public OK flag if the source has public OK. */
4434 if (sflags & SVf_NOK)
4435 SvFLAGS(dstr) |= SVf_NOK;
4436 SvNV_set(dstr, SvNVX(sstr));
4438 if (sflags & SVp_IOK) {
4439 (void)SvIOKp_on(dstr);
4440 if (sflags & SVf_IOK)
4441 SvFLAGS(dstr) |= SVf_IOK;
4442 if (sflags & SVf_IVisUV)
4444 SvIV_set(dstr, SvIVX(sstr));
4446 if (SvAMAGIC(sstr)) {
4450 else if (sflags & SVp_POK) {
4454 * Check to see if we can just swipe the string. If so, it's a
4455 * possible small lose on short strings, but a big win on long ones.
4456 * It might even be a win on short strings if SvPVX(dstr)
4457 * has to be allocated and SvPVX(sstr) has to be freed.
4460 /* Whichever path we take through the next code, we want this true,
4461 and doing it now facilitates the COW check. */
4462 (void)SvPOK_only(dstr);
4465 #ifdef PERL_COPY_ON_WRITE
4466 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4470 (sflags & SVs_TEMP) && /* slated for free anyway? */
4471 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4472 (!(flags & SV_NOSTEAL)) &&
4473 /* and we're allowed to steal temps */
4474 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4475 SvLEN(sstr) && /* and really is a string */
4476 /* and won't be needed again, potentially */
4477 !(PL_op && PL_op->op_type == OP_AASSIGN))
4478 #ifdef PERL_COPY_ON_WRITE
4479 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4480 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4481 && SvTYPE(sstr) >= SVt_PVIV)
4484 /* Failed the swipe test, and it's not a shared hash key either.
4485 Have to copy the string. */
4486 STRLEN len = SvCUR(sstr);
4487 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4488 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4489 SvCUR_set(dstr, len);
4490 *SvEND(dstr) = '\0';
4492 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4494 #ifdef PERL_COPY_ON_WRITE
4495 /* Either it's a shared hash key, or it's suitable for
4496 copy-on-write or we can swipe the string. */
4498 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4503 /* I believe I should acquire a global SV mutex if
4504 it's a COW sv (not a shared hash key) to stop
4505 it going un copy-on-write.
4506 If the source SV has gone un copy on write between up there
4507 and down here, then (assert() that) it is of the correct
4508 form to make it copy on write again */
4509 if ((sflags & (SVf_FAKE | SVf_READONLY))
4510 != (SVf_FAKE | SVf_READONLY)) {
4511 SvREADONLY_on(sstr);
4513 /* Make the source SV into a loop of 1.
4514 (about to become 2) */
4515 SV_COW_NEXT_SV_SET(sstr, sstr);
4519 /* Initial code is common. */
4520 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4522 SvFLAGS(dstr) &= ~SVf_OOK;
4523 Safefree(SvPVX(dstr) - SvIVX(dstr));
4525 else if (SvLEN(dstr))
4526 Safefree(SvPVX(dstr));
4529 #ifdef PERL_COPY_ON_WRITE
4531 /* making another shared SV. */
4532 STRLEN cur = SvCUR(sstr);
4533 STRLEN len = SvLEN(sstr);
4534 assert (SvTYPE(dstr) >= SVt_PVIV);
4536 /* SvIsCOW_normal */
4537 /* splice us in between source and next-after-source. */
4538 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4539 SV_COW_NEXT_SV_SET(sstr, dstr);
4540 SvPV_set(dstr, SvPVX(sstr));
4542 /* SvIsCOW_shared_hash */
4543 UV hash = SvUVX(sstr);
4544 DEBUG_C(PerlIO_printf(Perl_debug_log,
4545 "Copy on write: Sharing hash\n"));
4547 sharepvn(SvPVX(sstr),
4548 (sflags & SVf_UTF8?-cur:cur), hash));
4549 SvUV_set(dstr, hash);
4551 SvLEN_set(dstr, len);
4552 SvCUR_set(dstr, cur);
4553 SvREADONLY_on(dstr);
4555 /* Relesase a global SV mutex. */
4559 { /* Passes the swipe test. */
4560 SvPV_set(dstr, SvPVX(sstr));
4561 SvLEN_set(dstr, SvLEN(sstr));
4562 SvCUR_set(dstr, SvCUR(sstr));
4565 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4566 SvPV_set(sstr, Nullch);
4572 if (sflags & SVf_UTF8)
4575 if (sflags & SVp_NOK) {
4577 if (sflags & SVf_NOK)
4578 SvFLAGS(dstr) |= SVf_NOK;
4579 SvNV_set(dstr, SvNVX(sstr));
4581 if (sflags & SVp_IOK) {
4582 (void)SvIOKp_on(dstr);
4583 if (sflags & SVf_IOK)
4584 SvFLAGS(dstr) |= SVf_IOK;
4585 if (sflags & SVf_IVisUV)
4587 SvIV_set(dstr, SvIVX(sstr));
4590 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4591 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4592 smg->mg_ptr, smg->mg_len);
4593 SvRMAGICAL_on(dstr);
4596 else if (sflags & SVp_IOK) {
4597 if (sflags & SVf_IOK)
4598 (void)SvIOK_only(dstr);
4600 (void)SvOK_off(dstr);
4601 (void)SvIOKp_on(dstr);
4603 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4604 if (sflags & SVf_IVisUV)
4606 SvIV_set(dstr, SvIVX(sstr));
4607 if (sflags & SVp_NOK) {
4608 if (sflags & SVf_NOK)
4609 (void)SvNOK_on(dstr);
4611 (void)SvNOKp_on(dstr);
4612 SvNV_set(dstr, SvNVX(sstr));
4615 else if (sflags & SVp_NOK) {
4616 if (sflags & SVf_NOK)
4617 (void)SvNOK_only(dstr);
4619 (void)SvOK_off(dstr);
4622 SvNV_set(dstr, SvNVX(sstr));
4625 if (dtype == SVt_PVGV) {
4626 if (ckWARN(WARN_MISC))
4627 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4630 (void)SvOK_off(dstr);
4632 if (SvTAINTED(sstr))
4637 =for apidoc sv_setsv_mg
4639 Like C<sv_setsv>, but also handles 'set' magic.
4645 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4647 sv_setsv(dstr,sstr);
4651 #ifdef PERL_COPY_ON_WRITE
4653 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4655 STRLEN cur = SvCUR(sstr);
4656 STRLEN len = SvLEN(sstr);
4657 register char *new_pv;
4660 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4668 if (SvTHINKFIRST(dstr))
4669 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4670 else if (SvPVX(dstr))
4671 Safefree(SvPVX(dstr));
4675 (void)SvUPGRADE (dstr, SVt_PVIV);
4677 assert (SvPOK(sstr));
4678 assert (SvPOKp(sstr));
4679 assert (!SvIOK(sstr));
4680 assert (!SvIOKp(sstr));
4681 assert (!SvNOK(sstr));
4682 assert (!SvNOKp(sstr));
4684 if (SvIsCOW(sstr)) {
4686 if (SvLEN(sstr) == 0) {
4687 /* source is a COW shared hash key. */
4688 UV hash = SvUVX(sstr);
4689 DEBUG_C(PerlIO_printf(Perl_debug_log,
4690 "Fast copy on write: Sharing hash\n"));
4691 SvUV_set(dstr, hash);
4692 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4695 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4697 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4698 (void)SvUPGRADE (sstr, SVt_PVIV);
4699 SvREADONLY_on(sstr);
4701 DEBUG_C(PerlIO_printf(Perl_debug_log,
4702 "Fast copy on write: Converting sstr to COW\n"));
4703 SV_COW_NEXT_SV_SET(dstr, sstr);
4705 SV_COW_NEXT_SV_SET(sstr, dstr);
4706 new_pv = SvPVX(sstr);
4709 SvPV_set(dstr, new_pv);
4710 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4713 SvLEN_set(dstr, len);
4714 SvCUR_set(dstr, cur);
4723 =for apidoc sv_setpvn
4725 Copies a string into an SV. The C<len> parameter indicates the number of
4726 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4727 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4733 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4735 register char *dptr;
4737 SV_CHECK_THINKFIRST_COW_DROP(sv);
4743 /* len is STRLEN which is unsigned, need to copy to signed */
4746 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4748 (void)SvUPGRADE(sv, SVt_PV);
4750 SvGROW(sv, len + 1);
4752 Move(ptr,dptr,len,char);
4755 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4760 =for apidoc sv_setpvn_mg
4762 Like C<sv_setpvn>, but also handles 'set' magic.
4768 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4770 sv_setpvn(sv,ptr,len);
4775 =for apidoc sv_setpv
4777 Copies a string into an SV. The string must be null-terminated. Does not
4778 handle 'set' magic. See C<sv_setpv_mg>.
4784 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4786 register STRLEN len;
4788 SV_CHECK_THINKFIRST_COW_DROP(sv);
4794 (void)SvUPGRADE(sv, SVt_PV);
4796 SvGROW(sv, len + 1);
4797 Move(ptr,SvPVX(sv),len+1,char);
4799 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4804 =for apidoc sv_setpv_mg
4806 Like C<sv_setpv>, but also handles 'set' magic.
4812 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4819 =for apidoc sv_usepvn
4821 Tells an SV to use C<ptr> to find its string value. Normally the string is
4822 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4823 The C<ptr> should point to memory that was allocated by C<malloc>. The
4824 string length, C<len>, must be supplied. This function will realloc the
4825 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4826 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4827 See C<sv_usepvn_mg>.
4833 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4835 SV_CHECK_THINKFIRST_COW_DROP(sv);
4836 (void)SvUPGRADE(sv, SVt_PV);
4843 Renew(ptr, len+1, char);
4846 SvLEN_set(sv, len+1);
4848 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4853 =for apidoc sv_usepvn_mg
4855 Like C<sv_usepvn>, but also handles 'set' magic.
4861 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4863 sv_usepvn(sv,ptr,len);
4867 #ifdef PERL_COPY_ON_WRITE
4868 /* Need to do this *after* making the SV normal, as we need the buffer
4869 pointer to remain valid until after we've copied it. If we let go too early,
4870 another thread could invalidate it by unsharing last of the same hash key
4871 (which it can do by means other than releasing copy-on-write Svs)
4872 or by changing the other copy-on-write SVs in the loop. */
4874 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4875 U32 hash, SV *after)
4877 if (len) { /* this SV was SvIsCOW_normal(sv) */
4878 /* we need to find the SV pointing to us. */
4879 SV *current = SV_COW_NEXT_SV(after);
4881 if (current == sv) {
4882 /* The SV we point to points back to us (there were only two of us
4884 Hence other SV is no longer copy on write either. */
4886 SvREADONLY_off(after);
4888 /* We need to follow the pointers around the loop. */
4890 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4893 /* don't loop forever if the structure is bust, and we have
4894 a pointer into a closed loop. */
4895 assert (current != after);
4896 assert (SvPVX(current) == pvx);
4898 /* Make the SV before us point to the SV after us. */
4899 SV_COW_NEXT_SV_SET(current, after);
4902 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4907 Perl_sv_release_IVX(pTHX_ register SV *sv)
4910 sv_force_normal_flags(sv, 0);
4916 =for apidoc sv_force_normal_flags
4918 Undo various types of fakery on an SV: if the PV is a shared string, make
4919 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4920 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4921 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4922 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4923 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4924 set to some other value.) In addition, the C<flags> parameter gets passed to
4925 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4926 with flags set to 0.
4932 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4934 #ifdef PERL_COPY_ON_WRITE
4935 if (SvREADONLY(sv)) {
4936 /* At this point I believe I should acquire a global SV mutex. */
4938 char *pvx = SvPVX(sv);
4939 STRLEN len = SvLEN(sv);
4940 STRLEN cur = SvCUR(sv);
4941 U32 hash = SvUVX(sv);
4942 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4944 PerlIO_printf(Perl_debug_log,
4945 "Copy on write: Force normal %ld\n",
4951 /* This SV doesn't own the buffer, so need to New() a new one: */
4952 SvPV_set(sv, (char*)0);
4954 if (flags & SV_COW_DROP_PV) {
4955 /* OK, so we don't need to copy our buffer. */
4958 SvGROW(sv, cur + 1);
4959 Move(pvx,SvPVX(sv),cur,char);
4963 sv_release_COW(sv, pvx, cur, len, hash, next);
4968 else if (IN_PERL_RUNTIME)
4969 Perl_croak(aTHX_ PL_no_modify);
4970 /* At this point I believe that I can drop the global SV mutex. */
4973 if (SvREADONLY(sv)) {
4975 char *pvx = SvPVX(sv);
4976 int is_utf8 = SvUTF8(sv);
4977 STRLEN len = SvCUR(sv);
4978 U32 hash = SvUVX(sv);
4981 SvPV_set(sv, (char*)0);
4983 SvGROW(sv, len + 1);
4984 Move(pvx,SvPVX(sv),len,char);
4986 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
4988 else if (IN_PERL_RUNTIME)
4989 Perl_croak(aTHX_ PL_no_modify);
4993 sv_unref_flags(sv, flags);
4994 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4999 =for apidoc sv_force_normal
5001 Undo various types of fakery on an SV: if the PV is a shared string, make
5002 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5003 an xpvmg. See also C<sv_force_normal_flags>.
5009 Perl_sv_force_normal(pTHX_ register SV *sv)
5011 sv_force_normal_flags(sv, 0);
5017 Efficient removal of characters from the beginning of the string buffer.
5018 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5019 the string buffer. The C<ptr> becomes the first character of the adjusted
5020 string. Uses the "OOK hack".
5021 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5022 refer to the same chunk of data.
5028 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
5030 register STRLEN delta;
5031 if (!ptr || !SvPOKp(sv))
5033 delta = ptr - SvPVX(sv);
5034 SV_CHECK_THINKFIRST(sv);
5035 if (SvTYPE(sv) < SVt_PVIV)
5036 sv_upgrade(sv,SVt_PVIV);
5039 if (!SvLEN(sv)) { /* make copy of shared string */
5040 char *pvx = SvPVX(sv);
5041 STRLEN len = SvCUR(sv);
5042 SvGROW(sv, len + 1);
5043 Move(pvx,SvPVX(sv),len,char);
5047 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5048 and we do that anyway inside the SvNIOK_off
5050 SvFLAGS(sv) |= SVf_OOK;
5053 SvLEN_set(sv, SvLEN(sv) - delta);
5054 SvCUR_set(sv, SvCUR(sv) - delta);
5055 SvPV_set(sv, SvPVX(sv) + delta);
5056 SvIV_set(sv, SvIVX(sv) + delta);
5059 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5060 * this function provided for binary compatibility only
5064 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5066 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5070 =for apidoc sv_catpvn
5072 Concatenates the string onto the end of the string which is in the SV. The
5073 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5074 status set, then the bytes appended should be valid UTF-8.
5075 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5077 =for apidoc sv_catpvn_flags
5079 Concatenates the string onto the end of the string which is in the SV. The
5080 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5081 status set, then the bytes appended should be valid UTF-8.
5082 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5083 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5084 in terms of this function.
5090 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5095 dstr = SvPV_force_flags(dsv, dlen, flags);
5096 SvGROW(dsv, dlen + slen + 1);
5099 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5100 SvCUR_set(dsv, SvCUR(dsv) + slen);
5102 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5107 =for apidoc sv_catpvn_mg
5109 Like C<sv_catpvn>, but also handles 'set' magic.
5115 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5117 sv_catpvn(sv,ptr,len);
5121 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5122 * this function provided for binary compatibility only
5126 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5128 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5132 =for apidoc sv_catsv
5134 Concatenates the string from SV C<ssv> onto the end of the string in
5135 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5136 not 'set' magic. See C<sv_catsv_mg>.
5138 =for apidoc sv_catsv_flags
5140 Concatenates the string from SV C<ssv> onto the end of the string in
5141 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5142 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5143 and C<sv_catsv_nomg> are implemented in terms of this function.
5148 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5154 if ((spv = SvPV(ssv, slen))) {
5155 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5156 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5157 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5158 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5159 dsv->sv_flags doesn't have that bit set.
5160 Andy Dougherty 12 Oct 2001
5162 I32 sutf8 = DO_UTF8(ssv);
5165 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5167 dutf8 = DO_UTF8(dsv);
5169 if (dutf8 != sutf8) {
5171 /* Not modifying source SV, so taking a temporary copy. */
5172 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5174 sv_utf8_upgrade(csv);
5175 spv = SvPV(csv, slen);
5178 sv_utf8_upgrade_nomg(dsv);
5180 sv_catpvn_nomg(dsv, spv, slen);
5185 =for apidoc sv_catsv_mg
5187 Like C<sv_catsv>, but also handles 'set' magic.
5193 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5200 =for apidoc sv_catpv
5202 Concatenates the string onto the end of the string which is in the SV.
5203 If the SV has the UTF-8 status set, then the bytes appended should be
5204 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5209 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5211 register STRLEN len;
5217 junk = SvPV_force(sv, tlen);
5219 SvGROW(sv, tlen + len + 1);
5222 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5223 SvCUR_set(sv, SvCUR(sv) + len);
5224 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5229 =for apidoc sv_catpv_mg
5231 Like C<sv_catpv>, but also handles 'set' magic.
5237 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5246 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5247 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5254 Perl_newSV(pTHX_ STRLEN len)
5260 sv_upgrade(sv, SVt_PV);
5261 SvGROW(sv, len + 1);
5266 =for apidoc sv_magicext
5268 Adds magic to an SV, upgrading it if necessary. Applies the
5269 supplied vtable and returns a pointer to the magic added.
5271 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5272 In particular, you can add magic to SvREADONLY SVs, and add more than
5273 one instance of the same 'how'.
5275 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5276 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5277 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5278 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5280 (This is now used as a subroutine by C<sv_magic>.)
5285 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5286 const char* name, I32 namlen)
5290 if (SvTYPE(sv) < SVt_PVMG) {
5291 (void)SvUPGRADE(sv, SVt_PVMG);
5293 Newz(702,mg, 1, MAGIC);
5294 mg->mg_moremagic = SvMAGIC(sv);
5295 SvMAGIC_set(sv, mg);
5297 /* Sometimes a magic contains a reference loop, where the sv and
5298 object refer to each other. To prevent a reference loop that
5299 would prevent such objects being freed, we look for such loops
5300 and if we find one we avoid incrementing the object refcount.
5302 Note we cannot do this to avoid self-tie loops as intervening RV must
5303 have its REFCNT incremented to keep it in existence.
5306 if (!obj || obj == sv ||
5307 how == PERL_MAGIC_arylen ||
5308 how == PERL_MAGIC_qr ||
5309 (SvTYPE(obj) == SVt_PVGV &&
5310 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5311 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5312 GvFORM(obj) == (CV*)sv)))
5317 mg->mg_obj = SvREFCNT_inc(obj);
5318 mg->mg_flags |= MGf_REFCOUNTED;
5321 /* Normal self-ties simply pass a null object, and instead of
5322 using mg_obj directly, use the SvTIED_obj macro to produce a
5323 new RV as needed. For glob "self-ties", we are tieing the PVIO
5324 with an RV obj pointing to the glob containing the PVIO. In
5325 this case, to avoid a reference loop, we need to weaken the
5329 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5330 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5336 mg->mg_len = namlen;
5339 mg->mg_ptr = savepvn(name, namlen);
5340 else if (namlen == HEf_SVKEY)
5341 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5343 mg->mg_ptr = (char *) name;
5345 mg->mg_virtual = vtable;
5349 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5354 =for apidoc sv_magic
5356 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5357 then adds a new magic item of type C<how> to the head of the magic list.
5359 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5360 handling of the C<name> and C<namlen> arguments.
5362 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5363 to add more than one instance of the same 'how'.
5369 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5371 const MGVTBL *vtable = 0;
5374 #ifdef PERL_COPY_ON_WRITE
5376 sv_force_normal_flags(sv, 0);
5378 if (SvREADONLY(sv)) {
5380 && how != PERL_MAGIC_regex_global
5381 && how != PERL_MAGIC_bm
5382 && how != PERL_MAGIC_fm
5383 && how != PERL_MAGIC_sv
5384 && how != PERL_MAGIC_backref
5387 Perl_croak(aTHX_ PL_no_modify);
5390 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5391 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5392 /* sv_magic() refuses to add a magic of the same 'how' as an
5395 if (how == PERL_MAGIC_taint)
5403 vtable = &PL_vtbl_sv;
5405 case PERL_MAGIC_overload:
5406 vtable = &PL_vtbl_amagic;
5408 case PERL_MAGIC_overload_elem:
5409 vtable = &PL_vtbl_amagicelem;
5411 case PERL_MAGIC_overload_table:
5412 vtable = &PL_vtbl_ovrld;
5415 vtable = &PL_vtbl_bm;
5417 case PERL_MAGIC_regdata:
5418 vtable = &PL_vtbl_regdata;
5420 case PERL_MAGIC_regdatum:
5421 vtable = &PL_vtbl_regdatum;
5423 case PERL_MAGIC_env:
5424 vtable = &PL_vtbl_env;
5427 vtable = &PL_vtbl_fm;
5429 case PERL_MAGIC_envelem:
5430 vtable = &PL_vtbl_envelem;
5432 case PERL_MAGIC_regex_global:
5433 vtable = &PL_vtbl_mglob;
5435 case PERL_MAGIC_isa:
5436 vtable = &PL_vtbl_isa;
5438 case PERL_MAGIC_isaelem:
5439 vtable = &PL_vtbl_isaelem;
5441 case PERL_MAGIC_nkeys:
5442 vtable = &PL_vtbl_nkeys;
5444 case PERL_MAGIC_dbfile:
5447 case PERL_MAGIC_dbline:
5448 vtable = &PL_vtbl_dbline;
5450 #ifdef USE_LOCALE_COLLATE
5451 case PERL_MAGIC_collxfrm:
5452 vtable = &PL_vtbl_collxfrm;
5454 #endif /* USE_LOCALE_COLLATE */
5455 case PERL_MAGIC_tied:
5456 vtable = &PL_vtbl_pack;
5458 case PERL_MAGIC_tiedelem:
5459 case PERL_MAGIC_tiedscalar:
5460 vtable = &PL_vtbl_packelem;
5463 vtable = &PL_vtbl_regexp;
5465 case PERL_MAGIC_sig:
5466 vtable = &PL_vtbl_sig;
5468 case PERL_MAGIC_sigelem:
5469 vtable = &PL_vtbl_sigelem;
5471 case PERL_MAGIC_taint:
5472 vtable = &PL_vtbl_taint;
5474 case PERL_MAGIC_uvar:
5475 vtable = &PL_vtbl_uvar;
5477 case PERL_MAGIC_vec:
5478 vtable = &PL_vtbl_vec;
5480 case PERL_MAGIC_vstring:
5483 case PERL_MAGIC_utf8:
5484 vtable = &PL_vtbl_utf8;
5486 case PERL_MAGIC_substr:
5487 vtable = &PL_vtbl_substr;
5489 case PERL_MAGIC_defelem:
5490 vtable = &PL_vtbl_defelem;
5492 case PERL_MAGIC_glob:
5493 vtable = &PL_vtbl_glob;
5495 case PERL_MAGIC_arylen:
5496 vtable = &PL_vtbl_arylen;
5498 case PERL_MAGIC_pos:
5499 vtable = &PL_vtbl_pos;
5501 case PERL_MAGIC_backref:
5502 vtable = &PL_vtbl_backref;
5504 case PERL_MAGIC_ext:
5505 /* Reserved for use by extensions not perl internals. */
5506 /* Useful for attaching extension internal data to perl vars. */
5507 /* Note that multiple extensions may clash if magical scalars */
5508 /* etc holding private data from one are passed to another. */
5511 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5514 /* Rest of work is done else where */
5515 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5518 case PERL_MAGIC_taint:
5521 case PERL_MAGIC_ext:
5522 case PERL_MAGIC_dbfile:
5529 =for apidoc sv_unmagic
5531 Removes all magic of type C<type> from an SV.
5537 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5541 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5544 for (mg = *mgp; mg; mg = *mgp) {
5545 if (mg->mg_type == type) {
5546 const MGVTBL* const vtbl = mg->mg_virtual;
5547 *mgp = mg->mg_moremagic;
5548 if (vtbl && vtbl->svt_free)
5549 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5550 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5552 Safefree(mg->mg_ptr);
5553 else if (mg->mg_len == HEf_SVKEY)
5554 SvREFCNT_dec((SV*)mg->mg_ptr);
5555 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5556 Safefree(mg->mg_ptr);
5558 if (mg->mg_flags & MGf_REFCOUNTED)
5559 SvREFCNT_dec(mg->mg_obj);
5563 mgp = &mg->mg_moremagic;
5567 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5574 =for apidoc sv_rvweaken
5576 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5577 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5578 push a back-reference to this RV onto the array of backreferences
5579 associated with that magic.
5585 Perl_sv_rvweaken(pTHX_ SV *sv)
5588 if (!SvOK(sv)) /* let undefs pass */
5591 Perl_croak(aTHX_ "Can't weaken a nonreference");
5592 else if (SvWEAKREF(sv)) {
5593 if (ckWARN(WARN_MISC))
5594 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5598 sv_add_backref(tsv, sv);
5604 /* Give tsv backref magic if it hasn't already got it, then push a
5605 * back-reference to sv onto the array associated with the backref magic.
5609 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5613 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5614 av = (AV*)mg->mg_obj;
5617 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5618 /* av now has a refcnt of 2, which avoids it getting freed
5619 * before us during global cleanup. The extra ref is removed
5620 * by magic_killbackrefs() when tsv is being freed */
5622 if (AvFILLp(av) >= AvMAX(av)) {
5624 SV **svp = AvARRAY(av);
5625 for (i = AvFILLp(av); i >= 0; i--)
5627 svp[i] = sv; /* reuse the slot */
5630 av_extend(av, AvFILLp(av)+1);
5632 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5635 /* delete a back-reference to ourselves from the backref magic associated
5636 * with the SV we point to.
5640 S_sv_del_backref(pTHX_ SV *sv)
5647 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5648 Perl_croak(aTHX_ "panic: del_backref");
5649 av = (AV *)mg->mg_obj;
5651 for (i = AvFILLp(av); i >= 0; i--)
5652 if (svp[i] == sv) svp[i] = Nullsv;
5656 =for apidoc sv_insert
5658 Inserts a string at the specified offset/length within the SV. Similar to
5659 the Perl substr() function.
5665 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5669 register char *midend;
5670 register char *bigend;
5676 Perl_croak(aTHX_ "Can't modify non-existent substring");
5677 SvPV_force(bigstr, curlen);
5678 (void)SvPOK_only_UTF8(bigstr);
5679 if (offset + len > curlen) {
5680 SvGROW(bigstr, offset+len+1);
5681 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5682 SvCUR_set(bigstr, offset+len);
5686 i = littlelen - len;
5687 if (i > 0) { /* string might grow */
5688 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5689 mid = big + offset + len;
5690 midend = bigend = big + SvCUR(bigstr);
5693 while (midend > mid) /* shove everything down */
5694 *--bigend = *--midend;
5695 Move(little,big+offset,littlelen,char);
5696 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5701 Move(little,SvPVX(bigstr)+offset,len,char);
5706 big = SvPVX(bigstr);
5709 bigend = big + SvCUR(bigstr);
5711 if (midend > bigend)
5712 Perl_croak(aTHX_ "panic: sv_insert");
5714 if (mid - big > bigend - midend) { /* faster to shorten from end */
5716 Move(little, mid, littlelen,char);
5719 i = bigend - midend;
5721 Move(midend, mid, i,char);
5725 SvCUR_set(bigstr, mid - big);
5728 else if ((i = mid - big)) { /* faster from front */
5729 midend -= littlelen;
5731 sv_chop(bigstr,midend-i);
5736 Move(little, mid, littlelen,char);
5738 else if (littlelen) {
5739 midend -= littlelen;
5740 sv_chop(bigstr,midend);
5741 Move(little,midend,littlelen,char);
5744 sv_chop(bigstr,midend);
5750 =for apidoc sv_replace
5752 Make the first argument a copy of the second, then delete the original.
5753 The target SV physically takes over ownership of the body of the source SV
5754 and inherits its flags; however, the target keeps any magic it owns,
5755 and any magic in the source is discarded.
5756 Note that this is a rather specialist SV copying operation; most of the
5757 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5763 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5765 U32 refcnt = SvREFCNT(sv);
5766 SV_CHECK_THINKFIRST_COW_DROP(sv);
5767 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5768 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5769 if (SvMAGICAL(sv)) {
5773 sv_upgrade(nsv, SVt_PVMG);
5774 SvMAGIC_set(nsv, SvMAGIC(sv));
5775 SvFLAGS(nsv) |= SvMAGICAL(sv);
5777 SvMAGIC_set(sv, NULL);
5781 assert(!SvREFCNT(sv));
5782 #ifdef DEBUG_LEAKING_SCALARS
5783 sv->sv_flags = nsv->sv_flags;
5784 sv->sv_any = nsv->sv_any;
5785 sv->sv_refcnt = nsv->sv_refcnt;
5787 StructCopy(nsv,sv,SV);
5790 #ifdef PERL_COPY_ON_WRITE
5791 if (SvIsCOW_normal(nsv)) {
5792 /* We need to follow the pointers around the loop to make the
5793 previous SV point to sv, rather than nsv. */
5796 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5799 assert(SvPVX(current) == SvPVX(nsv));
5801 /* Make the SV before us point to the SV after us. */
5803 PerlIO_printf(Perl_debug_log, "previous is\n");
5805 PerlIO_printf(Perl_debug_log,
5806 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5807 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5809 SV_COW_NEXT_SV_SET(current, sv);
5812 SvREFCNT(sv) = refcnt;
5813 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5819 =for apidoc sv_clear
5821 Clear an SV: call any destructors, free up any memory used by the body,
5822 and free the body itself. The SV's head is I<not> freed, although
5823 its type is set to all 1's so that it won't inadvertently be assumed
5824 to be live during global destruction etc.
5825 This function should only be called when REFCNT is zero. Most of the time
5826 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5833 Perl_sv_clear(pTHX_ register SV *sv)
5838 assert(SvREFCNT(sv) == 0);
5841 if (PL_defstash) { /* Still have a symbol table? */
5848 stash = SvSTASH(sv);
5849 destructor = StashHANDLER(stash,DESTROY);
5851 SV* tmpref = newRV(sv);
5852 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5854 PUSHSTACKi(PERLSI_DESTROY);
5859 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5865 if(SvREFCNT(tmpref) < 2) {
5866 /* tmpref is not kept alive! */
5868 SvRV_set(tmpref, NULL);
5871 SvREFCNT_dec(tmpref);
5873 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5877 if (PL_in_clean_objs)
5878 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5880 /* DESTROY gave object new lease on life */
5886 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5887 SvOBJECT_off(sv); /* Curse the object. */
5888 if (SvTYPE(sv) != SVt_PVIO)
5889 --PL_sv_objcount; /* XXX Might want something more general */
5892 if (SvTYPE(sv) >= SVt_PVMG) {
5895 if (SvFLAGS(sv) & SVpad_TYPED)
5896 SvREFCNT_dec(SvSTASH(sv));
5899 switch (SvTYPE(sv)) {
5902 IoIFP(sv) != PerlIO_stdin() &&
5903 IoIFP(sv) != PerlIO_stdout() &&
5904 IoIFP(sv) != PerlIO_stderr())
5906 io_close((IO*)sv, FALSE);
5908 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5909 PerlDir_close(IoDIRP(sv));
5910 IoDIRP(sv) = (DIR*)NULL;
5911 Safefree(IoTOP_NAME(sv));
5912 Safefree(IoFMT_NAME(sv));
5913 Safefree(IoBOTTOM_NAME(sv));
5928 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5929 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5930 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5931 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5933 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5934 SvREFCNT_dec(LvTARG(sv));
5938 Safefree(GvNAME(sv));
5939 /* cannot decrease stash refcount yet, as we might recursively delete
5940 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5941 of stash until current sv is completely gone.
5942 -- JohnPC, 27 Mar 1998 */
5943 stash = GvSTASH(sv);
5949 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5951 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
5952 /* Don't even bother with turning off the OOK flag. */
5961 SvREFCNT_dec(SvRV(sv));
5963 #ifdef PERL_COPY_ON_WRITE
5964 else if (SvPVX(sv)) {
5966 /* I believe I need to grab the global SV mutex here and
5967 then recheck the COW status. */
5969 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5972 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5973 SvUVX(sv), SV_COW_NEXT_SV(sv));
5974 /* And drop it here. */
5976 } else if (SvLEN(sv)) {
5977 Safefree(SvPVX(sv));
5981 else if (SvPVX(sv) && SvLEN(sv))
5982 Safefree(SvPVX(sv));
5983 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5984 unsharepvn(SvPVX(sv),
5985 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5999 switch (SvTYPE(sv)) {
6015 del_XPVIV(SvANY(sv));
6018 del_XPVNV(SvANY(sv));
6021 del_XPVMG(SvANY(sv));
6024 del_XPVLV(SvANY(sv));
6027 del_XPVAV(SvANY(sv));
6030 del_XPVHV(SvANY(sv));
6033 del_XPVCV(SvANY(sv));
6036 del_XPVGV(SvANY(sv));
6037 /* code duplication for increased performance. */
6038 SvFLAGS(sv) &= SVf_BREAK;
6039 SvFLAGS(sv) |= SVTYPEMASK;
6040 /* decrease refcount of the stash that owns this GV, if any */
6042 SvREFCNT_dec(stash);
6043 return; /* not break, SvFLAGS reset already happened */
6045 del_XPVBM(SvANY(sv));
6048 del_XPVFM(SvANY(sv));
6051 del_XPVIO(SvANY(sv));
6054 SvFLAGS(sv) &= SVf_BREAK;
6055 SvFLAGS(sv) |= SVTYPEMASK;
6059 =for apidoc sv_newref
6061 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6068 Perl_sv_newref(pTHX_ SV *sv)
6078 Decrement an SV's reference count, and if it drops to zero, call
6079 C<sv_clear> to invoke destructors and free up any memory used by
6080 the body; finally, deallocate the SV's head itself.
6081 Normally called via a wrapper macro C<SvREFCNT_dec>.
6087 Perl_sv_free(pTHX_ SV *sv)
6092 if (SvREFCNT(sv) == 0) {
6093 if (SvFLAGS(sv) & SVf_BREAK)
6094 /* this SV's refcnt has been artificially decremented to
6095 * trigger cleanup */
6097 if (PL_in_clean_all) /* All is fair */
6099 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6100 /* make sure SvREFCNT(sv)==0 happens very seldom */
6101 SvREFCNT(sv) = (~(U32)0)/2;
6104 if (ckWARN_d(WARN_INTERNAL))
6105 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6106 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6107 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6110 if (--(SvREFCNT(sv)) > 0)
6112 Perl_sv_free2(aTHX_ sv);
6116 Perl_sv_free2(pTHX_ SV *sv)
6121 if (ckWARN_d(WARN_DEBUGGING))
6122 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6123 "Attempt to free temp prematurely: SV 0x%"UVxf
6124 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6128 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6129 /* make sure SvREFCNT(sv)==0 happens very seldom */
6130 SvREFCNT(sv) = (~(U32)0)/2;
6141 Returns the length of the string in the SV. Handles magic and type
6142 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6148 Perl_sv_len(pTHX_ register SV *sv)
6156 len = mg_length(sv);
6158 (void)SvPV(sv, len);
6163 =for apidoc sv_len_utf8
6165 Returns the number of characters in the string in an SV, counting wide
6166 UTF-8 bytes as a single character. Handles magic and type coercion.
6172 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6173 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6174 * (Note that the mg_len is not the length of the mg_ptr field.)
6179 Perl_sv_len_utf8(pTHX_ register SV *sv)
6185 return mg_length(sv);
6189 U8 *s = (U8*)SvPV(sv, len);
6190 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6192 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6194 #ifdef PERL_UTF8_CACHE_ASSERT
6195 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6199 ulen = Perl_utf8_length(aTHX_ s, s + len);
6200 if (!mg && !SvREADONLY(sv)) {
6201 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6202 mg = mg_find(sv, PERL_MAGIC_utf8);
6212 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6213 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6214 * between UTF-8 and byte offsets. There are two (substr offset and substr
6215 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6216 * and byte offset) cache positions.
6218 * The mg_len field is used by sv_len_utf8(), see its comments.
6219 * Note that the mg_len is not the length of the mg_ptr field.
6223 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
6227 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6229 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6233 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6235 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6236 (*mgp)->mg_ptr = (char *) *cachep;
6240 (*cachep)[i] = *offsetp;
6241 (*cachep)[i+1] = s - start;
6249 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6250 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6251 * between UTF-8 and byte offsets. See also the comments of
6252 * S_utf8_mg_pos_init().
6256 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6260 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6262 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6263 if (*mgp && (*mgp)->mg_ptr) {
6264 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6265 ASSERT_UTF8_CACHE(*cachep);
6266 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6268 else { /* We will skip to the right spot. */
6273 /* The assumption is that going backward is half
6274 * the speed of going forward (that's where the
6275 * 2 * backw in the below comes from). (The real
6276 * figure of course depends on the UTF-8 data.) */
6278 if ((*cachep)[i] > (STRLEN)uoff) {
6280 backw = (*cachep)[i] - (STRLEN)uoff;
6282 if (forw < 2 * backw)
6285 p = start + (*cachep)[i+1];
6287 /* Try this only for the substr offset (i == 0),
6288 * not for the substr length (i == 2). */
6289 else if (i == 0) { /* (*cachep)[i] < uoff */
6290 STRLEN ulen = sv_len_utf8(sv);
6292 if ((STRLEN)uoff < ulen) {
6293 forw = (STRLEN)uoff - (*cachep)[i];
6294 backw = ulen - (STRLEN)uoff;
6296 if (forw < 2 * backw)
6297 p = start + (*cachep)[i+1];
6302 /* If the string is not long enough for uoff,
6303 * we could extend it, but not at this low a level. */
6307 if (forw < 2 * backw) {
6314 while (UTF8_IS_CONTINUATION(*p))
6319 /* Update the cache. */
6320 (*cachep)[i] = (STRLEN)uoff;
6321 (*cachep)[i+1] = p - start;
6323 /* Drop the stale "length" cache */
6332 if (found) { /* Setup the return values. */
6333 *offsetp = (*cachep)[i+1];
6334 *sp = start + *offsetp;
6337 *offsetp = send - start;
6339 else if (*sp < start) {
6345 #ifdef PERL_UTF8_CACHE_ASSERT
6350 while (n-- && s < send)
6354 assert(*offsetp == s - start);
6355 assert((*cachep)[0] == (STRLEN)uoff);
6356 assert((*cachep)[1] == *offsetp);
6358 ASSERT_UTF8_CACHE(*cachep);
6367 =for apidoc sv_pos_u2b
6369 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6370 the start of the string, to a count of the equivalent number of bytes; if
6371 lenp is non-zero, it does the same to lenp, but this time starting from
6372 the offset, rather than from the start of the string. Handles magic and
6379 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6380 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6381 * byte offsets. See also the comments of S_utf8_mg_pos().
6386 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6397 start = s = (U8*)SvPV(sv, len);
6399 I32 uoffset = *offsetp;
6404 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6406 if (!found && uoffset > 0) {
6407 while (s < send && uoffset--)
6411 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
6413 *offsetp = s - start;
6418 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6422 if (!found && *lenp > 0) {
6425 while (s < send && ulen--)
6429 utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
6433 ASSERT_UTF8_CACHE(cache);
6445 =for apidoc sv_pos_b2u
6447 Converts the value pointed to by offsetp from a count of bytes from the
6448 start of the string, to a count of the equivalent number of UTF-8 chars.
6449 Handles magic and type coercion.
6455 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6456 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6457 * byte offsets. See also the comments of S_utf8_mg_pos().
6462 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6470 s = (U8*)SvPV(sv, len);
6471 if ((I32)len < *offsetp)
6472 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6474 U8* send = s + *offsetp;
6476 STRLEN *cache = NULL;
6480 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6481 mg = mg_find(sv, PERL_MAGIC_utf8);
6482 if (mg && mg->mg_ptr) {
6483 cache = (STRLEN *) mg->mg_ptr;
6484 if (cache[1] == (STRLEN)*offsetp) {
6485 /* An exact match. */
6486 *offsetp = cache[0];
6490 else if (cache[1] < (STRLEN)*offsetp) {
6491 /* We already know part of the way. */
6494 /* Let the below loop do the rest. */
6496 else { /* cache[1] > *offsetp */
6497 /* We already know all of the way, now we may
6498 * be able to walk back. The same assumption
6499 * is made as in S_utf8_mg_pos(), namely that
6500 * walking backward is twice slower than
6501 * walking forward. */
6502 STRLEN forw = *offsetp;
6503 STRLEN backw = cache[1] - *offsetp;
6505 if (!(forw < 2 * backw)) {
6506 U8 *p = s + cache[1];
6513 while (UTF8_IS_CONTINUATION(*p)) {
6521 *offsetp = cache[0];
6523 /* Drop the stale "length" cache */
6531 ASSERT_UTF8_CACHE(cache);
6537 /* Call utf8n_to_uvchr() to validate the sequence
6538 * (unless a simple non-UTF character) */
6539 if (!UTF8_IS_INVARIANT(*s))
6540 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6549 if (!SvREADONLY(sv)) {
6551 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6552 mg = mg_find(sv, PERL_MAGIC_utf8);
6557 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6558 mg->mg_ptr = (char *) cache;
6563 cache[1] = *offsetp;
6564 /* Drop the stale "length" cache */
6577 Returns a boolean indicating whether the strings in the two SVs are
6578 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6579 coerce its args to strings if necessary.
6585 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6593 SV* svrecode = Nullsv;
6600 pv1 = SvPV(sv1, cur1);
6607 pv2 = SvPV(sv2, cur2);
6609 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6610 /* Differing utf8ness.
6611 * Do not UTF8size the comparands as a side-effect. */
6614 svrecode = newSVpvn(pv2, cur2);
6615 sv_recode_to_utf8(svrecode, PL_encoding);
6616 pv2 = SvPV(svrecode, cur2);
6619 svrecode = newSVpvn(pv1, cur1);
6620 sv_recode_to_utf8(svrecode, PL_encoding);
6621 pv1 = SvPV(svrecode, cur1);
6623 /* Now both are in UTF-8. */
6625 SvREFCNT_dec(svrecode);
6630 bool is_utf8 = TRUE;
6633 /* sv1 is the UTF-8 one,
6634 * if is equal it must be downgrade-able */
6635 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6641 /* sv2 is the UTF-8 one,
6642 * if is equal it must be downgrade-able */
6643 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6649 /* Downgrade not possible - cannot be eq */
6657 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6660 SvREFCNT_dec(svrecode);
6671 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6672 string in C<sv1> is less than, equal to, or greater than the string in
6673 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6674 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6680 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6683 const char *pv1, *pv2;
6686 SV *svrecode = Nullsv;
6693 pv1 = SvPV(sv1, cur1);
6700 pv2 = SvPV(sv2, cur2);
6702 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6703 /* Differing utf8ness.
6704 * Do not UTF8size the comparands as a side-effect. */
6707 svrecode = newSVpvn(pv2, cur2);
6708 sv_recode_to_utf8(svrecode, PL_encoding);
6709 pv2 = SvPV(svrecode, cur2);
6712 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6717 svrecode = newSVpvn(pv1, cur1);
6718 sv_recode_to_utf8(svrecode, PL_encoding);
6719 pv1 = SvPV(svrecode, cur1);
6722 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6728 cmp = cur2 ? -1 : 0;
6732 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6735 cmp = retval < 0 ? -1 : 1;
6736 } else if (cur1 == cur2) {
6739 cmp = cur1 < cur2 ? -1 : 1;
6744 SvREFCNT_dec(svrecode);
6753 =for apidoc sv_cmp_locale
6755 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6756 'use bytes' aware, handles get magic, and will coerce its args to strings
6757 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6763 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6765 #ifdef USE_LOCALE_COLLATE
6771 if (PL_collation_standard)
6775 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6777 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6779 if (!pv1 || !len1) {
6790 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6793 return retval < 0 ? -1 : 1;
6796 * When the result of collation is equality, that doesn't mean
6797 * that there are no differences -- some locales exclude some
6798 * characters from consideration. So to avoid false equalities,
6799 * we use the raw string as a tiebreaker.
6805 #endif /* USE_LOCALE_COLLATE */
6807 return sv_cmp(sv1, sv2);
6811 #ifdef USE_LOCALE_COLLATE
6814 =for apidoc sv_collxfrm
6816 Add Collate Transform magic to an SV if it doesn't already have it.
6818 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6819 scalar data of the variable, but transformed to such a format that a normal
6820 memory comparison can be used to compare the data according to the locale
6827 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6831 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6832 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6837 Safefree(mg->mg_ptr);
6839 if ((xf = mem_collxfrm(s, len, &xlen))) {
6840 if (SvREADONLY(sv)) {
6843 return xf + sizeof(PL_collation_ix);
6846 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6847 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6860 if (mg && mg->mg_ptr) {
6862 return mg->mg_ptr + sizeof(PL_collation_ix);
6870 #endif /* USE_LOCALE_COLLATE */
6875 Get a line from the filehandle and store it into the SV, optionally
6876 appending to the currently-stored string.
6882 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6886 register STDCHAR rslast;
6887 register STDCHAR *bp;
6893 if (SvTHINKFIRST(sv))
6894 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6895 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6897 However, perlbench says it's slower, because the existing swipe code
6898 is faster than copy on write.
6899 Swings and roundabouts. */
6900 (void)SvUPGRADE(sv, SVt_PV);
6905 if (PerlIO_isutf8(fp)) {
6907 sv_utf8_upgrade_nomg(sv);
6908 sv_pos_u2b(sv,&append,0);
6910 } else if (SvUTF8(sv)) {
6911 SV *tsv = NEWSV(0,0);
6912 sv_gets(tsv, fp, 0);
6913 sv_utf8_upgrade_nomg(tsv);
6914 SvCUR_set(sv,append);
6917 goto return_string_or_null;
6922 if (PerlIO_isutf8(fp))
6925 if (IN_PERL_COMPILETIME) {
6926 /* we always read code in line mode */
6930 else if (RsSNARF(PL_rs)) {
6931 /* If it is a regular disk file use size from stat() as estimate
6932 of amount we are going to read - may result in malloc-ing
6933 more memory than we realy need if layers bellow reduce
6934 size we read (e.g. CRLF or a gzip layer)
6937 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6938 Off_t offset = PerlIO_tell(fp);
6939 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6940 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6946 else if (RsRECORD(PL_rs)) {
6950 /* Grab the size of the record we're getting */
6951 recsize = SvIV(SvRV(PL_rs));
6952 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6955 /* VMS wants read instead of fread, because fread doesn't respect */
6956 /* RMS record boundaries. This is not necessarily a good thing to be */
6957 /* doing, but we've got no other real choice - except avoid stdio
6958 as implementation - perhaps write a :vms layer ?
6960 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6962 bytesread = PerlIO_read(fp, buffer, recsize);
6966 SvCUR_set(sv, bytesread += append);
6967 buffer[bytesread] = '\0';
6968 goto return_string_or_null;
6970 else if (RsPARA(PL_rs)) {
6976 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6977 if (PerlIO_isutf8(fp)) {
6978 rsptr = SvPVutf8(PL_rs, rslen);
6981 if (SvUTF8(PL_rs)) {
6982 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6983 Perl_croak(aTHX_ "Wide character in $/");
6986 rsptr = SvPV(PL_rs, rslen);
6990 rslast = rslen ? rsptr[rslen - 1] : '\0';
6992 if (rspara) { /* have to do this both before and after */
6993 do { /* to make sure file boundaries work right */
6996 i = PerlIO_getc(fp);
7000 PerlIO_ungetc(fp,i);
7006 /* See if we know enough about I/O mechanism to cheat it ! */
7008 /* This used to be #ifdef test - it is made run-time test for ease
7009 of abstracting out stdio interface. One call should be cheap
7010 enough here - and may even be a macro allowing compile
7014 if (PerlIO_fast_gets(fp)) {
7017 * We're going to steal some values from the stdio struct
7018 * and put EVERYTHING in the innermost loop into registers.
7020 register STDCHAR *ptr;
7024 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7025 /* An ungetc()d char is handled separately from the regular
7026 * buffer, so we getc() it back out and stuff it in the buffer.
7028 i = PerlIO_getc(fp);
7029 if (i == EOF) return 0;
7030 *(--((*fp)->_ptr)) = (unsigned char) i;
7034 /* Here is some breathtakingly efficient cheating */
7036 cnt = PerlIO_get_cnt(fp); /* get count into register */
7037 /* make sure we have the room */
7038 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7039 /* Not room for all of it
7040 if we are looking for a separator and room for some
7042 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7043 /* just process what we have room for */
7044 shortbuffered = cnt - SvLEN(sv) + append + 1;
7045 cnt -= shortbuffered;
7049 /* remember that cnt can be negative */
7050 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7055 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7056 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7057 DEBUG_P(PerlIO_printf(Perl_debug_log,
7058 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7059 DEBUG_P(PerlIO_printf(Perl_debug_log,
7060 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7061 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7062 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7067 while (cnt > 0) { /* this | eat */
7069 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7070 goto thats_all_folks; /* screams | sed :-) */
7074 Copy(ptr, bp, cnt, char); /* this | eat */
7075 bp += cnt; /* screams | dust */
7076 ptr += cnt; /* louder | sed :-) */
7081 if (shortbuffered) { /* oh well, must extend */
7082 cnt = shortbuffered;
7084 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7086 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7087 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7091 DEBUG_P(PerlIO_printf(Perl_debug_log,
7092 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7093 PTR2UV(ptr),(long)cnt));
7094 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7096 DEBUG_P(PerlIO_printf(Perl_debug_log,
7097 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7098 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7099 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7101 /* This used to call 'filbuf' in stdio form, but as that behaves like
7102 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7103 another abstraction. */
7104 i = PerlIO_getc(fp); /* get more characters */
7106 DEBUG_P(PerlIO_printf(Perl_debug_log,
7107 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7108 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7109 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7111 cnt = PerlIO_get_cnt(fp);
7112 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7113 DEBUG_P(PerlIO_printf(Perl_debug_log,
7114 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7116 if (i == EOF) /* all done for ever? */
7117 goto thats_really_all_folks;
7119 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7121 SvGROW(sv, bpx + cnt + 2);
7122 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7124 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7126 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7127 goto thats_all_folks;
7131 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7132 memNE((char*)bp - rslen, rsptr, rslen))
7133 goto screamer; /* go back to the fray */
7134 thats_really_all_folks:
7136 cnt += shortbuffered;
7137 DEBUG_P(PerlIO_printf(Perl_debug_log,
7138 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7139 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7140 DEBUG_P(PerlIO_printf(Perl_debug_log,
7141 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7142 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7143 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7145 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7146 DEBUG_P(PerlIO_printf(Perl_debug_log,
7147 "Screamer: done, len=%ld, string=|%.*s|\n",
7148 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7152 /*The big, slow, and stupid way. */
7153 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7155 New(0, buf, 8192, STDCHAR);
7163 const register STDCHAR *bpe = buf + sizeof(buf);
7165 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7166 ; /* keep reading */
7170 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7171 /* Accomodate broken VAXC compiler, which applies U8 cast to
7172 * both args of ?: operator, causing EOF to change into 255
7175 i = (U8)buf[cnt - 1];
7181 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7183 sv_catpvn(sv, (char *) buf, cnt);
7185 sv_setpvn(sv, (char *) buf, cnt);
7187 if (i != EOF && /* joy */
7189 SvCUR(sv) < rslen ||
7190 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7194 * If we're reading from a TTY and we get a short read,
7195 * indicating that the user hit his EOF character, we need
7196 * to notice it now, because if we try to read from the TTY
7197 * again, the EOF condition will disappear.
7199 * The comparison of cnt to sizeof(buf) is an optimization
7200 * that prevents unnecessary calls to feof().
7204 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7208 #ifdef USE_HEAP_INSTEAD_OF_STACK
7213 if (rspara) { /* have to do this both before and after */
7214 while (i != EOF) { /* to make sure file boundaries work right */
7215 i = PerlIO_getc(fp);
7217 PerlIO_ungetc(fp,i);
7223 return_string_or_null:
7224 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7230 Auto-increment of the value in the SV, doing string to numeric conversion
7231 if necessary. Handles 'get' magic.
7237 Perl_sv_inc(pTHX_ register SV *sv)
7246 if (SvTHINKFIRST(sv)) {
7248 sv_force_normal_flags(sv, 0);
7249 if (SvREADONLY(sv)) {
7250 if (IN_PERL_RUNTIME)
7251 Perl_croak(aTHX_ PL_no_modify);
7255 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7257 i = PTR2IV(SvRV(sv));
7262 flags = SvFLAGS(sv);
7263 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7264 /* It's (privately or publicly) a float, but not tested as an
7265 integer, so test it to see. */
7267 flags = SvFLAGS(sv);
7269 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7270 /* It's publicly an integer, or privately an integer-not-float */
7271 #ifdef PERL_PRESERVE_IVUV
7275 if (SvUVX(sv) == UV_MAX)
7276 sv_setnv(sv, UV_MAX_P1);
7278 (void)SvIOK_only_UV(sv);
7279 SvUV_set(sv, SvUVX(sv) + 1);
7281 if (SvIVX(sv) == IV_MAX)
7282 sv_setuv(sv, (UV)IV_MAX + 1);
7284 (void)SvIOK_only(sv);
7285 SvIV_set(sv, SvIVX(sv) + 1);
7290 if (flags & SVp_NOK) {
7291 (void)SvNOK_only(sv);
7292 SvNV_set(sv, SvNVX(sv) + 1.0);
7296 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7297 if ((flags & SVTYPEMASK) < SVt_PVIV)
7298 sv_upgrade(sv, SVt_IV);
7299 (void)SvIOK_only(sv);
7304 while (isALPHA(*d)) d++;
7305 while (isDIGIT(*d)) d++;
7307 #ifdef PERL_PRESERVE_IVUV
7308 /* Got to punt this as an integer if needs be, but we don't issue
7309 warnings. Probably ought to make the sv_iv_please() that does
7310 the conversion if possible, and silently. */
7311 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7312 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7313 /* Need to try really hard to see if it's an integer.
7314 9.22337203685478e+18 is an integer.
7315 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7316 so $a="9.22337203685478e+18"; $a+0; $a++
7317 needs to be the same as $a="9.22337203685478e+18"; $a++
7324 /* sv_2iv *should* have made this an NV */
7325 if (flags & SVp_NOK) {
7326 (void)SvNOK_only(sv);
7327 SvNV_set(sv, SvNVX(sv) + 1.0);
7330 /* I don't think we can get here. Maybe I should assert this
7331 And if we do get here I suspect that sv_setnv will croak. NWC
7333 #if defined(USE_LONG_DOUBLE)
7334 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",
7335 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7337 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7338 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7341 #endif /* PERL_PRESERVE_IVUV */
7342 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7346 while (d >= SvPVX(sv)) {
7354 /* MKS: The original code here died if letters weren't consecutive.
7355 * at least it didn't have to worry about non-C locales. The
7356 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7357 * arranged in order (although not consecutively) and that only
7358 * [A-Za-z] are accepted by isALPHA in the C locale.
7360 if (*d != 'z' && *d != 'Z') {
7361 do { ++*d; } while (!isALPHA(*d));
7364 *(d--) -= 'z' - 'a';
7369 *(d--) -= 'z' - 'a' + 1;
7373 /* oh,oh, the number grew */
7374 SvGROW(sv, SvCUR(sv) + 2);
7375 SvCUR_set(sv, SvCUR(sv) + 1);
7376 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7387 Auto-decrement of the value in the SV, doing string to numeric conversion
7388 if necessary. Handles 'get' magic.
7394 Perl_sv_dec(pTHX_ register SV *sv)
7402 if (SvTHINKFIRST(sv)) {
7404 sv_force_normal_flags(sv, 0);
7405 if (SvREADONLY(sv)) {
7406 if (IN_PERL_RUNTIME)
7407 Perl_croak(aTHX_ PL_no_modify);
7411 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7413 i = PTR2IV(SvRV(sv));
7418 /* Unlike sv_inc we don't have to worry about string-never-numbers
7419 and keeping them magic. But we mustn't warn on punting */
7420 flags = SvFLAGS(sv);
7421 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7422 /* It's publicly an integer, or privately an integer-not-float */
7423 #ifdef PERL_PRESERVE_IVUV
7427 if (SvUVX(sv) == 0) {
7428 (void)SvIOK_only(sv);
7432 (void)SvIOK_only_UV(sv);
7433 SvUV_set(sv, SvUVX(sv) + 1);
7436 if (SvIVX(sv) == IV_MIN)
7437 sv_setnv(sv, (NV)IV_MIN - 1.0);
7439 (void)SvIOK_only(sv);
7440 SvIV_set(sv, SvIVX(sv) - 1);
7445 if (flags & SVp_NOK) {
7446 SvNV_set(sv, SvNVX(sv) - 1.0);
7447 (void)SvNOK_only(sv);
7450 if (!(flags & SVp_POK)) {
7451 if ((flags & SVTYPEMASK) < SVt_PVNV)
7452 sv_upgrade(sv, SVt_NV);
7454 (void)SvNOK_only(sv);
7457 #ifdef PERL_PRESERVE_IVUV
7459 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7460 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7461 /* Need to try really hard to see if it's an integer.
7462 9.22337203685478e+18 is an integer.
7463 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7464 so $a="9.22337203685478e+18"; $a+0; $a--
7465 needs to be the same as $a="9.22337203685478e+18"; $a--
7472 /* sv_2iv *should* have made this an NV */
7473 if (flags & SVp_NOK) {
7474 (void)SvNOK_only(sv);
7475 SvNV_set(sv, SvNVX(sv) - 1.0);
7478 /* I don't think we can get here. Maybe I should assert this
7479 And if we do get here I suspect that sv_setnv will croak. NWC
7481 #if defined(USE_LONG_DOUBLE)
7482 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",
7483 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7485 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7486 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7490 #endif /* PERL_PRESERVE_IVUV */
7491 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7495 =for apidoc sv_mortalcopy
7497 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7498 The new SV is marked as mortal. It will be destroyed "soon", either by an
7499 explicit call to FREETMPS, or by an implicit call at places such as
7500 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7505 /* Make a string that will exist for the duration of the expression
7506 * evaluation. Actually, it may have to last longer than that, but
7507 * hopefully we won't free it until it has been assigned to a
7508 * permanent location. */
7511 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7516 sv_setsv(sv,oldstr);
7518 PL_tmps_stack[++PL_tmps_ix] = sv;
7524 =for apidoc sv_newmortal
7526 Creates a new null SV which is mortal. The reference count of the SV is
7527 set to 1. It will be destroyed "soon", either by an explicit call to
7528 FREETMPS, or by an implicit call at places such as statement boundaries.
7529 See also C<sv_mortalcopy> and C<sv_2mortal>.
7535 Perl_sv_newmortal(pTHX)
7540 SvFLAGS(sv) = SVs_TEMP;
7542 PL_tmps_stack[++PL_tmps_ix] = sv;
7547 =for apidoc sv_2mortal
7549 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7550 by an explicit call to FREETMPS, or by an implicit call at places such as
7551 statement boundaries. SvTEMP() is turned on which means that the SV's
7552 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7553 and C<sv_mortalcopy>.
7559 Perl_sv_2mortal(pTHX_ register SV *sv)
7564 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7567 PL_tmps_stack[++PL_tmps_ix] = sv;
7575 Creates a new SV and copies a string into it. The reference count for the
7576 SV is set to 1. If C<len> is zero, Perl will compute the length using
7577 strlen(). For efficiency, consider using C<newSVpvn> instead.
7583 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7590 sv_setpvn(sv,s,len);
7595 =for apidoc newSVpvn
7597 Creates a new SV and copies a string into it. The reference count for the
7598 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7599 string. You are responsible for ensuring that the source string is at least
7600 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7606 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7611 sv_setpvn(sv,s,len);
7616 =for apidoc newSVpvn_share
7618 Creates a new SV with its SvPVX pointing to a shared string in the string
7619 table. If the string does not already exist in the table, it is created
7620 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7621 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7622 otherwise the hash is computed. The idea here is that as the string table
7623 is used for shared hash keys these strings will have SvPVX == HeKEY and
7624 hash lookup will avoid string compare.
7630 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7633 bool is_utf8 = FALSE;
7635 STRLEN tmplen = -len;
7637 /* See the note in hv.c:hv_fetch() --jhi */
7638 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7642 PERL_HASH(hash, src, len);
7644 sv_upgrade(sv, SVt_PVIV);
7645 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7658 #if defined(PERL_IMPLICIT_CONTEXT)
7660 /* pTHX_ magic can't cope with varargs, so this is a no-context
7661 * version of the main function, (which may itself be aliased to us).
7662 * Don't access this version directly.
7666 Perl_newSVpvf_nocontext(const char* pat, ...)
7671 va_start(args, pat);
7672 sv = vnewSVpvf(pat, &args);
7679 =for apidoc newSVpvf
7681 Creates a new SV and initializes it with the string formatted like
7688 Perl_newSVpvf(pTHX_ const char* pat, ...)
7692 va_start(args, pat);
7693 sv = vnewSVpvf(pat, &args);
7698 /* backend for newSVpvf() and newSVpvf_nocontext() */
7701 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7705 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7712 Creates a new SV and copies a floating point value into it.
7713 The reference count for the SV is set to 1.
7719 Perl_newSVnv(pTHX_ NV n)
7731 Creates a new SV and copies an integer into it. The reference count for the
7738 Perl_newSViv(pTHX_ IV i)
7750 Creates a new SV and copies an unsigned integer into it.
7751 The reference count for the SV is set to 1.
7757 Perl_newSVuv(pTHX_ UV u)
7767 =for apidoc newRV_noinc
7769 Creates an RV wrapper for an SV. The reference count for the original
7770 SV is B<not> incremented.
7776 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7781 sv_upgrade(sv, SVt_RV);
7783 SvRV_set(sv, tmpRef);
7788 /* newRV_inc is the official function name to use now.
7789 * newRV_inc is in fact #defined to newRV in sv.h
7793 Perl_newRV(pTHX_ SV *tmpRef)
7795 return newRV_noinc(SvREFCNT_inc(tmpRef));
7801 Creates a new SV which is an exact duplicate of the original SV.
7808 Perl_newSVsv(pTHX_ register SV *old)
7814 if (SvTYPE(old) == SVTYPEMASK) {
7815 if (ckWARN_d(WARN_INTERNAL))
7816 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7820 /* SV_GMAGIC is the default for sv_setv()
7821 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7822 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7823 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7828 =for apidoc sv_reset
7830 Underlying implementation for the C<reset> Perl function.
7831 Note that the perl-level function is vaguely deprecated.
7837 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7846 char todo[PERL_UCHAR_MAX+1];
7851 if (!*s) { /* reset ?? searches */
7852 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7853 pm->op_pmdynflags &= ~PMdf_USED;
7858 /* reset variables */
7860 if (!HvARRAY(stash))
7863 Zero(todo, 256, char);
7865 i = (unsigned char)*s;
7869 max = (unsigned char)*s++;
7870 for ( ; i <= max; i++) {
7873 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7874 for (entry = HvARRAY(stash)[i];
7876 entry = HeNEXT(entry))
7878 if (!todo[(U8)*HeKEY(entry)])
7880 gv = (GV*)HeVAL(entry);
7882 if (SvTHINKFIRST(sv)) {
7883 if (!SvREADONLY(sv) && SvROK(sv))
7888 if (SvTYPE(sv) >= SVt_PV) {
7890 if (SvPVX(sv) != Nullch)
7897 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7900 #ifdef USE_ENVIRON_ARRAY
7902 # ifdef USE_ITHREADS
7903 && PL_curinterp == aTHX
7907 environ[0] = Nullch;
7910 #endif /* !PERL_MICRO */
7920 Using various gambits, try to get an IO from an SV: the IO slot if its a
7921 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7922 named after the PV if we're a string.
7928 Perl_sv_2io(pTHX_ SV *sv)
7933 switch (SvTYPE(sv)) {
7941 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7945 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7947 return sv_2io(SvRV(sv));
7948 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7954 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7963 Using various gambits, try to get a CV from an SV; in addition, try if
7964 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7970 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7977 return *gvp = Nullgv, Nullcv;
7978 switch (SvTYPE(sv)) {
7997 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7998 tryAMAGICunDEREF(to_cv);
8001 if (SvTYPE(sv) == SVt_PVCV) {
8010 Perl_croak(aTHX_ "Not a subroutine reference");
8015 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8021 if (lref && !GvCVu(gv)) {
8024 tmpsv = NEWSV(704,0);
8025 gv_efullname3(tmpsv, gv, Nullch);
8026 /* XXX this is probably not what they think they're getting.
8027 * It has the same effect as "sub name;", i.e. just a forward
8029 newSUB(start_subparse(FALSE, 0),
8030 newSVOP(OP_CONST, 0, tmpsv),
8035 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8045 Returns true if the SV has a true value by Perl's rules.
8046 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8047 instead use an in-line version.
8053 Perl_sv_true(pTHX_ register SV *sv)
8058 const register XPV* tXpv;
8059 if ((tXpv = (XPV*)SvANY(sv)) &&
8060 (tXpv->xpv_cur > 1 ||
8061 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8068 return SvIVX(sv) != 0;
8071 return SvNVX(sv) != 0.0;
8073 return sv_2bool(sv);
8081 A private implementation of the C<SvIVx> macro for compilers which can't
8082 cope with complex macro expressions. Always use the macro instead.
8088 Perl_sv_iv(pTHX_ register SV *sv)
8092 return (IV)SvUVX(sv);
8101 A private implementation of the C<SvUVx> macro for compilers which can't
8102 cope with complex macro expressions. Always use the macro instead.
8108 Perl_sv_uv(pTHX_ register SV *sv)
8113 return (UV)SvIVX(sv);
8121 A private implementation of the C<SvNVx> macro for compilers which can't
8122 cope with complex macro expressions. Always use the macro instead.
8128 Perl_sv_nv(pTHX_ register SV *sv)
8135 /* sv_pv() is now a macro using SvPV_nolen();
8136 * this function provided for binary compatibility only
8140 Perl_sv_pv(pTHX_ SV *sv)
8147 return sv_2pv(sv, &n_a);
8153 Use the C<SvPV_nolen> macro instead
8157 A private implementation of the C<SvPV> macro for compilers which can't
8158 cope with complex macro expressions. Always use the macro instead.
8164 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8170 return sv_2pv(sv, lp);
8175 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8181 return sv_2pv_flags(sv, lp, 0);
8184 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8185 * this function provided for binary compatibility only
8189 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8191 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8195 =for apidoc sv_pvn_force
8197 Get a sensible string out of the SV somehow.
8198 A private implementation of the C<SvPV_force> macro for compilers which
8199 can't cope with complex macro expressions. Always use the macro instead.
8201 =for apidoc sv_pvn_force_flags
8203 Get a sensible string out of the SV somehow.
8204 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8205 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8206 implemented in terms of this function.
8207 You normally want to use the various wrapper macros instead: see
8208 C<SvPV_force> and C<SvPV_force_nomg>
8214 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8218 if (SvTHINKFIRST(sv) && !SvROK(sv))
8219 sv_force_normal_flags(sv, 0);
8225 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8226 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8230 s = sv_2pv_flags(sv, lp, flags);
8231 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8236 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8237 SvGROW(sv, len + 1);
8238 Move(s,SvPVX(sv),len,char);
8243 SvPOK_on(sv); /* validate pointer */
8245 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8246 PTR2UV(sv),SvPVX(sv)));
8252 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8253 * this function provided for binary compatibility only
8257 Perl_sv_pvbyte(pTHX_ SV *sv)
8259 sv_utf8_downgrade(sv,0);
8264 =for apidoc sv_pvbyte
8266 Use C<SvPVbyte_nolen> instead.
8268 =for apidoc sv_pvbyten
8270 A private implementation of the C<SvPVbyte> macro for compilers
8271 which can't cope with complex macro expressions. Always use the macro
8278 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8280 sv_utf8_downgrade(sv,0);
8281 return sv_pvn(sv,lp);
8285 =for apidoc sv_pvbyten_force
8287 A private implementation of the C<SvPVbytex_force> macro for compilers
8288 which can't cope with complex macro expressions. Always use the macro
8295 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8297 sv_pvn_force(sv,lp);
8298 sv_utf8_downgrade(sv,0);
8303 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8304 * this function provided for binary compatibility only
8308 Perl_sv_pvutf8(pTHX_ SV *sv)
8310 sv_utf8_upgrade(sv);
8315 =for apidoc sv_pvutf8
8317 Use the C<SvPVutf8_nolen> macro instead
8319 =for apidoc sv_pvutf8n
8321 A private implementation of the C<SvPVutf8> macro for compilers
8322 which can't cope with complex macro expressions. Always use the macro
8329 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8331 sv_utf8_upgrade(sv);
8332 return sv_pvn(sv,lp);
8336 =for apidoc sv_pvutf8n_force
8338 A private implementation of the C<SvPVutf8_force> macro for compilers
8339 which can't cope with complex macro expressions. Always use the macro
8346 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8348 sv_pvn_force(sv,lp);
8349 sv_utf8_upgrade(sv);
8355 =for apidoc sv_reftype
8357 Returns a string describing what the SV is a reference to.
8363 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8365 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8366 inside return suggests a const propagation bug in g++. */
8367 if (ob && SvOBJECT(sv)) {
8368 char *name = HvNAME(SvSTASH(sv));
8369 return name ? name : (char *) "__ANON__";
8372 switch (SvTYPE(sv)) {
8389 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8390 /* tied lvalues should appear to be
8391 * scalars for backwards compatitbility */
8392 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8393 ? "SCALAR" : "LVALUE");
8394 case SVt_PVAV: return "ARRAY";
8395 case SVt_PVHV: return "HASH";
8396 case SVt_PVCV: return "CODE";
8397 case SVt_PVGV: return "GLOB";
8398 case SVt_PVFM: return "FORMAT";
8399 case SVt_PVIO: return "IO";
8400 default: return "UNKNOWN";
8406 =for apidoc sv_isobject
8408 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8409 object. If the SV is not an RV, or if the object is not blessed, then this
8416 Perl_sv_isobject(pTHX_ SV *sv)
8433 Returns a boolean indicating whether the SV is blessed into the specified
8434 class. This does not check for subtypes; use C<sv_derived_from> to verify
8435 an inheritance relationship.
8441 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8452 if (!HvNAME(SvSTASH(sv)))
8455 return strEQ(HvNAME(SvSTASH(sv)), name);
8461 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8462 it will be upgraded to one. If C<classname> is non-null then the new SV will
8463 be blessed in the specified package. The new SV is returned and its
8464 reference count is 1.
8470 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8476 SV_CHECK_THINKFIRST_COW_DROP(rv);
8479 if (SvTYPE(rv) >= SVt_PVMG) {
8480 U32 refcnt = SvREFCNT(rv);
8484 SvREFCNT(rv) = refcnt;
8487 if (SvTYPE(rv) < SVt_RV)
8488 sv_upgrade(rv, SVt_RV);
8489 else if (SvTYPE(rv) > SVt_RV) {
8500 HV* stash = gv_stashpv(classname, TRUE);
8501 (void)sv_bless(rv, stash);
8507 =for apidoc sv_setref_pv
8509 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8510 argument will be upgraded to an RV. That RV will be modified to point to
8511 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8512 into the SV. The C<classname> argument indicates the package for the
8513 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8514 will have a reference count of 1, and the RV will be returned.
8516 Do not use with other Perl types such as HV, AV, SV, CV, because those
8517 objects will become corrupted by the pointer copy process.
8519 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8525 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8528 sv_setsv(rv, &PL_sv_undef);
8532 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8537 =for apidoc sv_setref_iv
8539 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8540 argument will be upgraded to an RV. That RV will be modified to point to
8541 the new SV. The C<classname> argument indicates the package for the
8542 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8543 will have a reference count of 1, and the RV will be returned.
8549 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8551 sv_setiv(newSVrv(rv,classname), iv);
8556 =for apidoc sv_setref_uv
8558 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8559 argument will be upgraded to an RV. That RV will be modified to point to
8560 the new SV. The C<classname> argument indicates the package for the
8561 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8562 will have a reference count of 1, and the RV will be returned.
8568 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8570 sv_setuv(newSVrv(rv,classname), uv);
8575 =for apidoc sv_setref_nv
8577 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8578 argument will be upgraded to an RV. That RV will be modified to point to
8579 the new 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.
8587 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8589 sv_setnv(newSVrv(rv,classname), nv);
8594 =for apidoc sv_setref_pvn
8596 Copies a string into a new SV, optionally blessing the SV. The length of the
8597 string must be specified with C<n>. The C<rv> argument will be upgraded to
8598 an RV. That RV will be modified to point to the new SV. The C<classname>
8599 argument indicates the package for the blessing. Set C<classname> to
8600 C<Nullch> to avoid the blessing. The new SV will have a reference count
8601 of 1, and the RV will be returned.
8603 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8609 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8611 sv_setpvn(newSVrv(rv,classname), pv, n);
8616 =for apidoc sv_bless
8618 Blesses an SV into a specified package. The SV must be an RV. The package
8619 must be designated by its stash (see C<gv_stashpv()>). The reference count
8620 of the SV is unaffected.
8626 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8630 Perl_croak(aTHX_ "Can't bless non-reference value");
8632 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8633 if (SvREADONLY(tmpRef))
8634 Perl_croak(aTHX_ PL_no_modify);
8635 if (SvOBJECT(tmpRef)) {
8636 if (SvTYPE(tmpRef) != SVt_PVIO)
8638 SvREFCNT_dec(SvSTASH(tmpRef));
8641 SvOBJECT_on(tmpRef);
8642 if (SvTYPE(tmpRef) != SVt_PVIO)
8644 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8645 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8652 if(SvSMAGICAL(tmpRef))
8653 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8661 /* Downgrades a PVGV to a PVMG.
8665 S_sv_unglob(pTHX_ SV *sv)
8669 assert(SvTYPE(sv) == SVt_PVGV);
8674 SvREFCNT_dec(GvSTASH(sv));
8675 GvSTASH(sv) = Nullhv;
8677 sv_unmagic(sv, PERL_MAGIC_glob);
8678 Safefree(GvNAME(sv));
8681 /* need to keep SvANY(sv) in the right arena */
8682 xpvmg = new_XPVMG();
8683 StructCopy(SvANY(sv), xpvmg, XPVMG);
8684 del_XPVGV(SvANY(sv));
8687 SvFLAGS(sv) &= ~SVTYPEMASK;
8688 SvFLAGS(sv) |= SVt_PVMG;
8692 =for apidoc sv_unref_flags
8694 Unsets the RV status of the SV, and decrements the reference count of
8695 whatever was being referenced by the RV. This can almost be thought of
8696 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8697 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8698 (otherwise the decrementing is conditional on the reference count being
8699 different from one or the reference being a readonly SV).
8706 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8710 if (SvWEAKREF(sv)) {
8718 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8719 assigned to as BEGIN {$a = \"Foo"} will fail. */
8720 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8722 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8723 sv_2mortal(rv); /* Schedule for freeing later */
8727 =for apidoc sv_unref
8729 Unsets the RV status of the SV, and decrements the reference count of
8730 whatever was being referenced by the RV. This can almost be thought of
8731 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8732 being zero. See C<SvROK_off>.
8738 Perl_sv_unref(pTHX_ SV *sv)
8740 sv_unref_flags(sv, 0);
8744 =for apidoc sv_taint
8746 Taint an SV. Use C<SvTAINTED_on> instead.
8751 Perl_sv_taint(pTHX_ SV *sv)
8753 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8757 =for apidoc sv_untaint
8759 Untaint an SV. Use C<SvTAINTED_off> instead.
8764 Perl_sv_untaint(pTHX_ SV *sv)
8766 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8767 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8774 =for apidoc sv_tainted
8776 Test an SV for taintedness. Use C<SvTAINTED> instead.
8781 Perl_sv_tainted(pTHX_ SV *sv)
8783 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8784 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8785 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8792 =for apidoc sv_setpviv
8794 Copies an integer into the given SV, also updating its string value.
8795 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8801 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8803 char buf[TYPE_CHARS(UV)];
8805 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8807 sv_setpvn(sv, ptr, ebuf - ptr);
8811 =for apidoc sv_setpviv_mg
8813 Like C<sv_setpviv>, but also handles 'set' magic.
8819 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8821 char buf[TYPE_CHARS(UV)];
8823 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8825 sv_setpvn(sv, ptr, ebuf - ptr);
8829 #if defined(PERL_IMPLICIT_CONTEXT)
8831 /* pTHX_ magic can't cope with varargs, so this is a no-context
8832 * version of the main function, (which may itself be aliased to us).
8833 * Don't access this version directly.
8837 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8841 va_start(args, pat);
8842 sv_vsetpvf(sv, pat, &args);
8846 /* pTHX_ magic can't cope with varargs, so this is a no-context
8847 * version of the main function, (which may itself be aliased to us).
8848 * Don't access this version directly.
8852 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8856 va_start(args, pat);
8857 sv_vsetpvf_mg(sv, pat, &args);
8863 =for apidoc sv_setpvf
8865 Works like C<sv_catpvf> but copies the text into the SV instead of
8866 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8872 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8875 va_start(args, pat);
8876 sv_vsetpvf(sv, pat, &args);
8881 =for apidoc sv_vsetpvf
8883 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8884 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8886 Usually used via its frontend C<sv_setpvf>.
8892 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8894 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8898 =for apidoc sv_setpvf_mg
8900 Like C<sv_setpvf>, but also handles 'set' magic.
8906 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8909 va_start(args, pat);
8910 sv_vsetpvf_mg(sv, pat, &args);
8915 =for apidoc sv_vsetpvf_mg
8917 Like C<sv_vsetpvf>, but also handles 'set' magic.
8919 Usually used via its frontend C<sv_setpvf_mg>.
8925 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8927 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8931 #if defined(PERL_IMPLICIT_CONTEXT)
8933 /* pTHX_ magic can't cope with varargs, so this is a no-context
8934 * version of the main function, (which may itself be aliased to us).
8935 * Don't access this version directly.
8939 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8943 va_start(args, pat);
8944 sv_vcatpvf(sv, pat, &args);
8948 /* pTHX_ magic can't cope with varargs, so this is a no-context
8949 * version of the main function, (which may itself be aliased to us).
8950 * Don't access this version directly.
8954 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8958 va_start(args, pat);
8959 sv_vcatpvf_mg(sv, pat, &args);
8965 =for apidoc sv_catpvf
8967 Processes its arguments like C<sprintf> and appends the formatted
8968 output to an SV. If the appended data contains "wide" characters
8969 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8970 and characters >255 formatted with %c), the original SV might get
8971 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8972 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8973 valid UTF-8; if the original SV was bytes, the pattern should be too.
8978 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8981 va_start(args, pat);
8982 sv_vcatpvf(sv, pat, &args);
8987 =for apidoc sv_vcatpvf
8989 Processes its arguments like C<vsprintf> and appends the formatted output
8990 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8992 Usually used via its frontend C<sv_catpvf>.
8998 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9000 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9004 =for apidoc sv_catpvf_mg
9006 Like C<sv_catpvf>, but also handles 'set' magic.
9012 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9015 va_start(args, pat);
9016 sv_vcatpvf_mg(sv, pat, &args);
9021 =for apidoc sv_vcatpvf_mg
9023 Like C<sv_vcatpvf>, but also handles 'set' magic.
9025 Usually used via its frontend C<sv_catpvf_mg>.
9031 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9033 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9038 =for apidoc sv_vsetpvfn
9040 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9043 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9049 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9051 sv_setpvn(sv, "", 0);
9052 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9055 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9058 S_expect_number(pTHX_ char** pattern)
9061 switch (**pattern) {
9062 case '1': case '2': case '3':
9063 case '4': case '5': case '6':
9064 case '7': case '8': case '9':
9065 while (isDIGIT(**pattern))
9066 var = var * 10 + (*(*pattern)++ - '0');
9070 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9073 F0convert(NV nv, char *endbuf, STRLEN *len)
9084 if (uv & 1 && uv == nv)
9085 uv--; /* Round to even */
9087 unsigned dig = uv % 10;
9100 =for apidoc sv_vcatpvfn
9102 Processes its arguments like C<vsprintf> and appends the formatted output
9103 to an SV. Uses an array of SVs if the C style variable argument list is
9104 missing (NULL). When running with taint checks enabled, indicates via
9105 C<maybe_tainted> if results are untrustworthy (often due to the use of
9108 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9113 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9116 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9123 static const char nullstr[] = "(null)";
9125 bool has_utf8; /* has the result utf8? */
9126 bool pat_utf8; /* the pattern is in utf8? */
9128 /* Times 4: a decimal digit takes more than 3 binary digits.
9129 * NV_DIG: mantissa takes than many decimal digits.
9130 * Plus 32: Playing safe. */
9131 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9132 /* large enough for "%#.#f" --chip */
9133 /* what about long double NVs? --jhi */
9135 has_utf8 = pat_utf8 = DO_UTF8(sv);
9137 /* no matter what, this is a string now */
9138 (void)SvPV_force(sv, origlen);
9140 /* special-case "", "%s", and "%_" */
9143 if (patlen == 2 && pat[0] == '%') {
9147 const char *s = va_arg(*args, char*);
9148 sv_catpv(sv, s ? s : nullstr);
9150 else if (svix < svmax) {
9151 sv_catsv(sv, *svargs);
9152 if (DO_UTF8(*svargs))
9158 argsv = va_arg(*args, SV*);
9159 sv_catsv(sv, argsv);
9164 /* See comment on '_' below */
9169 #ifndef USE_LONG_DOUBLE
9170 /* special-case "%.<number>[gf]" */
9171 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9172 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9173 unsigned digits = 0;
9177 while (*pp >= '0' && *pp <= '9')
9178 digits = 10 * digits + (*pp++ - '0');
9179 if (pp - pat == (int)patlen - 1) {
9183 nv = (NV)va_arg(*args, double);
9184 else if (svix < svmax)
9189 /* Add check for digits != 0 because it seems that some
9190 gconverts are buggy in this case, and we don't yet have
9191 a Configure test for this. */
9192 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9193 /* 0, point, slack */
9194 Gconvert(nv, (int)digits, 0, ebuf);
9196 if (*ebuf) /* May return an empty string for digits==0 */
9199 } else if (!digits) {
9202 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9203 sv_catpvn(sv, p, l);
9209 #endif /* !USE_LONG_DOUBLE */
9211 if (!args && svix < svmax && DO_UTF8(*svargs))
9214 patend = (char*)pat + patlen;
9215 for (p = (char*)pat; p < patend; p = q) {
9218 bool vectorize = FALSE;
9219 bool vectorarg = FALSE;
9220 bool vec_utf8 = FALSE;
9226 bool has_precis = FALSE;
9229 bool is_utf8 = FALSE; /* is this item utf8? */
9230 #ifdef HAS_LDBL_SPRINTF_BUG
9231 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9232 with sfio - Allen <allens@cpan.org> */
9233 bool fix_ldbl_sprintf_bug = FALSE;
9237 U8 utf8buf[UTF8_MAXBYTES+1];
9238 STRLEN esignlen = 0;
9240 char *eptr = Nullch;
9243 U8 *vecstr = Null(U8*);
9250 /* we need a long double target in case HAS_LONG_DOUBLE but
9253 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9261 const char *dotstr = ".";
9262 STRLEN dotstrlen = 1;
9263 I32 efix = 0; /* explicit format parameter index */
9264 I32 ewix = 0; /* explicit width index */
9265 I32 epix = 0; /* explicit precision index */
9266 I32 evix = 0; /* explicit vector index */
9267 bool asterisk = FALSE;
9269 /* echo everything up to the next format specification */
9270 for (q = p; q < patend && *q != '%'; ++q) ;
9272 if (has_utf8 && !pat_utf8)
9273 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9275 sv_catpvn(sv, p, q - p);
9282 We allow format specification elements in this order:
9283 \d+\$ explicit format parameter index
9285 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9286 0 flag (as above): repeated to allow "v02"
9287 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9288 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9290 [%bcdefginopsux_DFOUX] format (mandatory)
9292 if (EXPECT_NUMBER(q, width)) {
9333 if (EXPECT_NUMBER(q, ewix))
9342 if ((vectorarg = asterisk)) {
9354 EXPECT_NUMBER(q, width);
9359 vecsv = va_arg(*args, SV*);
9361 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9362 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9363 dotstr = SvPVx(vecsv, dotstrlen);
9368 vecsv = va_arg(*args, SV*);
9369 vecstr = (U8*)SvPVx(vecsv,veclen);
9370 vec_utf8 = DO_UTF8(vecsv);
9372 else if (efix ? efix <= svmax : svix < svmax) {
9373 vecsv = svargs[efix ? efix-1 : svix++];
9374 vecstr = (U8*)SvPVx(vecsv,veclen);
9375 vec_utf8 = DO_UTF8(vecsv);
9376 /* if this is a version object, we need to return the
9377 * stringified representation (which the SvPVX has
9378 * already done for us), but not vectorize the args
9380 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9382 q++; /* skip past the rest of the %vd format */
9383 eptr = (char *) vecstr;
9384 elen = strlen(eptr);
9397 i = va_arg(*args, int);
9399 i = (ewix ? ewix <= svmax : svix < svmax) ?
9400 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9402 width = (i < 0) ? -i : i;
9412 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9414 /* XXX: todo, support specified precision parameter */
9418 i = va_arg(*args, int);
9420 i = (ewix ? ewix <= svmax : svix < svmax)
9421 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9422 precis = (i < 0) ? 0 : i;
9427 precis = precis * 10 + (*q++ - '0');
9436 case 'I': /* Ix, I32x, and I64x */
9438 if (q[1] == '6' && q[2] == '4') {
9444 if (q[1] == '3' && q[2] == '2') {
9454 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9465 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9466 if (*(q + 1) == 'l') { /* lld, llf */
9491 argsv = (efix ? efix <= svmax : svix < svmax) ?
9492 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9499 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9501 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9503 eptr = (char*)utf8buf;
9504 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9515 if (args && !vectorize) {
9516 eptr = va_arg(*args, char*);
9518 #ifdef MACOS_TRADITIONAL
9519 /* On MacOS, %#s format is used for Pascal strings */
9524 elen = strlen(eptr);
9526 eptr = (char *)nullstr;
9527 elen = sizeof nullstr - 1;
9531 eptr = SvPVx(argsv, elen);
9532 if (DO_UTF8(argsv)) {
9533 if (has_precis && precis < elen) {
9535 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9538 if (width) { /* fudge width (can't fudge elen) */
9539 width += elen - sv_len_utf8(argsv);
9551 * The "%_" hack might have to be changed someday,
9552 * if ISO or ANSI decide to use '_' for something.
9553 * So we keep it hidden from users' code.
9555 if (!args || vectorize)
9557 argsv = va_arg(*args, SV*);
9558 eptr = SvPVx(argsv, elen);
9564 if (has_precis && elen > precis)
9575 goto format_sv; /* %-p -> %_ */
9579 goto format_sv; /* %-Np -> %.N_ */
9582 if (alt || vectorize)
9584 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9602 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9611 esignbuf[esignlen++] = plus;
9615 case 'h': iv = (short)va_arg(*args, int); break;
9616 case 'l': iv = va_arg(*args, long); break;
9617 case 'V': iv = va_arg(*args, IV); break;
9618 default: iv = va_arg(*args, int); break;
9620 case 'q': iv = va_arg(*args, Quad_t); break;
9625 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9627 case 'h': iv = (short)tiv; break;
9628 case 'l': iv = (long)tiv; break;
9630 default: iv = tiv; break;
9632 case 'q': iv = (Quad_t)tiv; break;
9636 if ( !vectorize ) /* we already set uv above */
9641 esignbuf[esignlen++] = plus;
9645 esignbuf[esignlen++] = '-';
9688 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9699 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9700 case 'l': uv = va_arg(*args, unsigned long); break;
9701 case 'V': uv = va_arg(*args, UV); break;
9702 default: uv = va_arg(*args, unsigned); break;
9704 case 'q': uv = va_arg(*args, Uquad_t); break;
9709 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9711 case 'h': uv = (unsigned short)tuv; break;
9712 case 'l': uv = (unsigned long)tuv; break;
9714 default: uv = tuv; break;
9716 case 'q': uv = (Uquad_t)tuv; break;
9722 eptr = ebuf + sizeof ebuf;
9728 p = (char*)((c == 'X')
9729 ? "0123456789ABCDEF" : "0123456789abcdef");
9735 esignbuf[esignlen++] = '0';
9736 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9742 *--eptr = '0' + dig;
9744 if (alt && *eptr != '0')
9750 *--eptr = '0' + dig;
9753 esignbuf[esignlen++] = '0';
9754 esignbuf[esignlen++] = 'b';
9757 default: /* it had better be ten or less */
9760 *--eptr = '0' + dig;
9761 } while (uv /= base);
9764 elen = (ebuf + sizeof ebuf) - eptr;
9767 zeros = precis - elen;
9768 else if (precis == 0 && elen == 1 && *eptr == '0')
9773 /* FLOATING POINT */
9776 c = 'f'; /* maybe %F isn't supported here */
9782 /* This is evil, but floating point is even more evil */
9784 /* for SV-style calling, we can only get NV
9785 for C-style calling, we assume %f is double;
9786 for simplicity we allow any of %Lf, %llf, %qf for long double
9790 #if defined(USE_LONG_DOUBLE)
9794 /* [perl #20339] - we should accept and ignore %lf rather than die */
9798 #if defined(USE_LONG_DOUBLE)
9799 intsize = args ? 0 : 'q';
9803 #if defined(HAS_LONG_DOUBLE)
9812 /* now we need (long double) if intsize == 'q', else (double) */
9813 nv = (args && !vectorize) ?
9814 #if LONG_DOUBLESIZE > DOUBLESIZE
9816 va_arg(*args, long double) :
9817 va_arg(*args, double)
9819 va_arg(*args, double)
9825 if (c != 'e' && c != 'E') {
9827 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9828 will cast our (long double) to (double) */
9829 (void)Perl_frexp(nv, &i);
9830 if (i == PERL_INT_MIN)
9831 Perl_die(aTHX_ "panic: frexp");
9833 need = BIT_DIGITS(i);
9835 need += has_precis ? precis : 6; /* known default */
9840 #ifdef HAS_LDBL_SPRINTF_BUG
9841 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9842 with sfio - Allen <allens@cpan.org> */
9845 # define MY_DBL_MAX DBL_MAX
9846 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9847 # if DOUBLESIZE >= 8
9848 # define MY_DBL_MAX 1.7976931348623157E+308L
9850 # define MY_DBL_MAX 3.40282347E+38L
9854 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9855 # define MY_DBL_MAX_BUG 1L
9857 # define MY_DBL_MAX_BUG MY_DBL_MAX
9861 # define MY_DBL_MIN DBL_MIN
9862 # else /* XXX guessing! -Allen */
9863 # if DOUBLESIZE >= 8
9864 # define MY_DBL_MIN 2.2250738585072014E-308L
9866 # define MY_DBL_MIN 1.17549435E-38L
9870 if ((intsize == 'q') && (c == 'f') &&
9871 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9873 /* it's going to be short enough that
9874 * long double precision is not needed */
9876 if ((nv <= 0L) && (nv >= -0L))
9877 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9879 /* would use Perl_fp_class as a double-check but not
9880 * functional on IRIX - see perl.h comments */
9882 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9883 /* It's within the range that a double can represent */
9884 #if defined(DBL_MAX) && !defined(DBL_MIN)
9885 if ((nv >= ((long double)1/DBL_MAX)) ||
9886 (nv <= (-(long double)1/DBL_MAX)))
9888 fix_ldbl_sprintf_bug = TRUE;
9891 if (fix_ldbl_sprintf_bug == TRUE) {
9901 # undef MY_DBL_MAX_BUG
9904 #endif /* HAS_LDBL_SPRINTF_BUG */
9906 need += 20; /* fudge factor */
9907 if (PL_efloatsize < need) {
9908 Safefree(PL_efloatbuf);
9909 PL_efloatsize = need + 20; /* more fudge */
9910 New(906, PL_efloatbuf, PL_efloatsize, char);
9911 PL_efloatbuf[0] = '\0';
9914 if ( !(width || left || plus || alt) && fill != '0'
9915 && has_precis && intsize != 'q' ) { /* Shortcuts */
9916 /* See earlier comment about buggy Gconvert when digits,
9918 if ( c == 'g' && precis) {
9919 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9920 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9921 goto float_converted;
9922 } else if ( c == 'f' && !precis) {
9923 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9927 eptr = ebuf + sizeof ebuf;
9930 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9931 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9932 if (intsize == 'q') {
9933 /* Copy the one or more characters in a long double
9934 * format before the 'base' ([efgEFG]) character to
9935 * the format string. */
9936 static char const prifldbl[] = PERL_PRIfldbl;
9937 char const *p = prifldbl + sizeof(prifldbl) - 3;
9938 while (p >= prifldbl) { *--eptr = *p--; }
9943 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9948 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9960 /* No taint. Otherwise we are in the strange situation
9961 * where printf() taints but print($float) doesn't.
9963 #if defined(HAS_LONG_DOUBLE)
9965 (void)sprintf(PL_efloatbuf, eptr, nv);
9967 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9969 (void)sprintf(PL_efloatbuf, eptr, nv);
9972 eptr = PL_efloatbuf;
9973 elen = strlen(PL_efloatbuf);
9979 i = SvCUR(sv) - origlen;
9980 if (args && !vectorize) {
9982 case 'h': *(va_arg(*args, short*)) = i; break;
9983 default: *(va_arg(*args, int*)) = i; break;
9984 case 'l': *(va_arg(*args, long*)) = i; break;
9985 case 'V': *(va_arg(*args, IV*)) = i; break;
9987 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9992 sv_setuv_mg(argsv, (UV)i);
9994 continue; /* not "break" */
10000 if (!args && ckWARN(WARN_PRINTF) &&
10001 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10002 SV *msg = sv_newmortal();
10003 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10004 (PL_op->op_type == OP_PRTF) ? "" : "s");
10007 Perl_sv_catpvf(aTHX_ msg,
10008 "\"%%%c\"", c & 0xFF);
10010 Perl_sv_catpvf(aTHX_ msg,
10011 "\"%%\\%03"UVof"\"",
10014 sv_catpv(msg, "end of string");
10015 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10018 /* output mangled stuff ... */
10024 /* ... right here, because formatting flags should not apply */
10025 SvGROW(sv, SvCUR(sv) + elen + 1);
10027 Copy(eptr, p, elen, char);
10030 SvCUR_set(sv, p - SvPVX(sv));
10032 continue; /* not "break" */
10035 /* calculate width before utf8_upgrade changes it */
10036 have = esignlen + zeros + elen;
10038 if (is_utf8 != has_utf8) {
10041 sv_utf8_upgrade(sv);
10044 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10045 sv_utf8_upgrade(nsv);
10049 SvGROW(sv, SvCUR(sv) + elen + 1);
10054 need = (have > width ? have : width);
10057 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10059 if (esignlen && fill == '0') {
10060 for (i = 0; i < (int)esignlen; i++)
10061 *p++ = esignbuf[i];
10063 if (gap && !left) {
10064 memset(p, fill, gap);
10067 if (esignlen && fill != '0') {
10068 for (i = 0; i < (int)esignlen; i++)
10069 *p++ = esignbuf[i];
10072 for (i = zeros; i; i--)
10076 Copy(eptr, p, elen, char);
10080 memset(p, ' ', gap);
10085 Copy(dotstr, p, dotstrlen, char);
10089 vectorize = FALSE; /* done iterating over vecstr */
10096 SvCUR_set(sv, p - SvPVX(sv));
10104 /* =========================================================================
10106 =head1 Cloning an interpreter
10108 All the macros and functions in this section are for the private use of
10109 the main function, perl_clone().
10111 The foo_dup() functions make an exact copy of an existing foo thinngy.
10112 During the course of a cloning, a hash table is used to map old addresses
10113 to new addresses. The table is created and manipulated with the
10114 ptr_table_* functions.
10118 ============================================================================*/
10121 #if defined(USE_ITHREADS)
10123 #ifndef GpREFCNT_inc
10124 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10128 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10129 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10130 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10131 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10132 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10133 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10134 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10135 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10136 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10137 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10138 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10139 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10140 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10143 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10144 regcomp.c. AMS 20010712 */
10147 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10152 struct reg_substr_datum *s;
10155 return (REGEXP *)NULL;
10157 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10160 len = r->offsets[0];
10161 npar = r->nparens+1;
10163 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10164 Copy(r->program, ret->program, len+1, regnode);
10166 New(0, ret->startp, npar, I32);
10167 Copy(r->startp, ret->startp, npar, I32);
10168 New(0, ret->endp, npar, I32);
10169 Copy(r->startp, ret->startp, npar, I32);
10171 New(0, ret->substrs, 1, struct reg_substr_data);
10172 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10173 s->min_offset = r->substrs->data[i].min_offset;
10174 s->max_offset = r->substrs->data[i].max_offset;
10175 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10176 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10179 ret->regstclass = NULL;
10181 struct reg_data *d;
10182 const int count = r->data->count;
10184 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10185 char, struct reg_data);
10186 New(0, d->what, count, U8);
10189 for (i = 0; i < count; i++) {
10190 d->what[i] = r->data->what[i];
10191 switch (d->what[i]) {
10192 /* legal options are one of: sfpont
10193 see also regcomp.h and pregfree() */
10195 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10198 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10201 /* This is cheating. */
10202 New(0, d->data[i], 1, struct regnode_charclass_class);
10203 StructCopy(r->data->data[i], d->data[i],
10204 struct regnode_charclass_class);
10205 ret->regstclass = (regnode*)d->data[i];
10208 /* Compiled op trees are readonly, and can thus be
10209 shared without duplication. */
10211 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10215 d->data[i] = r->data->data[i];
10218 d->data[i] = r->data->data[i];
10220 ((reg_trie_data*)d->data[i])->refcount++;
10224 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10233 New(0, ret->offsets, 2*len+1, U32);
10234 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10236 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10237 ret->refcnt = r->refcnt;
10238 ret->minlen = r->minlen;
10239 ret->prelen = r->prelen;
10240 ret->nparens = r->nparens;
10241 ret->lastparen = r->lastparen;
10242 ret->lastcloseparen = r->lastcloseparen;
10243 ret->reganch = r->reganch;
10245 ret->sublen = r->sublen;
10247 if (RX_MATCH_COPIED(ret))
10248 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10250 ret->subbeg = Nullch;
10251 #ifdef PERL_COPY_ON_WRITE
10252 ret->saved_copy = Nullsv;
10255 ptr_table_store(PL_ptr_table, r, ret);
10259 /* duplicate a file handle */
10262 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10268 return (PerlIO*)NULL;
10270 /* look for it in the table first */
10271 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10275 /* create anew and remember what it is */
10276 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10277 ptr_table_store(PL_ptr_table, fp, ret);
10281 /* duplicate a directory handle */
10284 Perl_dirp_dup(pTHX_ DIR *dp)
10292 /* duplicate a typeglob */
10295 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10300 /* look for it in the table first */
10301 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10305 /* create anew and remember what it is */
10306 Newz(0, ret, 1, GP);
10307 ptr_table_store(PL_ptr_table, gp, ret);
10310 ret->gp_refcnt = 0; /* must be before any other dups! */
10311 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10312 ret->gp_io = io_dup_inc(gp->gp_io, param);
10313 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10314 ret->gp_av = av_dup_inc(gp->gp_av, param);
10315 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10316 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10317 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10318 ret->gp_cvgen = gp->gp_cvgen;
10319 ret->gp_flags = gp->gp_flags;
10320 ret->gp_line = gp->gp_line;
10321 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10325 /* duplicate a chain of magic */
10328 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10330 MAGIC *mgprev = (MAGIC*)NULL;
10333 return (MAGIC*)NULL;
10334 /* look for it in the table first */
10335 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10339 for (; mg; mg = mg->mg_moremagic) {
10341 Newz(0, nmg, 1, MAGIC);
10343 mgprev->mg_moremagic = nmg;
10346 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10347 nmg->mg_private = mg->mg_private;
10348 nmg->mg_type = mg->mg_type;
10349 nmg->mg_flags = mg->mg_flags;
10350 if (mg->mg_type == PERL_MAGIC_qr) {
10351 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10353 else if(mg->mg_type == PERL_MAGIC_backref) {
10354 const AV * const av = (AV*) mg->mg_obj;
10357 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10359 for (i = AvFILLp(av); i >= 0; i--) {
10360 if (!svp[i]) continue;
10361 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10365 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10366 ? sv_dup_inc(mg->mg_obj, param)
10367 : sv_dup(mg->mg_obj, param);
10369 nmg->mg_len = mg->mg_len;
10370 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10371 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10372 if (mg->mg_len > 0) {
10373 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10374 if (mg->mg_type == PERL_MAGIC_overload_table &&
10375 AMT_AMAGIC((AMT*)mg->mg_ptr))
10377 AMT *amtp = (AMT*)mg->mg_ptr;
10378 AMT *namtp = (AMT*)nmg->mg_ptr;
10380 for (i = 1; i < NofAMmeth; i++) {
10381 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10385 else if (mg->mg_len == HEf_SVKEY)
10386 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10388 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10389 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10396 /* create a new pointer-mapping table */
10399 Perl_ptr_table_new(pTHX)
10402 Newz(0, tbl, 1, PTR_TBL_t);
10403 tbl->tbl_max = 511;
10404 tbl->tbl_items = 0;
10405 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10410 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10412 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10415 /* map an existing pointer using a table */
10418 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10420 PTR_TBL_ENT_t *tblent;
10421 UV hash = PTR_TABLE_HASH(sv);
10423 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10424 for (; tblent; tblent = tblent->next) {
10425 if (tblent->oldval == sv)
10426 return tblent->newval;
10428 return (void*)NULL;
10431 /* add a new entry to a pointer-mapping table */
10434 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10436 PTR_TBL_ENT_t *tblent, **otblent;
10437 /* XXX this may be pessimal on platforms where pointers aren't good
10438 * hash values e.g. if they grow faster in the most significant
10440 UV hash = PTR_TABLE_HASH(oldv);
10444 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10445 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10446 if (tblent->oldval == oldv) {
10447 tblent->newval = newv;
10451 Newz(0, tblent, 1, PTR_TBL_ENT_t);
10452 tblent->oldval = oldv;
10453 tblent->newval = newv;
10454 tblent->next = *otblent;
10457 if (!empty && tbl->tbl_items > tbl->tbl_max)
10458 ptr_table_split(tbl);
10461 /* double the hash bucket size of an existing ptr table */
10464 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10466 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10467 UV oldsize = tbl->tbl_max + 1;
10468 UV newsize = oldsize * 2;
10471 Renew(ary, newsize, PTR_TBL_ENT_t*);
10472 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10473 tbl->tbl_max = --newsize;
10474 tbl->tbl_ary = ary;
10475 for (i=0; i < oldsize; i++, ary++) {
10476 PTR_TBL_ENT_t **curentp, **entp, *ent;
10479 curentp = ary + oldsize;
10480 for (entp = ary, ent = *ary; ent; ent = *entp) {
10481 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10483 ent->next = *curentp;
10493 /* remove all the entries from a ptr table */
10496 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10498 register PTR_TBL_ENT_t **array;
10499 register PTR_TBL_ENT_t *entry;
10500 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10504 if (!tbl || !tbl->tbl_items) {
10508 array = tbl->tbl_ary;
10510 max = tbl->tbl_max;
10515 entry = entry->next;
10519 if (++riter > max) {
10522 entry = array[riter];
10526 tbl->tbl_items = 0;
10529 /* clear and free a ptr table */
10532 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10537 ptr_table_clear(tbl);
10538 Safefree(tbl->tbl_ary);
10542 /* attempt to make everything in the typeglob readonly */
10545 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10547 GV *gv = (GV*)sstr;
10548 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10550 if (GvIO(gv) || GvFORM(gv)) {
10551 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10553 else if (!GvCV(gv)) {
10554 GvCV(gv) = (CV*)sv;
10557 /* CvPADLISTs cannot be shared */
10558 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10563 if (!GvUNIQUE(gv)) {
10565 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10566 HvNAME(GvSTASH(gv)), GvNAME(gv));
10572 * write attempts will die with
10573 * "Modification of a read-only value attempted"
10579 SvREADONLY_on(GvSV(gv));
10583 GvAV(gv) = (AV*)sv;
10586 SvREADONLY_on(GvAV(gv));
10590 GvHV(gv) = (HV*)sv;
10593 SvREADONLY_on(GvHV(gv));
10596 return sstr; /* he_dup() will SvREFCNT_inc() */
10599 /* duplicate an SV of any type (including AV, HV etc) */
10602 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10605 SvRV_set(dstr, SvWEAKREF(sstr)
10606 ? sv_dup(SvRV(sstr), param)
10607 : sv_dup_inc(SvRV(sstr), param));
10610 else if (SvPVX(sstr)) {
10611 /* Has something there */
10613 /* Normal PV - clone whole allocated space */
10614 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
10615 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10616 /* Not that normal - actually sstr is copy on write.
10617 But we are a true, independant SV, so: */
10618 SvREADONLY_off(dstr);
10623 /* Special case - not normally malloced for some reason */
10624 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10625 /* A "shared" PV - clone it as unshared string */
10626 if(SvPADTMP(sstr)) {
10627 /* However, some of them live in the pad
10628 and they should not have these flags
10631 SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
10633 SvUV_set(dstr, SvUVX(sstr));
10636 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
10638 SvREADONLY_off(dstr);
10642 /* Some other special case - random pointer */
10643 SvPV_set(dstr, SvPVX(sstr));
10648 /* Copy the Null */
10649 if (SvTYPE(dstr) == SVt_RV)
10650 SvRV_set(dstr, NULL);
10657 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10662 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10664 /* look for it in the table first */
10665 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10669 if(param->flags & CLONEf_JOIN_IN) {
10670 /** We are joining here so we don't want do clone
10671 something that is bad **/
10673 if(SvTYPE(sstr) == SVt_PVHV &&
10675 /** don't clone stashes if they already exist **/
10676 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10677 return (SV*) old_stash;
10681 /* create anew and remember what it is */
10684 #ifdef DEBUG_LEAKING_SCALARS
10685 dstr->sv_debug_optype = sstr->sv_debug_optype;
10686 dstr->sv_debug_line = sstr->sv_debug_line;
10687 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10688 dstr->sv_debug_cloned = 1;
10690 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10692 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10696 ptr_table_store(PL_ptr_table, sstr, dstr);
10699 SvFLAGS(dstr) = SvFLAGS(sstr);
10700 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10701 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10704 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10705 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10706 PL_watch_pvx, SvPVX(sstr));
10709 /* don't clone objects whose class has asked us not to */
10710 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10711 SvFLAGS(dstr) &= ~SVTYPEMASK;
10712 SvOBJECT_off(dstr);
10716 switch (SvTYPE(sstr)) {
10718 SvANY(dstr) = NULL;
10721 SvANY(dstr) = new_XIV();
10722 SvIV_set(dstr, SvIVX(sstr));
10725 SvANY(dstr) = new_XNV();
10726 SvNV_set(dstr, SvNVX(sstr));
10729 SvANY(dstr) = new_XRV();
10730 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10733 SvANY(dstr) = new_XPV();
10734 SvCUR_set(dstr, SvCUR(sstr));
10735 SvLEN_set(dstr, SvLEN(sstr));
10736 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10739 SvANY(dstr) = new_XPVIV();
10740 SvCUR_set(dstr, SvCUR(sstr));
10741 SvLEN_set(dstr, SvLEN(sstr));
10742 SvIV_set(dstr, SvIVX(sstr));
10743 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10746 SvANY(dstr) = new_XPVNV();
10747 SvCUR_set(dstr, SvCUR(sstr));
10748 SvLEN_set(dstr, SvLEN(sstr));
10749 SvIV_set(dstr, SvIVX(sstr));
10750 SvNV_set(dstr, SvNVX(sstr));
10751 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10754 SvANY(dstr) = new_XPVMG();
10755 SvCUR_set(dstr, SvCUR(sstr));
10756 SvLEN_set(dstr, SvLEN(sstr));
10757 SvIV_set(dstr, SvIVX(sstr));
10758 SvNV_set(dstr, SvNVX(sstr));
10759 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10760 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10761 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10764 SvANY(dstr) = new_XPVBM();
10765 SvCUR_set(dstr, SvCUR(sstr));
10766 SvLEN_set(dstr, SvLEN(sstr));
10767 SvIV_set(dstr, SvIVX(sstr));
10768 SvNV_set(dstr, SvNVX(sstr));
10769 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10770 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10771 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10772 BmRARE(dstr) = BmRARE(sstr);
10773 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10774 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10777 SvANY(dstr) = new_XPVLV();
10778 SvCUR_set(dstr, SvCUR(sstr));
10779 SvLEN_set(dstr, SvLEN(sstr));
10780 SvIV_set(dstr, SvIVX(sstr));
10781 SvNV_set(dstr, SvNVX(sstr));
10782 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10783 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10784 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10785 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10786 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10787 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10788 LvTARG(dstr) = dstr;
10789 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10790 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10792 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10793 LvTYPE(dstr) = LvTYPE(sstr);
10796 if (GvUNIQUE((GV*)sstr)) {
10798 if ((share = gv_share(sstr, param))) {
10801 ptr_table_store(PL_ptr_table, sstr, dstr);
10803 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10804 HvNAME(GvSTASH(share)), GvNAME(share));
10809 SvANY(dstr) = new_XPVGV();
10810 SvCUR_set(dstr, SvCUR(sstr));
10811 SvLEN_set(dstr, SvLEN(sstr));
10812 SvIV_set(dstr, SvIVX(sstr));
10813 SvNV_set(dstr, SvNVX(sstr));
10814 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10815 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10816 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10817 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10818 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10819 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10820 GvFLAGS(dstr) = GvFLAGS(sstr);
10821 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10822 (void)GpREFCNT_inc(GvGP(dstr));
10825 SvANY(dstr) = new_XPVIO();
10826 SvCUR_set(dstr, SvCUR(sstr));
10827 SvLEN_set(dstr, SvLEN(sstr));
10828 SvIV_set(dstr, SvIVX(sstr));
10829 SvNV_set(dstr, SvNVX(sstr));
10830 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10831 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10832 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10833 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10834 if (IoOFP(sstr) == IoIFP(sstr))
10835 IoOFP(dstr) = IoIFP(dstr);
10837 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10838 /* PL_rsfp_filters entries have fake IoDIRP() */
10839 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10840 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10842 IoDIRP(dstr) = IoDIRP(sstr);
10843 IoLINES(dstr) = IoLINES(sstr);
10844 IoPAGE(dstr) = IoPAGE(sstr);
10845 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10846 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10847 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10848 /* I have no idea why fake dirp (rsfps)
10849 should be treaded differently but otherwise
10850 we end up with leaks -- sky*/
10851 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10852 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10853 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10855 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10856 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10857 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10859 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10860 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10861 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10862 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10863 IoTYPE(dstr) = IoTYPE(sstr);
10864 IoFLAGS(dstr) = IoFLAGS(sstr);
10867 SvANY(dstr) = new_XPVAV();
10868 SvCUR_set(dstr, SvCUR(sstr));
10869 SvLEN_set(dstr, SvLEN(sstr));
10870 SvIV_set(dstr, SvIVX(sstr));
10871 SvNV_set(dstr, SvNVX(sstr));
10872 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10873 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10874 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10875 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10876 if (AvARRAY((AV*)sstr)) {
10877 SV **dst_ary, **src_ary;
10878 SSize_t items = AvFILLp((AV*)sstr) + 1;
10880 src_ary = AvARRAY((AV*)sstr);
10881 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10882 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10883 SvPV_set(dstr, (char*)dst_ary);
10884 AvALLOC((AV*)dstr) = dst_ary;
10885 if (AvREAL((AV*)sstr)) {
10886 while (items-- > 0)
10887 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10890 while (items-- > 0)
10891 *dst_ary++ = sv_dup(*src_ary++, param);
10893 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10894 while (items-- > 0) {
10895 *dst_ary++ = &PL_sv_undef;
10899 SvPV_set(dstr, Nullch);
10900 AvALLOC((AV*)dstr) = (SV**)NULL;
10904 SvANY(dstr) = new_XPVHV();
10905 SvCUR_set(dstr, SvCUR(sstr));
10906 SvLEN_set(dstr, SvLEN(sstr));
10907 SvIV_set(dstr, SvIVX(sstr));
10908 SvNV_set(dstr, SvNVX(sstr));
10909 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10910 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10911 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10912 if (HvARRAY((HV*)sstr)) {
10914 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10915 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10916 Newz(0, dxhv->xhv_array,
10917 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10918 while (i <= sxhv->xhv_max) {
10919 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10920 (bool)!!HvSHAREKEYS(sstr),
10924 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10925 (bool)!!HvSHAREKEYS(sstr), param);
10928 SvPV_set(dstr, Nullch);
10929 HvEITER((HV*)dstr) = (HE*)NULL;
10931 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
10932 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
10933 /* Record stashes for possible cloning in Perl_clone(). */
10934 if(HvNAME((HV*)dstr))
10935 av_push(param->stashes, dstr);
10938 SvANY(dstr) = new_XPVFM();
10939 FmLINES(dstr) = FmLINES(sstr);
10943 SvANY(dstr) = new_XPVCV();
10945 SvCUR_set(dstr, SvCUR(sstr));
10946 SvLEN_set(dstr, SvLEN(sstr));
10947 SvIV_set(dstr, SvIVX(sstr));
10948 SvNV_set(dstr, SvNVX(sstr));
10949 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10950 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10951 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10952 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10953 CvSTART(dstr) = CvSTART(sstr);
10955 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10957 CvXSUB(dstr) = CvXSUB(sstr);
10958 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10959 if (CvCONST(sstr)) {
10960 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10961 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10962 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
10964 /* don't dup if copying back - CvGV isn't refcounted, so the
10965 * duped GV may never be freed. A bit of a hack! DAPM */
10966 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10967 Nullgv : gv_dup(CvGV(sstr), param) ;
10968 if (param->flags & CLONEf_COPY_STACKS) {
10969 CvDEPTH(dstr) = CvDEPTH(sstr);
10973 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10974 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10976 CvWEAKOUTSIDE(sstr)
10977 ? cv_dup( CvOUTSIDE(sstr), param)
10978 : cv_dup_inc(CvOUTSIDE(sstr), param);
10979 CvFLAGS(dstr) = CvFLAGS(sstr);
10980 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10983 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10987 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10993 /* duplicate a context */
10996 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10998 PERL_CONTEXT *ncxs;
11001 return (PERL_CONTEXT*)NULL;
11003 /* look for it in the table first */
11004 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11008 /* create anew and remember what it is */
11009 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11010 ptr_table_store(PL_ptr_table, cxs, ncxs);
11013 PERL_CONTEXT *cx = &cxs[ix];
11014 PERL_CONTEXT *ncx = &ncxs[ix];
11015 ncx->cx_type = cx->cx_type;
11016 if (CxTYPE(cx) == CXt_SUBST) {
11017 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11020 ncx->blk_oldsp = cx->blk_oldsp;
11021 ncx->blk_oldcop = cx->blk_oldcop;
11022 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11023 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11024 ncx->blk_oldpm = cx->blk_oldpm;
11025 ncx->blk_gimme = cx->blk_gimme;
11026 switch (CxTYPE(cx)) {
11028 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11029 ? cv_dup_inc(cx->blk_sub.cv, param)
11030 : cv_dup(cx->blk_sub.cv,param));
11031 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11032 ? av_dup_inc(cx->blk_sub.argarray, param)
11034 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11035 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11036 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11037 ncx->blk_sub.lval = cx->blk_sub.lval;
11038 ncx->blk_sub.retop = cx->blk_sub.retop;
11041 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11042 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11043 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11044 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11045 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11046 ncx->blk_eval.retop = cx->blk_eval.retop;
11049 ncx->blk_loop.label = cx->blk_loop.label;
11050 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11051 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11052 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11053 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11054 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11055 ? cx->blk_loop.iterdata
11056 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11057 ncx->blk_loop.oldcomppad
11058 = (PAD*)ptr_table_fetch(PL_ptr_table,
11059 cx->blk_loop.oldcomppad);
11060 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11061 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11062 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11063 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11064 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11067 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11068 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11069 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11070 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11071 ncx->blk_sub.retop = cx->blk_sub.retop;
11083 /* duplicate a stack info structure */
11086 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11091 return (PERL_SI*)NULL;
11093 /* look for it in the table first */
11094 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11098 /* create anew and remember what it is */
11099 Newz(56, nsi, 1, PERL_SI);
11100 ptr_table_store(PL_ptr_table, si, nsi);
11102 nsi->si_stack = av_dup_inc(si->si_stack, param);
11103 nsi->si_cxix = si->si_cxix;
11104 nsi->si_cxmax = si->si_cxmax;
11105 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11106 nsi->si_type = si->si_type;
11107 nsi->si_prev = si_dup(si->si_prev, param);
11108 nsi->si_next = si_dup(si->si_next, param);
11109 nsi->si_markoff = si->si_markoff;
11114 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11115 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11116 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11117 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11118 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11119 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11120 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11121 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11122 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11123 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11124 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11125 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11126 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11127 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11130 #define pv_dup_inc(p) SAVEPV(p)
11131 #define pv_dup(p) SAVEPV(p)
11132 #define svp_dup_inc(p,pp) any_dup(p,pp)
11134 /* map any object to the new equivent - either something in the
11135 * ptr table, or something in the interpreter structure
11139 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11144 return (void*)NULL;
11146 /* look for it in the table first */
11147 ret = ptr_table_fetch(PL_ptr_table, v);
11151 /* see if it is part of the interpreter structure */
11152 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11153 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11161 /* duplicate the save stack */
11164 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11166 ANY *ss = proto_perl->Tsavestack;
11167 I32 ix = proto_perl->Tsavestack_ix;
11168 I32 max = proto_perl->Tsavestack_max;
11181 void (*dptr) (void*);
11182 void (*dxptr) (pTHX_ void*);
11185 Newz(54, nss, max, ANY);
11189 TOPINT(nss,ix) = i;
11191 case SAVEt_ITEM: /* normal string */
11192 sv = (SV*)POPPTR(ss,ix);
11193 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11194 sv = (SV*)POPPTR(ss,ix);
11195 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11197 case SAVEt_SV: /* scalar reference */
11198 sv = (SV*)POPPTR(ss,ix);
11199 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11200 gv = (GV*)POPPTR(ss,ix);
11201 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11203 case SAVEt_GENERIC_PVREF: /* generic char* */
11204 c = (char*)POPPTR(ss,ix);
11205 TOPPTR(nss,ix) = pv_dup(c);
11206 ptr = POPPTR(ss,ix);
11207 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11209 case SAVEt_SHARED_PVREF: /* char* in shared space */
11210 c = (char*)POPPTR(ss,ix);
11211 TOPPTR(nss,ix) = savesharedpv(c);
11212 ptr = POPPTR(ss,ix);
11213 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11215 case SAVEt_GENERIC_SVREF: /* generic sv */
11216 case SAVEt_SVREF: /* scalar reference */
11217 sv = (SV*)POPPTR(ss,ix);
11218 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11219 ptr = POPPTR(ss,ix);
11220 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11222 case SAVEt_AV: /* array reference */
11223 av = (AV*)POPPTR(ss,ix);
11224 TOPPTR(nss,ix) = av_dup_inc(av, param);
11225 gv = (GV*)POPPTR(ss,ix);
11226 TOPPTR(nss,ix) = gv_dup(gv, param);
11228 case SAVEt_HV: /* hash reference */
11229 hv = (HV*)POPPTR(ss,ix);
11230 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11231 gv = (GV*)POPPTR(ss,ix);
11232 TOPPTR(nss,ix) = gv_dup(gv, param);
11234 case SAVEt_INT: /* int reference */
11235 ptr = POPPTR(ss,ix);
11236 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11237 intval = (int)POPINT(ss,ix);
11238 TOPINT(nss,ix) = intval;
11240 case SAVEt_LONG: /* long reference */
11241 ptr = POPPTR(ss,ix);
11242 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11243 longval = (long)POPLONG(ss,ix);
11244 TOPLONG(nss,ix) = longval;
11246 case SAVEt_I32: /* I32 reference */
11247 case SAVEt_I16: /* I16 reference */
11248 case SAVEt_I8: /* I8 reference */
11249 ptr = POPPTR(ss,ix);
11250 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11252 TOPINT(nss,ix) = i;
11254 case SAVEt_IV: /* IV reference */
11255 ptr = POPPTR(ss,ix);
11256 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11258 TOPIV(nss,ix) = iv;
11260 case SAVEt_SPTR: /* SV* reference */
11261 ptr = POPPTR(ss,ix);
11262 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11263 sv = (SV*)POPPTR(ss,ix);
11264 TOPPTR(nss,ix) = sv_dup(sv, param);
11266 case SAVEt_VPTR: /* random* reference */
11267 ptr = POPPTR(ss,ix);
11268 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11269 ptr = POPPTR(ss,ix);
11270 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11272 case SAVEt_PPTR: /* char* reference */
11273 ptr = POPPTR(ss,ix);
11274 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11275 c = (char*)POPPTR(ss,ix);
11276 TOPPTR(nss,ix) = pv_dup(c);
11278 case SAVEt_HPTR: /* HV* reference */
11279 ptr = POPPTR(ss,ix);
11280 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11281 hv = (HV*)POPPTR(ss,ix);
11282 TOPPTR(nss,ix) = hv_dup(hv, param);
11284 case SAVEt_APTR: /* AV* reference */
11285 ptr = POPPTR(ss,ix);
11286 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11287 av = (AV*)POPPTR(ss,ix);
11288 TOPPTR(nss,ix) = av_dup(av, param);
11291 gv = (GV*)POPPTR(ss,ix);
11292 TOPPTR(nss,ix) = gv_dup(gv, param);
11294 case SAVEt_GP: /* scalar reference */
11295 gp = (GP*)POPPTR(ss,ix);
11296 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11297 (void)GpREFCNT_inc(gp);
11298 gv = (GV*)POPPTR(ss,ix);
11299 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11300 c = (char*)POPPTR(ss,ix);
11301 TOPPTR(nss,ix) = pv_dup(c);
11303 TOPIV(nss,ix) = iv;
11305 TOPIV(nss,ix) = iv;
11308 case SAVEt_MORTALIZESV:
11309 sv = (SV*)POPPTR(ss,ix);
11310 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11313 ptr = POPPTR(ss,ix);
11314 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11315 /* these are assumed to be refcounted properly */
11316 switch (((OP*)ptr)->op_type) {
11318 case OP_LEAVESUBLV:
11322 case OP_LEAVEWRITE:
11323 TOPPTR(nss,ix) = ptr;
11328 TOPPTR(nss,ix) = Nullop;
11333 TOPPTR(nss,ix) = Nullop;
11336 c = (char*)POPPTR(ss,ix);
11337 TOPPTR(nss,ix) = pv_dup_inc(c);
11339 case SAVEt_CLEARSV:
11340 longval = POPLONG(ss,ix);
11341 TOPLONG(nss,ix) = longval;
11344 hv = (HV*)POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11346 c = (char*)POPPTR(ss,ix);
11347 TOPPTR(nss,ix) = pv_dup_inc(c);
11349 TOPINT(nss,ix) = i;
11351 case SAVEt_DESTRUCTOR:
11352 ptr = POPPTR(ss,ix);
11353 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11354 dptr = POPDPTR(ss,ix);
11355 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11357 case SAVEt_DESTRUCTOR_X:
11358 ptr = POPPTR(ss,ix);
11359 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11360 dxptr = POPDXPTR(ss,ix);
11361 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11363 case SAVEt_REGCONTEXT:
11366 TOPINT(nss,ix) = i;
11369 case SAVEt_STACK_POS: /* Position on Perl stack */
11371 TOPINT(nss,ix) = i;
11373 case SAVEt_AELEM: /* array element */
11374 sv = (SV*)POPPTR(ss,ix);
11375 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11377 TOPINT(nss,ix) = i;
11378 av = (AV*)POPPTR(ss,ix);
11379 TOPPTR(nss,ix) = av_dup_inc(av, param);
11381 case SAVEt_HELEM: /* hash element */
11382 sv = (SV*)POPPTR(ss,ix);
11383 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11384 sv = (SV*)POPPTR(ss,ix);
11385 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11386 hv = (HV*)POPPTR(ss,ix);
11387 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11390 ptr = POPPTR(ss,ix);
11391 TOPPTR(nss,ix) = ptr;
11395 TOPINT(nss,ix) = i;
11397 case SAVEt_COMPPAD:
11398 av = (AV*)POPPTR(ss,ix);
11399 TOPPTR(nss,ix) = av_dup(av, param);
11402 longval = (long)POPLONG(ss,ix);
11403 TOPLONG(nss,ix) = longval;
11404 ptr = POPPTR(ss,ix);
11405 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11406 sv = (SV*)POPPTR(ss,ix);
11407 TOPPTR(nss,ix) = sv_dup(sv, param);
11410 ptr = POPPTR(ss,ix);
11411 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11412 longval = (long)POPBOOL(ss,ix);
11413 TOPBOOL(nss,ix) = (bool)longval;
11415 case SAVEt_SET_SVFLAGS:
11417 TOPINT(nss,ix) = i;
11419 TOPINT(nss,ix) = i;
11420 sv = (SV*)POPPTR(ss,ix);
11421 TOPPTR(nss,ix) = sv_dup(sv, param);
11424 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11432 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11433 * flag to the result. This is done for each stash before cloning starts,
11434 * so we know which stashes want their objects cloned */
11437 do_mark_cloneable_stash(pTHX_ SV *sv)
11439 if (HvNAME((HV*)sv)) {
11440 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11441 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11442 if (cloner && GvCV(cloner)) {
11449 XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
11451 call_sv((SV*)GvCV(cloner), G_SCALAR);
11458 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11466 =for apidoc perl_clone
11468 Create and return a new interpreter by cloning the current one.
11470 perl_clone takes these flags as parameters:
11472 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11473 without it we only clone the data and zero the stacks,
11474 with it we copy the stacks and the new perl interpreter is
11475 ready to run at the exact same point as the previous one.
11476 The pseudo-fork code uses COPY_STACKS while the
11477 threads->new doesn't.
11479 CLONEf_KEEP_PTR_TABLE
11480 perl_clone keeps a ptr_table with the pointer of the old
11481 variable as a key and the new variable as a value,
11482 this allows it to check if something has been cloned and not
11483 clone it again but rather just use the value and increase the
11484 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11485 the ptr_table using the function
11486 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11487 reason to keep it around is if you want to dup some of your own
11488 variable who are outside the graph perl scans, example of this
11489 code is in threads.xs create
11492 This is a win32 thing, it is ignored on unix, it tells perls
11493 win32host code (which is c++) to clone itself, this is needed on
11494 win32 if you want to run two threads at the same time,
11495 if you just want to do some stuff in a separate perl interpreter
11496 and then throw it away and return to the original one,
11497 you don't need to do anything.
11502 /* XXX the above needs expanding by someone who actually understands it ! */
11503 EXTERN_C PerlInterpreter *
11504 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11507 perl_clone(PerlInterpreter *proto_perl, UV flags)
11510 #ifdef PERL_IMPLICIT_SYS
11512 /* perlhost.h so we need to call into it
11513 to clone the host, CPerlHost should have a c interface, sky */
11515 if (flags & CLONEf_CLONE_HOST) {
11516 return perl_clone_host(proto_perl,flags);
11518 return perl_clone_using(proto_perl, flags,
11520 proto_perl->IMemShared,
11521 proto_perl->IMemParse,
11523 proto_perl->IStdIO,
11527 proto_perl->IProc);
11531 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11532 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11533 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11534 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11535 struct IPerlDir* ipD, struct IPerlSock* ipS,
11536 struct IPerlProc* ipP)
11538 /* XXX many of the string copies here can be optimized if they're
11539 * constants; they need to be allocated as common memory and just
11540 * their pointers copied. */
11543 CLONE_PARAMS clone_params;
11544 CLONE_PARAMS* param = &clone_params;
11546 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11547 /* for each stash, determine whether its objects should be cloned */
11548 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11549 PERL_SET_THX(my_perl);
11552 Poison(my_perl, 1, PerlInterpreter);
11554 PL_curcop = (COP *)Nullop;
11558 PL_savestack_ix = 0;
11559 PL_savestack_max = -1;
11560 PL_sig_pending = 0;
11561 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11562 # else /* !DEBUGGING */
11563 Zero(my_perl, 1, PerlInterpreter);
11564 # endif /* DEBUGGING */
11566 /* host pointers */
11568 PL_MemShared = ipMS;
11569 PL_MemParse = ipMP;
11576 #else /* !PERL_IMPLICIT_SYS */
11578 CLONE_PARAMS clone_params;
11579 CLONE_PARAMS* param = &clone_params;
11580 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11581 /* for each stash, determine whether its objects should be cloned */
11582 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
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 */
11599 #endif /* PERL_IMPLICIT_SYS */
11600 param->flags = flags;
11601 param->proto_perl = proto_perl;
11604 PL_xiv_arenaroot = NULL;
11605 PL_xiv_root = NULL;
11606 PL_xnv_arenaroot = NULL;
11607 PL_xnv_root = NULL;
11608 PL_xrv_arenaroot = NULL;
11609 PL_xrv_root = NULL;
11610 PL_xpv_arenaroot = NULL;
11611 PL_xpv_root = NULL;
11612 PL_xpviv_arenaroot = NULL;
11613 PL_xpviv_root = NULL;
11614 PL_xpvnv_arenaroot = NULL;
11615 PL_xpvnv_root = NULL;
11616 PL_xpvcv_arenaroot = NULL;
11617 PL_xpvcv_root = NULL;
11618 PL_xpvav_arenaroot = NULL;
11619 PL_xpvav_root = NULL;
11620 PL_xpvhv_arenaroot = NULL;
11621 PL_xpvhv_root = NULL;
11622 PL_xpvmg_arenaroot = NULL;
11623 PL_xpvmg_root = NULL;
11624 PL_xpvlv_arenaroot = NULL;
11625 PL_xpvlv_root = NULL;
11626 PL_xpvbm_arenaroot = NULL;
11627 PL_xpvbm_root = NULL;
11628 PL_he_arenaroot = NULL;
11630 PL_nice_chunk = NULL;
11631 PL_nice_chunk_size = 0;
11633 PL_sv_objcount = 0;
11634 PL_sv_root = Nullsv;
11635 PL_sv_arenaroot = Nullsv;
11637 PL_debug = proto_perl->Idebug;
11639 #ifdef USE_REENTRANT_API
11640 /* XXX: things like -Dm will segfault here in perlio, but doing
11641 * PERL_SET_CONTEXT(proto_perl);
11642 * breaks too many other things
11644 Perl_reentrant_init(aTHX);
11647 /* create SV map for pointer relocation */
11648 PL_ptr_table = ptr_table_new();
11650 /* initialize these special pointers as early as possible */
11651 SvANY(&PL_sv_undef) = NULL;
11652 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11653 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11654 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11656 SvANY(&PL_sv_no) = new_XPVNV();
11657 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11658 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11659 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11660 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11661 SvCUR_set(&PL_sv_no, 0);
11662 SvLEN_set(&PL_sv_no, 1);
11663 SvIV_set(&PL_sv_no, 0);
11664 SvNV_set(&PL_sv_no, 0);
11665 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11667 SvANY(&PL_sv_yes) = new_XPVNV();
11668 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11669 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11670 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11671 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11672 SvCUR_set(&PL_sv_yes, 1);
11673 SvLEN_set(&PL_sv_yes, 2);
11674 SvIV_set(&PL_sv_yes, 1);
11675 SvNV_set(&PL_sv_yes, 1);
11676 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11678 /* create (a non-shared!) shared string table */
11679 PL_strtab = newHV();
11680 HvSHAREKEYS_off(PL_strtab);
11681 hv_ksplit(PL_strtab, 512);
11682 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11684 PL_compiling = proto_perl->Icompiling;
11686 /* These two PVs will be free'd special way so must set them same way op.c does */
11687 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11688 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11690 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11691 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11693 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11694 if (!specialWARN(PL_compiling.cop_warnings))
11695 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11696 if (!specialCopIO(PL_compiling.cop_io))
11697 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11698 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11700 /* pseudo environmental stuff */
11701 PL_origargc = proto_perl->Iorigargc;
11702 PL_origargv = proto_perl->Iorigargv;
11704 param->stashes = newAV(); /* Setup array of objects to call clone on */
11706 #ifdef PERLIO_LAYERS
11707 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11708 PerlIO_clone(aTHX_ proto_perl, param);
11711 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11712 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11713 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11714 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11715 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11716 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11719 PL_minus_c = proto_perl->Iminus_c;
11720 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11721 PL_localpatches = proto_perl->Ilocalpatches;
11722 PL_splitstr = proto_perl->Isplitstr;
11723 PL_preprocess = proto_perl->Ipreprocess;
11724 PL_minus_n = proto_perl->Iminus_n;
11725 PL_minus_p = proto_perl->Iminus_p;
11726 PL_minus_l = proto_perl->Iminus_l;
11727 PL_minus_a = proto_perl->Iminus_a;
11728 PL_minus_F = proto_perl->Iminus_F;
11729 PL_doswitches = proto_perl->Idoswitches;
11730 PL_dowarn = proto_perl->Idowarn;
11731 PL_doextract = proto_perl->Idoextract;
11732 PL_sawampersand = proto_perl->Isawampersand;
11733 PL_unsafe = proto_perl->Iunsafe;
11734 PL_inplace = SAVEPV(proto_perl->Iinplace);
11735 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11736 PL_perldb = proto_perl->Iperldb;
11737 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11738 PL_exit_flags = proto_perl->Iexit_flags;
11740 /* magical thingies */
11741 /* XXX time(&PL_basetime) when asked for? */
11742 PL_basetime = proto_perl->Ibasetime;
11743 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11745 PL_maxsysfd = proto_perl->Imaxsysfd;
11746 PL_multiline = proto_perl->Imultiline;
11747 PL_statusvalue = proto_perl->Istatusvalue;
11749 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11751 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11753 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11754 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11755 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11757 /* Clone the regex array */
11758 PL_regex_padav = newAV();
11760 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11761 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11762 av_push(PL_regex_padav,
11763 sv_dup_inc(regexen[0],param));
11764 for(i = 1; i <= len; i++) {
11765 if(SvREPADTMP(regexen[i])) {
11766 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11768 av_push(PL_regex_padav,
11770 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11771 SvIVX(regexen[i])), param)))
11776 PL_regex_pad = AvARRAY(PL_regex_padav);
11778 /* shortcuts to various I/O objects */
11779 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11780 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11781 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11782 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11783 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11784 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11786 /* shortcuts to regexp stuff */
11787 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11789 /* shortcuts to misc objects */
11790 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11792 /* shortcuts to debugging objects */
11793 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11794 PL_DBline = gv_dup(proto_perl->IDBline, param);
11795 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11796 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11797 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11798 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11799 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11800 PL_lineary = av_dup(proto_perl->Ilineary, param);
11801 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11803 /* symbol tables */
11804 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11805 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11806 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11807 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11808 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11810 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11811 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11812 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11813 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11814 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11815 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11817 PL_sub_generation = proto_perl->Isub_generation;
11819 /* funky return mechanisms */
11820 PL_forkprocess = proto_perl->Iforkprocess;
11822 /* subprocess state */
11823 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11825 /* internal state */
11826 PL_tainting = proto_perl->Itainting;
11827 PL_taint_warn = proto_perl->Itaint_warn;
11828 PL_maxo = proto_perl->Imaxo;
11829 if (proto_perl->Iop_mask)
11830 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11832 PL_op_mask = Nullch;
11833 /* PL_asserting = proto_perl->Iasserting; */
11835 /* current interpreter roots */
11836 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11837 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11838 PL_main_start = proto_perl->Imain_start;
11839 PL_eval_root = proto_perl->Ieval_root;
11840 PL_eval_start = proto_perl->Ieval_start;
11842 /* runtime control stuff */
11843 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11844 PL_copline = proto_perl->Icopline;
11846 PL_filemode = proto_perl->Ifilemode;
11847 PL_lastfd = proto_perl->Ilastfd;
11848 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11851 PL_gensym = proto_perl->Igensym;
11852 PL_preambled = proto_perl->Ipreambled;
11853 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11854 PL_laststatval = proto_perl->Ilaststatval;
11855 PL_laststype = proto_perl->Ilaststype;
11856 PL_mess_sv = Nullsv;
11858 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11859 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11861 /* interpreter atexit processing */
11862 PL_exitlistlen = proto_perl->Iexitlistlen;
11863 if (PL_exitlistlen) {
11864 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11865 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11868 PL_exitlist = (PerlExitListEntry*)NULL;
11869 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11870 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11871 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11873 PL_profiledata = NULL;
11874 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11875 /* PL_rsfp_filters entries have fake IoDIRP() */
11876 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11878 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11880 PAD_CLONE_VARS(proto_perl, param);
11882 #ifdef HAVE_INTERP_INTERN
11883 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11886 /* more statics moved here */
11887 PL_generation = proto_perl->Igeneration;
11888 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11890 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11891 PL_in_clean_all = proto_perl->Iin_clean_all;
11893 PL_uid = proto_perl->Iuid;
11894 PL_euid = proto_perl->Ieuid;
11895 PL_gid = proto_perl->Igid;
11896 PL_egid = proto_perl->Iegid;
11897 PL_nomemok = proto_perl->Inomemok;
11898 PL_an = proto_perl->Ian;
11899 PL_evalseq = proto_perl->Ievalseq;
11900 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11901 PL_origalen = proto_perl->Iorigalen;
11902 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11903 PL_osname = SAVEPV(proto_perl->Iosname);
11904 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11905 PL_sighandlerp = proto_perl->Isighandlerp;
11908 PL_runops = proto_perl->Irunops;
11910 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11913 PL_cshlen = proto_perl->Icshlen;
11914 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11917 PL_lex_state = proto_perl->Ilex_state;
11918 PL_lex_defer = proto_perl->Ilex_defer;
11919 PL_lex_expect = proto_perl->Ilex_expect;
11920 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11921 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11922 PL_lex_starts = proto_perl->Ilex_starts;
11923 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11924 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11925 PL_lex_op = proto_perl->Ilex_op;
11926 PL_lex_inpat = proto_perl->Ilex_inpat;
11927 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11928 PL_lex_brackets = proto_perl->Ilex_brackets;
11929 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11930 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11931 PL_lex_casemods = proto_perl->Ilex_casemods;
11932 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11933 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11935 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11936 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11937 PL_nexttoke = proto_perl->Inexttoke;
11939 /* XXX This is probably masking the deeper issue of why
11940 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11941 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11942 * (A little debugging with a watchpoint on it may help.)
11944 if (SvANY(proto_perl->Ilinestr)) {
11945 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11946 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11947 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11948 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11949 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11950 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11951 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11952 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11953 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11956 PL_linestr = NEWSV(65,79);
11957 sv_upgrade(PL_linestr,SVt_PVIV);
11958 sv_setpvn(PL_linestr,"",0);
11959 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11961 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11962 PL_pending_ident = proto_perl->Ipending_ident;
11963 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11965 PL_expect = proto_perl->Iexpect;
11967 PL_multi_start = proto_perl->Imulti_start;
11968 PL_multi_end = proto_perl->Imulti_end;
11969 PL_multi_open = proto_perl->Imulti_open;
11970 PL_multi_close = proto_perl->Imulti_close;
11972 PL_error_count = proto_perl->Ierror_count;
11973 PL_subline = proto_perl->Isubline;
11974 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11976 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11977 if (SvANY(proto_perl->Ilinestr)) {
11978 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11979 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11980 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11981 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11982 PL_last_lop_op = proto_perl->Ilast_lop_op;
11985 PL_last_uni = SvPVX(PL_linestr);
11986 PL_last_lop = SvPVX(PL_linestr);
11987 PL_last_lop_op = 0;
11989 PL_in_my = proto_perl->Iin_my;
11990 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11992 PL_cryptseen = proto_perl->Icryptseen;
11995 PL_hints = proto_perl->Ihints;
11997 PL_amagic_generation = proto_perl->Iamagic_generation;
11999 #ifdef USE_LOCALE_COLLATE
12000 PL_collation_ix = proto_perl->Icollation_ix;
12001 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12002 PL_collation_standard = proto_perl->Icollation_standard;
12003 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12004 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12005 #endif /* USE_LOCALE_COLLATE */
12007 #ifdef USE_LOCALE_NUMERIC
12008 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12009 PL_numeric_standard = proto_perl->Inumeric_standard;
12010 PL_numeric_local = proto_perl->Inumeric_local;
12011 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12012 #endif /* !USE_LOCALE_NUMERIC */
12014 /* utf8 character classes */
12015 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12016 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12017 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12018 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12019 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12020 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12021 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12022 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12023 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12024 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12025 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12026 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12027 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12028 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12029 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12030 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12031 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12032 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12033 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12034 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12036 /* Did the locale setup indicate UTF-8? */
12037 PL_utf8locale = proto_perl->Iutf8locale;
12038 /* Unicode features (see perlrun/-C) */
12039 PL_unicode = proto_perl->Iunicode;
12041 /* Pre-5.8 signals control */
12042 PL_signals = proto_perl->Isignals;
12044 /* times() ticks per second */
12045 PL_clocktick = proto_perl->Iclocktick;
12047 /* Recursion stopper for PerlIO_find_layer */
12048 PL_in_load_module = proto_perl->Iin_load_module;
12050 /* sort() routine */
12051 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12053 /* Not really needed/useful since the reenrant_retint is "volatile",
12054 * but do it for consistency's sake. */
12055 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12057 /* Hooks to shared SVs and locks. */
12058 PL_sharehook = proto_perl->Isharehook;
12059 PL_lockhook = proto_perl->Ilockhook;
12060 PL_unlockhook = proto_perl->Iunlockhook;
12061 PL_threadhook = proto_perl->Ithreadhook;
12063 PL_runops_std = proto_perl->Irunops_std;
12064 PL_runops_dbg = proto_perl->Irunops_dbg;
12066 #ifdef THREADS_HAVE_PIDS
12067 PL_ppid = proto_perl->Ippid;
12071 PL_last_swash_hv = Nullhv; /* reinits on demand */
12072 PL_last_swash_klen = 0;
12073 PL_last_swash_key[0]= '\0';
12074 PL_last_swash_tmps = (U8*)NULL;
12075 PL_last_swash_slen = 0;
12077 PL_glob_index = proto_perl->Iglob_index;
12078 PL_srand_called = proto_perl->Isrand_called;
12079 PL_hash_seed = proto_perl->Ihash_seed;
12080 PL_rehash_seed = proto_perl->Irehash_seed;
12081 PL_uudmap['M'] = 0; /* reinits on demand */
12082 PL_bitcount = Nullch; /* reinits on demand */
12084 if (proto_perl->Ipsig_pend) {
12085 Newz(0, PL_psig_pend, SIG_SIZE, int);
12088 PL_psig_pend = (int*)NULL;
12091 if (proto_perl->Ipsig_ptr) {
12092 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12093 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12094 for (i = 1; i < SIG_SIZE; i++) {
12095 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12096 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12100 PL_psig_ptr = (SV**)NULL;
12101 PL_psig_name = (SV**)NULL;
12104 /* thrdvar.h stuff */
12106 if (flags & CLONEf_COPY_STACKS) {
12107 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12108 PL_tmps_ix = proto_perl->Ttmps_ix;
12109 PL_tmps_max = proto_perl->Ttmps_max;
12110 PL_tmps_floor = proto_perl->Ttmps_floor;
12111 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12113 while (i <= PL_tmps_ix) {
12114 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12118 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12119 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12120 Newz(54, PL_markstack, i, I32);
12121 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12122 - proto_perl->Tmarkstack);
12123 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12124 - proto_perl->Tmarkstack);
12125 Copy(proto_perl->Tmarkstack, PL_markstack,
12126 PL_markstack_ptr - PL_markstack + 1, I32);
12128 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12129 * NOTE: unlike the others! */
12130 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12131 PL_scopestack_max = proto_perl->Tscopestack_max;
12132 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12133 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12135 /* NOTE: si_dup() looks at PL_markstack */
12136 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12138 /* PL_curstack = PL_curstackinfo->si_stack; */
12139 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12140 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12142 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12143 PL_stack_base = AvARRAY(PL_curstack);
12144 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12145 - proto_perl->Tstack_base);
12146 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12148 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12149 * NOTE: unlike the others! */
12150 PL_savestack_ix = proto_perl->Tsavestack_ix;
12151 PL_savestack_max = proto_perl->Tsavestack_max;
12152 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12153 PL_savestack = ss_dup(proto_perl, param);
12157 ENTER; /* perl_destruct() wants to LEAVE; */
12160 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12161 PL_top_env = &PL_start_env;
12163 PL_op = proto_perl->Top;
12166 PL_Xpv = (XPV*)NULL;
12167 PL_na = proto_perl->Tna;
12169 PL_statbuf = proto_perl->Tstatbuf;
12170 PL_statcache = proto_perl->Tstatcache;
12171 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12172 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12174 PL_timesbuf = proto_perl->Ttimesbuf;
12177 PL_tainted = proto_perl->Ttainted;
12178 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12179 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12180 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12181 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12182 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12183 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12184 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12185 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12186 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12188 PL_restartop = proto_perl->Trestartop;
12189 PL_in_eval = proto_perl->Tin_eval;
12190 PL_delaymagic = proto_perl->Tdelaymagic;
12191 PL_dirty = proto_perl->Tdirty;
12192 PL_localizing = proto_perl->Tlocalizing;
12194 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12195 PL_hv_fetch_ent_mh = Nullhe;
12196 PL_modcount = proto_perl->Tmodcount;
12197 PL_lastgotoprobe = Nullop;
12198 PL_dumpindent = proto_perl->Tdumpindent;
12200 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12201 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12202 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12203 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12204 PL_sortcxix = proto_perl->Tsortcxix;
12205 PL_efloatbuf = Nullch; /* reinits on demand */
12206 PL_efloatsize = 0; /* reinits on demand */
12210 PL_screamfirst = NULL;
12211 PL_screamnext = NULL;
12212 PL_maxscream = -1; /* reinits on demand */
12213 PL_lastscream = Nullsv;
12215 PL_watchaddr = NULL;
12216 PL_watchok = Nullch;
12218 PL_regdummy = proto_perl->Tregdummy;
12219 PL_regprecomp = Nullch;
12222 PL_colorset = 0; /* reinits PL_colors[] */
12223 /*PL_colors[6] = {0,0,0,0,0,0};*/
12224 PL_reginput = Nullch;
12225 PL_regbol = Nullch;
12226 PL_regeol = Nullch;
12227 PL_regstartp = (I32*)NULL;
12228 PL_regendp = (I32*)NULL;
12229 PL_reglastparen = (U32*)NULL;
12230 PL_reglastcloseparen = (U32*)NULL;
12231 PL_regtill = Nullch;
12232 PL_reg_start_tmp = (char**)NULL;
12233 PL_reg_start_tmpl = 0;
12234 PL_regdata = (struct reg_data*)NULL;
12237 PL_reg_eval_set = 0;
12239 PL_regprogram = (regnode*)NULL;
12241 PL_regcc = (CURCUR*)NULL;
12242 PL_reg_call_cc = (struct re_cc_state*)NULL;
12243 PL_reg_re = (regexp*)NULL;
12244 PL_reg_ganch = Nullch;
12245 PL_reg_sv = Nullsv;
12246 PL_reg_match_utf8 = FALSE;
12247 PL_reg_magic = (MAGIC*)NULL;
12249 PL_reg_oldcurpm = (PMOP*)NULL;
12250 PL_reg_curpm = (PMOP*)NULL;
12251 PL_reg_oldsaved = Nullch;
12252 PL_reg_oldsavedlen = 0;
12253 #ifdef PERL_COPY_ON_WRITE
12256 PL_reg_maxiter = 0;
12257 PL_reg_leftiter = 0;
12258 PL_reg_poscache = Nullch;
12259 PL_reg_poscache_size= 0;
12261 /* RE engine - function pointers */
12262 PL_regcompp = proto_perl->Tregcompp;
12263 PL_regexecp = proto_perl->Tregexecp;
12264 PL_regint_start = proto_perl->Tregint_start;
12265 PL_regint_string = proto_perl->Tregint_string;
12266 PL_regfree = proto_perl->Tregfree;
12268 PL_reginterp_cnt = 0;
12269 PL_reg_starttry = 0;
12271 /* Pluggable optimizer */
12272 PL_peepp = proto_perl->Tpeepp;
12274 PL_stashcache = newHV();
12276 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12277 ptr_table_free(PL_ptr_table);
12278 PL_ptr_table = NULL;
12281 /* Call the ->CLONE method, if it exists, for each of the stashes
12282 identified by sv_dup() above.
12284 while(av_len(param->stashes) != -1) {
12285 HV* stash = (HV*) av_shift(param->stashes);
12286 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12287 if (cloner && GvCV(cloner)) {
12292 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12294 call_sv((SV*)GvCV(cloner), G_DISCARD);
12300 SvREFCNT_dec(param->stashes);
12305 #endif /* USE_ITHREADS */
12308 =head1 Unicode Support
12310 =for apidoc sv_recode_to_utf8
12312 The encoding is assumed to be an Encode object, on entry the PV
12313 of the sv is assumed to be octets in that encoding, and the sv
12314 will be converted into Unicode (and UTF-8).
12316 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12317 is not a reference, nothing is done to the sv. If the encoding is not
12318 an C<Encode::XS> Encoding object, bad things will happen.
12319 (See F<lib/encoding.pm> and L<Encode>).
12321 The PV of the sv is returned.
12326 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12329 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12343 Passing sv_yes is wrong - it needs to be or'ed set of constants
12344 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12345 remove converted chars from source.
12347 Both will default the value - let them.
12349 XPUSHs(&PL_sv_yes);
12352 call_method("decode", G_SCALAR);
12356 s = SvPV(uni, len);
12357 if (s != SvPVX(sv)) {
12358 SvGROW(sv, len + 1);
12359 Move(s, SvPVX(sv), len, char);
12360 SvCUR_set(sv, len);
12361 SvPVX(sv)[len] = 0;
12368 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12372 =for apidoc sv_cat_decode
12374 The encoding is assumed to be an Encode object, the PV of the ssv is
12375 assumed to be octets in that encoding and decoding the input starts
12376 from the position which (PV + *offset) pointed to. The dsv will be
12377 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12378 when the string tstr appears in decoding output or the input ends on
12379 the PV of the ssv. The value which the offset points will be modified
12380 to the last input position on the ssv.
12382 Returns TRUE if the terminator was found, else returns FALSE.
12387 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12388 SV *ssv, int *offset, char *tstr, int tlen)
12392 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12403 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12404 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12406 call_method("cat_decode", G_SCALAR);
12408 ret = SvTRUE(TOPs);
12409 *offset = SvIV(offsv);
12415 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12421 * c-indentation-style: bsd
12422 * c-basic-offset: 4
12423 * indent-tabs-mode: t
12426 * vim: shiftwidth=4: