3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
168 #define plant_SV(p) \
170 SvANY(p) = (void *)PL_sv_root; \
171 SvFLAGS(p) = SVTYPEMASK; \
176 /* sv_mutex must be held while calling uproot_SV() */
177 #define uproot_SV(p) \
180 PL_sv_root = (SV*)SvANY(p); \
185 /* new_SV(): return a new, empty SV head */
187 #ifdef DEBUG_LEAKING_SCALARS
188 /* provide a real function for a debugger to play with */
205 # define new_SV(p) (p)=S_new_SV(aTHX)
223 /* del_SV(): return an empty SV head to the free list */
238 S_del_sv(pTHX_ SV *p)
245 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
247 svend = &sva[SvREFCNT(sva)];
248 if (p >= sv && p < svend)
252 if (ckWARN_d(WARN_INTERNAL))
253 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
254 "Attempt to free non-arena SV: 0x%"UVxf
255 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
262 #else /* ! DEBUGGING */
264 #define del_SV(p) plant_SV(p)
266 #endif /* DEBUGGING */
270 =head1 SV Manipulation Functions
272 =for apidoc sv_add_arena
274 Given a chunk of memory, link it to the head of the list of arenas,
275 and split it into a list of free SVs.
281 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
286 Zero(ptr, size, char);
288 /* The first SV in an arena isn't an SV. */
289 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
290 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
291 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
293 PL_sv_arenaroot = sva;
294 PL_sv_root = sva + 1;
296 svend = &sva[SvREFCNT(sva) - 1];
299 SvANY(sv) = (void *)(SV*)(sv + 1);
300 SvFLAGS(sv) = SVTYPEMASK;
304 SvFLAGS(sv) = SVTYPEMASK;
307 /* make some more SVs by adding another arena */
309 /* sv_mutex must be held while calling more_sv() */
316 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
317 PL_nice_chunk = Nullch;
318 PL_nice_chunk_size = 0;
321 char *chunk; /* must use New here to match call to */
322 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
323 sv_add_arena(chunk, 1008, 0);
329 /* visit(): call the named function for each non-free SV in the arenas
330 * whose flags field matches the flags/mask args. */
333 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
340 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
341 svend = &sva[SvREFCNT(sva)];
342 for (sv = sva + 1; sv < svend; ++sv) {
343 if (SvTYPE(sv) != SVTYPEMASK
344 && (sv->sv_flags & mask) == flags
357 /* called by sv_report_used() for each live SV */
360 do_report_used(pTHX_ SV *sv)
362 if (SvTYPE(sv) != SVTYPEMASK) {
363 PerlIO_printf(Perl_debug_log, "****\n");
370 =for apidoc sv_report_used
372 Dump the contents of all SVs not yet freed. (Debugging aid).
378 Perl_sv_report_used(pTHX)
381 visit(do_report_used, 0, 0);
385 /* called by sv_clean_objs() for each live SV */
388 do_clean_objs(pTHX_ SV *sv)
392 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
393 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
405 /* XXX Might want to check arrays, etc. */
408 /* called by sv_clean_objs() for each live SV */
410 #ifndef DISABLE_DESTRUCTOR_KLUDGE
412 do_clean_named_objs(pTHX_ SV *sv)
414 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
415 if ( SvOBJECT(GvSV(sv)) ||
416 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
417 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
418 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
419 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
421 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
422 SvFLAGS(sv) |= SVf_BREAK;
430 =for apidoc sv_clean_objs
432 Attempt to destroy all objects not yet freed
438 Perl_sv_clean_objs(pTHX)
440 PL_in_clean_objs = TRUE;
441 visit(do_clean_objs, SVf_ROK, SVf_ROK);
442 #ifndef DISABLE_DESTRUCTOR_KLUDGE
443 /* some barnacles may yet remain, clinging to typeglobs */
444 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
446 PL_in_clean_objs = FALSE;
449 /* called by sv_clean_all() for each live SV */
452 do_clean_all(pTHX_ SV *sv)
454 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
455 SvFLAGS(sv) |= SVf_BREAK;
456 if (PL_comppad == (AV*)sv) {
458 PL_curpad = Null(SV**);
464 =for apidoc sv_clean_all
466 Decrement the refcnt of each remaining SV, possibly triggering a
467 cleanup. This function may have to be called multiple times to free
468 SVs which are in complex self-referential hierarchies.
474 Perl_sv_clean_all(pTHX)
477 PL_in_clean_all = TRUE;
478 cleaned = visit(do_clean_all, 0,0);
479 PL_in_clean_all = FALSE;
484 =for apidoc sv_free_arenas
486 Deallocate the memory used by all arenas. Note that all the individual SV
487 heads and bodies within the arenas must already have been freed.
493 Perl_sv_free_arenas(pTHX)
497 XPV *arena, *arenanext;
499 /* Free arenas here, but be careful about fake ones. (We assume
500 contiguity of the fake ones with the corresponding real ones.) */
502 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
503 svanext = (SV*) SvANY(sva);
504 while (svanext && SvFAKE(svanext))
505 svanext = (SV*) SvANY(svanext);
508 Safefree((void *)sva);
511 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
512 arenanext = (XPV*)arena->xpv_pv;
515 PL_xiv_arenaroot = 0;
518 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
519 arenanext = (XPV*)arena->xpv_pv;
522 PL_xnv_arenaroot = 0;
525 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
526 arenanext = (XPV*)arena->xpv_pv;
529 PL_xrv_arenaroot = 0;
532 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
533 arenanext = (XPV*)arena->xpv_pv;
536 PL_xpv_arenaroot = 0;
539 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
540 arenanext = (XPV*)arena->xpv_pv;
543 PL_xpviv_arenaroot = 0;
546 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
547 arenanext = (XPV*)arena->xpv_pv;
550 PL_xpvnv_arenaroot = 0;
553 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
554 arenanext = (XPV*)arena->xpv_pv;
557 PL_xpvcv_arenaroot = 0;
560 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
561 arenanext = (XPV*)arena->xpv_pv;
564 PL_xpvav_arenaroot = 0;
567 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
568 arenanext = (XPV*)arena->xpv_pv;
571 PL_xpvhv_arenaroot = 0;
574 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
575 arenanext = (XPV*)arena->xpv_pv;
578 PL_xpvmg_arenaroot = 0;
581 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
582 arenanext = (XPV*)arena->xpv_pv;
585 PL_xpvlv_arenaroot = 0;
588 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
589 arenanext = (XPV*)arena->xpv_pv;
592 PL_xpvbm_arenaroot = 0;
595 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
596 arenanext = (XPV*)arena->xpv_pv;
603 Safefree(PL_nice_chunk);
604 PL_nice_chunk = Nullch;
605 PL_nice_chunk_size = 0;
610 /* ---------------------------------------------------------------------
612 * support functions for report_uninit()
615 /* the maxiumum size of array or hash where we will scan looking
616 * for the undefined element that triggered the warning */
618 #define FUV_MAX_SEARCH_SIZE 1000
620 /* Look for an entry in the hash whose value has the same SV as val;
621 * If so, return a mortal copy of the key. */
624 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
630 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
631 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
636 for (i=HvMAX(hv); i>0; i--) {
637 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
638 if (HeVAL(entry) != val)
640 if ( HeVAL(entry) == &PL_sv_undef ||
641 HeVAL(entry) == &PL_sv_placeholder)
645 if (HeKLEN(entry) == HEf_SVKEY)
646 return sv_mortalcopy(HeKEY_sv(entry));
647 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
653 /* Look for an entry in the array whose value has the same SV as val;
654 * If so, return the index, otherwise return -1. */
657 S_find_array_subscript(pTHX_ AV *av, SV* val)
661 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
662 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
666 for (i=AvFILLp(av); i>=0; i--) {
667 if (svp[i] == val && svp[i] != &PL_sv_undef)
673 /* S_varname(): return the name of a variable, optionally with a subscript.
674 * If gv is non-zero, use the name of that global, along with gvtype (one
675 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
676 * targ. Depending on the value of the subscript_type flag, return:
679 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
680 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
681 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
682 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
685 S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ,
686 SV* keyname, I32 aindex, int subscript_type)
692 name = sv_newmortal();
695 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
696 * XXX get rid of all this if gv_fullnameX() ever supports this
700 HV *hv = GvSTASH(gv);
701 sv_setpv(name, gvtype);
704 else if (!HvNAME(hv))
708 if (strNE(p, "main")) {
710 sv_catpvn(name,"::", 2);
712 if (GvNAMELEN(gv)>= 1 &&
713 ((unsigned int)*GvNAME(gv)) <= 26)
715 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
716 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
719 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
723 CV *cv = find_runcv(&u);
724 if (!cv || !CvPADLIST(cv))
726 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
727 sv = *av_fetch(av, targ, FALSE);
728 /* SvLEN in a pad name is not to be trusted */
729 sv_setpv(name, SvPV_nolen(sv));
732 if (subscript_type == FUV_SUBSCRIPT_HASH) {
735 Perl_sv_catpvf(aTHX_ name, "{%s}",
736 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
739 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
741 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
743 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
744 sv_insert(name, 0, 0, "within ", 7);
751 =for apidoc find_uninit_var
753 Find the name of the undefined variable (if any) that caused the operator o
754 to issue a "Use of uninitialized value" warning.
755 If match is true, only return a name if it's value matches uninit_sv.
756 So roughly speaking, if a unary operator (such as OP_COS) generates a
757 warning, then following the direct child of the op may yield an
758 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
759 other hand, with OP_ADD there are two branches to follow, so we only print
760 the variable name if we get an exact match.
762 The name is returned as a mortal SV.
764 Assumes that PL_op is the op that originally triggered the error, and that
765 PL_comppad/PL_curpad points to the currently executing pad.
771 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
779 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
780 uninit_sv == &PL_sv_placeholder)))
783 switch (obase->op_type) {
790 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
791 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
794 int subscript_type = FUV_SUBSCRIPT_WITHIN;
796 if (pad) { /* @lex, %lex */
797 sv = PAD_SVl(obase->op_targ);
801 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
802 /* @global, %global */
803 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
806 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
808 else /* @{expr}, %{expr} */
809 return find_uninit_var(cUNOPx(obase)->op_first,
813 /* attempt to find a match within the aggregate */
815 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
817 subscript_type = FUV_SUBSCRIPT_HASH;
820 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
822 subscript_type = FUV_SUBSCRIPT_ARRAY;
825 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
828 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
829 keysv, index, subscript_type);
833 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
835 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
836 Nullsv, 0, FUV_SUBSCRIPT_NONE);
839 gv = cGVOPx_gv(obase);
840 if (!gv || (match && GvSV(gv) != uninit_sv))
842 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
845 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
847 av = (AV*)PAD_SV(obase->op_targ);
848 if (!av || SvRMAGICAL(av))
850 svp = av_fetch(av, (I32)obase->op_private, FALSE);
851 if (!svp || *svp != uninit_sv)
854 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
855 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
858 gv = cGVOPx_gv(obase);
863 if (!av || SvRMAGICAL(av))
865 svp = av_fetch(av, (I32)obase->op_private, FALSE);
866 if (!svp || *svp != uninit_sv)
869 return S_varname(aTHX_ gv, "$", 0,
870 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
875 o = cUNOPx(obase)->op_first;
876 if (!o || o->op_type != OP_NULL ||
877 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
879 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
884 /* $a[uninit_expr] or $h{uninit_expr} */
885 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
888 o = cBINOPx(obase)->op_first;
889 kid = cBINOPx(obase)->op_last;
891 /* get the av or hv, and optionally the gv */
893 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
894 sv = PAD_SV(o->op_targ);
896 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
897 && cUNOPo->op_first->op_type == OP_GV)
899 gv = cGVOPx_gv(cUNOPo->op_first);
902 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
907 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
908 /* index is constant */
912 if (obase->op_type == OP_HELEM) {
913 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
914 if (!he || HeVAL(he) != uninit_sv)
918 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
919 if (!svp || *svp != uninit_sv)
923 if (obase->op_type == OP_HELEM)
924 return S_varname(aTHX_ gv, "%", o->op_targ,
925 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
927 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
928 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
932 /* index is an expression;
933 * attempt to find a match within the aggregate */
934 if (obase->op_type == OP_HELEM) {
935 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
937 return S_varname(aTHX_ gv, "%", o->op_targ,
938 keysv, 0, FUV_SUBSCRIPT_HASH);
941 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
943 return S_varname(aTHX_ gv, "@", o->op_targ,
944 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
948 return S_varname(aTHX_ gv,
949 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
951 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
957 /* only examine RHS */
958 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
961 o = cUNOPx(obase)->op_first;
962 if (o->op_type == OP_PUSHMARK)
965 if (!o->op_sibling) {
966 /* one-arg version of open is highly magical */
968 if (o->op_type == OP_GV) { /* open FOO; */
970 if (match && GvSV(gv) != uninit_sv)
972 return S_varname(aTHX_ gv, "$", 0,
973 Nullsv, 0, FUV_SUBSCRIPT_NONE);
975 /* other possibilities not handled are:
976 * open $x; or open my $x; should return '${*$x}'
977 * open expr; should return '$'.expr ideally
983 /* ops where $_ may be an implicit arg */
987 if ( !(obase->op_flags & OPf_STACKED)) {
988 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
989 ? PAD_SVl(obase->op_targ)
1001 /* skip filehandle as it can't produce 'undef' warning */
1002 o = cUNOPx(obase)->op_first;
1003 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1004 o = o->op_sibling->op_sibling;
1011 match = 1; /* XS or custom code could trigger random warnings */
1016 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1017 return sv_2mortal(newSVpv("${$/}", 0));
1022 if (!(obase->op_flags & OPf_KIDS))
1024 o = cUNOPx(obase)->op_first;
1030 /* if all except one arg are constant, or have no side-effects,
1031 * or are optimized away, then it's unambiguous */
1033 for (kid=o; kid; kid = kid->op_sibling) {
1035 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1036 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1037 || (kid->op_type == OP_PUSHMARK)
1041 if (o2) { /* more than one found */
1048 return find_uninit_var(o2, uninit_sv, match);
1052 sv = find_uninit_var(o, uninit_sv, 1);
1064 =for apidoc report_uninit
1066 Print appropriate "Use of uninitialized variable" warning
1072 Perl_report_uninit(pTHX_ SV* uninit_sv)
1077 varname = find_uninit_var(PL_op, uninit_sv,0);
1079 sv_insert(varname, 0, 0, " ", 1);
1081 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1082 varname ? SvPV_nolen(varname) : "",
1083 " in ", OP_DESC(PL_op));
1086 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1090 /* grab a new IV body from the free list, allocating more if necessary */
1101 * See comment in more_xiv() -- RAM.
1103 PL_xiv_root = *(IV**)xiv;
1105 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1108 /* return an IV body to the free list */
1111 S_del_xiv(pTHX_ XPVIV *p)
1113 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1115 *(IV**)xiv = PL_xiv_root;
1120 /* allocate another arena's worth of IV bodies */
1126 register IV* xivend;
1128 New(705, ptr, 1008/sizeof(XPV), XPV);
1129 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1130 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1133 xivend = &xiv[1008 / sizeof(IV) - 1];
1134 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1136 while (xiv < xivend) {
1137 *(IV**)xiv = (IV *)(xiv + 1);
1143 /* grab a new NV body from the free list, allocating more if necessary */
1153 PL_xnv_root = *(NV**)xnv;
1155 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1158 /* return an NV body to the free list */
1161 S_del_xnv(pTHX_ XPVNV *p)
1163 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1165 *(NV**)xnv = PL_xnv_root;
1170 /* allocate another arena's worth of NV bodies */
1176 register NV* xnvend;
1178 New(711, ptr, 1008/sizeof(XPV), XPV);
1179 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1180 PL_xnv_arenaroot = ptr;
1183 xnvend = &xnv[1008 / sizeof(NV) - 1];
1184 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1186 while (xnv < xnvend) {
1187 *(NV**)xnv = (NV*)(xnv + 1);
1193 /* grab a new struct xrv from the free list, allocating more if necessary */
1203 PL_xrv_root = (XRV*)xrv->xrv_rv;
1208 /* return a struct xrv to the free list */
1211 S_del_xrv(pTHX_ XRV *p)
1214 p->xrv_rv = (SV*)PL_xrv_root;
1219 /* allocate another arena's worth of struct xrv */
1225 register XRV* xrvend;
1227 New(712, ptr, 1008/sizeof(XPV), XPV);
1228 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1229 PL_xrv_arenaroot = ptr;
1232 xrvend = &xrv[1008 / sizeof(XRV) - 1];
1233 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1235 while (xrv < xrvend) {
1236 xrv->xrv_rv = (SV*)(xrv + 1);
1242 /* grab a new struct xpv from the free list, allocating more if necessary */
1252 PL_xpv_root = (XPV*)xpv->xpv_pv;
1257 /* return a struct xpv to the free list */
1260 S_del_xpv(pTHX_ XPV *p)
1263 p->xpv_pv = (char*)PL_xpv_root;
1268 /* allocate another arena's worth of struct xpv */
1274 register XPV* xpvend;
1275 New(713, xpv, 1008/sizeof(XPV), XPV);
1276 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1277 PL_xpv_arenaroot = xpv;
1279 xpvend = &xpv[1008 / sizeof(XPV) - 1];
1280 PL_xpv_root = ++xpv;
1281 while (xpv < xpvend) {
1282 xpv->xpv_pv = (char*)(xpv + 1);
1288 /* grab a new struct xpviv from the free list, allocating more if necessary */
1297 xpviv = PL_xpviv_root;
1298 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1303 /* return a struct xpviv to the free list */
1306 S_del_xpviv(pTHX_ XPVIV *p)
1309 p->xpv_pv = (char*)PL_xpviv_root;
1314 /* allocate another arena's worth of struct xpviv */
1319 register XPVIV* xpviv;
1320 register XPVIV* xpvivend;
1321 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
1322 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1323 PL_xpviv_arenaroot = xpviv;
1325 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
1326 PL_xpviv_root = ++xpviv;
1327 while (xpviv < xpvivend) {
1328 xpviv->xpv_pv = (char*)(xpviv + 1);
1334 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1343 xpvnv = PL_xpvnv_root;
1344 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1349 /* return a struct xpvnv to the free list */
1352 S_del_xpvnv(pTHX_ XPVNV *p)
1355 p->xpv_pv = (char*)PL_xpvnv_root;
1360 /* allocate another arena's worth of struct xpvnv */
1365 register XPVNV* xpvnv;
1366 register XPVNV* xpvnvend;
1367 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
1368 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1369 PL_xpvnv_arenaroot = xpvnv;
1371 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
1372 PL_xpvnv_root = ++xpvnv;
1373 while (xpvnv < xpvnvend) {
1374 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1380 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1389 xpvcv = PL_xpvcv_root;
1390 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1395 /* return a struct xpvcv to the free list */
1398 S_del_xpvcv(pTHX_ XPVCV *p)
1401 p->xpv_pv = (char*)PL_xpvcv_root;
1406 /* allocate another arena's worth of struct xpvcv */
1411 register XPVCV* xpvcv;
1412 register XPVCV* xpvcvend;
1413 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
1414 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1415 PL_xpvcv_arenaroot = xpvcv;
1417 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
1418 PL_xpvcv_root = ++xpvcv;
1419 while (xpvcv < xpvcvend) {
1420 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1426 /* grab a new struct xpvav from the free list, allocating more if necessary */
1435 xpvav = PL_xpvav_root;
1436 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1441 /* return a struct xpvav to the free list */
1444 S_del_xpvav(pTHX_ XPVAV *p)
1447 p->xav_array = (char*)PL_xpvav_root;
1452 /* allocate another arena's worth of struct xpvav */
1457 register XPVAV* xpvav;
1458 register XPVAV* xpvavend;
1459 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
1460 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1461 PL_xpvav_arenaroot = xpvav;
1463 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
1464 PL_xpvav_root = ++xpvav;
1465 while (xpvav < xpvavend) {
1466 xpvav->xav_array = (char*)(xpvav + 1);
1469 xpvav->xav_array = 0;
1472 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1481 xpvhv = PL_xpvhv_root;
1482 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1487 /* return a struct xpvhv to the free list */
1490 S_del_xpvhv(pTHX_ XPVHV *p)
1493 p->xhv_array = (char*)PL_xpvhv_root;
1498 /* allocate another arena's worth of struct xpvhv */
1503 register XPVHV* xpvhv;
1504 register XPVHV* xpvhvend;
1505 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1506 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1507 PL_xpvhv_arenaroot = xpvhv;
1509 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1510 PL_xpvhv_root = ++xpvhv;
1511 while (xpvhv < xpvhvend) {
1512 xpvhv->xhv_array = (char*)(xpvhv + 1);
1515 xpvhv->xhv_array = 0;
1518 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1527 xpvmg = PL_xpvmg_root;
1528 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1533 /* return a struct xpvmg to the free list */
1536 S_del_xpvmg(pTHX_ XPVMG *p)
1539 p->xpv_pv = (char*)PL_xpvmg_root;
1544 /* allocate another arena's worth of struct xpvmg */
1549 register XPVMG* xpvmg;
1550 register XPVMG* xpvmgend;
1551 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1552 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1553 PL_xpvmg_arenaroot = xpvmg;
1555 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1556 PL_xpvmg_root = ++xpvmg;
1557 while (xpvmg < xpvmgend) {
1558 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1564 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1573 xpvlv = PL_xpvlv_root;
1574 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1579 /* return a struct xpvlv to the free list */
1582 S_del_xpvlv(pTHX_ XPVLV *p)
1585 p->xpv_pv = (char*)PL_xpvlv_root;
1590 /* allocate another arena's worth of struct xpvlv */
1595 register XPVLV* xpvlv;
1596 register XPVLV* xpvlvend;
1597 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1598 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1599 PL_xpvlv_arenaroot = xpvlv;
1601 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1602 PL_xpvlv_root = ++xpvlv;
1603 while (xpvlv < xpvlvend) {
1604 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1610 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1619 xpvbm = PL_xpvbm_root;
1620 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1625 /* return a struct xpvbm to the free list */
1628 S_del_xpvbm(pTHX_ XPVBM *p)
1631 p->xpv_pv = (char*)PL_xpvbm_root;
1636 /* allocate another arena's worth of struct xpvbm */
1641 register XPVBM* xpvbm;
1642 register XPVBM* xpvbmend;
1643 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1644 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1645 PL_xpvbm_arenaroot = xpvbm;
1647 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1648 PL_xpvbm_root = ++xpvbm;
1649 while (xpvbm < xpvbmend) {
1650 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1656 #define my_safemalloc(s) (void*)safemalloc(s)
1657 #define my_safefree(p) safefree((char*)p)
1661 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1662 #define del_XIV(p) my_safefree(p)
1664 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1665 #define del_XNV(p) my_safefree(p)
1667 #define new_XRV() my_safemalloc(sizeof(XRV))
1668 #define del_XRV(p) my_safefree(p)
1670 #define new_XPV() my_safemalloc(sizeof(XPV))
1671 #define del_XPV(p) my_safefree(p)
1673 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1674 #define del_XPVIV(p) my_safefree(p)
1676 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1677 #define del_XPVNV(p) my_safefree(p)
1679 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1680 #define del_XPVCV(p) my_safefree(p)
1682 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1683 #define del_XPVAV(p) my_safefree(p)
1685 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1686 #define del_XPVHV(p) my_safefree(p)
1688 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1689 #define del_XPVMG(p) my_safefree(p)
1691 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1692 #define del_XPVLV(p) my_safefree(p)
1694 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1695 #define del_XPVBM(p) my_safefree(p)
1699 #define new_XIV() (void*)new_xiv()
1700 #define del_XIV(p) del_xiv((XPVIV*) p)
1702 #define new_XNV() (void*)new_xnv()
1703 #define del_XNV(p) del_xnv((XPVNV*) p)
1705 #define new_XRV() (void*)new_xrv()
1706 #define del_XRV(p) del_xrv((XRV*) p)
1708 #define new_XPV() (void*)new_xpv()
1709 #define del_XPV(p) del_xpv((XPV *)p)
1711 #define new_XPVIV() (void*)new_xpviv()
1712 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1714 #define new_XPVNV() (void*)new_xpvnv()
1715 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1717 #define new_XPVCV() (void*)new_xpvcv()
1718 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1720 #define new_XPVAV() (void*)new_xpvav()
1721 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1723 #define new_XPVHV() (void*)new_xpvhv()
1724 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1726 #define new_XPVMG() (void*)new_xpvmg()
1727 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1729 #define new_XPVLV() (void*)new_xpvlv()
1730 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1732 #define new_XPVBM() (void*)new_xpvbm()
1733 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1737 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1738 #define del_XPVGV(p) my_safefree(p)
1740 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1741 #define del_XPVFM(p) my_safefree(p)
1743 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1744 #define del_XPVIO(p) my_safefree(p)
1747 =for apidoc sv_upgrade
1749 Upgrade an SV to a more complex form. Generally adds a new body type to the
1750 SV, then copies across as much information as possible from the old body.
1751 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1757 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1764 MAGIC* magic = NULL;
1767 if (mt != SVt_PV && SvIsCOW(sv)) {
1768 sv_force_normal_flags(sv, 0);
1771 if (SvTYPE(sv) == mt)
1775 (void)SvOOK_off(sv);
1777 switch (SvTYPE(sv)) {
1798 else if (mt < SVt_PVIV)
1815 pv = (char*)SvRV(sv);
1835 else if (mt == SVt_NV)
1846 del_XPVIV(SvANY(sv));
1856 del_XPVNV(SvANY(sv));
1864 magic = SvMAGIC(sv);
1865 stash = SvSTASH(sv);
1866 del_XPVMG(SvANY(sv));
1869 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1874 Perl_croak(aTHX_ "Can't upgrade to undef");
1876 SvANY(sv) = new_XIV();
1880 SvANY(sv) = new_XNV();
1884 SvANY(sv) = new_XRV();
1888 SvANY(sv) = new_XPV();
1894 SvANY(sv) = new_XPVIV();
1904 SvANY(sv) = new_XPVNV();
1912 SvANY(sv) = new_XPVMG();
1918 SvMAGIC(sv) = magic;
1919 SvSTASH(sv) = stash;
1922 SvANY(sv) = new_XPVLV();
1928 SvMAGIC(sv) = magic;
1929 SvSTASH(sv) = stash;
1941 SvANY(sv) = new_XPVAV();
1949 SvMAGIC(sv) = magic;
1950 SvSTASH(sv) = stash;
1956 SvANY(sv) = new_XPVHV();
1962 HvTOTALKEYS(sv) = 0;
1963 HvPLACEHOLDERS(sv) = 0;
1964 SvMAGIC(sv) = magic;
1965 SvSTASH(sv) = stash;
1972 SvANY(sv) = new_XPVCV();
1973 Zero(SvANY(sv), 1, XPVCV);
1979 SvMAGIC(sv) = magic;
1980 SvSTASH(sv) = stash;
1983 SvANY(sv) = new_XPVGV();
1989 SvMAGIC(sv) = magic;
1990 SvSTASH(sv) = stash;
1998 SvANY(sv) = new_XPVBM();
2004 SvMAGIC(sv) = magic;
2005 SvSTASH(sv) = stash;
2011 SvANY(sv) = new_XPVFM();
2012 Zero(SvANY(sv), 1, XPVFM);
2018 SvMAGIC(sv) = magic;
2019 SvSTASH(sv) = stash;
2022 SvANY(sv) = new_XPVIO();
2023 Zero(SvANY(sv), 1, XPVIO);
2029 SvMAGIC(sv) = magic;
2030 SvSTASH(sv) = stash;
2031 IoPAGE_LEN(sv) = 60;
2034 SvFLAGS(sv) &= ~SVTYPEMASK;
2040 =for apidoc sv_backoff
2042 Remove any string offset. You should normally use the C<SvOOK_off> macro
2049 Perl_sv_backoff(pTHX_ register SV *sv)
2053 char *s = SvPVX(sv);
2054 SvLEN(sv) += SvIVX(sv);
2055 SvPVX(sv) -= SvIVX(sv);
2057 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2059 SvFLAGS(sv) &= ~SVf_OOK;
2066 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2067 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2068 Use the C<SvGROW> wrapper instead.
2074 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2078 #ifdef HAS_64K_LIMIT
2079 if (newlen >= 0x10000) {
2080 PerlIO_printf(Perl_debug_log,
2081 "Allocation too large: %"UVxf"\n", (UV)newlen);
2084 #endif /* HAS_64K_LIMIT */
2087 if (SvTYPE(sv) < SVt_PV) {
2088 sv_upgrade(sv, SVt_PV);
2091 else if (SvOOK(sv)) { /* pv is offset? */
2094 if (newlen > SvLEN(sv))
2095 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2096 #ifdef HAS_64K_LIMIT
2097 if (newlen >= 0x10000)
2104 if (newlen > SvLEN(sv)) { /* need more room? */
2105 if (SvLEN(sv) && s) {
2107 STRLEN l = malloced_size((void*)SvPVX(sv));
2113 Renew(s,newlen,char);
2116 New(703, s, newlen, char);
2117 if (SvPVX(sv) && SvCUR(sv)) {
2118 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2122 SvLEN_set(sv, newlen);
2128 =for apidoc sv_setiv
2130 Copies an integer into the given SV, upgrading first if necessary.
2131 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2137 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2139 SV_CHECK_THINKFIRST_COW_DROP(sv);
2140 switch (SvTYPE(sv)) {
2142 sv_upgrade(sv, SVt_IV);
2145 sv_upgrade(sv, SVt_PVNV);
2149 sv_upgrade(sv, SVt_PVIV);
2158 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2161 (void)SvIOK_only(sv); /* validate number */
2167 =for apidoc sv_setiv_mg
2169 Like C<sv_setiv>, but also handles 'set' magic.
2175 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2182 =for apidoc sv_setuv
2184 Copies an unsigned integer into the given SV, upgrading first if necessary.
2185 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2191 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2193 /* With these two if statements:
2194 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2197 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2199 If you wish to remove them, please benchmark to see what the effect is
2201 if (u <= (UV)IV_MAX) {
2202 sv_setiv(sv, (IV)u);
2211 =for apidoc sv_setuv_mg
2213 Like C<sv_setuv>, but also handles 'set' magic.
2219 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2221 /* With these two if statements:
2222 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2225 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2227 If you wish to remove them, please benchmark to see what the effect is
2229 if (u <= (UV)IV_MAX) {
2230 sv_setiv(sv, (IV)u);
2240 =for apidoc sv_setnv
2242 Copies a double into the given SV, upgrading first if necessary.
2243 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2249 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2251 SV_CHECK_THINKFIRST_COW_DROP(sv);
2252 switch (SvTYPE(sv)) {
2255 sv_upgrade(sv, SVt_NV);
2260 sv_upgrade(sv, SVt_PVNV);
2269 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2273 (void)SvNOK_only(sv); /* validate number */
2278 =for apidoc sv_setnv_mg
2280 Like C<sv_setnv>, but also handles 'set' magic.
2286 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2292 /* Print an "isn't numeric" warning, using a cleaned-up,
2293 * printable version of the offending string
2297 S_not_a_number(pTHX_ SV *sv)
2304 dsv = sv_2mortal(newSVpv("", 0));
2305 pv = sv_uni_display(dsv, sv, 10, 0);
2308 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2309 /* each *s can expand to 4 chars + "...\0",
2310 i.e. need room for 8 chars */
2313 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2315 if (ch & 128 && !isPRINT_LC(ch)) {
2324 else if (ch == '\r') {
2328 else if (ch == '\f') {
2332 else if (ch == '\\') {
2336 else if (ch == '\0') {
2340 else if (isPRINT_LC(ch))
2357 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2358 "Argument \"%s\" isn't numeric in %s", pv,
2361 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2362 "Argument \"%s\" isn't numeric", pv);
2366 =for apidoc looks_like_number
2368 Test if the content of an SV looks like a number (or is a number).
2369 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2370 non-numeric warning), even if your atof() doesn't grok them.
2376 Perl_looks_like_number(pTHX_ SV *sv)
2378 register char *sbegin;
2385 else if (SvPOKp(sv))
2386 sbegin = SvPV(sv, len);
2388 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2389 return grok_number(sbegin, len, NULL);
2392 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2393 until proven guilty, assume that things are not that bad... */
2398 As 64 bit platforms often have an NV that doesn't preserve all bits of
2399 an IV (an assumption perl has been based on to date) it becomes necessary
2400 to remove the assumption that the NV always carries enough precision to
2401 recreate the IV whenever needed, and that the NV is the canonical form.
2402 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2403 precision as a side effect of conversion (which would lead to insanity
2404 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2405 1) to distinguish between IV/UV/NV slots that have cached a valid
2406 conversion where precision was lost and IV/UV/NV slots that have a
2407 valid conversion which has lost no precision
2408 2) to ensure that if a numeric conversion to one form is requested that
2409 would lose precision, the precise conversion (or differently
2410 imprecise conversion) is also performed and cached, to prevent
2411 requests for different numeric formats on the same SV causing
2412 lossy conversion chains. (lossless conversion chains are perfectly
2417 SvIOKp is true if the IV slot contains a valid value
2418 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2419 SvNOKp is true if the NV slot contains a valid value
2420 SvNOK is true only if the NV value is accurate
2423 while converting from PV to NV, check to see if converting that NV to an
2424 IV(or UV) would lose accuracy over a direct conversion from PV to
2425 IV(or UV). If it would, cache both conversions, return NV, but mark
2426 SV as IOK NOKp (ie not NOK).
2428 While converting from PV to IV, check to see if converting that IV to an
2429 NV would lose accuracy over a direct conversion from PV to NV. If it
2430 would, cache both conversions, flag similarly.
2432 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2433 correctly because if IV & NV were set NV *always* overruled.
2434 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2435 changes - now IV and NV together means that the two are interchangeable:
2436 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2438 The benefit of this is that operations such as pp_add know that if
2439 SvIOK is true for both left and right operands, then integer addition
2440 can be used instead of floating point (for cases where the result won't
2441 overflow). Before, floating point was always used, which could lead to
2442 loss of precision compared with integer addition.
2444 * making IV and NV equal status should make maths accurate on 64 bit
2446 * may speed up maths somewhat if pp_add and friends start to use
2447 integers when possible instead of fp. (Hopefully the overhead in
2448 looking for SvIOK and checking for overflow will not outweigh the
2449 fp to integer speedup)
2450 * will slow down integer operations (callers of SvIV) on "inaccurate"
2451 values, as the change from SvIOK to SvIOKp will cause a call into
2452 sv_2iv each time rather than a macro access direct to the IV slot
2453 * should speed up number->string conversion on integers as IV is
2454 favoured when IV and NV are equally accurate
2456 ####################################################################
2457 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2458 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2459 On the other hand, SvUOK is true iff UV.
2460 ####################################################################
2462 Your mileage will vary depending your CPU's relative fp to integer
2466 #ifndef NV_PRESERVES_UV
2467 # define IS_NUMBER_UNDERFLOW_IV 1
2468 # define IS_NUMBER_UNDERFLOW_UV 2
2469 # define IS_NUMBER_IV_AND_UV 2
2470 # define IS_NUMBER_OVERFLOW_IV 4
2471 # define IS_NUMBER_OVERFLOW_UV 5
2473 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2475 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2477 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2479 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));
2480 if (SvNVX(sv) < (NV)IV_MIN) {
2481 (void)SvIOKp_on(sv);
2484 return IS_NUMBER_UNDERFLOW_IV;
2486 if (SvNVX(sv) > (NV)UV_MAX) {
2487 (void)SvIOKp_on(sv);
2491 return IS_NUMBER_OVERFLOW_UV;
2493 (void)SvIOKp_on(sv);
2495 /* Can't use strtol etc to convert this string. (See truth table in
2497 if (SvNVX(sv) <= (UV)IV_MAX) {
2498 SvIVX(sv) = I_V(SvNVX(sv));
2499 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2500 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2502 /* Integer is imprecise. NOK, IOKp */
2504 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2507 SvUVX(sv) = U_V(SvNVX(sv));
2508 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2509 if (SvUVX(sv) == UV_MAX) {
2510 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2511 possibly be preserved by NV. Hence, it must be overflow.
2513 return IS_NUMBER_OVERFLOW_UV;
2515 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2517 /* Integer is imprecise. NOK, IOKp */
2519 return IS_NUMBER_OVERFLOW_IV;
2521 #endif /* !NV_PRESERVES_UV*/
2523 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2524 * this function provided for binary compatibility only
2528 Perl_sv_2iv(pTHX_ register SV *sv)
2530 return sv_2iv_flags(sv, SV_GMAGIC);
2534 =for apidoc sv_2iv_flags
2536 Return the integer value of an SV, doing any necessary string
2537 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2538 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2544 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2548 if (SvGMAGICAL(sv)) {
2549 if (flags & SV_GMAGIC)
2554 return I_V(SvNVX(sv));
2556 if (SvPOKp(sv) && SvLEN(sv))
2559 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2560 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2566 if (SvTHINKFIRST(sv)) {
2569 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2570 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2571 return SvIV(tmpstr);
2572 return PTR2IV(SvRV(sv));
2575 sv_force_normal_flags(sv, 0);
2577 if (SvREADONLY(sv) && !SvOK(sv)) {
2578 if (ckWARN(WARN_UNINITIALIZED))
2585 return (IV)(SvUVX(sv));
2592 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2593 * without also getting a cached IV/UV from it at the same time
2594 * (ie PV->NV conversion should detect loss of accuracy and cache
2595 * IV or UV at same time to avoid this. NWC */
2597 if (SvTYPE(sv) == SVt_NV)
2598 sv_upgrade(sv, SVt_PVNV);
2600 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2601 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2602 certainly cast into the IV range at IV_MAX, whereas the correct
2603 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2605 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2606 SvIVX(sv) = I_V(SvNVX(sv));
2607 if (SvNVX(sv) == (NV) SvIVX(sv)
2608 #ifndef NV_PRESERVES_UV
2609 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2610 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(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 */
2616 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2617 DEBUG_c(PerlIO_printf(Perl_debug_log,
2618 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2624 /* IV not precise. No need to convert from PV, as NV
2625 conversion would already have cached IV if it detected
2626 that PV->IV would be better than PV->NV->IV
2627 flags already correct - don't set public IOK. */
2628 DEBUG_c(PerlIO_printf(Perl_debug_log,
2629 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2634 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2635 but the cast (NV)IV_MIN rounds to a the value less (more
2636 negative) than IV_MIN which happens to be equal to SvNVX ??
2637 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2638 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2639 (NV)UVX == NVX are both true, but the values differ. :-(
2640 Hopefully for 2s complement IV_MIN is something like
2641 0x8000000000000000 which will be exact. NWC */
2644 SvUVX(sv) = U_V(SvNVX(sv));
2646 (SvNVX(sv) == (NV) SvUVX(sv))
2647 #ifndef NV_PRESERVES_UV
2648 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2649 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2650 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2651 /* Don't flag it as "accurately an integer" if the number
2652 came from a (by definition imprecise) NV operation, and
2653 we're outside the range of NV integer precision */
2659 DEBUG_c(PerlIO_printf(Perl_debug_log,
2660 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2664 return (IV)SvUVX(sv);
2667 else if (SvPOKp(sv) && SvLEN(sv)) {
2669 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2670 /* We want to avoid a possible problem when we cache an IV which
2671 may be later translated to an NV, and the resulting NV is not
2672 the same as the direct translation of the initial string
2673 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2674 be careful to ensure that the value with the .456 is around if the
2675 NV value is requested in the future).
2677 This means that if we cache such an IV, we need to cache the
2678 NV as well. Moreover, we trade speed for space, and do not
2679 cache the NV if we are sure it's not needed.
2682 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2683 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2684 == IS_NUMBER_IN_UV) {
2685 /* It's definitely an integer, only upgrade to PVIV */
2686 if (SvTYPE(sv) < SVt_PVIV)
2687 sv_upgrade(sv, SVt_PVIV);
2689 } else if (SvTYPE(sv) < SVt_PVNV)
2690 sv_upgrade(sv, SVt_PVNV);
2692 /* If NV preserves UV then we only use the UV value if we know that
2693 we aren't going to call atof() below. If NVs don't preserve UVs
2694 then the value returned may have more precision than atof() will
2695 return, even though value isn't perfectly accurate. */
2696 if ((numtype & (IS_NUMBER_IN_UV
2697 #ifdef NV_PRESERVES_UV
2700 )) == IS_NUMBER_IN_UV) {
2701 /* This won't turn off the public IOK flag if it was set above */
2702 (void)SvIOKp_on(sv);
2704 if (!(numtype & IS_NUMBER_NEG)) {
2706 if (value <= (UV)IV_MAX) {
2707 SvIVX(sv) = (IV)value;
2713 /* 2s complement assumption */
2714 if (value <= (UV)IV_MIN) {
2715 SvIVX(sv) = -(IV)value;
2717 /* Too negative for an IV. This is a double upgrade, but
2718 I'm assuming it will be rare. */
2719 if (SvTYPE(sv) < SVt_PVNV)
2720 sv_upgrade(sv, SVt_PVNV);
2724 SvNVX(sv) = -(NV)value;
2729 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2730 will be in the previous block to set the IV slot, and the next
2731 block to set the NV slot. So no else here. */
2733 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2734 != IS_NUMBER_IN_UV) {
2735 /* It wasn't an (integer that doesn't overflow the UV). */
2736 SvNVX(sv) = Atof(SvPVX(sv));
2738 if (! numtype && ckWARN(WARN_NUMERIC))
2741 #if defined(USE_LONG_DOUBLE)
2742 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2743 PTR2UV(sv), SvNVX(sv)));
2745 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2746 PTR2UV(sv), SvNVX(sv)));
2750 #ifdef NV_PRESERVES_UV
2751 (void)SvIOKp_on(sv);
2753 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2754 SvIVX(sv) = I_V(SvNVX(sv));
2755 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2758 /* Integer is imprecise. NOK, IOKp */
2760 /* UV will not work better than IV */
2762 if (SvNVX(sv) > (NV)UV_MAX) {
2764 /* Integer is inaccurate. NOK, IOKp, is UV */
2768 SvUVX(sv) = U_V(SvNVX(sv));
2769 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2770 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2774 /* Integer is imprecise. NOK, IOKp, is UV */
2780 #else /* NV_PRESERVES_UV */
2781 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2782 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2783 /* The IV slot will have been set from value returned by
2784 grok_number above. The NV slot has just been set using
2787 assert (SvIOKp(sv));
2789 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2790 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2791 /* Small enough to preserve all bits. */
2792 (void)SvIOKp_on(sv);
2794 SvIVX(sv) = I_V(SvNVX(sv));
2795 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2797 /* Assumption: first non-preserved integer is < IV_MAX,
2798 this NV is in the preserved range, therefore: */
2799 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2801 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);
2805 0 0 already failed to read UV.
2806 0 1 already failed to read UV.
2807 1 0 you won't get here in this case. IV/UV
2808 slot set, public IOK, Atof() unneeded.
2809 1 1 already read UV.
2810 so there's no point in sv_2iuv_non_preserve() attempting
2811 to use atol, strtol, strtoul etc. */
2812 if (sv_2iuv_non_preserve (sv, numtype)
2813 >= IS_NUMBER_OVERFLOW_IV)
2817 #endif /* NV_PRESERVES_UV */
2820 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2822 if (SvTYPE(sv) < SVt_IV)
2823 /* Typically the caller expects that sv_any is not NULL now. */
2824 sv_upgrade(sv, SVt_IV);
2827 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2828 PTR2UV(sv),SvIVX(sv)));
2829 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2832 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2833 * this function provided for binary compatibility only
2837 Perl_sv_2uv(pTHX_ register SV *sv)
2839 return sv_2uv_flags(sv, SV_GMAGIC);
2843 =for apidoc sv_2uv_flags
2845 Return the unsigned integer value of an SV, doing any necessary string
2846 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2847 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2853 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2857 if (SvGMAGICAL(sv)) {
2858 if (flags & SV_GMAGIC)
2863 return U_V(SvNVX(sv));
2864 if (SvPOKp(sv) && SvLEN(sv))
2867 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2868 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2874 if (SvTHINKFIRST(sv)) {
2877 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2878 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2879 return SvUV(tmpstr);
2880 return PTR2UV(SvRV(sv));
2883 sv_force_normal_flags(sv, 0);
2885 if (SvREADONLY(sv) && !SvOK(sv)) {
2886 if (ckWARN(WARN_UNINITIALIZED))
2896 return (UV)SvIVX(sv);
2900 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2901 * without also getting a cached IV/UV from it at the same time
2902 * (ie PV->NV conversion should detect loss of accuracy and cache
2903 * IV or UV at same time to avoid this. */
2904 /* IV-over-UV optimisation - choose to cache IV if possible */
2906 if (SvTYPE(sv) == SVt_NV)
2907 sv_upgrade(sv, SVt_PVNV);
2909 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2910 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2911 SvIVX(sv) = I_V(SvNVX(sv));
2912 if (SvNVX(sv) == (NV) SvIVX(sv)
2913 #ifndef NV_PRESERVES_UV
2914 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2915 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(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 */
2921 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2922 DEBUG_c(PerlIO_printf(Perl_debug_log,
2923 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2929 /* IV not precise. No need to convert from PV, as NV
2930 conversion would already have cached IV if it detected
2931 that PV->IV would be better than PV->NV->IV
2932 flags already correct - don't set public IOK. */
2933 DEBUG_c(PerlIO_printf(Perl_debug_log,
2934 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2939 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2940 but the cast (NV)IV_MIN rounds to a the value less (more
2941 negative) than IV_MIN which happens to be equal to SvNVX ??
2942 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2943 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2944 (NV)UVX == NVX are both true, but the values differ. :-(
2945 Hopefully for 2s complement IV_MIN is something like
2946 0x8000000000000000 which will be exact. NWC */
2949 SvUVX(sv) = U_V(SvNVX(sv));
2951 (SvNVX(sv) == (NV) SvUVX(sv))
2952 #ifndef NV_PRESERVES_UV
2953 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2954 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2955 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2956 /* Don't flag it as "accurately an integer" if the number
2957 came from a (by definition imprecise) NV operation, and
2958 we're outside the range of NV integer precision */
2963 DEBUG_c(PerlIO_printf(Perl_debug_log,
2964 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2970 else if (SvPOKp(sv) && SvLEN(sv)) {
2972 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2974 /* We want to avoid a possible problem when we cache a UV which
2975 may be later translated to an NV, and the resulting NV is not
2976 the translation of the initial data.
2978 This means that if we cache such a UV, we need to cache the
2979 NV as well. Moreover, we trade speed for space, and do not
2980 cache the NV if not needed.
2983 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2984 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2985 == IS_NUMBER_IN_UV) {
2986 /* It's definitely an integer, only upgrade to PVIV */
2987 if (SvTYPE(sv) < SVt_PVIV)
2988 sv_upgrade(sv, SVt_PVIV);
2990 } else if (SvTYPE(sv) < SVt_PVNV)
2991 sv_upgrade(sv, SVt_PVNV);
2993 /* If NV preserves UV then we only use the UV value if we know that
2994 we aren't going to call atof() below. If NVs don't preserve UVs
2995 then the value returned may have more precision than atof() will
2996 return, even though it isn't accurate. */
2997 if ((numtype & (IS_NUMBER_IN_UV
2998 #ifdef NV_PRESERVES_UV
3001 )) == IS_NUMBER_IN_UV) {
3002 /* This won't turn off the public IOK flag if it was set above */
3003 (void)SvIOKp_on(sv);
3005 if (!(numtype & IS_NUMBER_NEG)) {
3007 if (value <= (UV)IV_MAX) {
3008 SvIVX(sv) = (IV)value;
3010 /* it didn't overflow, and it was positive. */
3015 /* 2s complement assumption */
3016 if (value <= (UV)IV_MIN) {
3017 SvIVX(sv) = -(IV)value;
3019 /* Too negative for an IV. This is a double upgrade, but
3020 I'm assuming it will be rare. */
3021 if (SvTYPE(sv) < SVt_PVNV)
3022 sv_upgrade(sv, SVt_PVNV);
3026 SvNVX(sv) = -(NV)value;
3032 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3033 != IS_NUMBER_IN_UV) {
3034 /* It wasn't an integer, or it overflowed the UV. */
3035 SvNVX(sv) = Atof(SvPVX(sv));
3037 if (! numtype && ckWARN(WARN_NUMERIC))
3040 #if defined(USE_LONG_DOUBLE)
3041 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3042 PTR2UV(sv), SvNVX(sv)));
3044 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3045 PTR2UV(sv), SvNVX(sv)));
3048 #ifdef NV_PRESERVES_UV
3049 (void)SvIOKp_on(sv);
3051 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3052 SvIVX(sv) = I_V(SvNVX(sv));
3053 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3056 /* Integer is imprecise. NOK, IOKp */
3058 /* UV will not work better than IV */
3060 if (SvNVX(sv) > (NV)UV_MAX) {
3062 /* Integer is inaccurate. NOK, IOKp, is UV */
3066 SvUVX(sv) = U_V(SvNVX(sv));
3067 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3068 NV preservse UV so can do correct comparison. */
3069 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3073 /* Integer is imprecise. NOK, IOKp, is UV */
3078 #else /* NV_PRESERVES_UV */
3079 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3080 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3081 /* The UV slot will have been set from value returned by
3082 grok_number above. The NV slot has just been set using
3085 assert (SvIOKp(sv));
3087 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3088 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3089 /* Small enough to preserve all bits. */
3090 (void)SvIOKp_on(sv);
3092 SvIVX(sv) = I_V(SvNVX(sv));
3093 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3095 /* Assumption: first non-preserved integer is < IV_MAX,
3096 this NV is in the preserved range, therefore: */
3097 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3099 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);
3102 sv_2iuv_non_preserve (sv, numtype);
3104 #endif /* NV_PRESERVES_UV */
3108 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3109 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3112 if (SvTYPE(sv) < SVt_IV)
3113 /* Typically the caller expects that sv_any is not NULL now. */
3114 sv_upgrade(sv, SVt_IV);
3118 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3119 PTR2UV(sv),SvUVX(sv)));
3120 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3126 Return the num value of an SV, doing any necessary string or integer
3127 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3134 Perl_sv_2nv(pTHX_ register SV *sv)
3138 if (SvGMAGICAL(sv)) {
3142 if (SvPOKp(sv) && SvLEN(sv)) {
3143 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3144 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3146 return Atof(SvPVX(sv));
3150 return (NV)SvUVX(sv);
3152 return (NV)SvIVX(sv);
3155 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3156 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3162 if (SvTHINKFIRST(sv)) {
3165 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3166 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3167 return SvNV(tmpstr);
3168 return PTR2NV(SvRV(sv));
3171 sv_force_normal_flags(sv, 0);
3173 if (SvREADONLY(sv) && !SvOK(sv)) {
3174 if (ckWARN(WARN_UNINITIALIZED))
3179 if (SvTYPE(sv) < SVt_NV) {
3180 if (SvTYPE(sv) == SVt_IV)
3181 sv_upgrade(sv, SVt_PVNV);
3183 sv_upgrade(sv, SVt_NV);
3184 #ifdef USE_LONG_DOUBLE
3186 STORE_NUMERIC_LOCAL_SET_STANDARD();
3187 PerlIO_printf(Perl_debug_log,
3188 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3189 PTR2UV(sv), SvNVX(sv));
3190 RESTORE_NUMERIC_LOCAL();
3194 STORE_NUMERIC_LOCAL_SET_STANDARD();
3195 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3196 PTR2UV(sv), SvNVX(sv));
3197 RESTORE_NUMERIC_LOCAL();
3201 else if (SvTYPE(sv) < SVt_PVNV)
3202 sv_upgrade(sv, SVt_PVNV);
3207 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
3208 #ifdef NV_PRESERVES_UV
3211 /* Only set the public NV OK flag if this NV preserves the IV */
3212 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3213 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3214 : (SvIVX(sv) == I_V(SvNVX(sv))))
3220 else if (SvPOKp(sv) && SvLEN(sv)) {
3222 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3223 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3225 #ifdef NV_PRESERVES_UV
3226 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3227 == IS_NUMBER_IN_UV) {
3228 /* It's definitely an integer */
3229 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
3231 SvNVX(sv) = Atof(SvPVX(sv));
3234 SvNVX(sv) = Atof(SvPVX(sv));
3235 /* Only set the public NV OK flag if this NV preserves the value in
3236 the PV at least as well as an IV/UV would.
3237 Not sure how to do this 100% reliably. */
3238 /* if that shift count is out of range then Configure's test is
3239 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3241 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3242 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3243 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3244 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3245 /* Can't use strtol etc to convert this string, so don't try.
3246 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3249 /* value has been set. It may not be precise. */
3250 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3251 /* 2s complement assumption for (UV)IV_MIN */
3252 SvNOK_on(sv); /* Integer is too negative. */
3257 if (numtype & IS_NUMBER_NEG) {
3258 SvIVX(sv) = -(IV)value;
3259 } else if (value <= (UV)IV_MAX) {
3260 SvIVX(sv) = (IV)value;
3266 if (numtype & IS_NUMBER_NOT_INT) {
3267 /* I believe that even if the original PV had decimals,
3268 they are lost beyond the limit of the FP precision.
3269 However, neither is canonical, so both only get p
3270 flags. NWC, 2000/11/25 */
3271 /* Both already have p flags, so do nothing */
3274 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3275 if (SvIVX(sv) == I_V(nv)) {
3280 /* It had no "." so it must be integer. */
3283 /* between IV_MAX and NV(UV_MAX).
3284 Could be slightly > UV_MAX */
3286 if (numtype & IS_NUMBER_NOT_INT) {
3287 /* UV and NV both imprecise. */
3289 UV nv_as_uv = U_V(nv);
3291 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3302 #endif /* NV_PRESERVES_UV */
3305 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3307 if (SvTYPE(sv) < SVt_NV)
3308 /* Typically the caller expects that sv_any is not NULL now. */
3309 /* XXX Ilya implies that this is a bug in callers that assume this
3310 and ideally should be fixed. */
3311 sv_upgrade(sv, SVt_NV);
3314 #if defined(USE_LONG_DOUBLE)
3316 STORE_NUMERIC_LOCAL_SET_STANDARD();
3317 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3318 PTR2UV(sv), SvNVX(sv));
3319 RESTORE_NUMERIC_LOCAL();
3323 STORE_NUMERIC_LOCAL_SET_STANDARD();
3324 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3325 PTR2UV(sv), SvNVX(sv));
3326 RESTORE_NUMERIC_LOCAL();
3332 /* asIV(): extract an integer from the string value of an SV.
3333 * Caller must validate PVX */
3336 S_asIV(pTHX_ SV *sv)
3339 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3341 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3342 == IS_NUMBER_IN_UV) {
3343 /* It's definitely an integer */
3344 if (numtype & IS_NUMBER_NEG) {
3345 if (value < (UV)IV_MIN)
3348 if (value < (UV)IV_MAX)
3353 if (ckWARN(WARN_NUMERIC))
3356 return I_V(Atof(SvPVX(sv)));
3359 /* asUV(): extract an unsigned integer from the string value of an SV
3360 * Caller must validate PVX */
3363 S_asUV(pTHX_ SV *sv)
3366 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3368 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3369 == IS_NUMBER_IN_UV) {
3370 /* It's definitely an integer */
3371 if (!(numtype & IS_NUMBER_NEG))
3375 if (ckWARN(WARN_NUMERIC))
3378 return U_V(Atof(SvPVX(sv)));
3382 =for apidoc sv_2pv_nolen
3384 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3385 use the macro wrapper C<SvPV_nolen(sv)> instead.
3390 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3393 return sv_2pv(sv, &n_a);
3396 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3397 * UV as a string towards the end of buf, and return pointers to start and
3400 * We assume that buf is at least TYPE_CHARS(UV) long.
3404 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3406 char *ptr = buf + TYPE_CHARS(UV);
3420 *--ptr = '0' + (char)(uv % 10);
3428 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3429 * this function provided for binary compatibility only
3433 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3435 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3439 =for apidoc sv_2pv_flags
3441 Returns a pointer to the string value of an SV, and sets *lp to its length.
3442 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3444 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3445 usually end up here too.
3451 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3456 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3457 char *tmpbuf = tbuf;
3463 if (SvGMAGICAL(sv)) {
3464 if (flags & SV_GMAGIC)
3472 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3474 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3479 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3484 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3485 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3492 if (SvTHINKFIRST(sv)) {
3495 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3496 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3497 char *pv = SvPV(tmpstr, *lp);
3511 switch (SvTYPE(sv)) {
3513 if ( ((SvFLAGS(sv) &
3514 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3515 == (SVs_OBJECT|SVs_SMG))
3516 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3517 regexp *re = (regexp *)mg->mg_obj;
3520 char *fptr = "msix";
3525 char need_newline = 0;
3526 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3528 while((ch = *fptr++)) {
3530 reflags[left++] = ch;
3533 reflags[right--] = ch;
3538 reflags[left] = '-';
3542 mg->mg_len = re->prelen + 4 + left;
3544 * If /x was used, we have to worry about a regex
3545 * ending with a comment later being embedded
3546 * within another regex. If so, we don't want this
3547 * regex's "commentization" to leak out to the
3548 * right part of the enclosing regex, we must cap
3549 * it with a newline.
3551 * So, if /x was used, we scan backwards from the
3552 * end of the regex. If we find a '#' before we
3553 * find a newline, we need to add a newline
3554 * ourself. If we find a '\n' first (or if we
3555 * don't find '#' or '\n'), we don't need to add
3556 * anything. -jfriedl
3558 if (PMf_EXTENDED & re->reganch)
3560 char *endptr = re->precomp + re->prelen;
3561 while (endptr >= re->precomp)
3563 char c = *(endptr--);
3565 break; /* don't need another */
3567 /* we end while in a comment, so we
3569 mg->mg_len++; /* save space for it */
3570 need_newline = 1; /* note to add it */
3576 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3577 Copy("(?", mg->mg_ptr, 2, char);
3578 Copy(reflags, mg->mg_ptr+2, left, char);
3579 Copy(":", mg->mg_ptr+left+2, 1, char);
3580 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3582 mg->mg_ptr[mg->mg_len - 2] = '\n';
3583 mg->mg_ptr[mg->mg_len - 1] = ')';
3584 mg->mg_ptr[mg->mg_len] = 0;
3586 PL_reginterp_cnt += re->program[0].next_off;
3588 if (re->reganch & ROPT_UTF8)
3603 case SVt_PVBM: if (SvROK(sv))
3606 s = "SCALAR"; break;
3607 case SVt_PVLV: s = SvROK(sv) ? "REF"
3608 /* tied lvalues should appear to be
3609 * scalars for backwards compatitbility */
3610 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3611 ? "SCALAR" : "LVALUE"; break;
3612 case SVt_PVAV: s = "ARRAY"; break;
3613 case SVt_PVHV: s = "HASH"; break;
3614 case SVt_PVCV: s = "CODE"; break;
3615 case SVt_PVGV: s = "GLOB"; break;
3616 case SVt_PVFM: s = "FORMAT"; break;
3617 case SVt_PVIO: s = "IO"; break;
3618 default: s = "UNKNOWN"; break;
3622 if (HvNAME(SvSTASH(sv)))
3623 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3625 Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
3628 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3634 if (SvREADONLY(sv) && !SvOK(sv)) {
3635 if (ckWARN(WARN_UNINITIALIZED))
3641 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3642 /* I'm assuming that if both IV and NV are equally valid then
3643 converting the IV is going to be more efficient */
3644 U32 isIOK = SvIOK(sv);
3645 U32 isUIOK = SvIsUV(sv);
3646 char buf[TYPE_CHARS(UV)];
3649 if (SvTYPE(sv) < SVt_PVIV)
3650 sv_upgrade(sv, SVt_PVIV);
3652 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3654 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3655 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3656 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3657 SvCUR_set(sv, ebuf - ptr);
3667 else if (SvNOKp(sv)) {
3668 if (SvTYPE(sv) < SVt_PVNV)
3669 sv_upgrade(sv, SVt_PVNV);
3670 /* The +20 is pure guesswork. Configure test needed. --jhi */
3671 SvGROW(sv, NV_DIG + 20);
3673 olderrno = errno; /* some Xenix systems wipe out errno here */
3675 if (SvNVX(sv) == 0.0)
3676 (void)strcpy(s,"0");
3680 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3683 #ifdef FIXNEGATIVEZERO
3684 if (*s == '-' && s[1] == '0' && !s[2])
3694 if (ckWARN(WARN_UNINITIALIZED)
3695 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3698 if (SvTYPE(sv) < SVt_PV)
3699 /* Typically the caller expects that sv_any is not NULL now. */
3700 sv_upgrade(sv, SVt_PV);
3703 *lp = s - SvPVX(sv);
3706 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3707 PTR2UV(sv),SvPVX(sv)));
3711 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3712 /* Sneaky stuff here */
3716 tsv = newSVpv(tmpbuf, 0);
3732 len = strlen(tmpbuf);
3734 #ifdef FIXNEGATIVEZERO
3735 if (len == 2 && t[0] == '-' && t[1] == '0') {
3740 (void)SvUPGRADE(sv, SVt_PV);
3742 s = SvGROW(sv, len + 1);
3751 =for apidoc sv_copypv
3753 Copies a stringified representation of the source SV into the
3754 destination SV. Automatically performs any necessary mg_get and
3755 coercion of numeric values into strings. Guaranteed to preserve
3756 UTF-8 flag even from overloaded objects. Similar in nature to
3757 sv_2pv[_flags] but operates directly on an SV instead of just the
3758 string. Mostly uses sv_2pv_flags to do its work, except when that
3759 would lose the UTF-8'ness of the PV.
3765 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3770 sv_setpvn(dsv,s,len);
3778 =for apidoc sv_2pvbyte_nolen
3780 Return a pointer to the byte-encoded representation of the SV.
3781 May cause the SV to be downgraded from UTF-8 as a side-effect.
3783 Usually accessed via the C<SvPVbyte_nolen> macro.
3789 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3792 return sv_2pvbyte(sv, &n_a);
3796 =for apidoc sv_2pvbyte
3798 Return a pointer to the byte-encoded representation of the SV, and set *lp
3799 to its length. May cause the SV to be downgraded from UTF-8 as a
3802 Usually accessed via the C<SvPVbyte> macro.
3808 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3810 sv_utf8_downgrade(sv,0);
3811 return SvPV(sv,*lp);
3815 =for apidoc sv_2pvutf8_nolen
3817 Return a pointer to the UTF-8-encoded representation of the SV.
3818 May cause the SV to be upgraded to UTF-8 as a side-effect.
3820 Usually accessed via the C<SvPVutf8_nolen> macro.
3826 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3829 return sv_2pvutf8(sv, &n_a);
3833 =for apidoc sv_2pvutf8
3835 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3836 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3838 Usually accessed via the C<SvPVutf8> macro.
3844 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3846 sv_utf8_upgrade(sv);
3847 return SvPV(sv,*lp);
3851 =for apidoc sv_2bool
3853 This function is only called on magical items, and is only used by
3854 sv_true() or its macro equivalent.
3860 Perl_sv_2bool(pTHX_ register SV *sv)
3869 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3870 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3871 return (bool)SvTRUE(tmpsv);
3872 return SvRV(sv) != 0;
3875 register XPV* Xpvtmp;
3876 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3877 (*Xpvtmp->xpv_pv > '0' ||
3878 Xpvtmp->xpv_cur > 1 ||
3879 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3886 return SvIVX(sv) != 0;
3889 return SvNVX(sv) != 0.0;
3896 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3897 * this function provided for binary compatibility only
3902 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3904 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3908 =for apidoc sv_utf8_upgrade
3910 Convert the PV of an SV to its UTF-8-encoded form.
3911 Forces the SV to string form if it is not already.
3912 Always sets the SvUTF8 flag to avoid future validity checks even
3913 if all the bytes have hibit clear.
3915 This is not as a general purpose byte encoding to Unicode interface:
3916 use the Encode extension for that.
3918 =for apidoc sv_utf8_upgrade_flags
3920 Convert the PV of an SV to its UTF-8-encoded form.
3921 Forces the SV to string form if it is not already.
3922 Always sets the SvUTF8 flag to avoid future validity checks even
3923 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3924 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3925 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3927 This is not as a general purpose byte encoding to Unicode interface:
3928 use the Encode extension for that.
3934 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3941 (void) SvPV_force(sv,len);
3950 sv_force_normal_flags(sv, 0);
3953 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3954 sv_recode_to_utf8(sv, PL_encoding);
3955 else { /* Assume Latin-1/EBCDIC */
3956 /* This function could be much more efficient if we
3957 * had a FLAG in SVs to signal if there are any hibit
3958 * chars in the PV. Given that there isn't such a flag
3959 * make the loop as fast as possible. */
3960 s = (U8 *) SvPVX(sv);
3961 e = (U8 *) SvEND(sv);
3965 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3970 (void)SvOOK_off(sv);
3972 len = SvCUR(sv) + 1; /* Plus the \0 */
3973 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3974 SvCUR(sv) = len - 1;
3976 Safefree(s); /* No longer using what was there before. */
3977 SvLEN(sv) = len; /* No longer know the real size. */
3979 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3987 =for apidoc sv_utf8_downgrade
3989 Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
3990 This may not be possible if the PV contains non-byte encoding characters;
3991 if this is the case, either returns false or, if C<fail_ok> is not
3994 This is not as a general purpose Unicode to byte encoding interface:
3995 use the Encode extension for that.
4001 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4003 if (SvPOK(sv) && SvUTF8(sv)) {
4009 sv_force_normal_flags(sv, 0);
4011 s = (U8 *) SvPV(sv, len);
4012 if (!utf8_to_bytes(s, &len)) {
4017 Perl_croak(aTHX_ "Wide character in %s",
4020 Perl_croak(aTHX_ "Wide character");
4031 =for apidoc sv_utf8_encode
4033 Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
4034 flag so that it looks like octets again. Used as a building block
4035 for encode_utf8 in Encode.xs
4041 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4043 (void) sv_utf8_upgrade(sv);
4045 sv_force_normal_flags(sv, 0);
4047 if (SvREADONLY(sv)) {
4048 Perl_croak(aTHX_ PL_no_modify);
4054 =for apidoc sv_utf8_decode
4056 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
4057 turn off SvUTF8 if needed so that we see characters. Used as a building block
4058 for decode_utf8 in Encode.xs
4064 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4070 /* The octets may have got themselves encoded - get them back as
4073 if (!sv_utf8_downgrade(sv, TRUE))
4076 /* it is actually just a matter of turning the utf8 flag on, but
4077 * we want to make sure everything inside is valid utf8 first.
4079 c = (U8 *) SvPVX(sv);
4080 if (!is_utf8_string(c, SvCUR(sv)+1))
4082 e = (U8 *) SvEND(sv);
4085 if (!UTF8_IS_INVARIANT(ch)) {
4094 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4095 * this function provided for binary compatibility only
4099 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4101 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4105 =for apidoc sv_setsv
4107 Copies the contents of the source SV C<ssv> into the destination SV
4108 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4109 function if the source SV needs to be reused. Does not handle 'set' magic.
4110 Loosely speaking, it performs a copy-by-value, obliterating any previous
4111 content of the destination.
4113 You probably want to use one of the assortment of wrappers, such as
4114 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4115 C<SvSetMagicSV_nosteal>.
4117 =for apidoc sv_setsv_flags
4119 Copies the contents of the source SV C<ssv> into the destination SV
4120 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4121 function if the source SV needs to be reused. Does not handle 'set' magic.
4122 Loosely speaking, it performs a copy-by-value, obliterating any previous
4123 content of the destination.
4124 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4125 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
4126 implemented in terms of this function.
4128 You probably want to use one of the assortment of wrappers, such as
4129 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4130 C<SvSetMagicSV_nosteal>.
4132 This is the primary function for copying scalars, and most other
4133 copy-ish functions and macros use this underneath.
4139 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4141 register U32 sflags;
4147 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4149 sstr = &PL_sv_undef;
4150 stype = SvTYPE(sstr);
4151 dtype = SvTYPE(dstr);
4156 /* need to nuke the magic */
4158 SvRMAGICAL_off(dstr);
4161 /* There's a lot of redundancy below but we're going for speed here */
4166 if (dtype != SVt_PVGV) {
4167 (void)SvOK_off(dstr);
4175 sv_upgrade(dstr, SVt_IV);
4178 sv_upgrade(dstr, SVt_PVNV);
4182 sv_upgrade(dstr, SVt_PVIV);
4185 (void)SvIOK_only(dstr);
4186 SvIVX(dstr) = SvIVX(sstr);
4189 if (SvTAINTED(sstr))
4200 sv_upgrade(dstr, SVt_NV);
4205 sv_upgrade(dstr, SVt_PVNV);
4208 SvNVX(dstr) = SvNVX(sstr);
4209 (void)SvNOK_only(dstr);
4210 if (SvTAINTED(sstr))
4218 sv_upgrade(dstr, SVt_RV);
4219 else if (dtype == SVt_PVGV &&
4220 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4223 if (GvIMPORTED(dstr) != GVf_IMPORTED
4224 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4226 GvIMPORTED_on(dstr);
4235 #ifdef PERL_COPY_ON_WRITE
4236 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4237 if (dtype < SVt_PVIV)
4238 sv_upgrade(dstr, SVt_PVIV);
4245 sv_upgrade(dstr, SVt_PV);
4248 if (dtype < SVt_PVIV)
4249 sv_upgrade(dstr, SVt_PVIV);
4252 if (dtype < SVt_PVNV)
4253 sv_upgrade(dstr, SVt_PVNV);
4260 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4263 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4267 if (dtype <= SVt_PVGV) {
4269 if (dtype != SVt_PVGV) {
4270 char *name = GvNAME(sstr);
4271 STRLEN len = GvNAMELEN(sstr);
4272 /* don't upgrade SVt_PVLV: it can hold a glob */
4273 if (dtype != SVt_PVLV)
4274 sv_upgrade(dstr, SVt_PVGV);
4275 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4276 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4277 GvNAME(dstr) = savepvn(name, len);
4278 GvNAMELEN(dstr) = len;
4279 SvFAKE_on(dstr); /* can coerce to non-glob */
4281 /* ahem, death to those who redefine active sort subs */
4282 else if (PL_curstackinfo->si_type == PERLSI_SORT
4283 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4284 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4287 #ifdef GV_UNIQUE_CHECK
4288 if (GvUNIQUE((GV*)dstr)) {
4289 Perl_croak(aTHX_ PL_no_modify);
4293 (void)SvOK_off(dstr);
4294 GvINTRO_off(dstr); /* one-shot flag */
4296 GvGP(dstr) = gp_ref(GvGP(sstr));
4297 if (SvTAINTED(sstr))
4299 if (GvIMPORTED(dstr) != GVf_IMPORTED
4300 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4302 GvIMPORTED_on(dstr);
4310 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4312 if ((int)SvTYPE(sstr) != stype) {
4313 stype = SvTYPE(sstr);
4314 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4318 if (stype == SVt_PVLV)
4319 (void)SvUPGRADE(dstr, SVt_PVNV);
4321 (void)SvUPGRADE(dstr, (U32)stype);
4324 sflags = SvFLAGS(sstr);
4326 if (sflags & SVf_ROK) {
4327 if (dtype >= SVt_PV) {
4328 if (dtype == SVt_PVGV) {
4329 SV *sref = SvREFCNT_inc(SvRV(sstr));
4331 int intro = GvINTRO(dstr);
4333 #ifdef GV_UNIQUE_CHECK
4334 if (GvUNIQUE((GV*)dstr)) {
4335 Perl_croak(aTHX_ PL_no_modify);
4340 GvINTRO_off(dstr); /* one-shot flag */
4341 GvLINE(dstr) = CopLINE(PL_curcop);
4342 GvEGV(dstr) = (GV*)dstr;
4345 switch (SvTYPE(sref)) {
4348 SAVEGENERICSV(GvAV(dstr));
4350 dref = (SV*)GvAV(dstr);
4351 GvAV(dstr) = (AV*)sref;
4352 if (!GvIMPORTED_AV(dstr)
4353 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4355 GvIMPORTED_AV_on(dstr);
4360 SAVEGENERICSV(GvHV(dstr));
4362 dref = (SV*)GvHV(dstr);
4363 GvHV(dstr) = (HV*)sref;
4364 if (!GvIMPORTED_HV(dstr)
4365 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4367 GvIMPORTED_HV_on(dstr);
4372 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4373 SvREFCNT_dec(GvCV(dstr));
4374 GvCV(dstr) = Nullcv;
4375 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4376 PL_sub_generation++;
4378 SAVEGENERICSV(GvCV(dstr));
4381 dref = (SV*)GvCV(dstr);
4382 if (GvCV(dstr) != (CV*)sref) {
4383 CV* cv = GvCV(dstr);
4385 if (!GvCVGEN((GV*)dstr) &&
4386 (CvROOT(cv) || CvXSUB(cv)))
4388 /* ahem, death to those who redefine
4389 * active sort subs */
4390 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4391 PL_sortcop == CvSTART(cv))
4393 "Can't redefine active sort subroutine %s",
4394 GvENAME((GV*)dstr));
4395 /* Redefining a sub - warning is mandatory if
4396 it was a const and its value changed. */
4397 if (ckWARN(WARN_REDEFINE)
4399 && (!CvCONST((CV*)sref)
4400 || sv_cmp(cv_const_sv(cv),
4401 cv_const_sv((CV*)sref)))))
4403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4405 ? "Constant subroutine %s::%s redefined"
4406 : "Subroutine %s::%s redefined",
4407 HvNAME(GvSTASH((GV*)dstr)),
4408 GvENAME((GV*)dstr));
4412 cv_ckproto(cv, (GV*)dstr,
4413 SvPOK(sref) ? SvPVX(sref) : Nullch);
4415 GvCV(dstr) = (CV*)sref;
4416 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4417 GvASSUMECV_on(dstr);
4418 PL_sub_generation++;
4420 if (!GvIMPORTED_CV(dstr)
4421 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4423 GvIMPORTED_CV_on(dstr);
4428 SAVEGENERICSV(GvIOp(dstr));
4430 dref = (SV*)GvIOp(dstr);
4431 GvIOp(dstr) = (IO*)sref;
4435 SAVEGENERICSV(GvFORM(dstr));
4437 dref = (SV*)GvFORM(dstr);
4438 GvFORM(dstr) = (CV*)sref;
4442 SAVEGENERICSV(GvSV(dstr));
4444 dref = (SV*)GvSV(dstr);
4446 if (!GvIMPORTED_SV(dstr)
4447 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4449 GvIMPORTED_SV_on(dstr);
4455 if (SvTAINTED(sstr))
4460 (void)SvOOK_off(dstr); /* backoff */
4462 Safefree(SvPVX(dstr));
4463 SvLEN(dstr)=SvCUR(dstr)=0;
4466 (void)SvOK_off(dstr);
4467 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
4469 if (sflags & SVp_NOK) {
4471 /* Only set the public OK flag if the source has public OK. */
4472 if (sflags & SVf_NOK)
4473 SvFLAGS(dstr) |= SVf_NOK;
4474 SvNVX(dstr) = SvNVX(sstr);
4476 if (sflags & SVp_IOK) {
4477 (void)SvIOKp_on(dstr);
4478 if (sflags & SVf_IOK)
4479 SvFLAGS(dstr) |= SVf_IOK;
4480 if (sflags & SVf_IVisUV)
4482 SvIVX(dstr) = SvIVX(sstr);
4484 if (SvAMAGIC(sstr)) {
4488 else if (sflags & SVp_POK) {
4492 * Check to see if we can just swipe the string. If so, it's a
4493 * possible small lose on short strings, but a big win on long ones.
4494 * It might even be a win on short strings if SvPVX(dstr)
4495 * has to be allocated and SvPVX(sstr) has to be freed.
4498 /* Whichever path we take through the next code, we want this true,
4499 and doing it now facilitates the COW check. */
4500 (void)SvPOK_only(dstr);
4503 #ifdef PERL_COPY_ON_WRITE
4504 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4508 (sflags & SVs_TEMP) && /* slated for free anyway? */
4509 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4510 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4511 SvLEN(sstr) && /* and really is a string */
4512 /* and won't be needed again, potentially */
4513 !(PL_op && PL_op->op_type == OP_AASSIGN))
4514 #ifdef PERL_COPY_ON_WRITE
4515 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4516 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4517 && SvTYPE(sstr) >= SVt_PVIV)
4520 /* Failed the swipe test, and it's not a shared hash key either.
4521 Have to copy the string. */
4522 STRLEN len = SvCUR(sstr);
4523 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4524 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4525 SvCUR_set(dstr, len);
4526 *SvEND(dstr) = '\0';
4528 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4530 #ifdef PERL_COPY_ON_WRITE
4531 /* Either it's a shared hash key, or it's suitable for
4532 copy-on-write or we can swipe the string. */
4534 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4539 /* I believe I should acquire a global SV mutex if
4540 it's a COW sv (not a shared hash key) to stop
4541 it going un copy-on-write.
4542 If the source SV has gone un copy on write between up there
4543 and down here, then (assert() that) it is of the correct
4544 form to make it copy on write again */
4545 if ((sflags & (SVf_FAKE | SVf_READONLY))
4546 != (SVf_FAKE | SVf_READONLY)) {
4547 SvREADONLY_on(sstr);
4549 /* Make the source SV into a loop of 1.
4550 (about to become 2) */
4551 SV_COW_NEXT_SV_SET(sstr, sstr);
4555 /* Initial code is common. */
4556 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4558 SvFLAGS(dstr) &= ~SVf_OOK;
4559 Safefree(SvPVX(dstr) - SvIVX(dstr));
4561 else if (SvLEN(dstr))
4562 Safefree(SvPVX(dstr));
4565 #ifdef PERL_COPY_ON_WRITE
4567 /* making another shared SV. */
4568 STRLEN cur = SvCUR(sstr);
4569 STRLEN len = SvLEN(sstr);
4570 assert (SvTYPE(dstr) >= SVt_PVIV);
4572 /* SvIsCOW_normal */
4573 /* splice us in between source and next-after-source. */
4574 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4575 SV_COW_NEXT_SV_SET(sstr, dstr);
4576 SvPV_set(dstr, SvPVX(sstr));
4578 /* SvIsCOW_shared_hash */
4579 UV hash = SvUVX(sstr);
4580 DEBUG_C(PerlIO_printf(Perl_debug_log,
4581 "Copy on write: Sharing hash\n"));
4583 sharepvn(SvPVX(sstr),
4584 (sflags & SVf_UTF8?-cur:cur), hash));
4589 SvREADONLY_on(dstr);
4591 /* Relesase a global SV mutex. */
4595 { /* Passes the swipe test. */
4596 SvPV_set(dstr, SvPVX(sstr));
4597 SvLEN_set(dstr, SvLEN(sstr));
4598 SvCUR_set(dstr, SvCUR(sstr));
4601 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4602 SvPV_set(sstr, Nullch);
4608 if (sflags & SVf_UTF8)
4611 if (sflags & SVp_NOK) {
4613 if (sflags & SVf_NOK)
4614 SvFLAGS(dstr) |= SVf_NOK;
4615 SvNVX(dstr) = SvNVX(sstr);
4617 if (sflags & SVp_IOK) {
4618 (void)SvIOKp_on(dstr);
4619 if (sflags & SVf_IOK)
4620 SvFLAGS(dstr) |= SVf_IOK;
4621 if (sflags & SVf_IVisUV)
4623 SvIVX(dstr) = SvIVX(sstr);
4626 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4627 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4628 smg->mg_ptr, smg->mg_len);
4629 SvRMAGICAL_on(dstr);
4632 else if (sflags & SVp_IOK) {
4633 if (sflags & SVf_IOK)
4634 (void)SvIOK_only(dstr);
4636 (void)SvOK_off(dstr);
4637 (void)SvIOKp_on(dstr);
4639 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4640 if (sflags & SVf_IVisUV)
4642 SvIVX(dstr) = SvIVX(sstr);
4643 if (sflags & SVp_NOK) {
4644 if (sflags & SVf_NOK)
4645 (void)SvNOK_on(dstr);
4647 (void)SvNOKp_on(dstr);
4648 SvNVX(dstr) = SvNVX(sstr);
4651 else if (sflags & SVp_NOK) {
4652 if (sflags & SVf_NOK)
4653 (void)SvNOK_only(dstr);
4655 (void)SvOK_off(dstr);
4658 SvNVX(dstr) = SvNVX(sstr);
4661 if (dtype == SVt_PVGV) {
4662 if (ckWARN(WARN_MISC))
4663 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4666 (void)SvOK_off(dstr);
4668 if (SvTAINTED(sstr))
4673 =for apidoc sv_setsv_mg
4675 Like C<sv_setsv>, but also handles 'set' magic.
4681 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4683 sv_setsv(dstr,sstr);
4687 #ifdef PERL_COPY_ON_WRITE
4689 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4691 STRLEN cur = SvCUR(sstr);
4692 STRLEN len = SvLEN(sstr);
4693 register char *new_pv;
4696 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4704 if (SvTHINKFIRST(dstr))
4705 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4706 else if (SvPVX(dstr))
4707 Safefree(SvPVX(dstr));
4711 (void)SvUPGRADE (dstr, SVt_PVIV);
4713 assert (SvPOK(sstr));
4714 assert (SvPOKp(sstr));
4715 assert (!SvIOK(sstr));
4716 assert (!SvIOKp(sstr));
4717 assert (!SvNOK(sstr));
4718 assert (!SvNOKp(sstr));
4720 if (SvIsCOW(sstr)) {
4722 if (SvLEN(sstr) == 0) {
4723 /* source is a COW shared hash key. */
4724 UV hash = SvUVX(sstr);
4725 DEBUG_C(PerlIO_printf(Perl_debug_log,
4726 "Fast copy on write: Sharing hash\n"));
4728 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4731 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4733 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4734 (void)SvUPGRADE (sstr, SVt_PVIV);
4735 SvREADONLY_on(sstr);
4737 DEBUG_C(PerlIO_printf(Perl_debug_log,
4738 "Fast copy on write: Converting sstr to COW\n"));
4739 SV_COW_NEXT_SV_SET(dstr, sstr);
4741 SV_COW_NEXT_SV_SET(sstr, dstr);
4742 new_pv = SvPVX(sstr);
4745 SvPV_set(dstr, new_pv);
4746 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4759 =for apidoc sv_setpvn
4761 Copies a string into an SV. The C<len> parameter indicates the number of
4762 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4768 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4770 register char *dptr;
4772 SV_CHECK_THINKFIRST_COW_DROP(sv);
4778 /* len is STRLEN which is unsigned, need to copy to signed */
4781 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4783 (void)SvUPGRADE(sv, SVt_PV);
4785 SvGROW(sv, len + 1);
4787 Move(ptr,dptr,len,char);
4790 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4795 =for apidoc sv_setpvn_mg
4797 Like C<sv_setpvn>, but also handles 'set' magic.
4803 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4805 sv_setpvn(sv,ptr,len);
4810 =for apidoc sv_setpv
4812 Copies a string into an SV. The string must be null-terminated. Does not
4813 handle 'set' magic. See C<sv_setpv_mg>.
4819 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4821 register STRLEN len;
4823 SV_CHECK_THINKFIRST_COW_DROP(sv);
4829 (void)SvUPGRADE(sv, SVt_PV);
4831 SvGROW(sv, len + 1);
4832 Move(ptr,SvPVX(sv),len+1,char);
4834 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4839 =for apidoc sv_setpv_mg
4841 Like C<sv_setpv>, but also handles 'set' magic.
4847 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4854 =for apidoc sv_usepvn
4856 Tells an SV to use C<ptr> to find its string value. Normally the string is
4857 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4858 The C<ptr> should point to memory that was allocated by C<malloc>. The
4859 string length, C<len>, must be supplied. This function will realloc the
4860 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4861 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4862 See C<sv_usepvn_mg>.
4868 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4870 SV_CHECK_THINKFIRST_COW_DROP(sv);
4871 (void)SvUPGRADE(sv, SVt_PV);
4876 (void)SvOOK_off(sv);
4877 if (SvPVX(sv) && SvLEN(sv))
4878 Safefree(SvPVX(sv));
4879 Renew(ptr, len+1, char);
4882 SvLEN_set(sv, len+1);
4884 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4889 =for apidoc sv_usepvn_mg
4891 Like C<sv_usepvn>, but also handles 'set' magic.
4897 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4899 sv_usepvn(sv,ptr,len);
4903 #ifdef PERL_COPY_ON_WRITE
4904 /* Need to do this *after* making the SV normal, as we need the buffer
4905 pointer to remain valid until after we've copied it. If we let go too early,
4906 another thread could invalidate it by unsharing last of the same hash key
4907 (which it can do by means other than releasing copy-on-write Svs)
4908 or by changing the other copy-on-write SVs in the loop. */
4910 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4911 U32 hash, SV *after)
4913 if (len) { /* this SV was SvIsCOW_normal(sv) */
4914 /* we need to find the SV pointing to us. */
4915 SV *current = SV_COW_NEXT_SV(after);
4917 if (current == sv) {
4918 /* The SV we point to points back to us (there were only two of us
4920 Hence other SV is no longer copy on write either. */
4922 SvREADONLY_off(after);
4924 /* We need to follow the pointers around the loop. */
4926 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4929 /* don't loop forever if the structure is bust, and we have
4930 a pointer into a closed loop. */
4931 assert (current != after);
4932 assert (SvPVX(current) == pvx);
4934 /* Make the SV before us point to the SV after us. */
4935 SV_COW_NEXT_SV_SET(current, after);
4938 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4943 Perl_sv_release_IVX(pTHX_ register SV *sv)
4946 sv_force_normal_flags(sv, 0);
4947 return SvOOK_off(sv);
4951 =for apidoc sv_force_normal_flags
4953 Undo various types of fakery on an SV: if the PV is a shared string, make
4954 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4955 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4956 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4957 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4958 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4959 set to some other value.) In addition, the C<flags> parameter gets passed to
4960 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4961 with flags set to 0.
4967 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4969 #ifdef PERL_COPY_ON_WRITE
4970 if (SvREADONLY(sv)) {
4971 /* At this point I believe I should acquire a global SV mutex. */
4973 char *pvx = SvPVX(sv);
4974 STRLEN len = SvLEN(sv);
4975 STRLEN cur = SvCUR(sv);
4976 U32 hash = SvUVX(sv);
4977 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4979 PerlIO_printf(Perl_debug_log,
4980 "Copy on write: Force normal %ld\n",
4986 /* This SV doesn't own the buffer, so need to New() a new one: */
4989 if (flags & SV_COW_DROP_PV) {
4990 /* OK, so we don't need to copy our buffer. */
4993 SvGROW(sv, cur + 1);
4994 Move(pvx,SvPVX(sv),cur,char);
4998 sv_release_COW(sv, pvx, cur, len, hash, next);
5003 else if (IN_PERL_RUNTIME)
5004 Perl_croak(aTHX_ PL_no_modify);
5005 /* At this point I believe that I can drop the global SV mutex. */
5008 if (SvREADONLY(sv)) {
5010 char *pvx = SvPVX(sv);
5011 int is_utf8 = SvUTF8(sv);
5012 STRLEN len = SvCUR(sv);
5013 U32 hash = SvUVX(sv);
5018 SvGROW(sv, len + 1);
5019 Move(pvx,SvPVX(sv),len,char);
5021 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5023 else if (IN_PERL_RUNTIME)
5024 Perl_croak(aTHX_ PL_no_modify);
5028 sv_unref_flags(sv, flags);
5029 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5034 =for apidoc sv_force_normal
5036 Undo various types of fakery on an SV: if the PV is a shared string, make
5037 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5038 an xpvmg. See also C<sv_force_normal_flags>.
5044 Perl_sv_force_normal(pTHX_ register SV *sv)
5046 sv_force_normal_flags(sv, 0);
5052 Efficient removal of characters from the beginning of the string buffer.
5053 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5054 the string buffer. The C<ptr> becomes the first character of the adjusted
5055 string. Uses the "OOK hack".
5056 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5057 refer to the same chunk of data.
5063 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
5065 register STRLEN delta;
5066 if (!ptr || !SvPOKp(sv))
5068 delta = ptr - SvPVX(sv);
5069 SV_CHECK_THINKFIRST(sv);
5070 if (SvTYPE(sv) < SVt_PVIV)
5071 sv_upgrade(sv,SVt_PVIV);
5074 if (!SvLEN(sv)) { /* make copy of shared string */
5075 char *pvx = SvPVX(sv);
5076 STRLEN len = SvCUR(sv);
5077 SvGROW(sv, len + 1);
5078 Move(pvx,SvPVX(sv),len,char);
5082 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5083 and we do that anyway inside the SvNIOK_off
5085 SvFLAGS(sv) |= SVf_OOK;
5094 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5095 * this function provided for binary compatibility only
5099 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5101 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5105 =for apidoc sv_catpvn
5107 Concatenates the string onto the end of the string which is in the SV. The
5108 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5109 status set, then the bytes appended should be valid UTF-8.
5110 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5112 =for apidoc sv_catpvn_flags
5114 Concatenates the string onto the end of the string which is in the SV. The
5115 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5116 status set, then the bytes appended should be valid UTF-8.
5117 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5118 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5119 in terms of this function.
5125 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5130 dstr = SvPV_force_flags(dsv, dlen, flags);
5131 SvGROW(dsv, dlen + slen + 1);
5134 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5137 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5142 =for apidoc sv_catpvn_mg
5144 Like C<sv_catpvn>, but also handles 'set' magic.
5150 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5152 sv_catpvn(sv,ptr,len);
5156 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5157 * this function provided for binary compatibility only
5161 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5163 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5167 =for apidoc sv_catsv
5169 Concatenates the string from SV C<ssv> onto the end of the string in
5170 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5171 not 'set' magic. See C<sv_catsv_mg>.
5173 =for apidoc sv_catsv_flags
5175 Concatenates the string from SV C<ssv> onto the end of the string in
5176 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5177 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5178 and C<sv_catsv_nomg> are implemented in terms of this function.
5183 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5189 if ((spv = SvPV(ssv, slen))) {
5190 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5191 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5192 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5193 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5194 dsv->sv_flags doesn't have that bit set.
5195 Andy Dougherty 12 Oct 2001
5197 I32 sutf8 = DO_UTF8(ssv);
5200 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5202 dutf8 = DO_UTF8(dsv);
5204 if (dutf8 != sutf8) {
5206 /* Not modifying source SV, so taking a temporary copy. */
5207 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5209 sv_utf8_upgrade(csv);
5210 spv = SvPV(csv, slen);
5213 sv_utf8_upgrade_nomg(dsv);
5215 sv_catpvn_nomg(dsv, spv, slen);
5220 =for apidoc sv_catsv_mg
5222 Like C<sv_catsv>, but also handles 'set' magic.
5228 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5235 =for apidoc sv_catpv
5237 Concatenates the string onto the end of the string which is in the SV.
5238 If the SV has the UTF-8 status set, then the bytes appended should be
5239 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5244 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5246 register STRLEN len;
5252 junk = SvPV_force(sv, tlen);
5254 SvGROW(sv, tlen + len + 1);
5257 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5259 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5264 =for apidoc sv_catpv_mg
5266 Like C<sv_catpv>, but also handles 'set' magic.
5272 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5281 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5282 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5289 Perl_newSV(pTHX_ STRLEN len)
5295 sv_upgrade(sv, SVt_PV);
5296 SvGROW(sv, len + 1);
5301 =for apidoc sv_magicext
5303 Adds magic to an SV, upgrading it if necessary. Applies the
5304 supplied vtable and returns pointer to the magic added.
5306 Note that sv_magicext will allow things that sv_magic will not.
5307 In particular you can add magic to SvREADONLY SVs and and more than
5308 one instance of the same 'how'
5310 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
5311 if C<namelen> is zero then C<name> is stored as-is and - as another special
5312 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
5313 an C<SV*> and has its REFCNT incremented
5315 (This is now used as a subroutine by sv_magic.)
5320 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
5321 const char* name, I32 namlen)
5325 if (SvTYPE(sv) < SVt_PVMG) {
5326 (void)SvUPGRADE(sv, SVt_PVMG);
5328 Newz(702,mg, 1, MAGIC);
5329 mg->mg_moremagic = SvMAGIC(sv);
5332 /* Some magic sontains a reference loop, where the sv and object refer to
5333 each other. To prevent a reference loop that would prevent such
5334 objects being freed, we look for such loops and if we find one we
5335 avoid incrementing the object refcount.
5337 Note we cannot do this to avoid self-tie loops as intervening RV must
5338 have its REFCNT incremented to keep it in existence.
5341 if (!obj || obj == sv ||
5342 how == PERL_MAGIC_arylen ||
5343 how == PERL_MAGIC_qr ||
5344 (SvTYPE(obj) == SVt_PVGV &&
5345 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5346 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5347 GvFORM(obj) == (CV*)sv)))
5352 mg->mg_obj = SvREFCNT_inc(obj);
5353 mg->mg_flags |= MGf_REFCOUNTED;
5356 /* Normal self-ties simply pass a null object, and instead of
5357 using mg_obj directly, use the SvTIED_obj macro to produce a
5358 new RV as needed. For glob "self-ties", we are tieing the PVIO
5359 with an RV obj pointing to the glob containing the PVIO. In
5360 this case, to avoid a reference loop, we need to weaken the
5364 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5365 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5371 mg->mg_len = namlen;
5374 mg->mg_ptr = savepvn(name, namlen);
5375 else if (namlen == HEf_SVKEY)
5376 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5378 mg->mg_ptr = (char *) name;
5380 mg->mg_virtual = vtable;
5384 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5389 =for apidoc sv_magic
5391 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5392 then adds a new magic item of type C<how> to the head of the magic list.
5398 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5403 #ifdef PERL_COPY_ON_WRITE
5405 sv_force_normal_flags(sv, 0);
5407 if (SvREADONLY(sv)) {
5409 && how != PERL_MAGIC_regex_global
5410 && how != PERL_MAGIC_bm
5411 && how != PERL_MAGIC_fm
5412 && how != PERL_MAGIC_sv
5413 && how != PERL_MAGIC_backref
5416 Perl_croak(aTHX_ PL_no_modify);
5419 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5420 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5421 /* sv_magic() refuses to add a magic of the same 'how' as an
5424 if (how == PERL_MAGIC_taint)
5432 vtable = &PL_vtbl_sv;
5434 case PERL_MAGIC_overload:
5435 vtable = &PL_vtbl_amagic;
5437 case PERL_MAGIC_overload_elem:
5438 vtable = &PL_vtbl_amagicelem;
5440 case PERL_MAGIC_overload_table:
5441 vtable = &PL_vtbl_ovrld;
5444 vtable = &PL_vtbl_bm;
5446 case PERL_MAGIC_regdata:
5447 vtable = &PL_vtbl_regdata;
5449 case PERL_MAGIC_regdatum:
5450 vtable = &PL_vtbl_regdatum;
5452 case PERL_MAGIC_env:
5453 vtable = &PL_vtbl_env;
5456 vtable = &PL_vtbl_fm;
5458 case PERL_MAGIC_envelem:
5459 vtable = &PL_vtbl_envelem;
5461 case PERL_MAGIC_regex_global:
5462 vtable = &PL_vtbl_mglob;
5464 case PERL_MAGIC_isa:
5465 vtable = &PL_vtbl_isa;
5467 case PERL_MAGIC_isaelem:
5468 vtable = &PL_vtbl_isaelem;
5470 case PERL_MAGIC_nkeys:
5471 vtable = &PL_vtbl_nkeys;
5473 case PERL_MAGIC_dbfile:
5476 case PERL_MAGIC_dbline:
5477 vtable = &PL_vtbl_dbline;
5479 #ifdef USE_LOCALE_COLLATE
5480 case PERL_MAGIC_collxfrm:
5481 vtable = &PL_vtbl_collxfrm;
5483 #endif /* USE_LOCALE_COLLATE */
5484 case PERL_MAGIC_tied:
5485 vtable = &PL_vtbl_pack;
5487 case PERL_MAGIC_tiedelem:
5488 case PERL_MAGIC_tiedscalar:
5489 vtable = &PL_vtbl_packelem;
5492 vtable = &PL_vtbl_regexp;
5494 case PERL_MAGIC_sig:
5495 vtable = &PL_vtbl_sig;
5497 case PERL_MAGIC_sigelem:
5498 vtable = &PL_vtbl_sigelem;
5500 case PERL_MAGIC_taint:
5501 vtable = &PL_vtbl_taint;
5503 case PERL_MAGIC_uvar:
5504 vtable = &PL_vtbl_uvar;
5506 case PERL_MAGIC_vec:
5507 vtable = &PL_vtbl_vec;
5509 case PERL_MAGIC_vstring:
5512 case PERL_MAGIC_utf8:
5513 vtable = &PL_vtbl_utf8;
5515 case PERL_MAGIC_substr:
5516 vtable = &PL_vtbl_substr;
5518 case PERL_MAGIC_defelem:
5519 vtable = &PL_vtbl_defelem;
5521 case PERL_MAGIC_glob:
5522 vtable = &PL_vtbl_glob;
5524 case PERL_MAGIC_arylen:
5525 vtable = &PL_vtbl_arylen;
5527 case PERL_MAGIC_pos:
5528 vtable = &PL_vtbl_pos;
5530 case PERL_MAGIC_backref:
5531 vtable = &PL_vtbl_backref;
5533 case PERL_MAGIC_ext:
5534 /* Reserved for use by extensions not perl internals. */
5535 /* Useful for attaching extension internal data to perl vars. */
5536 /* Note that multiple extensions may clash if magical scalars */
5537 /* etc holding private data from one are passed to another. */
5540 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5543 /* Rest of work is done else where */
5544 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5547 case PERL_MAGIC_taint:
5550 case PERL_MAGIC_ext:
5551 case PERL_MAGIC_dbfile:
5558 =for apidoc sv_unmagic
5560 Removes all magic of type C<type> from an SV.
5566 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5570 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5573 for (mg = *mgp; mg; mg = *mgp) {
5574 if (mg->mg_type == type) {
5575 MGVTBL* vtbl = mg->mg_virtual;
5576 *mgp = mg->mg_moremagic;
5577 if (vtbl && vtbl->svt_free)
5578 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5579 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5581 Safefree(mg->mg_ptr);
5582 else if (mg->mg_len == HEf_SVKEY)
5583 SvREFCNT_dec((SV*)mg->mg_ptr);
5584 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5585 Safefree(mg->mg_ptr);
5587 if (mg->mg_flags & MGf_REFCOUNTED)
5588 SvREFCNT_dec(mg->mg_obj);
5592 mgp = &mg->mg_moremagic;
5596 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5603 =for apidoc sv_rvweaken
5605 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5606 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5607 push a back-reference to this RV onto the array of backreferences
5608 associated with that magic.
5614 Perl_sv_rvweaken(pTHX_ SV *sv)
5617 if (!SvOK(sv)) /* let undefs pass */
5620 Perl_croak(aTHX_ "Can't weaken a nonreference");
5621 else if (SvWEAKREF(sv)) {
5622 if (ckWARN(WARN_MISC))
5623 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5627 sv_add_backref(tsv, sv);
5633 /* Give tsv backref magic if it hasn't already got it, then push a
5634 * back-reference to sv onto the array associated with the backref magic.
5638 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5642 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5643 av = (AV*)mg->mg_obj;
5646 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5647 /* av now has a refcnt of 2, which avoids it getting freed
5648 * before us during global cleanup. The extra ref is removed
5649 * by magic_killbackrefs() when tsv is being freed */
5651 if (AvFILLp(av) >= AvMAX(av)) {
5653 SV **svp = AvARRAY(av);
5654 for (i = AvFILLp(av); i >= 0; i--)
5656 svp[i] = sv; /* reuse the slot */
5659 av_extend(av, AvFILLp(av)+1);
5661 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5664 /* delete a back-reference to ourselves from the backref magic associated
5665 * with the SV we point to.
5669 S_sv_del_backref(pTHX_ SV *sv)
5676 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5677 Perl_croak(aTHX_ "panic: del_backref");
5678 av = (AV *)mg->mg_obj;
5680 for (i = AvFILLp(av); i >= 0; i--)
5681 if (svp[i] == sv) svp[i] = Nullsv;
5685 =for apidoc sv_insert
5687 Inserts a string at the specified offset/length within the SV. Similar to
5688 the Perl substr() function.
5694 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
5698 register char *midend;
5699 register char *bigend;
5705 Perl_croak(aTHX_ "Can't modify non-existent substring");
5706 SvPV_force(bigstr, curlen);
5707 (void)SvPOK_only_UTF8(bigstr);
5708 if (offset + len > curlen) {
5709 SvGROW(bigstr, offset+len+1);
5710 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5711 SvCUR_set(bigstr, offset+len);
5715 i = littlelen - len;
5716 if (i > 0) { /* string might grow */
5717 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5718 mid = big + offset + len;
5719 midend = bigend = big + SvCUR(bigstr);
5722 while (midend > mid) /* shove everything down */
5723 *--bigend = *--midend;
5724 Move(little,big+offset,littlelen,char);
5730 Move(little,SvPVX(bigstr)+offset,len,char);
5735 big = SvPVX(bigstr);
5738 bigend = big + SvCUR(bigstr);
5740 if (midend > bigend)
5741 Perl_croak(aTHX_ "panic: sv_insert");
5743 if (mid - big > bigend - midend) { /* faster to shorten from end */
5745 Move(little, mid, littlelen,char);
5748 i = bigend - midend;
5750 Move(midend, mid, i,char);
5754 SvCUR_set(bigstr, mid - big);
5757 else if ((i = mid - big)) { /* faster from front */
5758 midend -= littlelen;
5760 sv_chop(bigstr,midend-i);
5765 Move(little, mid, littlelen,char);
5767 else if (littlelen) {
5768 midend -= littlelen;
5769 sv_chop(bigstr,midend);
5770 Move(little,midend,littlelen,char);
5773 sv_chop(bigstr,midend);
5779 =for apidoc sv_replace
5781 Make the first argument a copy of the second, then delete the original.
5782 The target SV physically takes over ownership of the body of the source SV
5783 and inherits its flags; however, the target keeps any magic it owns,
5784 and any magic in the source is discarded.
5785 Note that this is a rather specialist SV copying operation; most of the
5786 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5792 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5794 U32 refcnt = SvREFCNT(sv);
5795 SV_CHECK_THINKFIRST_COW_DROP(sv);
5796 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5797 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5798 if (SvMAGICAL(sv)) {
5802 sv_upgrade(nsv, SVt_PVMG);
5803 SvMAGIC(nsv) = SvMAGIC(sv);
5804 SvFLAGS(nsv) |= SvMAGICAL(sv);
5810 assert(!SvREFCNT(sv));
5811 StructCopy(nsv,sv,SV);
5812 #ifdef PERL_COPY_ON_WRITE
5813 if (SvIsCOW_normal(nsv)) {
5814 /* We need to follow the pointers around the loop to make the
5815 previous SV point to sv, rather than nsv. */
5818 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5821 assert(SvPVX(current) == SvPVX(nsv));
5823 /* Make the SV before us point to the SV after us. */
5825 PerlIO_printf(Perl_debug_log, "previous is\n");
5827 PerlIO_printf(Perl_debug_log,
5828 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5829 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5831 SV_COW_NEXT_SV_SET(current, sv);
5834 SvREFCNT(sv) = refcnt;
5835 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5841 =for apidoc sv_clear
5843 Clear an SV: call any destructors, free up any memory used by the body,
5844 and free the body itself. The SV's head is I<not> freed, although
5845 its type is set to all 1's so that it won't inadvertently be assumed
5846 to be live during global destruction etc.
5847 This function should only be called when REFCNT is zero. Most of the time
5848 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5855 Perl_sv_clear(pTHX_ register SV *sv)
5859 assert(SvREFCNT(sv) == 0);
5862 if (PL_defstash) { /* Still have a symbol table? */
5869 stash = SvSTASH(sv);
5870 destructor = StashHANDLER(stash,DESTROY);
5872 SV* tmpref = newRV(sv);
5873 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5875 PUSHSTACKi(PERLSI_DESTROY);
5880 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5886 if(SvREFCNT(tmpref) < 2) {
5887 /* tmpref is not kept alive! */
5892 SvREFCNT_dec(tmpref);
5894 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5898 if (PL_in_clean_objs)
5899 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5901 /* DESTROY gave object new lease on life */
5907 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5908 SvOBJECT_off(sv); /* Curse the object. */
5909 if (SvTYPE(sv) != SVt_PVIO)
5910 --PL_sv_objcount; /* XXX Might want something more general */
5913 if (SvTYPE(sv) >= SVt_PVMG) {
5916 if (SvFLAGS(sv) & SVpad_TYPED)
5917 SvREFCNT_dec(SvSTASH(sv));
5920 switch (SvTYPE(sv)) {
5923 IoIFP(sv) != PerlIO_stdin() &&
5924 IoIFP(sv) != PerlIO_stdout() &&
5925 IoIFP(sv) != PerlIO_stderr())
5927 io_close((IO*)sv, FALSE);
5929 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5930 PerlDir_close(IoDIRP(sv));
5931 IoDIRP(sv) = (DIR*)NULL;
5932 Safefree(IoTOP_NAME(sv));
5933 Safefree(IoFMT_NAME(sv));
5934 Safefree(IoBOTTOM_NAME(sv));
5949 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5950 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5951 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5952 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5954 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5955 SvREFCNT_dec(LvTARG(sv));
5959 Safefree(GvNAME(sv));
5960 /* cannot decrease stash refcount yet, as we might recursively delete
5961 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5962 of stash until current sv is completely gone.
5963 -- JohnPC, 27 Mar 1998 */
5964 stash = GvSTASH(sv);
5970 (void)SvOOK_off(sv);
5978 SvREFCNT_dec(SvRV(sv));
5980 #ifdef PERL_COPY_ON_WRITE
5981 else if (SvPVX(sv)) {
5983 /* I believe I need to grab the global SV mutex here and
5984 then recheck the COW status. */
5986 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5989 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5990 SvUVX(sv), SV_COW_NEXT_SV(sv));
5991 /* And drop it here. */
5993 } else if (SvLEN(sv)) {
5994 Safefree(SvPVX(sv));
5998 else if (SvPVX(sv) && SvLEN(sv))
5999 Safefree(SvPVX(sv));
6000 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6001 unsharepvn(SvPVX(sv),
6002 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6016 switch (SvTYPE(sv)) {
6032 del_XPVIV(SvANY(sv));
6035 del_XPVNV(SvANY(sv));
6038 del_XPVMG(SvANY(sv));
6041 del_XPVLV(SvANY(sv));
6044 del_XPVAV(SvANY(sv));
6047 del_XPVHV(SvANY(sv));
6050 del_XPVCV(SvANY(sv));
6053 del_XPVGV(SvANY(sv));
6054 /* code duplication for increased performance. */
6055 SvFLAGS(sv) &= SVf_BREAK;
6056 SvFLAGS(sv) |= SVTYPEMASK;
6057 /* decrease refcount of the stash that owns this GV, if any */
6059 SvREFCNT_dec(stash);
6060 return; /* not break, SvFLAGS reset already happened */
6062 del_XPVBM(SvANY(sv));
6065 del_XPVFM(SvANY(sv));
6068 del_XPVIO(SvANY(sv));
6071 SvFLAGS(sv) &= SVf_BREAK;
6072 SvFLAGS(sv) |= SVTYPEMASK;
6076 =for apidoc sv_newref
6078 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6085 Perl_sv_newref(pTHX_ SV *sv)
6095 Decrement an SV's reference count, and if it drops to zero, call
6096 C<sv_clear> to invoke destructors and free up any memory used by
6097 the body; finally, deallocate the SV's head itself.
6098 Normally called via a wrapper macro C<SvREFCNT_dec>.
6104 Perl_sv_free(pTHX_ SV *sv)
6108 if (SvREFCNT(sv) == 0) {
6109 if (SvFLAGS(sv) & SVf_BREAK)
6110 /* this SV's refcnt has been artificially decremented to
6111 * trigger cleanup */
6113 if (PL_in_clean_all) /* All is fair */
6115 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6116 /* make sure SvREFCNT(sv)==0 happens very seldom */
6117 SvREFCNT(sv) = (~(U32)0)/2;
6120 if (ckWARN_d(WARN_INTERNAL))
6121 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6122 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6123 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6126 if (--(SvREFCNT(sv)) > 0)
6128 Perl_sv_free2(aTHX_ sv);
6132 Perl_sv_free2(pTHX_ SV *sv)
6136 if (ckWARN_d(WARN_DEBUGGING))
6137 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6138 "Attempt to free temp prematurely: SV 0x%"UVxf
6139 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6143 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6144 /* make sure SvREFCNT(sv)==0 happens very seldom */
6145 SvREFCNT(sv) = (~(U32)0)/2;
6156 Returns the length of the string in the SV. Handles magic and type
6157 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6163 Perl_sv_len(pTHX_ register SV *sv)
6171 len = mg_length(sv);
6173 (void)SvPV(sv, len);
6178 =for apidoc sv_len_utf8
6180 Returns the number of characters in the string in an SV, counting wide
6181 UTF-8 bytes as a single character. Handles magic and type coercion.
6187 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6188 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6189 * (Note that the mg_len is not the length of the mg_ptr field.)
6194 Perl_sv_len_utf8(pTHX_ register SV *sv)
6200 return mg_length(sv);
6204 U8 *s = (U8*)SvPV(sv, len);
6205 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6207 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6209 #ifdef PERL_UTF8_CACHE_ASSERT
6210 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6214 ulen = Perl_utf8_length(aTHX_ s, s + len);
6215 if (!mg && !SvREADONLY(sv)) {
6216 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6217 mg = mg_find(sv, PERL_MAGIC_utf8);
6227 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6228 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6229 * between UTF-8 and byte offsets. There are two (substr offset and substr
6230 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6231 * and byte offset) cache positions.
6233 * The mg_len field is used by sv_len_utf8(), see its comments.
6234 * Note that the mg_len is not the length of the mg_ptr field.
6238 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
6242 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6244 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6248 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6250 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6251 (*mgp)->mg_ptr = (char *) *cachep;
6255 (*cachep)[i] = *offsetp;
6256 (*cachep)[i+1] = s - start;
6264 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6265 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6266 * between UTF-8 and byte offsets. See also the comments of
6267 * S_utf8_mg_pos_init().
6271 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6275 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6277 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6278 if (*mgp && (*mgp)->mg_ptr) {
6279 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6280 ASSERT_UTF8_CACHE(*cachep);
6281 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6283 else { /* We will skip to the right spot. */
6288 /* The assumption is that going backward is half
6289 * the speed of going forward (that's where the
6290 * 2 * backw in the below comes from). (The real
6291 * figure of course depends on the UTF-8 data.) */
6293 if ((*cachep)[i] > (STRLEN)uoff) {
6295 backw = (*cachep)[i] - (STRLEN)uoff;
6297 if (forw < 2 * backw)
6300 p = start + (*cachep)[i+1];
6302 /* Try this only for the substr offset (i == 0),
6303 * not for the substr length (i == 2). */
6304 else if (i == 0) { /* (*cachep)[i] < uoff */
6305 STRLEN ulen = sv_len_utf8(sv);
6307 if ((STRLEN)uoff < ulen) {
6308 forw = (STRLEN)uoff - (*cachep)[i];
6309 backw = ulen - (STRLEN)uoff;
6311 if (forw < 2 * backw)
6312 p = start + (*cachep)[i+1];
6317 /* If the string is not long enough for uoff,
6318 * we could extend it, but not at this low a level. */
6322 if (forw < 2 * backw) {
6329 while (UTF8_IS_CONTINUATION(*p))
6334 /* Update the cache. */
6335 (*cachep)[i] = (STRLEN)uoff;
6336 (*cachep)[i+1] = p - start;
6338 /* Drop the stale "length" cache */
6347 if (found) { /* Setup the return values. */
6348 *offsetp = (*cachep)[i+1];
6349 *sp = start + *offsetp;
6352 *offsetp = send - start;
6354 else if (*sp < start) {
6360 #ifdef PERL_UTF8_CACHE_ASSERT
6365 while (n-- && s < send)
6369 assert(*offsetp == s - start);
6370 assert((*cachep)[0] == (STRLEN)uoff);
6371 assert((*cachep)[1] == *offsetp);
6373 ASSERT_UTF8_CACHE(*cachep);
6382 =for apidoc sv_pos_u2b
6384 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6385 the start of the string, to a count of the equivalent number of bytes; if
6386 lenp is non-zero, it does the same to lenp, but this time starting from
6387 the offset, rather than from the start of the string. Handles magic and
6394 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6395 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6396 * byte offsets. See also the comments of S_utf8_mg_pos().
6401 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6412 start = s = (U8*)SvPV(sv, len);
6414 I32 uoffset = *offsetp;
6419 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6421 if (!found && uoffset > 0) {
6422 while (s < send && uoffset--)
6426 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
6428 *offsetp = s - start;
6433 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
6437 if (!found && *lenp > 0) {
6440 while (s < send && ulen--)
6444 utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
6448 ASSERT_UTF8_CACHE(cache);
6460 =for apidoc sv_pos_b2u
6462 Converts the value pointed to by offsetp from a count of bytes from the
6463 start of the string, to a count of the equivalent number of UTF-8 chars.
6464 Handles magic and type coercion.
6470 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6471 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6472 * byte offsets. See also the comments of S_utf8_mg_pos().
6477 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6485 s = (U8*)SvPV(sv, len);
6486 if ((I32)len < *offsetp)
6487 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6489 U8* send = s + *offsetp;
6491 STRLEN *cache = NULL;
6495 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6496 mg = mg_find(sv, PERL_MAGIC_utf8);
6497 if (mg && mg->mg_ptr) {
6498 cache = (STRLEN *) mg->mg_ptr;
6499 if (cache[1] == (STRLEN)*offsetp) {
6500 /* An exact match. */
6501 *offsetp = cache[0];
6505 else if (cache[1] < (STRLEN)*offsetp) {
6506 /* We already know part of the way. */
6509 /* Let the below loop do the rest. */
6511 else { /* cache[1] > *offsetp */
6512 /* We already know all of the way, now we may
6513 * be able to walk back. The same assumption
6514 * is made as in S_utf8_mg_pos(), namely that
6515 * walking backward is twice slower than
6516 * walking forward. */
6517 STRLEN forw = *offsetp;
6518 STRLEN backw = cache[1] - *offsetp;
6520 if (!(forw < 2 * backw)) {
6521 U8 *p = s + cache[1];
6528 while (UTF8_IS_CONTINUATION(*p)) {
6536 *offsetp = cache[0];
6538 /* Drop the stale "length" cache */
6546 ASSERT_UTF8_CACHE(cache);
6552 /* Call utf8n_to_uvchr() to validate the sequence
6553 * (unless a simple non-UTF character) */
6554 if (!UTF8_IS_INVARIANT(*s))
6555 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6564 if (!SvREADONLY(sv)) {
6566 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6567 mg = mg_find(sv, PERL_MAGIC_utf8);
6572 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6573 mg->mg_ptr = (char *) cache;
6578 cache[1] = *offsetp;
6579 /* Drop the stale "length" cache */
6592 Returns a boolean indicating whether the strings in the two SVs are
6593 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6594 coerce its args to strings if necessary.
6600 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6608 SV* svrecode = Nullsv;
6615 pv1 = SvPV(sv1, cur1);
6622 pv2 = SvPV(sv2, cur2);
6624 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6625 /* Differing utf8ness.
6626 * Do not UTF8size the comparands as a side-effect. */
6629 svrecode = newSVpvn(pv2, cur2);
6630 sv_recode_to_utf8(svrecode, PL_encoding);
6631 pv2 = SvPV(svrecode, cur2);
6634 svrecode = newSVpvn(pv1, cur1);
6635 sv_recode_to_utf8(svrecode, PL_encoding);
6636 pv1 = SvPV(svrecode, cur1);
6638 /* Now both are in UTF-8. */
6643 bool is_utf8 = TRUE;
6646 /* sv1 is the UTF-8 one,
6647 * if is equal it must be downgrade-able */
6648 char *pv = (char*)bytes_from_utf8((U8*)pv1,
6654 /* sv2 is the UTF-8 one,
6655 * if is equal it must be downgrade-able */
6656 char *pv = (char *)bytes_from_utf8((U8*)pv2,
6662 /* Downgrade not possible - cannot be eq */
6669 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6672 SvREFCNT_dec(svrecode);
6683 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6684 string in C<sv1> is less than, equal to, or greater than the string in
6685 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6686 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6692 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6695 char *pv1, *pv2, *tpv = Nullch;
6697 SV *svrecode = Nullsv;
6704 pv1 = SvPV(sv1, cur1);
6711 pv2 = SvPV(sv2, cur2);
6713 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6714 /* Differing utf8ness.
6715 * Do not UTF8size the comparands as a side-effect. */
6718 svrecode = newSVpvn(pv2, cur2);
6719 sv_recode_to_utf8(svrecode, PL_encoding);
6720 pv2 = SvPV(svrecode, cur2);
6723 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
6728 svrecode = newSVpvn(pv1, cur1);
6729 sv_recode_to_utf8(svrecode, PL_encoding);
6730 pv1 = SvPV(svrecode, cur1);
6733 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
6739 cmp = cur2 ? -1 : 0;
6743 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
6746 cmp = retval < 0 ? -1 : 1;
6747 } else if (cur1 == cur2) {
6750 cmp = cur1 < cur2 ? -1 : 1;
6755 SvREFCNT_dec(svrecode);
6764 =for apidoc sv_cmp_locale
6766 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6767 'use bytes' aware, handles get magic, and will coerce its args to strings
6768 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6774 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6776 #ifdef USE_LOCALE_COLLATE
6782 if (PL_collation_standard)
6786 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6788 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6790 if (!pv1 || !len1) {
6801 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6804 return retval < 0 ? -1 : 1;
6807 * When the result of collation is equality, that doesn't mean
6808 * that there are no differences -- some locales exclude some
6809 * characters from consideration. So to avoid false equalities,
6810 * we use the raw string as a tiebreaker.
6816 #endif /* USE_LOCALE_COLLATE */
6818 return sv_cmp(sv1, sv2);
6822 #ifdef USE_LOCALE_COLLATE
6825 =for apidoc sv_collxfrm
6827 Add Collate Transform magic to an SV if it doesn't already have it.
6829 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6830 scalar data of the variable, but transformed to such a format that a normal
6831 memory comparison can be used to compare the data according to the locale
6838 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6842 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6843 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6848 Safefree(mg->mg_ptr);
6850 if ((xf = mem_collxfrm(s, len, &xlen))) {
6851 if (SvREADONLY(sv)) {
6854 return xf + sizeof(PL_collation_ix);
6857 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6858 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6871 if (mg && mg->mg_ptr) {
6873 return mg->mg_ptr + sizeof(PL_collation_ix);
6881 #endif /* USE_LOCALE_COLLATE */
6886 Get a line from the filehandle and store it into the SV, optionally
6887 appending to the currently-stored string.
6893 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6897 register STDCHAR rslast;
6898 register STDCHAR *bp;
6904 if (SvTHINKFIRST(sv))
6905 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6906 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6908 However, perlbench says it's slower, because the existing swipe code
6909 is faster than copy on write.
6910 Swings and roundabouts. */
6911 (void)SvUPGRADE(sv, SVt_PV);
6916 if (PerlIO_isutf8(fp)) {
6918 sv_utf8_upgrade_nomg(sv);
6919 sv_pos_u2b(sv,&append,0);
6921 } else if (SvUTF8(sv)) {
6922 SV *tsv = NEWSV(0,0);
6923 sv_gets(tsv, fp, 0);
6924 sv_utf8_upgrade_nomg(tsv);
6925 SvCUR_set(sv,append);
6928 goto return_string_or_null;
6933 if (PerlIO_isutf8(fp))
6936 if (IN_PERL_COMPILETIME) {
6937 /* we always read code in line mode */
6941 else if (RsSNARF(PL_rs)) {
6942 /* If it is a regular disk file use size from stat() as estimate
6943 of amount we are going to read - may result in malloc-ing
6944 more memory than we realy need if layers bellow reduce
6945 size we read (e.g. CRLF or a gzip layer)
6948 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6949 Off_t offset = PerlIO_tell(fp);
6950 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6951 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6957 else if (RsRECORD(PL_rs)) {
6961 /* Grab the size of the record we're getting */
6962 recsize = SvIV(SvRV(PL_rs));
6963 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6966 /* VMS wants read instead of fread, because fread doesn't respect */
6967 /* RMS record boundaries. This is not necessarily a good thing to be */
6968 /* doing, but we've got no other real choice - except avoid stdio
6969 as implementation - perhaps write a :vms layer ?
6971 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6973 bytesread = PerlIO_read(fp, buffer, recsize);
6977 SvCUR_set(sv, bytesread += append);
6978 buffer[bytesread] = '\0';
6979 goto return_string_or_null;
6981 else if (RsPARA(PL_rs)) {
6987 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6988 if (PerlIO_isutf8(fp)) {
6989 rsptr = SvPVutf8(PL_rs, rslen);
6992 if (SvUTF8(PL_rs)) {
6993 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6994 Perl_croak(aTHX_ "Wide character in $/");
6997 rsptr = SvPV(PL_rs, rslen);
7001 rslast = rslen ? rsptr[rslen - 1] : '\0';
7003 if (rspara) { /* have to do this both before and after */
7004 do { /* to make sure file boundaries work right */
7007 i = PerlIO_getc(fp);
7011 PerlIO_ungetc(fp,i);
7017 /* See if we know enough about I/O mechanism to cheat it ! */
7019 /* This used to be #ifdef test - it is made run-time test for ease
7020 of abstracting out stdio interface. One call should be cheap
7021 enough here - and may even be a macro allowing compile
7025 if (PerlIO_fast_gets(fp)) {
7028 * We're going to steal some values from the stdio struct
7029 * and put EVERYTHING in the innermost loop into registers.
7031 register STDCHAR *ptr;
7035 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7036 /* An ungetc()d char is handled separately from the regular
7037 * buffer, so we getc() it back out and stuff it in the buffer.
7039 i = PerlIO_getc(fp);
7040 if (i == EOF) return 0;
7041 *(--((*fp)->_ptr)) = (unsigned char) i;
7045 /* Here is some breathtakingly efficient cheating */
7047 cnt = PerlIO_get_cnt(fp); /* get count into register */
7048 /* make sure we have the room */
7049 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7050 /* Not room for all of it
7051 if we are looking for a separator and room for some
7053 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7054 /* just process what we have room for */
7055 shortbuffered = cnt - SvLEN(sv) + append + 1;
7056 cnt -= shortbuffered;
7060 /* remember that cnt can be negative */
7061 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7066 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7067 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7068 DEBUG_P(PerlIO_printf(Perl_debug_log,
7069 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7070 DEBUG_P(PerlIO_printf(Perl_debug_log,
7071 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7072 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7073 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7078 while (cnt > 0) { /* this | eat */
7080 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7081 goto thats_all_folks; /* screams | sed :-) */
7085 Copy(ptr, bp, cnt, char); /* this | eat */
7086 bp += cnt; /* screams | dust */
7087 ptr += cnt; /* louder | sed :-) */
7092 if (shortbuffered) { /* oh well, must extend */
7093 cnt = shortbuffered;
7095 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7097 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7098 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7102 DEBUG_P(PerlIO_printf(Perl_debug_log,
7103 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7104 PTR2UV(ptr),(long)cnt));
7105 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7107 DEBUG_P(PerlIO_printf(Perl_debug_log,
7108 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7109 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7110 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7112 /* This used to call 'filbuf' in stdio form, but as that behaves like
7113 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7114 another abstraction. */
7115 i = PerlIO_getc(fp); /* get more characters */
7117 DEBUG_P(PerlIO_printf(Perl_debug_log,
7118 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7119 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7120 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7122 cnt = PerlIO_get_cnt(fp);
7123 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7124 DEBUG_P(PerlIO_printf(Perl_debug_log,
7125 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7127 if (i == EOF) /* all done for ever? */
7128 goto thats_really_all_folks;
7130 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7132 SvGROW(sv, bpx + cnt + 2);
7133 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7135 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7137 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7138 goto thats_all_folks;
7142 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7143 memNE((char*)bp - rslen, rsptr, rslen))
7144 goto screamer; /* go back to the fray */
7145 thats_really_all_folks:
7147 cnt += shortbuffered;
7148 DEBUG_P(PerlIO_printf(Perl_debug_log,
7149 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7150 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7151 DEBUG_P(PerlIO_printf(Perl_debug_log,
7152 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7153 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7154 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7156 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7157 DEBUG_P(PerlIO_printf(Perl_debug_log,
7158 "Screamer: done, len=%ld, string=|%.*s|\n",
7159 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7163 /*The big, slow, and stupid way. */
7165 /* Any stack-challenged places. */
7167 /* EPOC: need to work around SDK features. *
7168 * On WINS: MS VC5 generates calls to _chkstk, *
7169 * if a "large" stack frame is allocated. *
7170 * gcc on MARM does not generate calls like these. */
7171 # define USEHEAPINSTEADOFSTACK
7174 #ifdef USEHEAPINSTEADOFSTACK
7176 New(0, buf, 8192, STDCHAR);
7184 register STDCHAR *bpe = buf + sizeof(buf);
7186 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7187 ; /* keep reading */
7191 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7192 /* Accomodate broken VAXC compiler, which applies U8 cast to
7193 * both args of ?: operator, causing EOF to change into 255
7196 i = (U8)buf[cnt - 1];
7202 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7204 sv_catpvn(sv, (char *) buf, cnt);
7206 sv_setpvn(sv, (char *) buf, cnt);
7208 if (i != EOF && /* joy */
7210 SvCUR(sv) < rslen ||
7211 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7215 * If we're reading from a TTY and we get a short read,
7216 * indicating that the user hit his EOF character, we need
7217 * to notice it now, because if we try to read from the TTY
7218 * again, the EOF condition will disappear.
7220 * The comparison of cnt to sizeof(buf) is an optimization
7221 * that prevents unnecessary calls to feof().
7225 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7229 #ifdef USEHEAPINSTEADOFSTACK
7234 if (rspara) { /* have to do this both before and after */
7235 while (i != EOF) { /* to make sure file boundaries work right */
7236 i = PerlIO_getc(fp);
7238 PerlIO_ungetc(fp,i);
7244 return_string_or_null:
7245 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7251 Auto-increment of the value in the SV, doing string to numeric conversion
7252 if necessary. Handles 'get' magic.
7258 Perl_sv_inc(pTHX_ register SV *sv)
7267 if (SvTHINKFIRST(sv)) {
7269 sv_force_normal_flags(sv, 0);
7270 if (SvREADONLY(sv)) {
7271 if (IN_PERL_RUNTIME)
7272 Perl_croak(aTHX_ PL_no_modify);
7276 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7278 i = PTR2IV(SvRV(sv));
7283 flags = SvFLAGS(sv);
7284 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7285 /* It's (privately or publicly) a float, but not tested as an
7286 integer, so test it to see. */
7288 flags = SvFLAGS(sv);
7290 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7291 /* It's publicly an integer, or privately an integer-not-float */
7292 #ifdef PERL_PRESERVE_IVUV
7296 if (SvUVX(sv) == UV_MAX)
7297 sv_setnv(sv, UV_MAX_P1);
7299 (void)SvIOK_only_UV(sv);
7302 if (SvIVX(sv) == IV_MAX)
7303 sv_setuv(sv, (UV)IV_MAX + 1);
7305 (void)SvIOK_only(sv);
7311 if (flags & SVp_NOK) {
7312 (void)SvNOK_only(sv);
7317 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7318 if ((flags & SVTYPEMASK) < SVt_PVIV)
7319 sv_upgrade(sv, SVt_IV);
7320 (void)SvIOK_only(sv);
7325 while (isALPHA(*d)) d++;
7326 while (isDIGIT(*d)) d++;
7328 #ifdef PERL_PRESERVE_IVUV
7329 /* Got to punt this as an integer if needs be, but we don't issue
7330 warnings. Probably ought to make the sv_iv_please() that does
7331 the conversion if possible, and silently. */
7332 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7333 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7334 /* Need to try really hard to see if it's an integer.
7335 9.22337203685478e+18 is an integer.
7336 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7337 so $a="9.22337203685478e+18"; $a+0; $a++
7338 needs to be the same as $a="9.22337203685478e+18"; $a++
7345 /* sv_2iv *should* have made this an NV */
7346 if (flags & SVp_NOK) {
7347 (void)SvNOK_only(sv);
7351 /* I don't think we can get here. Maybe I should assert this
7352 And if we do get here I suspect that sv_setnv will croak. NWC
7354 #if defined(USE_LONG_DOUBLE)
7355 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",
7356 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7358 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7359 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7362 #endif /* PERL_PRESERVE_IVUV */
7363 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7367 while (d >= SvPVX(sv)) {
7375 /* MKS: The original code here died if letters weren't consecutive.
7376 * at least it didn't have to worry about non-C locales. The
7377 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7378 * arranged in order (although not consecutively) and that only
7379 * [A-Za-z] are accepted by isALPHA in the C locale.
7381 if (*d != 'z' && *d != 'Z') {
7382 do { ++*d; } while (!isALPHA(*d));
7385 *(d--) -= 'z' - 'a';
7390 *(d--) -= 'z' - 'a' + 1;
7394 /* oh,oh, the number grew */
7395 SvGROW(sv, SvCUR(sv) + 2);
7397 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7408 Auto-decrement of the value in the SV, doing string to numeric conversion
7409 if necessary. Handles 'get' magic.
7415 Perl_sv_dec(pTHX_ register SV *sv)
7423 if (SvTHINKFIRST(sv)) {
7425 sv_force_normal_flags(sv, 0);
7426 if (SvREADONLY(sv)) {
7427 if (IN_PERL_RUNTIME)
7428 Perl_croak(aTHX_ PL_no_modify);
7432 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7434 i = PTR2IV(SvRV(sv));
7439 /* Unlike sv_inc we don't have to worry about string-never-numbers
7440 and keeping them magic. But we mustn't warn on punting */
7441 flags = SvFLAGS(sv);
7442 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7443 /* It's publicly an integer, or privately an integer-not-float */
7444 #ifdef PERL_PRESERVE_IVUV
7448 if (SvUVX(sv) == 0) {
7449 (void)SvIOK_only(sv);
7453 (void)SvIOK_only_UV(sv);
7457 if (SvIVX(sv) == IV_MIN)
7458 sv_setnv(sv, (NV)IV_MIN - 1.0);
7460 (void)SvIOK_only(sv);
7466 if (flags & SVp_NOK) {
7468 (void)SvNOK_only(sv);
7471 if (!(flags & SVp_POK)) {
7472 if ((flags & SVTYPEMASK) < SVt_PVNV)
7473 sv_upgrade(sv, SVt_NV);
7475 (void)SvNOK_only(sv);
7478 #ifdef PERL_PRESERVE_IVUV
7480 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7481 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7482 /* Need to try really hard to see if it's an integer.
7483 9.22337203685478e+18 is an integer.
7484 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7485 so $a="9.22337203685478e+18"; $a+0; $a--
7486 needs to be the same as $a="9.22337203685478e+18"; $a--
7493 /* sv_2iv *should* have made this an NV */
7494 if (flags & SVp_NOK) {
7495 (void)SvNOK_only(sv);
7499 /* I don't think we can get here. Maybe I should assert this
7500 And if we do get here I suspect that sv_setnv will croak. NWC
7502 #if defined(USE_LONG_DOUBLE)
7503 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",
7504 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7506 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7507 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7511 #endif /* PERL_PRESERVE_IVUV */
7512 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7516 =for apidoc sv_mortalcopy
7518 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7519 The new SV is marked as mortal. It will be destroyed "soon", either by an
7520 explicit call to FREETMPS, or by an implicit call at places such as
7521 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7526 /* Make a string that will exist for the duration of the expression
7527 * evaluation. Actually, it may have to last longer than that, but
7528 * hopefully we won't free it until it has been assigned to a
7529 * permanent location. */
7532 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7537 sv_setsv(sv,oldstr);
7539 PL_tmps_stack[++PL_tmps_ix] = sv;
7545 =for apidoc sv_newmortal
7547 Creates a new null SV which is mortal. The reference count of the SV is
7548 set to 1. It will be destroyed "soon", either by an explicit call to
7549 FREETMPS, or by an implicit call at places such as statement boundaries.
7550 See also C<sv_mortalcopy> and C<sv_2mortal>.
7556 Perl_sv_newmortal(pTHX)
7561 SvFLAGS(sv) = SVs_TEMP;
7563 PL_tmps_stack[++PL_tmps_ix] = sv;
7568 =for apidoc sv_2mortal
7570 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7571 by an explicit call to FREETMPS, or by an implicit call at places such as
7572 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
7578 Perl_sv_2mortal(pTHX_ register SV *sv)
7582 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7585 PL_tmps_stack[++PL_tmps_ix] = sv;
7593 Creates a new SV and copies a string into it. The reference count for the
7594 SV is set to 1. If C<len> is zero, Perl will compute the length using
7595 strlen(). For efficiency, consider using C<newSVpvn> instead.
7601 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7608 sv_setpvn(sv,s,len);
7613 =for apidoc newSVpvn
7615 Creates a new SV and copies a string into it. The reference count for the
7616 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7617 string. You are responsible for ensuring that the source string is at least
7624 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7629 sv_setpvn(sv,s,len);
7634 =for apidoc newSVpvn_share
7636 Creates a new SV with its SvPVX pointing to a shared string in the string
7637 table. If the string does not already exist in the table, it is created
7638 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7639 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7640 otherwise the hash is computed. The idea here is that as the string table
7641 is used for shared hash keys these strings will have SvPVX == HeKEY and
7642 hash lookup will avoid string compare.
7648 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7651 bool is_utf8 = FALSE;
7653 STRLEN tmplen = -len;
7655 /* See the note in hv.c:hv_fetch() --jhi */
7656 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
7660 PERL_HASH(hash, src, len);
7662 sv_upgrade(sv, SVt_PVIV);
7663 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7676 #if defined(PERL_IMPLICIT_CONTEXT)
7678 /* pTHX_ magic can't cope with varargs, so this is a no-context
7679 * version of the main function, (which may itself be aliased to us).
7680 * Don't access this version directly.
7684 Perl_newSVpvf_nocontext(const char* pat, ...)
7689 va_start(args, pat);
7690 sv = vnewSVpvf(pat, &args);
7697 =for apidoc newSVpvf
7699 Creates a new SV and initializes it with the string formatted like
7706 Perl_newSVpvf(pTHX_ const char* pat, ...)
7710 va_start(args, pat);
7711 sv = vnewSVpvf(pat, &args);
7716 /* backend for newSVpvf() and newSVpvf_nocontext() */
7719 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7723 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7730 Creates a new SV and copies a floating point value into it.
7731 The reference count for the SV is set to 1.
7737 Perl_newSVnv(pTHX_ NV n)
7749 Creates a new SV and copies an integer into it. The reference count for the
7756 Perl_newSViv(pTHX_ IV i)
7768 Creates a new SV and copies an unsigned integer into it.
7769 The reference count for the SV is set to 1.
7775 Perl_newSVuv(pTHX_ UV u)
7785 =for apidoc newRV_noinc
7787 Creates an RV wrapper for an SV. The reference count for the original
7788 SV is B<not> incremented.
7794 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7799 sv_upgrade(sv, SVt_RV);
7806 /* newRV_inc is the official function name to use now.
7807 * newRV_inc is in fact #defined to newRV in sv.h
7811 Perl_newRV(pTHX_ SV *tmpRef)
7813 return newRV_noinc(SvREFCNT_inc(tmpRef));
7819 Creates a new SV which is an exact duplicate of the original SV.
7826 Perl_newSVsv(pTHX_ register SV *old)
7832 if (SvTYPE(old) == SVTYPEMASK) {
7833 if (ckWARN_d(WARN_INTERNAL))
7834 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7849 =for apidoc sv_reset
7851 Underlying implementation for the C<reset> Perl function.
7852 Note that the perl-level function is vaguely deprecated.
7858 Perl_sv_reset(pTHX_ register char *s, HV *stash)
7866 char todo[PERL_UCHAR_MAX+1];
7871 if (!*s) { /* reset ?? searches */
7872 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7873 pm->op_pmdynflags &= ~PMdf_USED;
7878 /* reset variables */
7880 if (!HvARRAY(stash))
7883 Zero(todo, 256, char);
7885 i = (unsigned char)*s;
7889 max = (unsigned char)*s++;
7890 for ( ; i <= max; i++) {
7893 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7894 for (entry = HvARRAY(stash)[i];
7896 entry = HeNEXT(entry))
7898 if (!todo[(U8)*HeKEY(entry)])
7900 gv = (GV*)HeVAL(entry);
7902 if (SvTHINKFIRST(sv)) {
7903 if (!SvREADONLY(sv) && SvROK(sv))
7908 if (SvTYPE(sv) >= SVt_PV) {
7910 if (SvPVX(sv) != Nullch)
7917 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7920 #ifdef USE_ENVIRON_ARRAY
7922 # ifdef USE_ITHREADS
7923 && PL_curinterp == aTHX
7927 environ[0] = Nullch;
7930 #endif /* !PERL_MICRO */
7940 Using various gambits, try to get an IO from an SV: the IO slot if its a
7941 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7942 named after the PV if we're a string.
7948 Perl_sv_2io(pTHX_ SV *sv)
7954 switch (SvTYPE(sv)) {
7962 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7966 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7968 return sv_2io(SvRV(sv));
7969 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7975 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7984 Using various gambits, try to get a CV from an SV; in addition, try if
7985 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7991 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7998 return *gvp = Nullgv, Nullcv;
7999 switch (SvTYPE(sv)) {
8018 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8019 tryAMAGICunDEREF(to_cv);
8022 if (SvTYPE(sv) == SVt_PVCV) {
8031 Perl_croak(aTHX_ "Not a subroutine reference");
8036 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
8042 if (lref && !GvCVu(gv)) {
8045 tmpsv = NEWSV(704,0);
8046 gv_efullname3(tmpsv, gv, Nullch);
8047 /* XXX this is probably not what they think they're getting.
8048 * It has the same effect as "sub name;", i.e. just a forward
8050 newSUB(start_subparse(FALSE, 0),
8051 newSVOP(OP_CONST, 0, tmpsv),
8056 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8066 Returns true if the SV has a true value by Perl's rules.
8067 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8068 instead use an in-line version.
8074 Perl_sv_true(pTHX_ register SV *sv)
8080 if ((tXpv = (XPV*)SvANY(sv)) &&
8081 (tXpv->xpv_cur > 1 ||
8082 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8089 return SvIVX(sv) != 0;
8092 return SvNVX(sv) != 0.0;
8094 return sv_2bool(sv);
8102 A private implementation of the C<SvIVx> macro for compilers which can't
8103 cope with complex macro expressions. Always use the macro instead.
8109 Perl_sv_iv(pTHX_ register SV *sv)
8113 return (IV)SvUVX(sv);
8122 A private implementation of the C<SvUVx> macro for compilers which can't
8123 cope with complex macro expressions. Always use the macro instead.
8129 Perl_sv_uv(pTHX_ register SV *sv)
8134 return (UV)SvIVX(sv);
8142 A private implementation of the C<SvNVx> macro for compilers which can't
8143 cope with complex macro expressions. Always use the macro instead.
8149 Perl_sv_nv(pTHX_ register SV *sv)
8156 /* sv_pv() is now a macro using SvPV_nolen();
8157 * this function provided for binary compatibility only
8161 Perl_sv_pv(pTHX_ SV *sv)
8168 return sv_2pv(sv, &n_a);
8174 Use the C<SvPV_nolen> macro instead
8178 A private implementation of the C<SvPV> macro for compilers which can't
8179 cope with complex macro expressions. Always use the macro instead.
8185 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8191 return sv_2pv(sv, lp);
8196 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8202 return sv_2pv_flags(sv, lp, 0);
8205 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8206 * this function provided for binary compatibility only
8210 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8212 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8216 =for apidoc sv_pvn_force
8218 Get a sensible string out of the SV somehow.
8219 A private implementation of the C<SvPV_force> macro for compilers which
8220 can't cope with complex macro expressions. Always use the macro instead.
8222 =for apidoc sv_pvn_force_flags
8224 Get a sensible string out of the SV somehow.
8225 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8226 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8227 implemented in terms of this function.
8228 You normally want to use the various wrapper macros instead: see
8229 C<SvPV_force> and C<SvPV_force_nomg>
8235 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8239 if (SvTHINKFIRST(sv) && !SvROK(sv))
8240 sv_force_normal_flags(sv, 0);
8246 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8247 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8251 s = sv_2pv_flags(sv, lp, flags);
8252 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8257 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8258 SvGROW(sv, len + 1);
8259 Move(s,SvPVX(sv),len,char);
8264 SvPOK_on(sv); /* validate pointer */
8266 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8267 PTR2UV(sv),SvPVX(sv)));
8273 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8274 * this function provided for binary compatibility only
8278 Perl_sv_pvbyte(pTHX_ SV *sv)
8280 sv_utf8_downgrade(sv,0);
8285 =for apidoc sv_pvbyte
8287 Use C<SvPVbyte_nolen> instead.
8289 =for apidoc sv_pvbyten
8291 A private implementation of the C<SvPVbyte> macro for compilers
8292 which can't cope with complex macro expressions. Always use the macro
8299 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8301 sv_utf8_downgrade(sv,0);
8302 return sv_pvn(sv,lp);
8306 =for apidoc sv_pvbyten_force
8308 A private implementation of the C<SvPVbytex_force> macro for compilers
8309 which can't cope with complex macro expressions. Always use the macro
8316 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8318 sv_pvn_force(sv,lp);
8319 sv_utf8_downgrade(sv,0);
8324 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8325 * this function provided for binary compatibility only
8329 Perl_sv_pvutf8(pTHX_ SV *sv)
8331 sv_utf8_upgrade(sv);
8336 =for apidoc sv_pvutf8
8338 Use the C<SvPVutf8_nolen> macro instead
8340 =for apidoc sv_pvutf8n
8342 A private implementation of the C<SvPVutf8> macro for compilers
8343 which can't cope with complex macro expressions. Always use the macro
8350 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8352 sv_utf8_upgrade(sv);
8353 return sv_pvn(sv,lp);
8357 =for apidoc sv_pvutf8n_force
8359 A private implementation of the C<SvPVutf8_force> macro for compilers
8360 which can't cope with complex macro expressions. Always use the macro
8367 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8369 sv_pvn_force(sv,lp);
8370 sv_utf8_upgrade(sv);
8376 =for apidoc sv_reftype
8378 Returns a string describing what the SV is a reference to.
8384 Perl_sv_reftype(pTHX_ SV *sv, int ob)
8386 if (ob && SvOBJECT(sv)) {
8387 if (HvNAME(SvSTASH(sv)))
8388 return HvNAME(SvSTASH(sv));
8393 switch (SvTYPE(sv)) {
8410 case SVt_PVLV: return SvROK(sv) ? "REF"
8411 /* tied lvalues should appear to be
8412 * scalars for backwards compatitbility */
8413 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8414 ? "SCALAR" : "LVALUE";
8415 case SVt_PVAV: return "ARRAY";
8416 case SVt_PVHV: return "HASH";
8417 case SVt_PVCV: return "CODE";
8418 case SVt_PVGV: return "GLOB";
8419 case SVt_PVFM: return "FORMAT";
8420 case SVt_PVIO: return "IO";
8421 default: return "UNKNOWN";
8427 =for apidoc sv_isobject
8429 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8430 object. If the SV is not an RV, or if the object is not blessed, then this
8437 Perl_sv_isobject(pTHX_ SV *sv)
8454 Returns a boolean indicating whether the SV is blessed into the specified
8455 class. This does not check for subtypes; use C<sv_derived_from> to verify
8456 an inheritance relationship.
8462 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8473 if (!HvNAME(SvSTASH(sv)))
8476 return strEQ(HvNAME(SvSTASH(sv)), name);
8482 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8483 it will be upgraded to one. If C<classname> is non-null then the new SV will
8484 be blessed in the specified package. The new SV is returned and its
8485 reference count is 1.
8491 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8497 SV_CHECK_THINKFIRST_COW_DROP(rv);
8500 if (SvTYPE(rv) >= SVt_PVMG) {
8501 U32 refcnt = SvREFCNT(rv);
8505 SvREFCNT(rv) = refcnt;
8508 if (SvTYPE(rv) < SVt_RV)
8509 sv_upgrade(rv, SVt_RV);
8510 else if (SvTYPE(rv) > SVt_RV) {
8511 (void)SvOOK_off(rv);
8512 if (SvPVX(rv) && SvLEN(rv))
8513 Safefree(SvPVX(rv));
8523 HV* stash = gv_stashpv(classname, TRUE);
8524 (void)sv_bless(rv, stash);
8530 =for apidoc sv_setref_pv
8532 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8533 argument will be upgraded to an RV. That RV will be modified to point to
8534 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8535 into the SV. The C<classname> argument indicates the package for the
8536 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8537 will have a reference count of 1, and the RV will be returned.
8539 Do not use with other Perl types such as HV, AV, SV, CV, because those
8540 objects will become corrupted by the pointer copy process.
8542 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8548 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8551 sv_setsv(rv, &PL_sv_undef);
8555 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8560 =for apidoc sv_setref_iv
8562 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8563 argument will be upgraded to an RV. That RV will be modified to point to
8564 the new SV. The C<classname> argument indicates the package for the
8565 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8566 will have a reference count of 1, and the RV will be returned.
8572 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8574 sv_setiv(newSVrv(rv,classname), iv);
8579 =for apidoc sv_setref_uv
8581 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8582 argument will be upgraded to an RV. That RV will be modified to point to
8583 the new SV. The C<classname> argument indicates the package for the
8584 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8585 will have a reference count of 1, and the RV will be returned.
8591 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8593 sv_setuv(newSVrv(rv,classname), uv);
8598 =for apidoc sv_setref_nv
8600 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8601 argument will be upgraded to an RV. That RV will be modified to point to
8602 the new SV. The C<classname> argument indicates the package for the
8603 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8604 will have a reference count of 1, and the RV will be returned.
8610 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8612 sv_setnv(newSVrv(rv,classname), nv);
8617 =for apidoc sv_setref_pvn
8619 Copies a string into a new SV, optionally blessing the SV. The length of the
8620 string must be specified with C<n>. The C<rv> argument will be upgraded to
8621 an RV. That RV will be modified to point to the new SV. The C<classname>
8622 argument indicates the package for the blessing. Set C<classname> to
8623 C<Nullch> to avoid the blessing. The new SV will have a reference count
8624 of 1, and the RV will be returned.
8626 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8632 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8634 sv_setpvn(newSVrv(rv,classname), pv, n);
8639 =for apidoc sv_bless
8641 Blesses an SV into a specified package. The SV must be an RV. The package
8642 must be designated by its stash (see C<gv_stashpv()>). The reference count
8643 of the SV is unaffected.
8649 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8653 Perl_croak(aTHX_ "Can't bless non-reference value");
8655 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8656 if (SvREADONLY(tmpRef))
8657 Perl_croak(aTHX_ PL_no_modify);
8658 if (SvOBJECT(tmpRef)) {
8659 if (SvTYPE(tmpRef) != SVt_PVIO)
8661 SvREFCNT_dec(SvSTASH(tmpRef));
8664 SvOBJECT_on(tmpRef);
8665 if (SvTYPE(tmpRef) != SVt_PVIO)
8667 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8668 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8675 if(SvSMAGICAL(tmpRef))
8676 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8684 /* Downgrades a PVGV to a PVMG.
8688 S_sv_unglob(pTHX_ SV *sv)
8692 assert(SvTYPE(sv) == SVt_PVGV);
8697 SvREFCNT_dec(GvSTASH(sv));
8698 GvSTASH(sv) = Nullhv;
8700 sv_unmagic(sv, PERL_MAGIC_glob);
8701 Safefree(GvNAME(sv));
8704 /* need to keep SvANY(sv) in the right arena */
8705 xpvmg = new_XPVMG();
8706 StructCopy(SvANY(sv), xpvmg, XPVMG);
8707 del_XPVGV(SvANY(sv));
8710 SvFLAGS(sv) &= ~SVTYPEMASK;
8711 SvFLAGS(sv) |= SVt_PVMG;
8715 =for apidoc sv_unref_flags
8717 Unsets the RV status of the SV, and decrements the reference count of
8718 whatever was being referenced by the RV. This can almost be thought of
8719 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8720 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8721 (otherwise the decrementing is conditional on the reference count being
8722 different from one or the reference being a readonly SV).
8729 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8733 if (SvWEAKREF(sv)) {
8741 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8742 assigned to as BEGIN {$a = \"Foo"} will fail. */
8743 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8745 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8746 sv_2mortal(rv); /* Schedule for freeing later */
8750 =for apidoc sv_unref
8752 Unsets the RV status of the SV, and decrements the reference count of
8753 whatever was being referenced by the RV. This can almost be thought of
8754 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8755 being zero. See C<SvROK_off>.
8761 Perl_sv_unref(pTHX_ SV *sv)
8763 sv_unref_flags(sv, 0);
8767 =for apidoc sv_taint
8769 Taint an SV. Use C<SvTAINTED_on> instead.
8774 Perl_sv_taint(pTHX_ SV *sv)
8776 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8780 =for apidoc sv_untaint
8782 Untaint an SV. Use C<SvTAINTED_off> instead.
8787 Perl_sv_untaint(pTHX_ SV *sv)
8789 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8790 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8797 =for apidoc sv_tainted
8799 Test an SV for taintedness. Use C<SvTAINTED> instead.
8804 Perl_sv_tainted(pTHX_ SV *sv)
8806 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8807 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8808 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8815 =for apidoc sv_setpviv
8817 Copies an integer into the given SV, also updating its string value.
8818 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8824 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8826 char buf[TYPE_CHARS(UV)];
8828 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8830 sv_setpvn(sv, ptr, ebuf - ptr);
8834 =for apidoc sv_setpviv_mg
8836 Like C<sv_setpviv>, but also handles 'set' magic.
8842 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8844 char buf[TYPE_CHARS(UV)];
8846 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8848 sv_setpvn(sv, ptr, ebuf - ptr);
8852 #if defined(PERL_IMPLICIT_CONTEXT)
8854 /* pTHX_ magic can't cope with varargs, so this is a no-context
8855 * version of the main function, (which may itself be aliased to us).
8856 * Don't access this version directly.
8860 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8864 va_start(args, pat);
8865 sv_vsetpvf(sv, pat, &args);
8869 /* pTHX_ magic can't cope with varargs, so this is a no-context
8870 * version of the main function, (which may itself be aliased to us).
8871 * Don't access this version directly.
8875 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8879 va_start(args, pat);
8880 sv_vsetpvf_mg(sv, pat, &args);
8886 =for apidoc sv_setpvf
8888 Processes its arguments like C<sprintf> and sets an SV to the formatted
8889 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8895 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8898 va_start(args, pat);
8899 sv_vsetpvf(sv, pat, &args);
8903 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8906 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8908 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8912 =for apidoc sv_setpvf_mg
8914 Like C<sv_setpvf>, but also handles 'set' magic.
8920 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8923 va_start(args, pat);
8924 sv_vsetpvf_mg(sv, pat, &args);
8928 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8931 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8933 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8937 #if defined(PERL_IMPLICIT_CONTEXT)
8939 /* pTHX_ magic can't cope with varargs, so this is a no-context
8940 * version of the main function, (which may itself be aliased to us).
8941 * Don't access this version directly.
8945 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8949 va_start(args, pat);
8950 sv_vcatpvf(sv, pat, &args);
8954 /* pTHX_ magic can't cope with varargs, so this is a no-context
8955 * version of the main function, (which may itself be aliased to us).
8956 * Don't access this version directly.
8960 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8964 va_start(args, pat);
8965 sv_vcatpvf_mg(sv, pat, &args);
8971 =for apidoc sv_catpvf
8973 Processes its arguments like C<sprintf> and appends the formatted
8974 output to an SV. If the appended data contains "wide" characters
8975 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8976 and characters >255 formatted with %c), the original SV might get
8977 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
8978 C<SvSETMAGIC()> must typically be called after calling this function
8979 to handle 'set' magic.
8984 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8987 va_start(args, pat);
8988 sv_vcatpvf(sv, pat, &args);
8992 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8995 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8997 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9001 =for apidoc sv_catpvf_mg
9003 Like C<sv_catpvf>, but also handles 'set' magic.
9009 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9012 va_start(args, pat);
9013 sv_vcatpvf_mg(sv, pat, &args);
9017 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
9020 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9022 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9027 =for apidoc sv_vsetpvfn
9029 Works like C<vcatpvfn> but copies the text into the SV instead of
9032 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
9038 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9040 sv_setpvn(sv, "", 0);
9041 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9044 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9047 S_expect_number(pTHX_ char** pattern)
9050 switch (**pattern) {
9051 case '1': case '2': case '3':
9052 case '4': case '5': case '6':
9053 case '7': case '8': case '9':
9054 while (isDIGIT(**pattern))
9055 var = var * 10 + (*(*pattern)++ - '0');
9059 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9062 F0convert(NV nv, char *endbuf, STRLEN *len)
9073 if (uv & 1 && uv == nv)
9074 uv--; /* Round to even */
9076 unsigned dig = uv % 10;
9089 =for apidoc sv_vcatpvfn
9091 Processes its arguments like C<vsprintf> and appends the formatted output
9092 to an SV. Uses an array of SVs if the C style variable argument list is
9093 missing (NULL). When running with taint checks enabled, indicates via
9094 C<maybe_tainted> if results are untrustworthy (often due to the use of
9097 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
9103 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9110 static char nullstr[] = "(null)";
9112 bool has_utf8; /* has the result utf8? */
9113 bool pat_utf8; /* the pattern is in utf8? */
9115 /* Times 4: a decimal digit takes more than 3 binary digits.
9116 * NV_DIG: mantissa takes than many decimal digits.
9117 * Plus 32: Playing safe. */
9118 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9119 /* large enough for "%#.#f" --chip */
9120 /* what about long double NVs? --jhi */
9122 has_utf8 = pat_utf8 = DO_UTF8(sv);
9124 /* no matter what, this is a string now */
9125 (void)SvPV_force(sv, origlen);
9127 /* special-case "", "%s", and "%_" */
9130 if (patlen == 2 && pat[0] == '%') {
9134 char *s = va_arg(*args, char*);
9135 sv_catpv(sv, s ? s : nullstr);
9137 else if (svix < svmax) {
9138 sv_catsv(sv, *svargs);
9139 if (DO_UTF8(*svargs))
9145 argsv = va_arg(*args, SV*);
9146 sv_catsv(sv, argsv);
9151 /* See comment on '_' below */
9156 #ifndef USE_LONG_DOUBLE
9157 /* special-case "%.<number>[gf]" */
9158 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9159 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9160 unsigned digits = 0;
9164 while (*pp >= '0' && *pp <= '9')
9165 digits = 10 * digits + (*pp++ - '0');
9166 if (pp - pat == (int)patlen - 1) {
9170 nv = (NV)va_arg(*args, double);
9171 else if (svix < svmax)
9176 /* Add check for digits != 0 because it seems that some
9177 gconverts are buggy in this case, and we don't yet have
9178 a Configure test for this. */
9179 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9180 /* 0, point, slack */
9181 Gconvert(nv, (int)digits, 0, ebuf);
9183 if (*ebuf) /* May return an empty string for digits==0 */
9186 } else if (!digits) {
9189 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9190 sv_catpvn(sv, p, l);
9196 #endif /* !USE_LONG_DOUBLE */
9198 if (!args && svix < svmax && DO_UTF8(*svargs))
9201 patend = (char*)pat + patlen;
9202 for (p = (char*)pat; p < patend; p = q) {
9205 bool vectorize = FALSE;
9206 bool vectorarg = FALSE;
9207 bool vec_utf8 = FALSE;
9213 bool has_precis = FALSE;
9216 bool is_utf8 = FALSE; /* is this item utf8? */
9217 #ifdef HAS_LDBL_SPRINTF_BUG
9218 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9219 with sfio - Allen <allens@cpan.org> */
9220 bool fix_ldbl_sprintf_bug = FALSE;
9224 U8 utf8buf[UTF8_MAXLEN+1];
9225 STRLEN esignlen = 0;
9227 char *eptr = Nullch;
9230 U8 *vecstr = Null(U8*);
9237 /* we need a long double target in case HAS_LONG_DOUBLE but
9240 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9249 STRLEN dotstrlen = 1;
9250 I32 efix = 0; /* explicit format parameter index */
9251 I32 ewix = 0; /* explicit width index */
9252 I32 epix = 0; /* explicit precision index */
9253 I32 evix = 0; /* explicit vector index */
9254 bool asterisk = FALSE;
9256 /* echo everything up to the next format specification */
9257 for (q = p; q < patend && *q != '%'; ++q) ;
9259 if (has_utf8 && !pat_utf8)
9260 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9262 sv_catpvn(sv, p, q - p);
9269 We allow format specification elements in this order:
9270 \d+\$ explicit format parameter index
9272 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9273 0 flag (as above): repeated to allow "v02"
9274 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9275 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9277 [%bcdefginopsux_DFOUX] format (mandatory)
9279 if (EXPECT_NUMBER(q, width)) {
9320 if (EXPECT_NUMBER(q, ewix))
9329 if ((vectorarg = asterisk)) {
9341 EXPECT_NUMBER(q, width);
9346 vecsv = va_arg(*args, SV*);
9348 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9349 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9350 dotstr = SvPVx(vecsv, dotstrlen);
9355 vecsv = va_arg(*args, SV*);
9356 vecstr = (U8*)SvPVx(vecsv,veclen);
9357 vec_utf8 = DO_UTF8(vecsv);
9359 else if (efix ? efix <= svmax : svix < svmax) {
9360 vecsv = svargs[efix ? efix-1 : svix++];
9361 vecstr = (U8*)SvPVx(vecsv,veclen);
9362 vec_utf8 = DO_UTF8(vecsv);
9372 i = va_arg(*args, int);
9374 i = (ewix ? ewix <= svmax : svix < svmax) ?
9375 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9377 width = (i < 0) ? -i : i;
9387 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9389 /* XXX: todo, support specified precision parameter */
9393 i = va_arg(*args, int);
9395 i = (ewix ? ewix <= svmax : svix < svmax)
9396 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9397 precis = (i < 0) ? 0 : i;
9402 precis = precis * 10 + (*q++ - '0');
9411 case 'I': /* Ix, I32x, and I64x */
9413 if (q[1] == '6' && q[2] == '4') {
9419 if (q[1] == '3' && q[2] == '2') {
9429 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9440 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9441 if (*(q + 1) == 'l') { /* lld, llf */
9466 argsv = (efix ? efix <= svmax : svix < svmax) ?
9467 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9474 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9476 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9478 eptr = (char*)utf8buf;
9479 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9490 if (args && !vectorize) {
9491 eptr = va_arg(*args, char*);
9493 #ifdef MACOS_TRADITIONAL
9494 /* On MacOS, %#s format is used for Pascal strings */
9499 elen = strlen(eptr);
9502 elen = sizeof nullstr - 1;
9506 eptr = SvPVx(argsv, elen);
9507 if (DO_UTF8(argsv)) {
9508 if (has_precis && precis < elen) {
9510 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9513 if (width) { /* fudge width (can't fudge elen) */
9514 width += elen - sv_len_utf8(argsv);
9523 * The "%_" hack might have to be changed someday,
9524 * if ISO or ANSI decide to use '_' for something.
9525 * So we keep it hidden from users' code.
9527 if (!args || vectorize)
9529 argsv = va_arg(*args, SV*);
9530 eptr = SvPVx(argsv, elen);
9536 if (has_precis && elen > precis)
9543 if (alt || vectorize)
9545 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9563 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9572 esignbuf[esignlen++] = plus;
9576 case 'h': iv = (short)va_arg(*args, int); break;
9577 case 'l': iv = va_arg(*args, long); break;
9578 case 'V': iv = va_arg(*args, IV); break;
9579 default: iv = va_arg(*args, int); break;
9581 case 'q': iv = va_arg(*args, Quad_t); break;
9586 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9588 case 'h': iv = (short)tiv; break;
9589 case 'l': iv = (long)tiv; break;
9591 default: iv = tiv; break;
9593 case 'q': iv = (Quad_t)tiv; break;
9597 if ( !vectorize ) /* we already set uv above */
9602 esignbuf[esignlen++] = plus;
9606 esignbuf[esignlen++] = '-';
9649 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9660 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9661 case 'l': uv = va_arg(*args, unsigned long); break;
9662 case 'V': uv = va_arg(*args, UV); break;
9663 default: uv = va_arg(*args, unsigned); break;
9665 case 'q': uv = va_arg(*args, Uquad_t); break;
9670 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9672 case 'h': uv = (unsigned short)tuv; break;
9673 case 'l': uv = (unsigned long)tuv; break;
9675 default: uv = tuv; break;
9677 case 'q': uv = (Uquad_t)tuv; break;
9683 eptr = ebuf + sizeof ebuf;
9689 p = (char*)((c == 'X')
9690 ? "0123456789ABCDEF" : "0123456789abcdef");
9696 esignbuf[esignlen++] = '0';
9697 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9703 *--eptr = '0' + dig;
9705 if (alt && *eptr != '0')
9711 *--eptr = '0' + dig;
9714 esignbuf[esignlen++] = '0';
9715 esignbuf[esignlen++] = 'b';
9718 default: /* it had better be ten or less */
9719 #if defined(PERL_Y2KWARN)
9720 if (ckWARN(WARN_Y2K)) {
9722 char *s = SvPV(sv,n);
9723 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9724 && (n == 2 || !isDIGIT(s[n-3])))
9726 Perl_warner(aTHX_ packWARN(WARN_Y2K),
9727 "Possible Y2K bug: %%%c %s",
9728 c, "format string following '19'");
9734 *--eptr = '0' + dig;
9735 } while (uv /= base);
9738 elen = (ebuf + sizeof ebuf) - eptr;
9741 zeros = precis - elen;
9742 else if (precis == 0 && elen == 1 && *eptr == '0')
9747 /* FLOATING POINT */
9750 c = 'f'; /* maybe %F isn't supported here */
9756 /* This is evil, but floating point is even more evil */
9758 /* for SV-style calling, we can only get NV
9759 for C-style calling, we assume %f is double;
9760 for simplicity we allow any of %Lf, %llf, %qf for long double
9764 #if defined(USE_LONG_DOUBLE)
9768 /* [perl #20339] - we should accept and ignore %lf rather than die */
9772 #if defined(USE_LONG_DOUBLE)
9773 intsize = args ? 0 : 'q';
9777 #if defined(HAS_LONG_DOUBLE)
9786 /* now we need (long double) if intsize == 'q', else (double) */
9787 nv = (args && !vectorize) ?
9788 #if LONG_DOUBLESIZE > DOUBLESIZE
9790 va_arg(*args, long double) :
9791 va_arg(*args, double)
9793 va_arg(*args, double)
9799 if (c != 'e' && c != 'E') {
9801 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9802 will cast our (long double) to (double) */
9803 (void)Perl_frexp(nv, &i);
9804 if (i == PERL_INT_MIN)
9805 Perl_die(aTHX_ "panic: frexp");
9807 need = BIT_DIGITS(i);
9809 need += has_precis ? precis : 6; /* known default */
9814 #ifdef HAS_LDBL_SPRINTF_BUG
9815 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9816 with sfio - Allen <allens@cpan.org> */
9819 # define MY_DBL_MAX DBL_MAX
9820 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9821 # if DOUBLESIZE >= 8
9822 # define MY_DBL_MAX 1.7976931348623157E+308L
9824 # define MY_DBL_MAX 3.40282347E+38L
9828 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9829 # define MY_DBL_MAX_BUG 1L
9831 # define MY_DBL_MAX_BUG MY_DBL_MAX
9835 # define MY_DBL_MIN DBL_MIN
9836 # else /* XXX guessing! -Allen */
9837 # if DOUBLESIZE >= 8
9838 # define MY_DBL_MIN 2.2250738585072014E-308L
9840 # define MY_DBL_MIN 1.17549435E-38L
9844 if ((intsize == 'q') && (c == 'f') &&
9845 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9847 /* it's going to be short enough that
9848 * long double precision is not needed */
9850 if ((nv <= 0L) && (nv >= -0L))
9851 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9853 /* would use Perl_fp_class as a double-check but not
9854 * functional on IRIX - see perl.h comments */
9856 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9857 /* It's within the range that a double can represent */
9858 #if defined(DBL_MAX) && !defined(DBL_MIN)
9859 if ((nv >= ((long double)1/DBL_MAX)) ||
9860 (nv <= (-(long double)1/DBL_MAX)))
9862 fix_ldbl_sprintf_bug = TRUE;
9865 if (fix_ldbl_sprintf_bug == TRUE) {
9875 # undef MY_DBL_MAX_BUG
9878 #endif /* HAS_LDBL_SPRINTF_BUG */
9880 need += 20; /* fudge factor */
9881 if (PL_efloatsize < need) {
9882 Safefree(PL_efloatbuf);
9883 PL_efloatsize = need + 20; /* more fudge */
9884 New(906, PL_efloatbuf, PL_efloatsize, char);
9885 PL_efloatbuf[0] = '\0';
9888 if ( !(width || left || plus || alt) && fill != '0'
9889 && has_precis && intsize != 'q' ) { /* Shortcuts */
9890 /* See earlier comment about buggy Gconvert when digits,
9892 if ( c == 'g' && precis) {
9893 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9894 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9895 goto float_converted;
9896 } else if ( c == 'f' && !precis) {
9897 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9901 eptr = ebuf + sizeof ebuf;
9904 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9905 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9906 if (intsize == 'q') {
9907 /* Copy the one or more characters in a long double
9908 * format before the 'base' ([efgEFG]) character to
9909 * the format string. */
9910 static char const prifldbl[] = PERL_PRIfldbl;
9911 char const *p = prifldbl + sizeof(prifldbl) - 3;
9912 while (p >= prifldbl) { *--eptr = *p--; }
9917 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9922 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9934 /* No taint. Otherwise we are in the strange situation
9935 * where printf() taints but print($float) doesn't.
9937 #if defined(HAS_LONG_DOUBLE)
9939 (void)sprintf(PL_efloatbuf, eptr, nv);
9941 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9943 (void)sprintf(PL_efloatbuf, eptr, nv);
9946 eptr = PL_efloatbuf;
9947 elen = strlen(PL_efloatbuf);
9953 i = SvCUR(sv) - origlen;
9954 if (args && !vectorize) {
9956 case 'h': *(va_arg(*args, short*)) = i; break;
9957 default: *(va_arg(*args, int*)) = i; break;
9958 case 'l': *(va_arg(*args, long*)) = i; break;
9959 case 'V': *(va_arg(*args, IV*)) = i; break;
9961 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9966 sv_setuv_mg(argsv, (UV)i);
9968 continue; /* not "break" */
9974 if (!args && ckWARN(WARN_PRINTF) &&
9975 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9976 SV *msg = sv_newmortal();
9977 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9978 (PL_op->op_type == OP_PRTF) ? "" : "s");
9981 Perl_sv_catpvf(aTHX_ msg,
9982 "\"%%%c\"", c & 0xFF);
9984 Perl_sv_catpvf(aTHX_ msg,
9985 "\"%%\\%03"UVof"\"",
9988 sv_catpv(msg, "end of string");
9989 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9992 /* output mangled stuff ... */
9998 /* ... right here, because formatting flags should not apply */
9999 SvGROW(sv, SvCUR(sv) + elen + 1);
10001 Copy(eptr, p, elen, char);
10004 SvCUR(sv) = p - SvPVX(sv);
10006 continue; /* not "break" */
10009 /* calculate width before utf8_upgrade changes it */
10010 have = esignlen + zeros + elen;
10012 if (is_utf8 != has_utf8) {
10015 sv_utf8_upgrade(sv);
10018 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10019 sv_utf8_upgrade(nsv);
10023 SvGROW(sv, SvCUR(sv) + elen + 1);
10027 /* Use memchr() instead of strchr(), as eptr is not guaranteed */
10028 /* to point to a null-terminated string. */
10029 if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
10030 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
10031 Perl_warner(aTHX_ packWARN(WARN_PRINTF),
10032 "Newline in left-justified string for %sprintf",
10033 (PL_op->op_type == OP_PRTF) ? "" : "s");
10035 need = (have > width ? have : width);
10038 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10040 if (esignlen && fill == '0') {
10041 for (i = 0; i < (int)esignlen; i++)
10042 *p++ = esignbuf[i];
10044 if (gap && !left) {
10045 memset(p, fill, gap);
10048 if (esignlen && fill != '0') {
10049 for (i = 0; i < (int)esignlen; i++)
10050 *p++ = esignbuf[i];
10053 for (i = zeros; i; i--)
10057 Copy(eptr, p, elen, char);
10061 memset(p, ' ', gap);
10066 Copy(dotstr, p, dotstrlen, char);
10070 vectorize = FALSE; /* done iterating over vecstr */
10077 SvCUR(sv) = p - SvPVX(sv);
10085 /* =========================================================================
10087 =head1 Cloning an interpreter
10089 All the macros and functions in this section are for the private use of
10090 the main function, perl_clone().
10092 The foo_dup() functions make an exact copy of an existing foo thinngy.
10093 During the course of a cloning, a hash table is used to map old addresses
10094 to new addresses. The table is created and manipulated with the
10095 ptr_table_* functions.
10099 ============================================================================*/
10102 #if defined(USE_ITHREADS)
10104 #ifndef GpREFCNT_inc
10105 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10109 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10110 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10111 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10112 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10113 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10114 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10115 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10116 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10117 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10118 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10119 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10120 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10121 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10124 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10125 regcomp.c. AMS 20010712 */
10128 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10132 struct reg_substr_datum *s;
10135 return (REGEXP *)NULL;
10137 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10140 len = r->offsets[0];
10141 npar = r->nparens+1;
10143 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10144 Copy(r->program, ret->program, len+1, regnode);
10146 New(0, ret->startp, npar, I32);
10147 Copy(r->startp, ret->startp, npar, I32);
10148 New(0, ret->endp, npar, I32);
10149 Copy(r->startp, ret->startp, npar, I32);
10151 New(0, ret->substrs, 1, struct reg_substr_data);
10152 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10153 s->min_offset = r->substrs->data[i].min_offset;
10154 s->max_offset = r->substrs->data[i].max_offset;
10155 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10156 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10159 ret->regstclass = NULL;
10161 struct reg_data *d;
10162 int count = r->data->count;
10164 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10165 char, struct reg_data);
10166 New(0, d->what, count, U8);
10169 for (i = 0; i < count; i++) {
10170 d->what[i] = r->data->what[i];
10171 switch (d->what[i]) {
10173 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10176 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10179 /* This is cheating. */
10180 New(0, d->data[i], 1, struct regnode_charclass_class);
10181 StructCopy(r->data->data[i], d->data[i],
10182 struct regnode_charclass_class);
10183 ret->regstclass = (regnode*)d->data[i];
10186 /* Compiled op trees are readonly, and can thus be
10187 shared without duplication. */
10188 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10191 d->data[i] = r->data->data[i];
10201 New(0, ret->offsets, 2*len+1, U32);
10202 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10204 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10205 ret->refcnt = r->refcnt;
10206 ret->minlen = r->minlen;
10207 ret->prelen = r->prelen;
10208 ret->nparens = r->nparens;
10209 ret->lastparen = r->lastparen;
10210 ret->lastcloseparen = r->lastcloseparen;
10211 ret->reganch = r->reganch;
10213 ret->sublen = r->sublen;
10215 if (RX_MATCH_COPIED(ret))
10216 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10218 ret->subbeg = Nullch;
10219 #ifdef PERL_COPY_ON_WRITE
10220 ret->saved_copy = Nullsv;
10223 ptr_table_store(PL_ptr_table, r, ret);
10227 /* duplicate a file handle */
10230 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10234 return (PerlIO*)NULL;
10236 /* look for it in the table first */
10237 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10241 /* create anew and remember what it is */
10242 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10243 ptr_table_store(PL_ptr_table, fp, ret);
10247 /* duplicate a directory handle */
10250 Perl_dirp_dup(pTHX_ DIR *dp)
10258 /* duplicate a typeglob */
10261 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10266 /* look for it in the table first */
10267 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10271 /* create anew and remember what it is */
10272 Newz(0, ret, 1, GP);
10273 ptr_table_store(PL_ptr_table, gp, ret);
10276 ret->gp_refcnt = 0; /* must be before any other dups! */
10277 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10278 ret->gp_io = io_dup_inc(gp->gp_io, param);
10279 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10280 ret->gp_av = av_dup_inc(gp->gp_av, param);
10281 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10282 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10283 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10284 ret->gp_cvgen = gp->gp_cvgen;
10285 ret->gp_flags = gp->gp_flags;
10286 ret->gp_line = gp->gp_line;
10287 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10291 /* duplicate a chain of magic */
10294 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10296 MAGIC *mgprev = (MAGIC*)NULL;
10299 return (MAGIC*)NULL;
10300 /* look for it in the table first */
10301 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10305 for (; mg; mg = mg->mg_moremagic) {
10307 Newz(0, nmg, 1, MAGIC);
10309 mgprev->mg_moremagic = nmg;
10312 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10313 nmg->mg_private = mg->mg_private;
10314 nmg->mg_type = mg->mg_type;
10315 nmg->mg_flags = mg->mg_flags;
10316 if (mg->mg_type == PERL_MAGIC_qr) {
10317 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10319 else if(mg->mg_type == PERL_MAGIC_backref) {
10320 AV *av = (AV*) mg->mg_obj;
10323 SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10325 for (i = AvFILLp(av); i >= 0; i--) {
10326 if (!svp[i]) continue;
10327 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10331 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10332 ? sv_dup_inc(mg->mg_obj, param)
10333 : sv_dup(mg->mg_obj, param);
10335 nmg->mg_len = mg->mg_len;
10336 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10337 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10338 if (mg->mg_len > 0) {
10339 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10340 if (mg->mg_type == PERL_MAGIC_overload_table &&
10341 AMT_AMAGIC((AMT*)mg->mg_ptr))
10343 AMT *amtp = (AMT*)mg->mg_ptr;
10344 AMT *namtp = (AMT*)nmg->mg_ptr;
10346 for (i = 1; i < NofAMmeth; i++) {
10347 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10351 else if (mg->mg_len == HEf_SVKEY)
10352 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10354 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10355 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10362 /* create a new pointer-mapping table */
10365 Perl_ptr_table_new(pTHX)
10368 Newz(0, tbl, 1, PTR_TBL_t);
10369 tbl->tbl_max = 511;
10370 tbl->tbl_items = 0;
10371 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10376 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10378 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10381 /* map an existing pointer using a table */
10384 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10386 PTR_TBL_ENT_t *tblent;
10387 UV hash = PTR_TABLE_HASH(sv);
10389 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10390 for (; tblent; tblent = tblent->next) {
10391 if (tblent->oldval == sv)
10392 return tblent->newval;
10394 return (void*)NULL;
10397 /* add a new entry to a pointer-mapping table */
10400 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10402 PTR_TBL_ENT_t *tblent, **otblent;
10403 /* XXX this may be pessimal on platforms where pointers aren't good
10404 * hash values e.g. if they grow faster in the most significant
10406 UV hash = PTR_TABLE_HASH(oldv);
10410 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10411 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10412 if (tblent->oldval == oldv) {
10413 tblent->newval = newv;
10417 Newz(0, tblent, 1, PTR_TBL_ENT_t);
10418 tblent->oldval = oldv;
10419 tblent->newval = newv;
10420 tblent->next = *otblent;
10423 if (!empty && tbl->tbl_items > tbl->tbl_max)
10424 ptr_table_split(tbl);
10427 /* double the hash bucket size of an existing ptr table */
10430 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10432 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10433 UV oldsize = tbl->tbl_max + 1;
10434 UV newsize = oldsize * 2;
10437 Renew(ary, newsize, PTR_TBL_ENT_t*);
10438 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10439 tbl->tbl_max = --newsize;
10440 tbl->tbl_ary = ary;
10441 for (i=0; i < oldsize; i++, ary++) {
10442 PTR_TBL_ENT_t **curentp, **entp, *ent;
10445 curentp = ary + oldsize;
10446 for (entp = ary, ent = *ary; ent; ent = *entp) {
10447 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10449 ent->next = *curentp;
10459 /* remove all the entries from a ptr table */
10462 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10464 register PTR_TBL_ENT_t **array;
10465 register PTR_TBL_ENT_t *entry;
10466 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10470 if (!tbl || !tbl->tbl_items) {
10474 array = tbl->tbl_ary;
10476 max = tbl->tbl_max;
10481 entry = entry->next;
10485 if (++riter > max) {
10488 entry = array[riter];
10492 tbl->tbl_items = 0;
10495 /* clear and free a ptr table */
10498 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10503 ptr_table_clear(tbl);
10504 Safefree(tbl->tbl_ary);
10509 char *PL_watch_pvx;
10512 /* attempt to make everything in the typeglob readonly */
10515 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10517 GV *gv = (GV*)sstr;
10518 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10520 if (GvIO(gv) || GvFORM(gv)) {
10521 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10523 else if (!GvCV(gv)) {
10524 GvCV(gv) = (CV*)sv;
10527 /* CvPADLISTs cannot be shared */
10528 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10533 if (!GvUNIQUE(gv)) {
10535 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10536 HvNAME(GvSTASH(gv)), GvNAME(gv));
10542 * write attempts will die with
10543 * "Modification of a read-only value attempted"
10549 SvREADONLY_on(GvSV(gv));
10553 GvAV(gv) = (AV*)sv;
10556 SvREADONLY_on(GvAV(gv));
10560 GvHV(gv) = (HV*)sv;
10563 SvREADONLY_on(GvHV(gv));
10566 return sstr; /* he_dup() will SvREFCNT_inc() */
10569 /* duplicate an SV of any type (including AV, HV etc) */
10572 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10575 SvRV(dstr) = SvWEAKREF(sstr)
10576 ? sv_dup(SvRV(sstr), param)
10577 : sv_dup_inc(SvRV(sstr), param);
10579 else if (SvPVX(sstr)) {
10580 /* Has something there */
10582 /* Normal PV - clone whole allocated space */
10583 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
10584 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10585 /* Not that normal - actually sstr is copy on write.
10586 But we are a true, independant SV, so: */
10587 SvREADONLY_off(dstr);
10592 /* Special case - not normally malloced for some reason */
10593 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10594 /* A "shared" PV - clone it as unshared string */
10595 if(SvPADTMP(sstr)) {
10596 /* However, some of them live in the pad
10597 and they should not have these flags
10600 SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
10602 SvUVX(dstr) = SvUVX(sstr);
10605 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
10607 SvREADONLY_off(dstr);
10611 /* Some other special case - random pointer */
10612 SvPVX(dstr) = SvPVX(sstr);
10617 /* Copy the Null */
10618 SvPVX(dstr) = SvPVX(sstr);
10623 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10627 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10629 /* look for it in the table first */
10630 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10634 if(param->flags & CLONEf_JOIN_IN) {
10635 /** We are joining here so we don't want do clone
10636 something that is bad **/
10638 if(SvTYPE(sstr) == SVt_PVHV &&
10640 /** don't clone stashes if they already exist **/
10641 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10642 return (SV*) old_stash;
10646 /* create anew and remember what it is */
10648 ptr_table_store(PL_ptr_table, sstr, dstr);
10651 SvFLAGS(dstr) = SvFLAGS(sstr);
10652 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10653 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10656 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10657 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10658 PL_watch_pvx, SvPVX(sstr));
10661 switch (SvTYPE(sstr)) {
10663 SvANY(dstr) = NULL;
10666 SvANY(dstr) = new_XIV();
10667 SvIVX(dstr) = SvIVX(sstr);
10670 SvANY(dstr) = new_XNV();
10671 SvNVX(dstr) = SvNVX(sstr);
10674 SvANY(dstr) = new_XRV();
10675 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10678 SvANY(dstr) = new_XPV();
10679 SvCUR(dstr) = SvCUR(sstr);
10680 SvLEN(dstr) = SvLEN(sstr);
10681 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10684 SvANY(dstr) = new_XPVIV();
10685 SvCUR(dstr) = SvCUR(sstr);
10686 SvLEN(dstr) = SvLEN(sstr);
10687 SvIVX(dstr) = SvIVX(sstr);
10688 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10691 SvANY(dstr) = new_XPVNV();
10692 SvCUR(dstr) = SvCUR(sstr);
10693 SvLEN(dstr) = SvLEN(sstr);
10694 SvIVX(dstr) = SvIVX(sstr);
10695 SvNVX(dstr) = SvNVX(sstr);
10696 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10699 SvANY(dstr) = new_XPVMG();
10700 SvCUR(dstr) = SvCUR(sstr);
10701 SvLEN(dstr) = SvLEN(sstr);
10702 SvIVX(dstr) = SvIVX(sstr);
10703 SvNVX(dstr) = SvNVX(sstr);
10704 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10705 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10706 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10709 SvANY(dstr) = new_XPVBM();
10710 SvCUR(dstr) = SvCUR(sstr);
10711 SvLEN(dstr) = SvLEN(sstr);
10712 SvIVX(dstr) = SvIVX(sstr);
10713 SvNVX(dstr) = SvNVX(sstr);
10714 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10715 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10716 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10717 BmRARE(dstr) = BmRARE(sstr);
10718 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10719 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10722 SvANY(dstr) = new_XPVLV();
10723 SvCUR(dstr) = SvCUR(sstr);
10724 SvLEN(dstr) = SvLEN(sstr);
10725 SvIVX(dstr) = SvIVX(sstr);
10726 SvNVX(dstr) = SvNVX(sstr);
10727 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10728 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10729 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10730 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10731 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10732 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10733 LvTARG(dstr) = dstr;
10734 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10735 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10737 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10738 LvTYPE(dstr) = LvTYPE(sstr);
10741 if (GvUNIQUE((GV*)sstr)) {
10743 if ((share = gv_share(sstr, param))) {
10746 ptr_table_store(PL_ptr_table, sstr, dstr);
10748 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10749 HvNAME(GvSTASH(share)), GvNAME(share));
10754 SvANY(dstr) = new_XPVGV();
10755 SvCUR(dstr) = SvCUR(sstr);
10756 SvLEN(dstr) = SvLEN(sstr);
10757 SvIVX(dstr) = SvIVX(sstr);
10758 SvNVX(dstr) = SvNVX(sstr);
10759 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10760 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10761 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10762 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10763 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10764 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10765 GvFLAGS(dstr) = GvFLAGS(sstr);
10766 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10767 (void)GpREFCNT_inc(GvGP(dstr));
10770 SvANY(dstr) = new_XPVIO();
10771 SvCUR(dstr) = SvCUR(sstr);
10772 SvLEN(dstr) = SvLEN(sstr);
10773 SvIVX(dstr) = SvIVX(sstr);
10774 SvNVX(dstr) = SvNVX(sstr);
10775 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10776 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10777 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10778 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10779 if (IoOFP(sstr) == IoIFP(sstr))
10780 IoOFP(dstr) = IoIFP(dstr);
10782 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10783 /* PL_rsfp_filters entries have fake IoDIRP() */
10784 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10785 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10787 IoDIRP(dstr) = IoDIRP(sstr);
10788 IoLINES(dstr) = IoLINES(sstr);
10789 IoPAGE(dstr) = IoPAGE(sstr);
10790 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10791 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10792 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10793 /* I have no idea why fake dirp (rsfps)
10794 should be treaded differently but otherwise
10795 we end up with leaks -- sky*/
10796 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10797 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10798 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10800 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10801 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10802 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10804 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10805 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10806 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10807 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10808 IoTYPE(dstr) = IoTYPE(sstr);
10809 IoFLAGS(dstr) = IoFLAGS(sstr);
10812 SvANY(dstr) = new_XPVAV();
10813 SvCUR(dstr) = SvCUR(sstr);
10814 SvLEN(dstr) = SvLEN(sstr);
10815 SvIVX(dstr) = SvIVX(sstr);
10816 SvNVX(dstr) = SvNVX(sstr);
10817 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10818 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10819 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10820 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10821 if (AvARRAY((AV*)sstr)) {
10822 SV **dst_ary, **src_ary;
10823 SSize_t items = AvFILLp((AV*)sstr) + 1;
10825 src_ary = AvARRAY((AV*)sstr);
10826 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10827 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10828 SvPVX(dstr) = (char*)dst_ary;
10829 AvALLOC((AV*)dstr) = dst_ary;
10830 if (AvREAL((AV*)sstr)) {
10831 while (items-- > 0)
10832 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10835 while (items-- > 0)
10836 *dst_ary++ = sv_dup(*src_ary++, param);
10838 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10839 while (items-- > 0) {
10840 *dst_ary++ = &PL_sv_undef;
10844 SvPVX(dstr) = Nullch;
10845 AvALLOC((AV*)dstr) = (SV**)NULL;
10849 SvANY(dstr) = new_XPVHV();
10850 SvCUR(dstr) = SvCUR(sstr);
10851 SvLEN(dstr) = SvLEN(sstr);
10852 SvIVX(dstr) = SvIVX(sstr);
10853 SvNVX(dstr) = SvNVX(sstr);
10854 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10855 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10856 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10857 if (HvARRAY((HV*)sstr)) {
10859 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10860 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10861 Newz(0, dxhv->xhv_array,
10862 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10863 while (i <= sxhv->xhv_max) {
10864 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10865 (bool)!!HvSHAREKEYS(sstr),
10869 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10870 (bool)!!HvSHAREKEYS(sstr), param);
10873 SvPVX(dstr) = Nullch;
10874 HvEITER((HV*)dstr) = (HE*)NULL;
10876 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
10877 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
10878 /* Record stashes for possible cloning in Perl_clone(). */
10879 if(HvNAME((HV*)dstr))
10880 av_push(param->stashes, dstr);
10883 SvANY(dstr) = new_XPVFM();
10884 FmLINES(dstr) = FmLINES(sstr);
10888 SvANY(dstr) = new_XPVCV();
10890 SvCUR(dstr) = SvCUR(sstr);
10891 SvLEN(dstr) = SvLEN(sstr);
10892 SvIVX(dstr) = SvIVX(sstr);
10893 SvNVX(dstr) = SvNVX(sstr);
10894 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10895 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10896 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10897 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10898 CvSTART(dstr) = CvSTART(sstr);
10899 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10900 CvXSUB(dstr) = CvXSUB(sstr);
10901 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10902 if (CvCONST(sstr)) {
10903 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10904 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10905 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10907 /* don't dup if copying back - CvGV isn't refcounted, so the
10908 * duped GV may never be freed. A bit of a hack! DAPM */
10909 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10910 Nullgv : gv_dup(CvGV(sstr), param) ;
10911 if (param->flags & CLONEf_COPY_STACKS) {
10912 CvDEPTH(dstr) = CvDEPTH(sstr);
10916 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10917 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10919 CvWEAKOUTSIDE(sstr)
10920 ? cv_dup( CvOUTSIDE(sstr), param)
10921 : cv_dup_inc(CvOUTSIDE(sstr), param);
10922 CvFLAGS(dstr) = CvFLAGS(sstr);
10923 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10926 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10930 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10936 /* duplicate a context */
10939 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10941 PERL_CONTEXT *ncxs;
10944 return (PERL_CONTEXT*)NULL;
10946 /* look for it in the table first */
10947 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10951 /* create anew and remember what it is */
10952 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10953 ptr_table_store(PL_ptr_table, cxs, ncxs);
10956 PERL_CONTEXT *cx = &cxs[ix];
10957 PERL_CONTEXT *ncx = &ncxs[ix];
10958 ncx->cx_type = cx->cx_type;
10959 if (CxTYPE(cx) == CXt_SUBST) {
10960 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10963 ncx->blk_oldsp = cx->blk_oldsp;
10964 ncx->blk_oldcop = cx->blk_oldcop;
10965 ncx->blk_oldretsp = cx->blk_oldretsp;
10966 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10967 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10968 ncx->blk_oldpm = cx->blk_oldpm;
10969 ncx->blk_gimme = cx->blk_gimme;
10970 switch (CxTYPE(cx)) {
10972 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10973 ? cv_dup_inc(cx->blk_sub.cv, param)
10974 : cv_dup(cx->blk_sub.cv,param));
10975 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10976 ? av_dup_inc(cx->blk_sub.argarray, param)
10978 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10979 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10980 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10981 ncx->blk_sub.lval = cx->blk_sub.lval;
10984 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10985 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10986 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10987 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10988 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10991 ncx->blk_loop.label = cx->blk_loop.label;
10992 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10993 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10994 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10995 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10996 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10997 ? cx->blk_loop.iterdata
10998 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10999 ncx->blk_loop.oldcomppad
11000 = (PAD*)ptr_table_fetch(PL_ptr_table,
11001 cx->blk_loop.oldcomppad);
11002 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11003 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11004 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11005 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11006 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11009 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11010 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11011 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11012 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11024 /* duplicate a stack info structure */
11027 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11032 return (PERL_SI*)NULL;
11034 /* look for it in the table first */
11035 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11039 /* create anew and remember what it is */
11040 Newz(56, nsi, 1, PERL_SI);
11041 ptr_table_store(PL_ptr_table, si, nsi);
11043 nsi->si_stack = av_dup_inc(si->si_stack, param);
11044 nsi->si_cxix = si->si_cxix;
11045 nsi->si_cxmax = si->si_cxmax;
11046 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11047 nsi->si_type = si->si_type;
11048 nsi->si_prev = si_dup(si->si_prev, param);
11049 nsi->si_next = si_dup(si->si_next, param);
11050 nsi->si_markoff = si->si_markoff;
11055 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11056 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11057 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11058 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11059 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11060 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11061 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11062 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11063 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11064 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11065 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11066 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11067 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11068 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11071 #define pv_dup_inc(p) SAVEPV(p)
11072 #define pv_dup(p) SAVEPV(p)
11073 #define svp_dup_inc(p,pp) any_dup(p,pp)
11075 /* map any object to the new equivent - either something in the
11076 * ptr table, or something in the interpreter structure
11080 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11085 return (void*)NULL;
11087 /* look for it in the table first */
11088 ret = ptr_table_fetch(PL_ptr_table, v);
11092 /* see if it is part of the interpreter structure */
11093 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11094 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11102 /* duplicate the save stack */
11105 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11107 ANY *ss = proto_perl->Tsavestack;
11108 I32 ix = proto_perl->Tsavestack_ix;
11109 I32 max = proto_perl->Tsavestack_max;
11122 void (*dptr) (void*);
11123 void (*dxptr) (pTHX_ void*);
11126 Newz(54, nss, max, ANY);
11130 TOPINT(nss,ix) = i;
11132 case SAVEt_ITEM: /* normal string */
11133 sv = (SV*)POPPTR(ss,ix);
11134 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11135 sv = (SV*)POPPTR(ss,ix);
11136 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11138 case SAVEt_SV: /* scalar reference */
11139 sv = (SV*)POPPTR(ss,ix);
11140 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11141 gv = (GV*)POPPTR(ss,ix);
11142 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11144 case SAVEt_GENERIC_PVREF: /* generic char* */
11145 c = (char*)POPPTR(ss,ix);
11146 TOPPTR(nss,ix) = pv_dup(c);
11147 ptr = POPPTR(ss,ix);
11148 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11150 case SAVEt_SHARED_PVREF: /* char* in shared space */
11151 c = (char*)POPPTR(ss,ix);
11152 TOPPTR(nss,ix) = savesharedpv(c);
11153 ptr = POPPTR(ss,ix);
11154 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11156 case SAVEt_GENERIC_SVREF: /* generic sv */
11157 case SAVEt_SVREF: /* scalar reference */
11158 sv = (SV*)POPPTR(ss,ix);
11159 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11160 ptr = POPPTR(ss,ix);
11161 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11163 case SAVEt_AV: /* array reference */
11164 av = (AV*)POPPTR(ss,ix);
11165 TOPPTR(nss,ix) = av_dup_inc(av, param);
11166 gv = (GV*)POPPTR(ss,ix);
11167 TOPPTR(nss,ix) = gv_dup(gv, param);
11169 case SAVEt_HV: /* hash reference */
11170 hv = (HV*)POPPTR(ss,ix);
11171 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11172 gv = (GV*)POPPTR(ss,ix);
11173 TOPPTR(nss,ix) = gv_dup(gv, param);
11175 case SAVEt_INT: /* int reference */
11176 ptr = POPPTR(ss,ix);
11177 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11178 intval = (int)POPINT(ss,ix);
11179 TOPINT(nss,ix) = intval;
11181 case SAVEt_LONG: /* long reference */
11182 ptr = POPPTR(ss,ix);
11183 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11184 longval = (long)POPLONG(ss,ix);
11185 TOPLONG(nss,ix) = longval;
11187 case SAVEt_I32: /* I32 reference */
11188 case SAVEt_I16: /* I16 reference */
11189 case SAVEt_I8: /* I8 reference */
11190 ptr = POPPTR(ss,ix);
11191 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11193 TOPINT(nss,ix) = i;
11195 case SAVEt_IV: /* IV reference */
11196 ptr = POPPTR(ss,ix);
11197 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11199 TOPIV(nss,ix) = iv;
11201 case SAVEt_SPTR: /* SV* reference */
11202 ptr = POPPTR(ss,ix);
11203 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11204 sv = (SV*)POPPTR(ss,ix);
11205 TOPPTR(nss,ix) = sv_dup(sv, param);
11207 case SAVEt_VPTR: /* random* reference */
11208 ptr = POPPTR(ss,ix);
11209 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11210 ptr = POPPTR(ss,ix);
11211 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11213 case SAVEt_PPTR: /* char* reference */
11214 ptr = POPPTR(ss,ix);
11215 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11216 c = (char*)POPPTR(ss,ix);
11217 TOPPTR(nss,ix) = pv_dup(c);
11219 case SAVEt_HPTR: /* HV* reference */
11220 ptr = POPPTR(ss,ix);
11221 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11222 hv = (HV*)POPPTR(ss,ix);
11223 TOPPTR(nss,ix) = hv_dup(hv, param);
11225 case SAVEt_APTR: /* AV* reference */
11226 ptr = POPPTR(ss,ix);
11227 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11228 av = (AV*)POPPTR(ss,ix);
11229 TOPPTR(nss,ix) = av_dup(av, param);
11232 gv = (GV*)POPPTR(ss,ix);
11233 TOPPTR(nss,ix) = gv_dup(gv, param);
11235 case SAVEt_GP: /* scalar reference */
11236 gp = (GP*)POPPTR(ss,ix);
11237 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11238 (void)GpREFCNT_inc(gp);
11239 gv = (GV*)POPPTR(ss,ix);
11240 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11241 c = (char*)POPPTR(ss,ix);
11242 TOPPTR(nss,ix) = pv_dup(c);
11244 TOPIV(nss,ix) = iv;
11246 TOPIV(nss,ix) = iv;
11249 case SAVEt_MORTALIZESV:
11250 sv = (SV*)POPPTR(ss,ix);
11251 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11254 ptr = POPPTR(ss,ix);
11255 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11256 /* these are assumed to be refcounted properly */
11257 switch (((OP*)ptr)->op_type) {
11259 case OP_LEAVESUBLV:
11263 case OP_LEAVEWRITE:
11264 TOPPTR(nss,ix) = ptr;
11269 TOPPTR(nss,ix) = Nullop;
11274 TOPPTR(nss,ix) = Nullop;
11277 c = (char*)POPPTR(ss,ix);
11278 TOPPTR(nss,ix) = pv_dup_inc(c);
11280 case SAVEt_CLEARSV:
11281 longval = POPLONG(ss,ix);
11282 TOPLONG(nss,ix) = longval;
11285 hv = (HV*)POPPTR(ss,ix);
11286 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11287 c = (char*)POPPTR(ss,ix);
11288 TOPPTR(nss,ix) = pv_dup_inc(c);
11290 TOPINT(nss,ix) = i;
11292 case SAVEt_DESTRUCTOR:
11293 ptr = POPPTR(ss,ix);
11294 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11295 dptr = POPDPTR(ss,ix);
11296 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11298 case SAVEt_DESTRUCTOR_X:
11299 ptr = POPPTR(ss,ix);
11300 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11301 dxptr = POPDXPTR(ss,ix);
11302 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11304 case SAVEt_REGCONTEXT:
11307 TOPINT(nss,ix) = i;
11310 case SAVEt_STACK_POS: /* Position on Perl stack */
11312 TOPINT(nss,ix) = i;
11314 case SAVEt_AELEM: /* array element */
11315 sv = (SV*)POPPTR(ss,ix);
11316 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11318 TOPINT(nss,ix) = i;
11319 av = (AV*)POPPTR(ss,ix);
11320 TOPPTR(nss,ix) = av_dup_inc(av, param);
11322 case SAVEt_HELEM: /* hash element */
11323 sv = (SV*)POPPTR(ss,ix);
11324 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11325 sv = (SV*)POPPTR(ss,ix);
11326 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11327 hv = (HV*)POPPTR(ss,ix);
11328 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11331 ptr = POPPTR(ss,ix);
11332 TOPPTR(nss,ix) = ptr;
11336 TOPINT(nss,ix) = i;
11338 case SAVEt_COMPPAD:
11339 av = (AV*)POPPTR(ss,ix);
11340 TOPPTR(nss,ix) = av_dup(av, param);
11343 longval = (long)POPLONG(ss,ix);
11344 TOPLONG(nss,ix) = longval;
11345 ptr = POPPTR(ss,ix);
11346 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11347 sv = (SV*)POPPTR(ss,ix);
11348 TOPPTR(nss,ix) = sv_dup(sv, param);
11351 ptr = POPPTR(ss,ix);
11352 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11353 longval = (long)POPBOOL(ss,ix);
11354 TOPBOOL(nss,ix) = (bool)longval;
11356 case SAVEt_SET_SVFLAGS:
11358 TOPINT(nss,ix) = i;
11360 TOPINT(nss,ix) = i;
11361 sv = (SV*)POPPTR(ss,ix);
11362 TOPPTR(nss,ix) = sv_dup(sv, param);
11365 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11373 =for apidoc perl_clone
11375 Create and return a new interpreter by cloning the current one.
11377 perl_clone takes these flags as parameters:
11379 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11380 without it we only clone the data and zero the stacks,
11381 with it we copy the stacks and the new perl interpreter is
11382 ready to run at the exact same point as the previous one.
11383 The pseudo-fork code uses COPY_STACKS while the
11384 threads->new doesn't.
11386 CLONEf_KEEP_PTR_TABLE
11387 perl_clone keeps a ptr_table with the pointer of the old
11388 variable as a key and the new variable as a value,
11389 this allows it to check if something has been cloned and not
11390 clone it again but rather just use the value and increase the
11391 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11392 the ptr_table using the function
11393 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11394 reason to keep it around is if you want to dup some of your own
11395 variable who are outside the graph perl scans, example of this
11396 code is in threads.xs create
11399 This is a win32 thing, it is ignored on unix, it tells perls
11400 win32host code (which is c++) to clone itself, this is needed on
11401 win32 if you want to run two threads at the same time,
11402 if you just want to do some stuff in a separate perl interpreter
11403 and then throw it away and return to the original one,
11404 you don't need to do anything.
11409 /* XXX the above needs expanding by someone who actually understands it ! */
11410 EXTERN_C PerlInterpreter *
11411 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11414 perl_clone(PerlInterpreter *proto_perl, UV flags)
11416 #ifdef PERL_IMPLICIT_SYS
11418 /* perlhost.h so we need to call into it
11419 to clone the host, CPerlHost should have a c interface, sky */
11421 if (flags & CLONEf_CLONE_HOST) {
11422 return perl_clone_host(proto_perl,flags);
11424 return perl_clone_using(proto_perl, flags,
11426 proto_perl->IMemShared,
11427 proto_perl->IMemParse,
11429 proto_perl->IStdIO,
11433 proto_perl->IProc);
11437 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11438 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11439 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11440 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11441 struct IPerlDir* ipD, struct IPerlSock* ipS,
11442 struct IPerlProc* ipP)
11444 /* XXX many of the string copies here can be optimized if they're
11445 * constants; they need to be allocated as common memory and just
11446 * their pointers copied. */
11449 CLONE_PARAMS clone_params;
11450 CLONE_PARAMS* param = &clone_params;
11452 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11453 PERL_SET_THX(my_perl);
11456 Poison(my_perl, 1, PerlInterpreter);
11460 PL_savestack_ix = 0;
11461 PL_savestack_max = -1;
11463 PL_sig_pending = 0;
11464 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11465 # else /* !DEBUGGING */
11466 Zero(my_perl, 1, PerlInterpreter);
11467 # endif /* DEBUGGING */
11469 /* host pointers */
11471 PL_MemShared = ipMS;
11472 PL_MemParse = ipMP;
11479 #else /* !PERL_IMPLICIT_SYS */
11481 CLONE_PARAMS clone_params;
11482 CLONE_PARAMS* param = &clone_params;
11483 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11484 PERL_SET_THX(my_perl);
11489 Poison(my_perl, 1, PerlInterpreter);
11493 PL_savestack_ix = 0;
11494 PL_savestack_max = -1;
11496 PL_sig_pending = 0;
11497 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11498 # else /* !DEBUGGING */
11499 Zero(my_perl, 1, PerlInterpreter);
11500 # endif /* DEBUGGING */
11501 #endif /* PERL_IMPLICIT_SYS */
11502 param->flags = flags;
11503 param->proto_perl = proto_perl;
11506 PL_xiv_arenaroot = NULL;
11507 PL_xiv_root = NULL;
11508 PL_xnv_arenaroot = NULL;
11509 PL_xnv_root = NULL;
11510 PL_xrv_arenaroot = NULL;
11511 PL_xrv_root = NULL;
11512 PL_xpv_arenaroot = NULL;
11513 PL_xpv_root = NULL;
11514 PL_xpviv_arenaroot = NULL;
11515 PL_xpviv_root = NULL;
11516 PL_xpvnv_arenaroot = NULL;
11517 PL_xpvnv_root = NULL;
11518 PL_xpvcv_arenaroot = NULL;
11519 PL_xpvcv_root = NULL;
11520 PL_xpvav_arenaroot = NULL;
11521 PL_xpvav_root = NULL;
11522 PL_xpvhv_arenaroot = NULL;
11523 PL_xpvhv_root = NULL;
11524 PL_xpvmg_arenaroot = NULL;
11525 PL_xpvmg_root = NULL;
11526 PL_xpvlv_arenaroot = NULL;
11527 PL_xpvlv_root = NULL;
11528 PL_xpvbm_arenaroot = NULL;
11529 PL_xpvbm_root = NULL;
11530 PL_he_arenaroot = NULL;
11532 PL_nice_chunk = NULL;
11533 PL_nice_chunk_size = 0;
11535 PL_sv_objcount = 0;
11536 PL_sv_root = Nullsv;
11537 PL_sv_arenaroot = Nullsv;
11539 PL_debug = proto_perl->Idebug;
11541 #ifdef USE_REENTRANT_API
11542 /* XXX: things like -Dm will segfault here in perlio, but doing
11543 * PERL_SET_CONTEXT(proto_perl);
11544 * breaks too many other things
11546 Perl_reentrant_init(aTHX);
11549 /* create SV map for pointer relocation */
11550 PL_ptr_table = ptr_table_new();
11552 /* initialize these special pointers as early as possible */
11553 SvANY(&PL_sv_undef) = NULL;
11554 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11555 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11556 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11558 SvANY(&PL_sv_no) = new_XPVNV();
11559 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11560 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11561 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
11562 SvCUR(&PL_sv_no) = 0;
11563 SvLEN(&PL_sv_no) = 1;
11564 SvNVX(&PL_sv_no) = 0;
11565 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11567 SvANY(&PL_sv_yes) = new_XPVNV();
11568 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11569 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11570 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
11571 SvCUR(&PL_sv_yes) = 1;
11572 SvLEN(&PL_sv_yes) = 2;
11573 SvNVX(&PL_sv_yes) = 1;
11574 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11576 /* create (a non-shared!) shared string table */
11577 PL_strtab = newHV();
11578 HvSHAREKEYS_off(PL_strtab);
11579 hv_ksplit(PL_strtab, 512);
11580 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11582 PL_compiling = proto_perl->Icompiling;
11584 /* These two PVs will be free'd special way so must set them same way op.c does */
11585 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11586 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11588 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11589 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11591 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11592 if (!specialWARN(PL_compiling.cop_warnings))
11593 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11594 if (!specialCopIO(PL_compiling.cop_io))
11595 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11596 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11598 /* pseudo environmental stuff */
11599 PL_origargc = proto_perl->Iorigargc;
11600 PL_origargv = proto_perl->Iorigargv;
11602 param->stashes = newAV(); /* Setup array of objects to call clone on */
11604 #ifdef PERLIO_LAYERS
11605 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11606 PerlIO_clone(aTHX_ proto_perl, param);
11609 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11610 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11611 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11612 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11613 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11614 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11617 PL_minus_c = proto_perl->Iminus_c;
11618 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11619 PL_localpatches = proto_perl->Ilocalpatches;
11620 PL_splitstr = proto_perl->Isplitstr;
11621 PL_preprocess = proto_perl->Ipreprocess;
11622 PL_minus_n = proto_perl->Iminus_n;
11623 PL_minus_p = proto_perl->Iminus_p;
11624 PL_minus_l = proto_perl->Iminus_l;
11625 PL_minus_a = proto_perl->Iminus_a;
11626 PL_minus_F = proto_perl->Iminus_F;
11627 PL_doswitches = proto_perl->Idoswitches;
11628 PL_dowarn = proto_perl->Idowarn;
11629 PL_doextract = proto_perl->Idoextract;
11630 PL_sawampersand = proto_perl->Isawampersand;
11631 PL_unsafe = proto_perl->Iunsafe;
11632 PL_inplace = SAVEPV(proto_perl->Iinplace);
11633 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11634 PL_perldb = proto_perl->Iperldb;
11635 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11636 PL_exit_flags = proto_perl->Iexit_flags;
11638 /* magical thingies */
11639 /* XXX time(&PL_basetime) when asked for? */
11640 PL_basetime = proto_perl->Ibasetime;
11641 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11643 PL_maxsysfd = proto_perl->Imaxsysfd;
11644 PL_multiline = proto_perl->Imultiline;
11645 PL_statusvalue = proto_perl->Istatusvalue;
11647 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11649 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11651 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11652 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11653 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11655 /* Clone the regex array */
11656 PL_regex_padav = newAV();
11658 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11659 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11660 av_push(PL_regex_padav,
11661 sv_dup_inc(regexen[0],param));
11662 for(i = 1; i <= len; i++) {
11663 if(SvREPADTMP(regexen[i])) {
11664 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11666 av_push(PL_regex_padav,
11668 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11669 SvIVX(regexen[i])), param)))
11674 PL_regex_pad = AvARRAY(PL_regex_padav);
11676 /* shortcuts to various I/O objects */
11677 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11678 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11679 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11680 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11681 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11682 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11684 /* shortcuts to regexp stuff */
11685 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11687 /* shortcuts to misc objects */
11688 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11690 /* shortcuts to debugging objects */
11691 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11692 PL_DBline = gv_dup(proto_perl->IDBline, param);
11693 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11694 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11695 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11696 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11697 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11698 PL_lineary = av_dup(proto_perl->Ilineary, param);
11699 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11701 /* symbol tables */
11702 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11703 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11704 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11705 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11706 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11708 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11709 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11710 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11711 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11712 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11713 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11715 PL_sub_generation = proto_perl->Isub_generation;
11717 /* funky return mechanisms */
11718 PL_forkprocess = proto_perl->Iforkprocess;
11720 /* subprocess state */
11721 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11723 /* internal state */
11724 PL_tainting = proto_perl->Itainting;
11725 PL_taint_warn = proto_perl->Itaint_warn;
11726 PL_maxo = proto_perl->Imaxo;
11727 if (proto_perl->Iop_mask)
11728 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11730 PL_op_mask = Nullch;
11731 /* PL_asserting = proto_perl->Iasserting; */
11733 /* current interpreter roots */
11734 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11735 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11736 PL_main_start = proto_perl->Imain_start;
11737 PL_eval_root = proto_perl->Ieval_root;
11738 PL_eval_start = proto_perl->Ieval_start;
11740 /* runtime control stuff */
11741 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11742 PL_copline = proto_perl->Icopline;
11744 PL_filemode = proto_perl->Ifilemode;
11745 PL_lastfd = proto_perl->Ilastfd;
11746 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11749 PL_gensym = proto_perl->Igensym;
11750 PL_preambled = proto_perl->Ipreambled;
11751 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11752 PL_laststatval = proto_perl->Ilaststatval;
11753 PL_laststype = proto_perl->Ilaststype;
11754 PL_mess_sv = Nullsv;
11756 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11757 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11759 /* interpreter atexit processing */
11760 PL_exitlistlen = proto_perl->Iexitlistlen;
11761 if (PL_exitlistlen) {
11762 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11763 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11766 PL_exitlist = (PerlExitListEntry*)NULL;
11767 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11768 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11769 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11771 PL_profiledata = NULL;
11772 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11773 /* PL_rsfp_filters entries have fake IoDIRP() */
11774 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11776 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11778 PAD_CLONE_VARS(proto_perl, param);
11780 #ifdef HAVE_INTERP_INTERN
11781 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11784 /* more statics moved here */
11785 PL_generation = proto_perl->Igeneration;
11786 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11788 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11789 PL_in_clean_all = proto_perl->Iin_clean_all;
11791 PL_uid = proto_perl->Iuid;
11792 PL_euid = proto_perl->Ieuid;
11793 PL_gid = proto_perl->Igid;
11794 PL_egid = proto_perl->Iegid;
11795 PL_nomemok = proto_perl->Inomemok;
11796 PL_an = proto_perl->Ian;
11797 PL_evalseq = proto_perl->Ievalseq;
11798 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11799 PL_origalen = proto_perl->Iorigalen;
11800 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11801 PL_osname = SAVEPV(proto_perl->Iosname);
11802 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11803 PL_sighandlerp = proto_perl->Isighandlerp;
11806 PL_runops = proto_perl->Irunops;
11808 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11811 PL_cshlen = proto_perl->Icshlen;
11812 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11815 PL_lex_state = proto_perl->Ilex_state;
11816 PL_lex_defer = proto_perl->Ilex_defer;
11817 PL_lex_expect = proto_perl->Ilex_expect;
11818 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11819 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11820 PL_lex_starts = proto_perl->Ilex_starts;
11821 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11822 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11823 PL_lex_op = proto_perl->Ilex_op;
11824 PL_lex_inpat = proto_perl->Ilex_inpat;
11825 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11826 PL_lex_brackets = proto_perl->Ilex_brackets;
11827 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11828 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11829 PL_lex_casemods = proto_perl->Ilex_casemods;
11830 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11831 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11833 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11834 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11835 PL_nexttoke = proto_perl->Inexttoke;
11837 /* XXX This is probably masking the deeper issue of why
11838 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11839 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11840 * (A little debugging with a watchpoint on it may help.)
11842 if (SvANY(proto_perl->Ilinestr)) {
11843 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11844 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11845 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11846 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11847 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11848 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11849 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11850 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11851 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11854 PL_linestr = NEWSV(65,79);
11855 sv_upgrade(PL_linestr,SVt_PVIV);
11856 sv_setpvn(PL_linestr,"",0);
11857 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11859 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11860 PL_pending_ident = proto_perl->Ipending_ident;
11861 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11863 PL_expect = proto_perl->Iexpect;
11865 PL_multi_start = proto_perl->Imulti_start;
11866 PL_multi_end = proto_perl->Imulti_end;
11867 PL_multi_open = proto_perl->Imulti_open;
11868 PL_multi_close = proto_perl->Imulti_close;
11870 PL_error_count = proto_perl->Ierror_count;
11871 PL_subline = proto_perl->Isubline;
11872 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11874 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11875 if (SvANY(proto_perl->Ilinestr)) {
11876 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11877 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11878 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11879 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11880 PL_last_lop_op = proto_perl->Ilast_lop_op;
11883 PL_last_uni = SvPVX(PL_linestr);
11884 PL_last_lop = SvPVX(PL_linestr);
11885 PL_last_lop_op = 0;
11887 PL_in_my = proto_perl->Iin_my;
11888 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11890 PL_cryptseen = proto_perl->Icryptseen;
11893 PL_hints = proto_perl->Ihints;
11895 PL_amagic_generation = proto_perl->Iamagic_generation;
11897 #ifdef USE_LOCALE_COLLATE
11898 PL_collation_ix = proto_perl->Icollation_ix;
11899 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11900 PL_collation_standard = proto_perl->Icollation_standard;
11901 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11902 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11903 #endif /* USE_LOCALE_COLLATE */
11905 #ifdef USE_LOCALE_NUMERIC
11906 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11907 PL_numeric_standard = proto_perl->Inumeric_standard;
11908 PL_numeric_local = proto_perl->Inumeric_local;
11909 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11910 #endif /* !USE_LOCALE_NUMERIC */
11912 /* utf8 character classes */
11913 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11914 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11915 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11916 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11917 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11918 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11919 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11920 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11921 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11922 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11923 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11924 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11925 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11926 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11927 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11928 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11929 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11930 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11931 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11932 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11934 /* Did the locale setup indicate UTF-8? */
11935 PL_utf8locale = proto_perl->Iutf8locale;
11936 /* Unicode features (see perlrun/-C) */
11937 PL_unicode = proto_perl->Iunicode;
11939 /* Pre-5.8 signals control */
11940 PL_signals = proto_perl->Isignals;
11942 /* times() ticks per second */
11943 PL_clocktick = proto_perl->Iclocktick;
11945 /* Recursion stopper for PerlIO_find_layer */
11946 PL_in_load_module = proto_perl->Iin_load_module;
11948 /* sort() routine */
11949 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11951 /* Not really needed/useful since the reenrant_retint is "volatile",
11952 * but do it for consistency's sake. */
11953 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11955 /* Hooks to shared SVs and locks. */
11956 PL_sharehook = proto_perl->Isharehook;
11957 PL_lockhook = proto_perl->Ilockhook;
11958 PL_unlockhook = proto_perl->Iunlockhook;
11959 PL_threadhook = proto_perl->Ithreadhook;
11961 PL_runops_std = proto_perl->Irunops_std;
11962 PL_runops_dbg = proto_perl->Irunops_dbg;
11964 #ifdef THREADS_HAVE_PIDS
11965 PL_ppid = proto_perl->Ippid;
11969 PL_last_swash_hv = Nullhv; /* reinits on demand */
11970 PL_last_swash_klen = 0;
11971 PL_last_swash_key[0]= '\0';
11972 PL_last_swash_tmps = (U8*)NULL;
11973 PL_last_swash_slen = 0;
11975 PL_glob_index = proto_perl->Iglob_index;
11976 PL_srand_called = proto_perl->Isrand_called;
11977 PL_hash_seed = proto_perl->Ihash_seed;
11978 PL_rehash_seed = proto_perl->Irehash_seed;
11979 PL_uudmap['M'] = 0; /* reinits on demand */
11980 PL_bitcount = Nullch; /* reinits on demand */
11982 if (proto_perl->Ipsig_pend) {
11983 Newz(0, PL_psig_pend, SIG_SIZE, int);
11986 PL_psig_pend = (int*)NULL;
11989 if (proto_perl->Ipsig_ptr) {
11990 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
11991 Newz(0, PL_psig_name, SIG_SIZE, SV*);
11992 for (i = 1; i < SIG_SIZE; i++) {
11993 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11994 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11998 PL_psig_ptr = (SV**)NULL;
11999 PL_psig_name = (SV**)NULL;
12002 /* thrdvar.h stuff */
12004 if (flags & CLONEf_COPY_STACKS) {
12005 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12006 PL_tmps_ix = proto_perl->Ttmps_ix;
12007 PL_tmps_max = proto_perl->Ttmps_max;
12008 PL_tmps_floor = proto_perl->Ttmps_floor;
12009 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12011 while (i <= PL_tmps_ix) {
12012 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12016 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12017 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12018 Newz(54, PL_markstack, i, I32);
12019 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12020 - proto_perl->Tmarkstack);
12021 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12022 - proto_perl->Tmarkstack);
12023 Copy(proto_perl->Tmarkstack, PL_markstack,
12024 PL_markstack_ptr - PL_markstack + 1, I32);
12026 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12027 * NOTE: unlike the others! */
12028 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12029 PL_scopestack_max = proto_perl->Tscopestack_max;
12030 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12031 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12033 /* next push_return() sets PL_retstack[PL_retstack_ix]
12034 * NOTE: unlike the others! */
12035 PL_retstack_ix = proto_perl->Tretstack_ix;
12036 PL_retstack_max = proto_perl->Tretstack_max;
12037 Newz(54, PL_retstack, PL_retstack_max, OP*);
12038 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
12040 /* NOTE: si_dup() looks at PL_markstack */
12041 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12043 /* PL_curstack = PL_curstackinfo->si_stack; */
12044 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12045 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12047 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12048 PL_stack_base = AvARRAY(PL_curstack);
12049 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12050 - proto_perl->Tstack_base);
12051 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12053 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12054 * NOTE: unlike the others! */
12055 PL_savestack_ix = proto_perl->Tsavestack_ix;
12056 PL_savestack_max = proto_perl->Tsavestack_max;
12057 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12058 PL_savestack = ss_dup(proto_perl, param);
12062 ENTER; /* perl_destruct() wants to LEAVE; */
12065 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12066 PL_top_env = &PL_start_env;
12068 PL_op = proto_perl->Top;
12071 PL_Xpv = (XPV*)NULL;
12072 PL_na = proto_perl->Tna;
12074 PL_statbuf = proto_perl->Tstatbuf;
12075 PL_statcache = proto_perl->Tstatcache;
12076 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12077 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12079 PL_timesbuf = proto_perl->Ttimesbuf;
12082 PL_tainted = proto_perl->Ttainted;
12083 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12084 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12085 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12086 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12087 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12088 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12089 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12090 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12091 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12093 PL_restartop = proto_perl->Trestartop;
12094 PL_in_eval = proto_perl->Tin_eval;
12095 PL_delaymagic = proto_perl->Tdelaymagic;
12096 PL_dirty = proto_perl->Tdirty;
12097 PL_localizing = proto_perl->Tlocalizing;
12099 #ifdef PERL_FLEXIBLE_EXCEPTIONS
12100 PL_protect = proto_perl->Tprotect;
12102 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12103 PL_hv_fetch_ent_mh = Nullhe;
12104 PL_modcount = proto_perl->Tmodcount;
12105 PL_lastgotoprobe = Nullop;
12106 PL_dumpindent = proto_perl->Tdumpindent;
12108 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12109 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12110 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12111 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12112 PL_sortcxix = proto_perl->Tsortcxix;
12113 PL_efloatbuf = Nullch; /* reinits on demand */
12114 PL_efloatsize = 0; /* reinits on demand */
12118 PL_screamfirst = NULL;
12119 PL_screamnext = NULL;
12120 PL_maxscream = -1; /* reinits on demand */
12121 PL_lastscream = Nullsv;
12123 PL_watchaddr = NULL;
12124 PL_watchok = Nullch;
12126 PL_regdummy = proto_perl->Tregdummy;
12127 PL_regprecomp = Nullch;
12130 PL_colorset = 0; /* reinits PL_colors[] */
12131 /*PL_colors[6] = {0,0,0,0,0,0};*/
12132 PL_reginput = Nullch;
12133 PL_regbol = Nullch;
12134 PL_regeol = Nullch;
12135 PL_regstartp = (I32*)NULL;
12136 PL_regendp = (I32*)NULL;
12137 PL_reglastparen = (U32*)NULL;
12138 PL_reglastcloseparen = (U32*)NULL;
12139 PL_regtill = Nullch;
12140 PL_reg_start_tmp = (char**)NULL;
12141 PL_reg_start_tmpl = 0;
12142 PL_regdata = (struct reg_data*)NULL;
12145 PL_reg_eval_set = 0;
12147 PL_regprogram = (regnode*)NULL;
12149 PL_regcc = (CURCUR*)NULL;
12150 PL_reg_call_cc = (struct re_cc_state*)NULL;
12151 PL_reg_re = (regexp*)NULL;
12152 PL_reg_ganch = Nullch;
12153 PL_reg_sv = Nullsv;
12154 PL_reg_match_utf8 = FALSE;
12155 PL_reg_magic = (MAGIC*)NULL;
12157 PL_reg_oldcurpm = (PMOP*)NULL;
12158 PL_reg_curpm = (PMOP*)NULL;
12159 PL_reg_oldsaved = Nullch;
12160 PL_reg_oldsavedlen = 0;
12161 #ifdef PERL_COPY_ON_WRITE
12164 PL_reg_maxiter = 0;
12165 PL_reg_leftiter = 0;
12166 PL_reg_poscache = Nullch;
12167 PL_reg_poscache_size= 0;
12169 /* RE engine - function pointers */
12170 PL_regcompp = proto_perl->Tregcompp;
12171 PL_regexecp = proto_perl->Tregexecp;
12172 PL_regint_start = proto_perl->Tregint_start;
12173 PL_regint_string = proto_perl->Tregint_string;
12174 PL_regfree = proto_perl->Tregfree;
12176 PL_reginterp_cnt = 0;
12177 PL_reg_starttry = 0;
12179 /* Pluggable optimizer */
12180 PL_peepp = proto_perl->Tpeepp;
12182 PL_stashcache = newHV();
12184 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12185 ptr_table_free(PL_ptr_table);
12186 PL_ptr_table = NULL;
12189 /* Call the ->CLONE method, if it exists, for each of the stashes
12190 identified by sv_dup() above.
12192 while(av_len(param->stashes) != -1) {
12193 HV* stash = (HV*) av_shift(param->stashes);
12194 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12195 if (cloner && GvCV(cloner)) {
12200 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12202 call_sv((SV*)GvCV(cloner), G_DISCARD);
12208 SvREFCNT_dec(param->stashes);
12213 #endif /* USE_ITHREADS */
12216 =head1 Unicode Support
12218 =for apidoc sv_recode_to_utf8
12220 The encoding is assumed to be an Encode object, on entry the PV
12221 of the sv is assumed to be octets in that encoding, and the sv
12222 will be converted into Unicode (and UTF-8).
12224 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12225 is not a reference, nothing is done to the sv. If the encoding is not
12226 an C<Encode::XS> Encoding object, bad things will happen.
12227 (See F<lib/encoding.pm> and L<Encode>).
12229 The PV of the sv is returned.
12234 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12236 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12250 Passing sv_yes is wrong - it needs to be or'ed set of constants
12251 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12252 remove converted chars from source.
12254 Both will default the value - let them.
12256 XPUSHs(&PL_sv_yes);
12259 call_method("decode", G_SCALAR);
12263 s = SvPV(uni, len);
12264 if (s != SvPVX(sv)) {
12265 SvGROW(sv, len + 1);
12266 Move(s, SvPVX(sv), len, char);
12267 SvCUR_set(sv, len);
12268 SvPVX(sv)[len] = 0;
12278 =for apidoc sv_cat_decode
12280 The encoding is assumed to be an Encode object, the PV of the ssv is
12281 assumed to be octets in that encoding and decoding the input starts
12282 from the position which (PV + *offset) pointed to. The dsv will be
12283 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12284 when the string tstr appears in decoding output or the input ends on
12285 the PV of the ssv. The value which the offset points will be modified
12286 to the last input position on the ssv.
12288 Returns TRUE if the terminator was found, else returns FALSE.
12293 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12294 SV *ssv, int *offset, char *tstr, int tlen)
12297 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12308 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12309 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12311 call_method("cat_decode", G_SCALAR);
12313 ret = SvTRUE(TOPs);
12314 *offset = SvIV(offsv);
12320 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");