3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
168 #ifdef DEBUG_LEAKING_SCALARS
170 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
172 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
175 # define FREE_SV_DEBUG_FILE(sv)
178 #define plant_SV(p) \
180 FREE_SV_DEBUG_FILE(p); \
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
187 /* sv_mutex must be held while calling uproot_SV() */
188 #define uproot_SV(p) \
191 PL_sv_root = (SV*)SvANY(p); \
196 /* new_SV(): return a new, empty SV head */
198 #ifdef DEBUG_LEAKING_SCALARS
199 /* provide a real function for a debugger to play with */
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
227 # define new_SV(p) (p)=S_new_SV(aTHX)
245 /* del_SV(): return an empty SV head to the free list */
260 S_del_sv(pTHX_ SV *p)
267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
269 svend = &sva[SvREFCNT(sva)];
270 if (p >= sv && p < svend)
274 if (ckWARN_d(WARN_INTERNAL))
275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
284 #else /* ! DEBUGGING */
286 #define del_SV(p) plant_SV(p)
288 #endif /* DEBUGGING */
292 =head1 SV Manipulation Functions
294 =for apidoc sv_add_arena
296 Given a chunk of memory, link it to the head of the list of arenas,
297 and split it into a list of free SVs.
303 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
309 /* The first SV in an arena isn't an SV. */
310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
317 svend = &sva[SvREFCNT(sva) - 1];
320 SvANY(sv) = (void *)(SV*)(sv + 1);
322 SvFLAGS(sv) = SVTYPEMASK;
326 SvFLAGS(sv) = SVTYPEMASK;
329 /* make some more SVs by adding another arena */
331 /* sv_mutex must be held while calling more_sv() */
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
340 PL_nice_chunk_size = 0;
343 char *chunk; /* must use New here to match call to */
344 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
345 sv_add_arena(chunk, 1008, 0);
351 /* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
355 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 svend = &sva[SvREFCNT(sva)];
364 for (sv = sva + 1; sv < svend; ++sv) {
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
379 /* called by sv_report_used() for each live SV */
382 do_report_used(pTHX_ SV *sv)
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
392 =for apidoc sv_report_used
394 Dump the contents of all SVs not yet freed. (Debugging aid).
400 Perl_sv_report_used(pTHX)
403 visit(do_report_used, 0, 0);
407 /* called by sv_clean_objs() for each live SV */
410 do_clean_objs(pTHX_ SV *sv)
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
427 /* XXX Might want to check arrays, etc. */
430 /* called by sv_clean_objs() for each live SV */
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
434 do_clean_named_objs(pTHX_ SV *sv)
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
444 SvFLAGS(sv) |= SVf_BREAK;
452 =for apidoc sv_clean_objs
454 Attempt to destroy all objects not yet freed
460 Perl_sv_clean_objs(pTHX)
462 PL_in_clean_objs = TRUE;
463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
464 #ifndef DISABLE_DESTRUCTOR_KLUDGE
465 /* some barnacles may yet remain, clinging to typeglobs */
466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
468 PL_in_clean_objs = FALSE;
471 /* called by sv_clean_all() for each live SV */
474 do_clean_all(pTHX_ SV *sv)
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
478 if (PL_comppad == (AV*)sv) {
480 PL_curpad = Null(SV**);
486 =for apidoc sv_clean_all
488 Decrement the refcnt of each remaining SV, possibly triggering a
489 cleanup. This function may have to be called multiple times to free
490 SVs which are in complex self-referential hierarchies.
496 Perl_sv_clean_all(pTHX)
499 PL_in_clean_all = TRUE;
500 cleaned = visit(do_clean_all, 0,0);
501 PL_in_clean_all = FALSE;
506 =for apidoc sv_free_arenas
508 Deallocate the memory used by all arenas. Note that all the individual SV
509 heads and bodies within the arenas must already have been freed.
515 Perl_sv_free_arenas(pTHX)
519 XPV *arena, *arenanext;
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
530 Safefree((void *)sva);
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xiv_arenaroot = 0;
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xrv_arenaroot = 0;
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xpv_arenaroot = 0;
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpviv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpvnv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvcv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvav_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvhv_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvmg_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvbm_arenaroot = 0;
617 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
625 Safefree(PL_nice_chunk);
626 PL_nice_chunk = Nullch;
627 PL_nice_chunk_size = 0;
632 /* ---------------------------------------------------------------------
634 * support functions for report_uninit()
637 /* the maxiumum size of array or hash where we will scan looking
638 * for the undefined element that triggered the warning */
640 #define FUV_MAX_SEARCH_SIZE 1000
642 /* Look for an entry in the hash whose value has the same SV as val;
643 * If so, return a mortal copy of the key. */
646 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
653 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
654 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
659 for (i=HvMAX(hv); i>0; i--) {
660 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
661 if (HeVAL(entry) != val)
663 if ( HeVAL(entry) == &PL_sv_undef ||
664 HeVAL(entry) == &PL_sv_placeholder)
668 if (HeKLEN(entry) == HEf_SVKEY)
669 return sv_mortalcopy(HeKEY_sv(entry));
670 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
676 /* Look for an entry in the array whose value has the same SV as val;
677 * If so, return the index, otherwise return -1. */
680 S_find_array_subscript(pTHX_ AV *av, SV* val)
684 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
685 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
689 for (i=AvFILLp(av); i>=0; i--) {
690 if (svp[i] == val && svp[i] != &PL_sv_undef)
696 /* S_varname(): return the name of a variable, optionally with a subscript.
697 * If gv is non-zero, use the name of that global, along with gvtype (one
698 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
699 * targ. Depending on the value of the subscript_type flag, return:
702 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
703 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
704 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
705 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
708 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
709 SV* keyname, I32 aindex, int subscript_type)
715 name = sv_newmortal();
718 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
719 * XXX get rid of all this if gv_fullnameX() ever supports this
723 HV *hv = GvSTASH(gv);
724 sv_setpv(name, gvtype);
727 else if (!(p=HvNAME(hv)))
729 if (strNE(p, "main")) {
731 sv_catpvn(name,"::", 2);
733 if (GvNAMELEN(gv)>= 1 &&
734 ((unsigned int)*GvNAME(gv)) <= 26)
736 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
737 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
740 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
744 CV *cv = find_runcv(&u);
745 if (!cv || !CvPADLIST(cv))
747 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
748 sv = *av_fetch(av, targ, FALSE);
749 /* SvLEN in a pad name is not to be trusted */
750 sv_setpv(name, SvPV_nolen(sv));
753 if (subscript_type == FUV_SUBSCRIPT_HASH) {
756 Perl_sv_catpvf(aTHX_ name, "{%s}",
757 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
760 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
762 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
764 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
765 sv_insert(name, 0, 0, "within ", 7);
772 =for apidoc find_uninit_var
774 Find the name of the undefined variable (if any) that caused the operator o
775 to issue a "Use of uninitialized value" warning.
776 If match is true, only return a name if it's value matches uninit_sv.
777 So roughly speaking, if a unary operator (such as OP_COS) generates a
778 warning, then following the direct child of the op may yield an
779 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
780 other hand, with OP_ADD there are two branches to follow, so we only print
781 the variable name if we get an exact match.
783 The name is returned as a mortal SV.
785 Assumes that PL_op is the op that originally triggered the error, and that
786 PL_comppad/PL_curpad points to the currently executing pad.
792 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
801 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
802 uninit_sv == &PL_sv_placeholder)))
805 switch (obase->op_type) {
812 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
813 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
816 int subscript_type = FUV_SUBSCRIPT_WITHIN;
818 if (pad) { /* @lex, %lex */
819 sv = PAD_SVl(obase->op_targ);
823 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
824 /* @global, %global */
825 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
828 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
830 else /* @{expr}, %{expr} */
831 return find_uninit_var(cUNOPx(obase)->op_first,
835 /* attempt to find a match within the aggregate */
837 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
839 subscript_type = FUV_SUBSCRIPT_HASH;
842 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
844 subscript_type = FUV_SUBSCRIPT_ARRAY;
847 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
850 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
851 keysv, index, subscript_type);
855 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
857 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
858 Nullsv, 0, FUV_SUBSCRIPT_NONE);
861 gv = cGVOPx_gv(obase);
862 if (!gv || (match && GvSV(gv) != uninit_sv))
864 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
867 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
869 av = (AV*)PAD_SV(obase->op_targ);
870 if (!av || SvRMAGICAL(av))
872 svp = av_fetch(av, (I32)obase->op_private, FALSE);
873 if (!svp || *svp != uninit_sv)
876 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
877 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
880 gv = cGVOPx_gv(obase);
885 if (!av || SvRMAGICAL(av))
887 svp = av_fetch(av, (I32)obase->op_private, FALSE);
888 if (!svp || *svp != uninit_sv)
891 return S_varname(aTHX_ gv, "$", 0,
892 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
897 o = cUNOPx(obase)->op_first;
898 if (!o || o->op_type != OP_NULL ||
899 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
901 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
906 /* $a[uninit_expr] or $h{uninit_expr} */
907 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
910 o = cBINOPx(obase)->op_first;
911 kid = cBINOPx(obase)->op_last;
913 /* get the av or hv, and optionally the gv */
915 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
916 sv = PAD_SV(o->op_targ);
918 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
919 && cUNOPo->op_first->op_type == OP_GV)
921 gv = cGVOPx_gv(cUNOPo->op_first);
924 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
929 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
930 /* index is constant */
934 if (obase->op_type == OP_HELEM) {
935 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
936 if (!he || HeVAL(he) != uninit_sv)
940 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
941 if (!svp || *svp != uninit_sv)
945 if (obase->op_type == OP_HELEM)
946 return S_varname(aTHX_ gv, "%", o->op_targ,
947 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
949 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
950 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
954 /* index is an expression;
955 * attempt to find a match within the aggregate */
956 if (obase->op_type == OP_HELEM) {
957 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
959 return S_varname(aTHX_ gv, "%", o->op_targ,
960 keysv, 0, FUV_SUBSCRIPT_HASH);
963 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
965 return S_varname(aTHX_ gv, "@", o->op_targ,
966 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
970 return S_varname(aTHX_ gv,
971 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
973 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
979 /* only examine RHS */
980 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
983 o = cUNOPx(obase)->op_first;
984 if (o->op_type == OP_PUSHMARK)
987 if (!o->op_sibling) {
988 /* one-arg version of open is highly magical */
990 if (o->op_type == OP_GV) { /* open FOO; */
992 if (match && GvSV(gv) != uninit_sv)
994 return S_varname(aTHX_ gv, "$", 0,
995 Nullsv, 0, FUV_SUBSCRIPT_NONE);
997 /* other possibilities not handled are:
998 * open $x; or open my $x; should return '${*$x}'
999 * open expr; should return '$'.expr ideally
1005 /* ops where $_ may be an implicit arg */
1009 if ( !(obase->op_flags & OPf_STACKED)) {
1010 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1011 ? PAD_SVl(obase->op_targ)
1014 sv = sv_newmortal();
1023 /* skip filehandle as it can't produce 'undef' warning */
1024 o = cUNOPx(obase)->op_first;
1025 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1026 o = o->op_sibling->op_sibling;
1033 match = 1; /* XS or custom code could trigger random warnings */
1038 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1039 return sv_2mortal(newSVpv("${$/}", 0));
1044 if (!(obase->op_flags & OPf_KIDS))
1046 o = cUNOPx(obase)->op_first;
1052 /* if all except one arg are constant, or have no side-effects,
1053 * or are optimized away, then it's unambiguous */
1055 for (kid=o; kid; kid = kid->op_sibling) {
1057 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1058 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1059 || (kid->op_type == OP_PUSHMARK)
1063 if (o2) { /* more than one found */
1070 return find_uninit_var(o2, uninit_sv, match);
1074 sv = find_uninit_var(o, uninit_sv, 1);
1086 =for apidoc report_uninit
1088 Print appropriate "Use of uninitialized variable" warning
1094 Perl_report_uninit(pTHX_ SV* uninit_sv)
1097 SV* varname = Nullsv;
1099 varname = find_uninit_var(PL_op, uninit_sv,0);
1101 sv_insert(varname, 0, 0, " ", 1);
1103 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1104 varname ? SvPV_nolen(varname) : "",
1105 " in ", OP_DESC(PL_op));
1108 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1112 /* grab a new IV body from the free list, allocating more if necessary */
1123 * See comment in more_xiv() -- RAM.
1125 PL_xiv_root = *(IV**)xiv;
1127 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1130 /* return an IV body to the free list */
1133 S_del_xiv(pTHX_ XPVIV *p)
1135 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1137 *(IV**)xiv = PL_xiv_root;
1142 /* allocate another arena's worth of IV bodies */
1148 register IV* xivend;
1150 New(705, ptr, 1008/sizeof(XPV), XPV);
1151 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1152 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1155 xivend = &xiv[1008 / sizeof(IV) - 1];
1156 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1158 while (xiv < xivend) {
1159 *(IV**)xiv = (IV *)(xiv + 1);
1165 /* grab a new NV body from the free list, allocating more if necessary */
1175 PL_xnv_root = *(NV**)xnv;
1177 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1180 /* return an NV body to the free list */
1183 S_del_xnv(pTHX_ XPVNV *p)
1185 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1187 *(NV**)xnv = PL_xnv_root;
1192 /* allocate another arena's worth of NV bodies */
1198 register NV* xnvend;
1200 New(711, ptr, 1008/sizeof(XPV), XPV);
1201 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1202 PL_xnv_arenaroot = ptr;
1205 xnvend = &xnv[1008 / sizeof(NV) - 1];
1206 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1208 while (xnv < xnvend) {
1209 *(NV**)xnv = (NV*)(xnv + 1);
1215 /* grab a new struct xrv from the free list, allocating more if necessary */
1225 PL_xrv_root = (XRV*)xrv->xrv_rv;
1230 /* return a struct xrv to the free list */
1233 S_del_xrv(pTHX_ XRV *p)
1236 p->xrv_rv = (SV*)PL_xrv_root;
1241 /* allocate another arena's worth of struct xrv */
1247 register XRV* xrvend;
1249 New(712, ptr, 1008/sizeof(XPV), XPV);
1250 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1251 PL_xrv_arenaroot = ptr;
1254 xrvend = &xrv[1008 / sizeof(XRV) - 1];
1255 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1257 while (xrv < xrvend) {
1258 xrv->xrv_rv = (SV*)(xrv + 1);
1264 /* grab a new struct xpv from the free list, allocating more if necessary */
1274 PL_xpv_root = (XPV*)xpv->xpv_pv;
1279 /* return a struct xpv to the free list */
1282 S_del_xpv(pTHX_ XPV *p)
1285 p->xpv_pv = (char*)PL_xpv_root;
1290 /* allocate another arena's worth of struct xpv */
1296 register XPV* xpvend;
1297 New(713, xpv, 1008/sizeof(XPV), XPV);
1298 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1299 PL_xpv_arenaroot = xpv;
1301 xpvend = &xpv[1008 / sizeof(XPV) - 1];
1302 PL_xpv_root = ++xpv;
1303 while (xpv < xpvend) {
1304 xpv->xpv_pv = (char*)(xpv + 1);
1310 /* grab a new struct xpviv from the free list, allocating more if necessary */
1319 xpviv = PL_xpviv_root;
1320 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1325 /* return a struct xpviv to the free list */
1328 S_del_xpviv(pTHX_ XPVIV *p)
1331 p->xpv_pv = (char*)PL_xpviv_root;
1336 /* allocate another arena's worth of struct xpviv */
1341 register XPVIV* xpviv;
1342 register XPVIV* xpvivend;
1343 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
1344 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1345 PL_xpviv_arenaroot = xpviv;
1347 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
1348 PL_xpviv_root = ++xpviv;
1349 while (xpviv < xpvivend) {
1350 xpviv->xpv_pv = (char*)(xpviv + 1);
1356 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1365 xpvnv = PL_xpvnv_root;
1366 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1371 /* return a struct xpvnv to the free list */
1374 S_del_xpvnv(pTHX_ XPVNV *p)
1377 p->xpv_pv = (char*)PL_xpvnv_root;
1382 /* allocate another arena's worth of struct xpvnv */
1387 register XPVNV* xpvnv;
1388 register XPVNV* xpvnvend;
1389 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
1390 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1391 PL_xpvnv_arenaroot = xpvnv;
1393 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
1394 PL_xpvnv_root = ++xpvnv;
1395 while (xpvnv < xpvnvend) {
1396 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1402 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1411 xpvcv = PL_xpvcv_root;
1412 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1417 /* return a struct xpvcv to the free list */
1420 S_del_xpvcv(pTHX_ XPVCV *p)
1423 p->xpv_pv = (char*)PL_xpvcv_root;
1428 /* allocate another arena's worth of struct xpvcv */
1433 register XPVCV* xpvcv;
1434 register XPVCV* xpvcvend;
1435 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
1436 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1437 PL_xpvcv_arenaroot = xpvcv;
1439 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
1440 PL_xpvcv_root = ++xpvcv;
1441 while (xpvcv < xpvcvend) {
1442 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1448 /* grab a new struct xpvav from the free list, allocating more if necessary */
1457 xpvav = PL_xpvav_root;
1458 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1463 /* return a struct xpvav to the free list */
1466 S_del_xpvav(pTHX_ XPVAV *p)
1469 p->xav_array = (char*)PL_xpvav_root;
1474 /* allocate another arena's worth of struct xpvav */
1479 register XPVAV* xpvav;
1480 register XPVAV* xpvavend;
1481 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
1482 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1483 PL_xpvav_arenaroot = xpvav;
1485 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
1486 PL_xpvav_root = ++xpvav;
1487 while (xpvav < xpvavend) {
1488 xpvav->xav_array = (char*)(xpvav + 1);
1491 xpvav->xav_array = 0;
1494 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1503 xpvhv = PL_xpvhv_root;
1504 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1509 /* return a struct xpvhv to the free list */
1512 S_del_xpvhv(pTHX_ XPVHV *p)
1515 p->xhv_array = (char*)PL_xpvhv_root;
1520 /* allocate another arena's worth of struct xpvhv */
1525 register XPVHV* xpvhv;
1526 register XPVHV* xpvhvend;
1527 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1528 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1529 PL_xpvhv_arenaroot = xpvhv;
1531 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1532 PL_xpvhv_root = ++xpvhv;
1533 while (xpvhv < xpvhvend) {
1534 xpvhv->xhv_array = (char*)(xpvhv + 1);
1537 xpvhv->xhv_array = 0;
1540 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1549 xpvmg = PL_xpvmg_root;
1550 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1555 /* return a struct xpvmg to the free list */
1558 S_del_xpvmg(pTHX_ XPVMG *p)
1561 p->xpv_pv = (char*)PL_xpvmg_root;
1566 /* allocate another arena's worth of struct xpvmg */
1571 register XPVMG* xpvmg;
1572 register XPVMG* xpvmgend;
1573 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1574 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1575 PL_xpvmg_arenaroot = xpvmg;
1577 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1578 PL_xpvmg_root = ++xpvmg;
1579 while (xpvmg < xpvmgend) {
1580 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1586 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1595 xpvlv = PL_xpvlv_root;
1596 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1601 /* return a struct xpvlv to the free list */
1604 S_del_xpvlv(pTHX_ XPVLV *p)
1607 p->xpv_pv = (char*)PL_xpvlv_root;
1612 /* allocate another arena's worth of struct xpvlv */
1617 register XPVLV* xpvlv;
1618 register XPVLV* xpvlvend;
1619 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1620 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1621 PL_xpvlv_arenaroot = xpvlv;
1623 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1624 PL_xpvlv_root = ++xpvlv;
1625 while (xpvlv < xpvlvend) {
1626 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1632 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1641 xpvbm = PL_xpvbm_root;
1642 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1647 /* return a struct xpvbm to the free list */
1650 S_del_xpvbm(pTHX_ XPVBM *p)
1653 p->xpv_pv = (char*)PL_xpvbm_root;
1658 /* allocate another arena's worth of struct xpvbm */
1663 register XPVBM* xpvbm;
1664 register XPVBM* xpvbmend;
1665 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1666 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1667 PL_xpvbm_arenaroot = xpvbm;
1669 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1670 PL_xpvbm_root = ++xpvbm;
1671 while (xpvbm < xpvbmend) {
1672 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1678 #define my_safemalloc(s) (void*)safemalloc(s)
1679 #define my_safefree(p) safefree((char*)p)
1683 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1684 #define del_XIV(p) my_safefree(p)
1686 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1687 #define del_XNV(p) my_safefree(p)
1689 #define new_XRV() my_safemalloc(sizeof(XRV))
1690 #define del_XRV(p) my_safefree(p)
1692 #define new_XPV() my_safemalloc(sizeof(XPV))
1693 #define del_XPV(p) my_safefree(p)
1695 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1696 #define del_XPVIV(p) my_safefree(p)
1698 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1699 #define del_XPVNV(p) my_safefree(p)
1701 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1702 #define del_XPVCV(p) my_safefree(p)
1704 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1705 #define del_XPVAV(p) my_safefree(p)
1707 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1708 #define del_XPVHV(p) my_safefree(p)
1710 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1711 #define del_XPVMG(p) my_safefree(p)
1713 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1714 #define del_XPVLV(p) my_safefree(p)
1716 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1717 #define del_XPVBM(p) my_safefree(p)
1721 #define new_XIV() (void*)new_xiv()
1722 #define del_XIV(p) del_xiv((XPVIV*) p)
1724 #define new_XNV() (void*)new_xnv()
1725 #define del_XNV(p) del_xnv((XPVNV*) p)
1727 #define new_XRV() (void*)new_xrv()
1728 #define del_XRV(p) del_xrv((XRV*) p)
1730 #define new_XPV() (void*)new_xpv()
1731 #define del_XPV(p) del_xpv((XPV *)p)
1733 #define new_XPVIV() (void*)new_xpviv()
1734 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1736 #define new_XPVNV() (void*)new_xpvnv()
1737 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1739 #define new_XPVCV() (void*)new_xpvcv()
1740 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1742 #define new_XPVAV() (void*)new_xpvav()
1743 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1745 #define new_XPVHV() (void*)new_xpvhv()
1746 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1748 #define new_XPVMG() (void*)new_xpvmg()
1749 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1751 #define new_XPVLV() (void*)new_xpvlv()
1752 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1754 #define new_XPVBM() (void*)new_xpvbm()
1755 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1759 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1760 #define del_XPVGV(p) my_safefree(p)
1762 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1763 #define del_XPVFM(p) my_safefree(p)
1765 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1766 #define del_XPVIO(p) my_safefree(p)
1769 =for apidoc sv_upgrade
1771 Upgrade an SV to a more complex form. Generally adds a new body type to the
1772 SV, then copies across as much information as possible from the old body.
1773 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1779 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1790 if (mt != SVt_PV && SvIsCOW(sv)) {
1791 sv_force_normal_flags(sv, 0);
1794 if (SvTYPE(sv) == mt)
1798 (void)SvOOK_off(sv);
1808 switch (SvTYPE(sv)) {
1816 else if (mt < SVt_PVIV)
1826 pv = (char*)SvRV(sv);
1836 else if (mt == SVt_NV)
1844 del_XPVIV(SvANY(sv));
1852 del_XPVNV(SvANY(sv));
1860 magic = SvMAGIC(sv);
1861 stash = SvSTASH(sv);
1862 del_XPVMG(SvANY(sv));
1865 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1868 SvFLAGS(sv) &= ~SVTYPEMASK;
1873 Perl_croak(aTHX_ "Can't upgrade to undef");
1875 SvANY(sv) = new_XIV();
1879 SvANY(sv) = new_XNV();
1883 SvANY(sv) = new_XRV();
1884 SvRV_set(sv, (SV*)pv);
1887 SvANY(sv) = new_XPVHV();
1894 HvTOTALKEYS(sv) = 0;
1895 HvPLACEHOLDERS(sv) = 0;
1897 /* Fall through... */
1900 SvANY(sv) = new_XPVAV();
1905 AvFLAGS(sv) = AVf_REAL;
1912 SvPV_set(sv, (char*)0);
1913 SvMAGIC_set(sv, magic);
1914 SvSTASH_set(sv, stash);
1918 SvANY(sv) = new_XPVIO();
1919 Zero(SvANY(sv), 1, XPVIO);
1920 IoPAGE_LEN(sv) = 60;
1921 goto set_magic_common;
1923 SvANY(sv) = new_XPVFM();
1924 Zero(SvANY(sv), 1, XPVFM);
1925 goto set_magic_common;
1927 SvANY(sv) = new_XPVBM();
1931 goto set_magic_common;
1933 SvANY(sv) = new_XPVGV();
1939 goto set_magic_common;
1941 SvANY(sv) = new_XPVCV();
1942 Zero(SvANY(sv), 1, XPVCV);
1943 goto set_magic_common;
1945 SvANY(sv) = new_XPVLV();
1958 SvANY(sv) = new_XPVMG();
1961 SvMAGIC_set(sv, magic);
1962 SvSTASH_set(sv, stash);
1966 SvANY(sv) = new_XPVNV();
1972 SvANY(sv) = new_XPVIV();
1981 SvANY(sv) = new_XPV();
1992 =for apidoc sv_backoff
1994 Remove any string offset. You should normally use the C<SvOOK_off> macro
2001 Perl_sv_backoff(pTHX_ register SV *sv)
2005 char *s = SvPVX(sv);
2006 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2007 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2009 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2011 SvFLAGS(sv) &= ~SVf_OOK;
2018 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2019 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2020 Use the C<SvGROW> wrapper instead.
2026 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2030 #ifdef HAS_64K_LIMIT
2031 if (newlen >= 0x10000) {
2032 PerlIO_printf(Perl_debug_log,
2033 "Allocation too large: %"UVxf"\n", (UV)newlen);
2036 #endif /* HAS_64K_LIMIT */
2039 if (SvTYPE(sv) < SVt_PV) {
2040 sv_upgrade(sv, SVt_PV);
2043 else if (SvOOK(sv)) { /* pv is offset? */
2046 if (newlen > SvLEN(sv))
2047 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2048 #ifdef HAS_64K_LIMIT
2049 if (newlen >= 0x10000)
2056 if (newlen > SvLEN(sv)) { /* need more room? */
2057 if (SvLEN(sv) && s) {
2059 STRLEN l = malloced_size((void*)SvPVX(sv));
2065 Renew(s,newlen,char);
2068 New(703, s, newlen, char);
2069 if (SvPVX(sv) && SvCUR(sv)) {
2070 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2074 SvLEN_set(sv, newlen);
2080 =for apidoc sv_setiv
2082 Copies an integer into the given SV, upgrading first if necessary.
2083 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2089 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2091 SV_CHECK_THINKFIRST_COW_DROP(sv);
2092 switch (SvTYPE(sv)) {
2094 sv_upgrade(sv, SVt_IV);
2097 sv_upgrade(sv, SVt_PVNV);
2101 sv_upgrade(sv, SVt_PVIV);
2110 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2113 (void)SvIOK_only(sv); /* validate number */
2119 =for apidoc sv_setiv_mg
2121 Like C<sv_setiv>, but also handles 'set' magic.
2127 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2134 =for apidoc sv_setuv
2136 Copies an unsigned integer into the given SV, upgrading first if necessary.
2137 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2143 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2145 /* With these two if statements:
2146 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2149 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2151 If you wish to remove them, please benchmark to see what the effect is
2153 if (u <= (UV)IV_MAX) {
2154 sv_setiv(sv, (IV)u);
2163 =for apidoc sv_setuv_mg
2165 Like C<sv_setuv>, but also handles 'set' magic.
2171 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2173 /* With these two if statements:
2174 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2177 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2179 If you wish to remove them, please benchmark to see what the effect is
2181 if (u <= (UV)IV_MAX) {
2182 sv_setiv(sv, (IV)u);
2192 =for apidoc sv_setnv
2194 Copies a double into the given SV, upgrading first if necessary.
2195 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2201 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2203 SV_CHECK_THINKFIRST_COW_DROP(sv);
2204 switch (SvTYPE(sv)) {
2207 sv_upgrade(sv, SVt_NV);
2212 sv_upgrade(sv, SVt_PVNV);
2221 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2225 (void)SvNOK_only(sv); /* validate number */
2230 =for apidoc sv_setnv_mg
2232 Like C<sv_setnv>, but also handles 'set' magic.
2238 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2244 /* Print an "isn't numeric" warning, using a cleaned-up,
2245 * printable version of the offending string
2249 S_not_a_number(pTHX_ SV *sv)
2256 dsv = sv_2mortal(newSVpv("", 0));
2257 pv = sv_uni_display(dsv, sv, 10, 0);
2260 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2261 /* each *s can expand to 4 chars + "...\0",
2262 i.e. need room for 8 chars */
2265 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2267 if (ch & 128 && !isPRINT_LC(ch)) {
2276 else if (ch == '\r') {
2280 else if (ch == '\f') {
2284 else if (ch == '\\') {
2288 else if (ch == '\0') {
2292 else if (isPRINT_LC(ch))
2309 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2310 "Argument \"%s\" isn't numeric in %s", pv,
2313 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2314 "Argument \"%s\" isn't numeric", pv);
2318 =for apidoc looks_like_number
2320 Test if the content of an SV looks like a number (or is a number).
2321 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2322 non-numeric warning), even if your atof() doesn't grok them.
2328 Perl_looks_like_number(pTHX_ SV *sv)
2330 register char *sbegin;
2337 else if (SvPOKp(sv))
2338 sbegin = SvPV(sv, len);
2340 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2341 return grok_number(sbegin, len, NULL);
2344 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2345 until proven guilty, assume that things are not that bad... */
2350 As 64 bit platforms often have an NV that doesn't preserve all bits of
2351 an IV (an assumption perl has been based on to date) it becomes necessary
2352 to remove the assumption that the NV always carries enough precision to
2353 recreate the IV whenever needed, and that the NV is the canonical form.
2354 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2355 precision as a side effect of conversion (which would lead to insanity
2356 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2357 1) to distinguish between IV/UV/NV slots that have cached a valid
2358 conversion where precision was lost and IV/UV/NV slots that have a
2359 valid conversion which has lost no precision
2360 2) to ensure that if a numeric conversion to one form is requested that
2361 would lose precision, the precise conversion (or differently
2362 imprecise conversion) is also performed and cached, to prevent
2363 requests for different numeric formats on the same SV causing
2364 lossy conversion chains. (lossless conversion chains are perfectly
2369 SvIOKp is true if the IV slot contains a valid value
2370 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2371 SvNOKp is true if the NV slot contains a valid value
2372 SvNOK is true only if the NV value is accurate
2375 while converting from PV to NV, check to see if converting that NV to an
2376 IV(or UV) would lose accuracy over a direct conversion from PV to
2377 IV(or UV). If it would, cache both conversions, return NV, but mark
2378 SV as IOK NOKp (ie not NOK).
2380 While converting from PV to IV, check to see if converting that IV to an
2381 NV would lose accuracy over a direct conversion from PV to NV. If it
2382 would, cache both conversions, flag similarly.
2384 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2385 correctly because if IV & NV were set NV *always* overruled.
2386 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2387 changes - now IV and NV together means that the two are interchangeable:
2388 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2390 The benefit of this is that operations such as pp_add know that if
2391 SvIOK is true for both left and right operands, then integer addition
2392 can be used instead of floating point (for cases where the result won't
2393 overflow). Before, floating point was always used, which could lead to
2394 loss of precision compared with integer addition.
2396 * making IV and NV equal status should make maths accurate on 64 bit
2398 * may speed up maths somewhat if pp_add and friends start to use
2399 integers when possible instead of fp. (Hopefully the overhead in
2400 looking for SvIOK and checking for overflow will not outweigh the
2401 fp to integer speedup)
2402 * will slow down integer operations (callers of SvIV) on "inaccurate"
2403 values, as the change from SvIOK to SvIOKp will cause a call into
2404 sv_2iv each time rather than a macro access direct to the IV slot
2405 * should speed up number->string conversion on integers as IV is
2406 favoured when IV and NV are equally accurate
2408 ####################################################################
2409 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2410 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2411 On the other hand, SvUOK is true iff UV.
2412 ####################################################################
2414 Your mileage will vary depending your CPU's relative fp to integer
2418 #ifndef NV_PRESERVES_UV
2419 # define IS_NUMBER_UNDERFLOW_IV 1
2420 # define IS_NUMBER_UNDERFLOW_UV 2
2421 # define IS_NUMBER_IV_AND_UV 2
2422 # define IS_NUMBER_OVERFLOW_IV 4
2423 # define IS_NUMBER_OVERFLOW_UV 5
2425 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2427 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2429 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2431 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));
2432 if (SvNVX(sv) < (NV)IV_MIN) {
2433 (void)SvIOKp_on(sv);
2435 SvIV_set(sv, IV_MIN);
2436 return IS_NUMBER_UNDERFLOW_IV;
2438 if (SvNVX(sv) > (NV)UV_MAX) {
2439 (void)SvIOKp_on(sv);
2442 SvUV_set(sv, UV_MAX);
2443 return IS_NUMBER_OVERFLOW_UV;
2445 (void)SvIOKp_on(sv);
2447 /* Can't use strtol etc to convert this string. (See truth table in
2449 if (SvNVX(sv) <= (UV)IV_MAX) {
2450 SvIV_set(sv, I_V(SvNVX(sv)));
2451 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2452 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2454 /* Integer is imprecise. NOK, IOKp */
2456 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2459 SvUV_set(sv, U_V(SvNVX(sv)));
2460 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2461 if (SvUVX(sv) == UV_MAX) {
2462 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2463 possibly be preserved by NV. Hence, it must be overflow.
2465 return IS_NUMBER_OVERFLOW_UV;
2467 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2469 /* Integer is imprecise. NOK, IOKp */
2471 return IS_NUMBER_OVERFLOW_IV;
2473 #endif /* !NV_PRESERVES_UV*/
2475 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2476 * this function provided for binary compatibility only
2480 Perl_sv_2iv(pTHX_ register SV *sv)
2482 return sv_2iv_flags(sv, SV_GMAGIC);
2486 =for apidoc sv_2iv_flags
2488 Return the integer value of an SV, doing any necessary string
2489 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2490 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2496 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2500 if (SvGMAGICAL(sv)) {
2501 if (flags & SV_GMAGIC)
2506 return I_V(SvNVX(sv));
2508 if (SvPOKp(sv) && SvLEN(sv))
2511 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2512 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2518 if (SvTHINKFIRST(sv)) {
2521 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2522 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2523 return SvIV(tmpstr);
2524 return PTR2IV(SvRV(sv));
2527 sv_force_normal_flags(sv, 0);
2529 if (SvREADONLY(sv) && !SvOK(sv)) {
2530 if (ckWARN(WARN_UNINITIALIZED))
2537 return (IV)(SvUVX(sv));
2544 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2545 * without also getting a cached IV/UV from it at the same time
2546 * (ie PV->NV conversion should detect loss of accuracy and cache
2547 * IV or UV at same time to avoid this. NWC */
2549 if (SvTYPE(sv) == SVt_NV)
2550 sv_upgrade(sv, SVt_PVNV);
2552 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2553 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2554 certainly cast into the IV range at IV_MAX, whereas the correct
2555 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2557 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2558 SvIV_set(sv, I_V(SvNVX(sv)));
2559 if (SvNVX(sv) == (NV) SvIVX(sv)
2560 #ifndef NV_PRESERVES_UV
2561 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2562 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2563 /* Don't flag it as "accurately an integer" if the number
2564 came from a (by definition imprecise) NV operation, and
2565 we're outside the range of NV integer precision */
2568 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2569 DEBUG_c(PerlIO_printf(Perl_debug_log,
2570 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2576 /* IV not precise. No need to convert from PV, as NV
2577 conversion would already have cached IV if it detected
2578 that PV->IV would be better than PV->NV->IV
2579 flags already correct - don't set public IOK. */
2580 DEBUG_c(PerlIO_printf(Perl_debug_log,
2581 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2586 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2587 but the cast (NV)IV_MIN rounds to a the value less (more
2588 negative) than IV_MIN which happens to be equal to SvNVX ??
2589 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2590 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2591 (NV)UVX == NVX are both true, but the values differ. :-(
2592 Hopefully for 2s complement IV_MIN is something like
2593 0x8000000000000000 which will be exact. NWC */
2596 SvUV_set(sv, U_V(SvNVX(sv)));
2598 (SvNVX(sv) == (NV) SvUVX(sv))
2599 #ifndef NV_PRESERVES_UV
2600 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2601 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2602 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2603 /* Don't flag it as "accurately an integer" if the number
2604 came from a (by definition imprecise) NV operation, and
2605 we're outside the range of NV integer precision */
2611 DEBUG_c(PerlIO_printf(Perl_debug_log,
2612 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2616 return (IV)SvUVX(sv);
2619 else if (SvPOKp(sv) && SvLEN(sv)) {
2621 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2622 /* We want to avoid a possible problem when we cache an IV which
2623 may be later translated to an NV, and the resulting NV is not
2624 the same as the direct translation of the initial string
2625 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2626 be careful to ensure that the value with the .456 is around if the
2627 NV value is requested in the future).
2629 This means that if we cache such an IV, we need to cache the
2630 NV as well. Moreover, we trade speed for space, and do not
2631 cache the NV if we are sure it's not needed.
2634 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2635 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2636 == IS_NUMBER_IN_UV) {
2637 /* It's definitely an integer, only upgrade to PVIV */
2638 if (SvTYPE(sv) < SVt_PVIV)
2639 sv_upgrade(sv, SVt_PVIV);
2641 } else if (SvTYPE(sv) < SVt_PVNV)
2642 sv_upgrade(sv, SVt_PVNV);
2644 /* If NV preserves UV then we only use the UV value if we know that
2645 we aren't going to call atof() below. If NVs don't preserve UVs
2646 then the value returned may have more precision than atof() will
2647 return, even though value isn't perfectly accurate. */
2648 if ((numtype & (IS_NUMBER_IN_UV
2649 #ifdef NV_PRESERVES_UV
2652 )) == IS_NUMBER_IN_UV) {
2653 /* This won't turn off the public IOK flag if it was set above */
2654 (void)SvIOKp_on(sv);
2656 if (!(numtype & IS_NUMBER_NEG)) {
2658 if (value <= (UV)IV_MAX) {
2659 SvIV_set(sv, (IV)value);
2661 SvUV_set(sv, value);
2665 /* 2s complement assumption */
2666 if (value <= (UV)IV_MIN) {
2667 SvIV_set(sv, -(IV)value);
2669 /* Too negative for an IV. This is a double upgrade, but
2670 I'm assuming it will be rare. */
2671 if (SvTYPE(sv) < SVt_PVNV)
2672 sv_upgrade(sv, SVt_PVNV);
2676 SvNV_set(sv, -(NV)value);
2677 SvIV_set(sv, IV_MIN);
2681 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2682 will be in the previous block to set the IV slot, and the next
2683 block to set the NV slot. So no else here. */
2685 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2686 != IS_NUMBER_IN_UV) {
2687 /* It wasn't an (integer that doesn't overflow the UV). */
2688 SvNV_set(sv, Atof(SvPVX(sv)));
2690 if (! numtype && ckWARN(WARN_NUMERIC))
2693 #if defined(USE_LONG_DOUBLE)
2694 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2695 PTR2UV(sv), SvNVX(sv)));
2697 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2698 PTR2UV(sv), SvNVX(sv)));
2702 #ifdef NV_PRESERVES_UV
2703 (void)SvIOKp_on(sv);
2705 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2706 SvIV_set(sv, I_V(SvNVX(sv)));
2707 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2710 /* Integer is imprecise. NOK, IOKp */
2712 /* UV will not work better than IV */
2714 if (SvNVX(sv) > (NV)UV_MAX) {
2716 /* Integer is inaccurate. NOK, IOKp, is UV */
2717 SvUV_set(sv, UV_MAX);
2720 SvUV_set(sv, U_V(SvNVX(sv)));
2721 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2722 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2726 /* Integer is imprecise. NOK, IOKp, is UV */
2732 #else /* NV_PRESERVES_UV */
2733 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2734 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2735 /* The IV slot will have been set from value returned by
2736 grok_number above. The NV slot has just been set using
2739 assert (SvIOKp(sv));
2741 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2742 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2743 /* Small enough to preserve all bits. */
2744 (void)SvIOKp_on(sv);
2746 SvIV_set(sv, I_V(SvNVX(sv)));
2747 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2749 /* Assumption: first non-preserved integer is < IV_MAX,
2750 this NV is in the preserved range, therefore: */
2751 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2753 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);
2757 0 0 already failed to read UV.
2758 0 1 already failed to read UV.
2759 1 0 you won't get here in this case. IV/UV
2760 slot set, public IOK, Atof() unneeded.
2761 1 1 already read UV.
2762 so there's no point in sv_2iuv_non_preserve() attempting
2763 to use atol, strtol, strtoul etc. */
2764 if (sv_2iuv_non_preserve (sv, numtype)
2765 >= IS_NUMBER_OVERFLOW_IV)
2769 #endif /* NV_PRESERVES_UV */
2772 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2774 if (SvTYPE(sv) < SVt_IV)
2775 /* Typically the caller expects that sv_any is not NULL now. */
2776 sv_upgrade(sv, SVt_IV);
2779 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2780 PTR2UV(sv),SvIVX(sv)));
2781 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2784 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2785 * this function provided for binary compatibility only
2789 Perl_sv_2uv(pTHX_ register SV *sv)
2791 return sv_2uv_flags(sv, SV_GMAGIC);
2795 =for apidoc sv_2uv_flags
2797 Return the unsigned integer value of an SV, doing any necessary string
2798 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2799 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2805 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2809 if (SvGMAGICAL(sv)) {
2810 if (flags & SV_GMAGIC)
2815 return U_V(SvNVX(sv));
2816 if (SvPOKp(sv) && SvLEN(sv))
2819 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2820 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2826 if (SvTHINKFIRST(sv)) {
2829 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2830 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2831 return SvUV(tmpstr);
2832 return PTR2UV(SvRV(sv));
2835 sv_force_normal_flags(sv, 0);
2837 if (SvREADONLY(sv) && !SvOK(sv)) {
2838 if (ckWARN(WARN_UNINITIALIZED))
2848 return (UV)SvIVX(sv);
2852 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2853 * without also getting a cached IV/UV from it at the same time
2854 * (ie PV->NV conversion should detect loss of accuracy and cache
2855 * IV or UV at same time to avoid this. */
2856 /* IV-over-UV optimisation - choose to cache IV if possible */
2858 if (SvTYPE(sv) == SVt_NV)
2859 sv_upgrade(sv, SVt_PVNV);
2861 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2862 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2863 SvIV_set(sv, I_V(SvNVX(sv)));
2864 if (SvNVX(sv) == (NV) SvIVX(sv)
2865 #ifndef NV_PRESERVES_UV
2866 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2867 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2868 /* Don't flag it as "accurately an integer" if the number
2869 came from a (by definition imprecise) NV operation, and
2870 we're outside the range of NV integer precision */
2873 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2874 DEBUG_c(PerlIO_printf(Perl_debug_log,
2875 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2881 /* IV not precise. No need to convert from PV, as NV
2882 conversion would already have cached IV if it detected
2883 that PV->IV would be better than PV->NV->IV
2884 flags already correct - don't set public IOK. */
2885 DEBUG_c(PerlIO_printf(Perl_debug_log,
2886 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2891 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2892 but the cast (NV)IV_MIN rounds to a the value less (more
2893 negative) than IV_MIN which happens to be equal to SvNVX ??
2894 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2895 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2896 (NV)UVX == NVX are both true, but the values differ. :-(
2897 Hopefully for 2s complement IV_MIN is something like
2898 0x8000000000000000 which will be exact. NWC */
2901 SvUV_set(sv, U_V(SvNVX(sv)));
2903 (SvNVX(sv) == (NV) SvUVX(sv))
2904 #ifndef NV_PRESERVES_UV
2905 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2906 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2907 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2908 /* Don't flag it as "accurately an integer" if the number
2909 came from a (by definition imprecise) NV operation, and
2910 we're outside the range of NV integer precision */
2915 DEBUG_c(PerlIO_printf(Perl_debug_log,
2916 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2922 else if (SvPOKp(sv) && SvLEN(sv)) {
2924 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2926 /* We want to avoid a possible problem when we cache a UV which
2927 may be later translated to an NV, and the resulting NV is not
2928 the translation of the initial data.
2930 This means that if we cache such a UV, we need to cache the
2931 NV as well. Moreover, we trade speed for space, and do not
2932 cache the NV if not needed.
2935 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2936 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2937 == IS_NUMBER_IN_UV) {
2938 /* It's definitely an integer, only upgrade to PVIV */
2939 if (SvTYPE(sv) < SVt_PVIV)
2940 sv_upgrade(sv, SVt_PVIV);
2942 } else if (SvTYPE(sv) < SVt_PVNV)
2943 sv_upgrade(sv, SVt_PVNV);
2945 /* If NV preserves UV then we only use the UV value if we know that
2946 we aren't going to call atof() below. If NVs don't preserve UVs
2947 then the value returned may have more precision than atof() will
2948 return, even though it isn't accurate. */
2949 if ((numtype & (IS_NUMBER_IN_UV
2950 #ifdef NV_PRESERVES_UV
2953 )) == IS_NUMBER_IN_UV) {
2954 /* This won't turn off the public IOK flag if it was set above */
2955 (void)SvIOKp_on(sv);
2957 if (!(numtype & IS_NUMBER_NEG)) {
2959 if (value <= (UV)IV_MAX) {
2960 SvIV_set(sv, (IV)value);
2962 /* it didn't overflow, and it was positive. */
2963 SvUV_set(sv, value);
2967 /* 2s complement assumption */
2968 if (value <= (UV)IV_MIN) {
2969 SvIV_set(sv, -(IV)value);
2971 /* Too negative for an IV. This is a double upgrade, but
2972 I'm assuming it will be rare. */
2973 if (SvTYPE(sv) < SVt_PVNV)
2974 sv_upgrade(sv, SVt_PVNV);
2978 SvNV_set(sv, -(NV)value);
2979 SvIV_set(sv, IV_MIN);
2984 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2985 != IS_NUMBER_IN_UV) {
2986 /* It wasn't an integer, or it overflowed the UV. */
2987 SvNV_set(sv, Atof(SvPVX(sv)));
2989 if (! numtype && ckWARN(WARN_NUMERIC))
2992 #if defined(USE_LONG_DOUBLE)
2993 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2994 PTR2UV(sv), SvNVX(sv)));
2996 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2997 PTR2UV(sv), SvNVX(sv)));
3000 #ifdef NV_PRESERVES_UV
3001 (void)SvIOKp_on(sv);
3003 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3004 SvIV_set(sv, I_V(SvNVX(sv)));
3005 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3008 /* Integer is imprecise. NOK, IOKp */
3010 /* UV will not work better than IV */
3012 if (SvNVX(sv) > (NV)UV_MAX) {
3014 /* Integer is inaccurate. NOK, IOKp, is UV */
3015 SvUV_set(sv, UV_MAX);
3018 SvUV_set(sv, U_V(SvNVX(sv)));
3019 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3020 NV preservse UV so can do correct comparison. */
3021 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3025 /* Integer is imprecise. NOK, IOKp, is UV */
3030 #else /* NV_PRESERVES_UV */
3031 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3032 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3033 /* The UV slot will have been set from value returned by
3034 grok_number above. The NV slot has just been set using
3037 assert (SvIOKp(sv));
3039 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3040 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3041 /* Small enough to preserve all bits. */
3042 (void)SvIOKp_on(sv);
3044 SvIV_set(sv, I_V(SvNVX(sv)));
3045 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3047 /* Assumption: first non-preserved integer is < IV_MAX,
3048 this NV is in the preserved range, therefore: */
3049 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3051 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);
3054 sv_2iuv_non_preserve (sv, numtype);
3056 #endif /* NV_PRESERVES_UV */
3060 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3061 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3064 if (SvTYPE(sv) < SVt_IV)
3065 /* Typically the caller expects that sv_any is not NULL now. */
3066 sv_upgrade(sv, SVt_IV);
3070 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3071 PTR2UV(sv),SvUVX(sv)));
3072 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3078 Return the num value of an SV, doing any necessary string or integer
3079 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3086 Perl_sv_2nv(pTHX_ register SV *sv)
3090 if (SvGMAGICAL(sv)) {
3094 if (SvPOKp(sv) && SvLEN(sv)) {
3095 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3096 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3098 return Atof(SvPVX(sv));
3102 return (NV)SvUVX(sv);
3104 return (NV)SvIVX(sv);
3107 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3108 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3114 if (SvTHINKFIRST(sv)) {
3117 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3118 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3119 return SvNV(tmpstr);
3120 return PTR2NV(SvRV(sv));
3123 sv_force_normal_flags(sv, 0);
3125 if (SvREADONLY(sv) && !SvOK(sv)) {
3126 if (ckWARN(WARN_UNINITIALIZED))
3131 if (SvTYPE(sv) < SVt_NV) {
3132 if (SvTYPE(sv) == SVt_IV)
3133 sv_upgrade(sv, SVt_PVNV);
3135 sv_upgrade(sv, SVt_NV);
3136 #ifdef USE_LONG_DOUBLE
3138 STORE_NUMERIC_LOCAL_SET_STANDARD();
3139 PerlIO_printf(Perl_debug_log,
3140 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3141 PTR2UV(sv), SvNVX(sv));
3142 RESTORE_NUMERIC_LOCAL();
3146 STORE_NUMERIC_LOCAL_SET_STANDARD();
3147 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3148 PTR2UV(sv), SvNVX(sv));
3149 RESTORE_NUMERIC_LOCAL();
3153 else if (SvTYPE(sv) < SVt_PVNV)
3154 sv_upgrade(sv, SVt_PVNV);
3159 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3160 #ifdef NV_PRESERVES_UV
3163 /* Only set the public NV OK flag if this NV preserves the IV */
3164 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3165 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3166 : (SvIVX(sv) == I_V(SvNVX(sv))))
3172 else if (SvPOKp(sv) && SvLEN(sv)) {
3174 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3175 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3177 #ifdef NV_PRESERVES_UV
3178 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3179 == IS_NUMBER_IN_UV) {
3180 /* It's definitely an integer */
3181 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3183 SvNV_set(sv, Atof(SvPVX(sv)));
3186 SvNV_set(sv, Atof(SvPVX(sv)));
3187 /* Only set the public NV OK flag if this NV preserves the value in
3188 the PV at least as well as an IV/UV would.
3189 Not sure how to do this 100% reliably. */
3190 /* if that shift count is out of range then Configure's test is
3191 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3193 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3194 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3195 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3196 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3197 /* Can't use strtol etc to convert this string, so don't try.
3198 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3201 /* value has been set. It may not be precise. */
3202 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3203 /* 2s complement assumption for (UV)IV_MIN */
3204 SvNOK_on(sv); /* Integer is too negative. */
3209 if (numtype & IS_NUMBER_NEG) {
3210 SvIV_set(sv, -(IV)value);
3211 } else if (value <= (UV)IV_MAX) {
3212 SvIV_set(sv, (IV)value);
3214 SvUV_set(sv, value);
3218 if (numtype & IS_NUMBER_NOT_INT) {
3219 /* I believe that even if the original PV had decimals,
3220 they are lost beyond the limit of the FP precision.
3221 However, neither is canonical, so both only get p
3222 flags. NWC, 2000/11/25 */
3223 /* Both already have p flags, so do nothing */
3226 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3227 if (SvIVX(sv) == I_V(nv)) {
3232 /* It had no "." so it must be integer. */
3235 /* between IV_MAX and NV(UV_MAX).
3236 Could be slightly > UV_MAX */
3238 if (numtype & IS_NUMBER_NOT_INT) {
3239 /* UV and NV both imprecise. */
3241 UV nv_as_uv = U_V(nv);
3243 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3254 #endif /* NV_PRESERVES_UV */
3257 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3259 if (SvTYPE(sv) < SVt_NV)
3260 /* Typically the caller expects that sv_any is not NULL now. */
3261 /* XXX Ilya implies that this is a bug in callers that assume this
3262 and ideally should be fixed. */
3263 sv_upgrade(sv, SVt_NV);
3266 #if defined(USE_LONG_DOUBLE)
3268 STORE_NUMERIC_LOCAL_SET_STANDARD();
3269 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3270 PTR2UV(sv), SvNVX(sv));
3271 RESTORE_NUMERIC_LOCAL();
3275 STORE_NUMERIC_LOCAL_SET_STANDARD();
3276 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3277 PTR2UV(sv), SvNVX(sv));
3278 RESTORE_NUMERIC_LOCAL();
3284 /* asIV(): extract an integer from the string value of an SV.
3285 * Caller must validate PVX */
3288 S_asIV(pTHX_ SV *sv)
3291 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3293 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3294 == IS_NUMBER_IN_UV) {
3295 /* It's definitely an integer */
3296 if (numtype & IS_NUMBER_NEG) {
3297 if (value < (UV)IV_MIN)
3300 if (value < (UV)IV_MAX)
3305 if (ckWARN(WARN_NUMERIC))
3308 return I_V(Atof(SvPVX(sv)));
3311 /* asUV(): extract an unsigned integer from the string value of an SV
3312 * Caller must validate PVX */
3315 S_asUV(pTHX_ SV *sv)
3318 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3320 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3321 == IS_NUMBER_IN_UV) {
3322 /* It's definitely an integer */
3323 if (!(numtype & IS_NUMBER_NEG))
3327 if (ckWARN(WARN_NUMERIC))
3330 return U_V(Atof(SvPVX(sv)));
3334 =for apidoc sv_2pv_nolen
3336 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3337 use the macro wrapper C<SvPV_nolen(sv)> instead.
3342 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3345 return sv_2pv(sv, &n_a);
3348 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3349 * UV as a string towards the end of buf, and return pointers to start and
3352 * We assume that buf is at least TYPE_CHARS(UV) long.
3356 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3358 char *ptr = buf + TYPE_CHARS(UV);
3372 *--ptr = '0' + (char)(uv % 10);
3380 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3381 * this function provided for binary compatibility only
3385 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3387 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3391 =for apidoc sv_2pv_flags
3393 Returns a pointer to the string value of an SV, and sets *lp to its length.
3394 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3396 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3397 usually end up here too.
3403 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3408 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3409 char *tmpbuf = tbuf;
3415 if (SvGMAGICAL(sv)) {
3416 if (flags & SV_GMAGIC)
3424 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3426 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3431 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3436 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3437 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3444 if (SvTHINKFIRST(sv)) {
3447 register const char *typestr;
3448 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3449 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3450 char *pv = SvPV(tmpstr, *lp);
3460 typestr = "NULLREF";
3464 switch (SvTYPE(sv)) {
3466 if ( ((SvFLAGS(sv) &
3467 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3468 == (SVs_OBJECT|SVs_SMG))
3469 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3470 const regexp *re = (regexp *)mg->mg_obj;
3473 const char *fptr = "msix";
3478 char need_newline = 0;
3479 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3481 while((ch = *fptr++)) {
3483 reflags[left++] = ch;
3486 reflags[right--] = ch;
3491 reflags[left] = '-';
3495 mg->mg_len = re->prelen + 4 + left;
3497 * If /x was used, we have to worry about a regex
3498 * ending with a comment later being embedded
3499 * within another regex. If so, we don't want this
3500 * regex's "commentization" to leak out to the
3501 * right part of the enclosing regex, we must cap
3502 * it with a newline.
3504 * So, if /x was used, we scan backwards from the
3505 * end of the regex. If we find a '#' before we
3506 * find a newline, we need to add a newline
3507 * ourself. If we find a '\n' first (or if we
3508 * don't find '#' or '\n'), we don't need to add
3509 * anything. -jfriedl
3511 if (PMf_EXTENDED & re->reganch)
3513 const char *endptr = re->precomp + re->prelen;
3514 while (endptr >= re->precomp)
3516 const char c = *(endptr--);
3518 break; /* don't need another */
3520 /* we end while in a comment, so we
3522 mg->mg_len++; /* save space for it */
3523 need_newline = 1; /* note to add it */
3529 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3530 Copy("(?", mg->mg_ptr, 2, char);
3531 Copy(reflags, mg->mg_ptr+2, left, char);
3532 Copy(":", mg->mg_ptr+left+2, 1, char);
3533 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3535 mg->mg_ptr[mg->mg_len - 2] = '\n';
3536 mg->mg_ptr[mg->mg_len - 1] = ')';
3537 mg->mg_ptr[mg->mg_len] = 0;
3539 PL_reginterp_cnt += re->program[0].next_off;
3541 if (re->reganch & ROPT_UTF8)
3556 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3557 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3558 /* tied lvalues should appear to be
3559 * scalars for backwards compatitbility */
3560 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3561 ? "SCALAR" : "LVALUE"; break;
3562 case SVt_PVAV: typestr = "ARRAY"; break;
3563 case SVt_PVHV: typestr = "HASH"; break;
3564 case SVt_PVCV: typestr = "CODE"; break;
3565 case SVt_PVGV: typestr = "GLOB"; break;
3566 case SVt_PVFM: typestr = "FORMAT"; break;
3567 case SVt_PVIO: typestr = "IO"; break;
3568 default: typestr = "UNKNOWN"; break;
3572 const char *name = HvNAME(SvSTASH(sv));
3573 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3574 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3577 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3580 *lp = strlen(typestr);
3581 return (char *)typestr;
3583 if (SvREADONLY(sv) && !SvOK(sv)) {
3584 if (ckWARN(WARN_UNINITIALIZED))
3590 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3591 /* I'm assuming that if both IV and NV are equally valid then
3592 converting the IV is going to be more efficient */
3593 const U32 isIOK = SvIOK(sv);
3594 const U32 isUIOK = SvIsUV(sv);
3595 char buf[TYPE_CHARS(UV)];
3598 if (SvTYPE(sv) < SVt_PVIV)
3599 sv_upgrade(sv, SVt_PVIV);
3601 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3603 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3604 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3605 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3606 SvCUR_set(sv, ebuf - ptr);
3616 else if (SvNOKp(sv)) {
3617 if (SvTYPE(sv) < SVt_PVNV)
3618 sv_upgrade(sv, SVt_PVNV);
3619 /* The +20 is pure guesswork. Configure test needed. --jhi */
3620 SvGROW(sv, NV_DIG + 20);
3622 olderrno = errno; /* some Xenix systems wipe out errno here */
3624 if (SvNVX(sv) == 0.0)
3625 (void)strcpy(s,"0");
3629 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3632 #ifdef FIXNEGATIVEZERO
3633 if (*s == '-' && s[1] == '0' && !s[2])
3643 if (ckWARN(WARN_UNINITIALIZED)
3644 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3647 if (SvTYPE(sv) < SVt_PV)
3648 /* Typically the caller expects that sv_any is not NULL now. */
3649 sv_upgrade(sv, SVt_PV);
3652 *lp = s - SvPVX(sv);
3655 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3656 PTR2UV(sv),SvPVX(sv)));
3660 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3661 /* Sneaky stuff here */
3665 tsv = newSVpv(tmpbuf, 0);
3682 len = strlen(tmpbuf);
3684 #ifdef FIXNEGATIVEZERO
3685 if (len == 2 && t[0] == '-' && t[1] == '0') {
3690 (void)SvUPGRADE(sv, SVt_PV);
3692 s = SvGROW(sv, len + 1);
3695 return strcpy(s, t);
3700 =for apidoc sv_copypv
3702 Copies a stringified representation of the source SV into the
3703 destination SV. Automatically performs any necessary mg_get and
3704 coercion of numeric values into strings. Guaranteed to preserve
3705 UTF-8 flag even from overloaded objects. Similar in nature to
3706 sv_2pv[_flags] but operates directly on an SV instead of just the
3707 string. Mostly uses sv_2pv_flags to do its work, except when that
3708 would lose the UTF-8'ness of the PV.
3714 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3719 sv_setpvn(dsv,s,len);
3727 =for apidoc sv_2pvbyte_nolen
3729 Return a pointer to the byte-encoded representation of the SV.
3730 May cause the SV to be downgraded from UTF-8 as a side-effect.
3732 Usually accessed via the C<SvPVbyte_nolen> macro.
3738 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3741 return sv_2pvbyte(sv, &n_a);
3745 =for apidoc sv_2pvbyte
3747 Return a pointer to the byte-encoded representation of the SV, and set *lp
3748 to its length. May cause the SV to be downgraded from UTF-8 as a
3751 Usually accessed via the C<SvPVbyte> macro.
3757 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3759 sv_utf8_downgrade(sv,0);
3760 return SvPV(sv,*lp);
3764 =for apidoc sv_2pvutf8_nolen
3766 Return a pointer to the UTF-8-encoded representation of the SV.
3767 May cause the SV to be upgraded to UTF-8 as a side-effect.
3769 Usually accessed via the C<SvPVutf8_nolen> macro.
3775 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3778 return sv_2pvutf8(sv, &n_a);
3782 =for apidoc sv_2pvutf8
3784 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3785 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3787 Usually accessed via the C<SvPVutf8> macro.
3793 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3795 sv_utf8_upgrade(sv);
3796 return SvPV(sv,*lp);
3800 =for apidoc sv_2bool
3802 This function is only called on magical items, and is only used by
3803 sv_true() or its macro equivalent.
3809 Perl_sv_2bool(pTHX_ register SV *sv)
3818 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3819 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3820 return (bool)SvTRUE(tmpsv);
3821 return SvRV(sv) != 0;
3824 register XPV* Xpvtmp;
3825 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3826 (*Xpvtmp->xpv_pv > '0' ||
3827 Xpvtmp->xpv_cur > 1 ||
3828 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3835 return SvIVX(sv) != 0;
3838 return SvNVX(sv) != 0.0;
3845 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3846 * this function provided for binary compatibility only
3851 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3853 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3857 =for apidoc sv_utf8_upgrade
3859 Converts the PV of an SV to its UTF-8-encoded form.
3860 Forces the SV to string form if it is not already.
3861 Always sets the SvUTF8 flag to avoid future validity checks even
3862 if all the bytes have hibit clear.
3864 This is not as a general purpose byte encoding to Unicode interface:
3865 use the Encode extension for that.
3867 =for apidoc sv_utf8_upgrade_flags
3869 Converts the PV of an SV to its UTF-8-encoded form.
3870 Forces the SV to string form if it is not already.
3871 Always sets the SvUTF8 flag to avoid future validity checks even
3872 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3873 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3874 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3876 This is not as a general purpose byte encoding to Unicode interface:
3877 use the Encode extension for that.
3883 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3888 if (sv == &PL_sv_undef)
3892 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3893 (void) sv_2pv_flags(sv,&len, flags);
3897 (void) SvPV_force(sv,len);
3906 sv_force_normal_flags(sv, 0);
3909 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3910 sv_recode_to_utf8(sv, PL_encoding);
3911 else { /* Assume Latin-1/EBCDIC */
3912 /* This function could be much more efficient if we
3913 * had a FLAG in SVs to signal if there are any hibit
3914 * chars in the PV. Given that there isn't such a flag
3915 * make the loop as fast as possible. */
3916 s = (U8 *) SvPVX(sv);
3917 e = (U8 *) SvEND(sv);
3921 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3926 (void)SvOOK_off(sv);
3928 len = SvCUR(sv) + 1; /* Plus the \0 */
3929 SvPV_set(sv, (char*)bytes_to_utf8((U8*)s, &len));
3930 SvCUR_set(sv, len - 1);
3932 Safefree(s); /* No longer using what was there before. */
3933 SvLEN_set(sv, len); /* No longer know the real size. */
3935 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3942 =for apidoc sv_utf8_downgrade
3944 Attempts to convert the PV of an SV from characters to bytes.
3945 If the PV contains a character beyond byte, this conversion will fail;
3946 in this case, either returns false or, if C<fail_ok> is not
3949 This is not as a general purpose Unicode to byte encoding interface:
3950 use the Encode extension for that.
3956 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3958 if (SvPOKp(sv) && SvUTF8(sv)) {
3964 sv_force_normal_flags(sv, 0);
3966 s = (U8 *) SvPV(sv, len);
3967 if (!utf8_to_bytes(s, &len)) {
3972 Perl_croak(aTHX_ "Wide character in %s",
3975 Perl_croak(aTHX_ "Wide character");
3986 =for apidoc sv_utf8_encode
3988 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3989 flag off so that it looks like octets again.
3995 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3997 (void) sv_utf8_upgrade(sv);
3999 sv_force_normal_flags(sv, 0);
4001 if (SvREADONLY(sv)) {
4002 Perl_croak(aTHX_ PL_no_modify);
4008 =for apidoc sv_utf8_decode
4010 If the PV of the SV is an octet sequence in UTF-8
4011 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4012 so that it looks like a character. If the PV contains only single-byte
4013 characters, the C<SvUTF8> flag stays being off.
4014 Scans PV for validity and returns false if the PV is invalid UTF-8.
4020 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4026 /* The octets may have got themselves encoded - get them back as
4029 if (!sv_utf8_downgrade(sv, TRUE))
4032 /* it is actually just a matter of turning the utf8 flag on, but
4033 * we want to make sure everything inside is valid utf8 first.
4035 c = (U8 *) SvPVX(sv);
4036 if (!is_utf8_string(c, SvCUR(sv)+1))
4038 e = (U8 *) SvEND(sv);
4041 if (!UTF8_IS_INVARIANT(ch)) {
4050 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4051 * this function provided for binary compatibility only
4055 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4057 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4061 =for apidoc sv_setsv
4063 Copies the contents of the source SV C<ssv> into the destination SV
4064 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4065 function if the source SV needs to be reused. Does not handle 'set' magic.
4066 Loosely speaking, it performs a copy-by-value, obliterating any previous
4067 content of the destination.
4069 You probably want to use one of the assortment of wrappers, such as
4070 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4071 C<SvSetMagicSV_nosteal>.
4073 =for apidoc sv_setsv_flags
4075 Copies the contents of the source SV C<ssv> into the destination SV
4076 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4077 function if the source SV needs to be reused. Does not handle 'set' magic.
4078 Loosely speaking, it performs a copy-by-value, obliterating any previous
4079 content of the destination.
4080 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4081 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4082 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4083 and C<sv_setsv_nomg> are implemented in terms of this function.
4085 You probably want to use one of the assortment of wrappers, such as
4086 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4087 C<SvSetMagicSV_nosteal>.
4089 This is the primary function for copying scalars, and most other
4090 copy-ish functions and macros use this underneath.
4096 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4098 register U32 sflags;
4104 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4106 sstr = &PL_sv_undef;
4107 stype = SvTYPE(sstr);
4108 dtype = SvTYPE(dstr);
4113 /* need to nuke the magic */
4115 SvRMAGICAL_off(dstr);
4118 /* There's a lot of redundancy below but we're going for speed here */
4123 if (dtype != SVt_PVGV) {
4124 (void)SvOK_off(dstr);
4132 sv_upgrade(dstr, SVt_IV);
4135 sv_upgrade(dstr, SVt_PVNV);
4139 sv_upgrade(dstr, SVt_PVIV);
4142 (void)SvIOK_only(dstr);
4143 SvIV_set(dstr, SvIVX(sstr));
4146 if (SvTAINTED(sstr))
4157 sv_upgrade(dstr, SVt_NV);
4162 sv_upgrade(dstr, SVt_PVNV);
4165 SvNV_set(dstr, SvNVX(sstr));
4166 (void)SvNOK_only(dstr);
4167 if (SvTAINTED(sstr))
4175 sv_upgrade(dstr, SVt_RV);
4176 else if (dtype == SVt_PVGV &&
4177 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4180 if (GvIMPORTED(dstr) != GVf_IMPORTED
4181 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4183 GvIMPORTED_on(dstr);
4192 #ifdef PERL_COPY_ON_WRITE
4193 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4194 if (dtype < SVt_PVIV)
4195 sv_upgrade(dstr, SVt_PVIV);
4202 sv_upgrade(dstr, SVt_PV);
4205 if (dtype < SVt_PVIV)
4206 sv_upgrade(dstr, SVt_PVIV);
4209 if (dtype < SVt_PVNV)
4210 sv_upgrade(dstr, SVt_PVNV);
4217 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4220 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4224 if (dtype <= SVt_PVGV) {
4226 if (dtype != SVt_PVGV) {
4227 char *name = GvNAME(sstr);
4228 STRLEN len = GvNAMELEN(sstr);
4229 /* don't upgrade SVt_PVLV: it can hold a glob */
4230 if (dtype != SVt_PVLV)
4231 sv_upgrade(dstr, SVt_PVGV);
4232 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4233 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4234 GvNAME(dstr) = savepvn(name, len);
4235 GvNAMELEN(dstr) = len;
4236 SvFAKE_on(dstr); /* can coerce to non-glob */
4238 /* ahem, death to those who redefine active sort subs */
4239 else if (PL_curstackinfo->si_type == PERLSI_SORT
4240 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4241 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4244 #ifdef GV_UNIQUE_CHECK
4245 if (GvUNIQUE((GV*)dstr)) {
4246 Perl_croak(aTHX_ PL_no_modify);
4250 (void)SvOK_off(dstr);
4251 GvINTRO_off(dstr); /* one-shot flag */
4253 GvGP(dstr) = gp_ref(GvGP(sstr));
4254 if (SvTAINTED(sstr))
4256 if (GvIMPORTED(dstr) != GVf_IMPORTED
4257 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4259 GvIMPORTED_on(dstr);
4267 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4269 if ((int)SvTYPE(sstr) != stype) {
4270 stype = SvTYPE(sstr);
4271 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4275 if (stype == SVt_PVLV)
4276 (void)SvUPGRADE(dstr, SVt_PVNV);
4278 (void)SvUPGRADE(dstr, (U32)stype);
4281 sflags = SvFLAGS(sstr);
4283 if (sflags & SVf_ROK) {
4284 if (dtype >= SVt_PV) {
4285 if (dtype == SVt_PVGV) {
4286 SV *sref = SvREFCNT_inc(SvRV(sstr));
4288 int intro = GvINTRO(dstr);
4290 #ifdef GV_UNIQUE_CHECK
4291 if (GvUNIQUE((GV*)dstr)) {
4292 Perl_croak(aTHX_ PL_no_modify);
4297 GvINTRO_off(dstr); /* one-shot flag */
4298 GvLINE(dstr) = CopLINE(PL_curcop);
4299 GvEGV(dstr) = (GV*)dstr;
4302 switch (SvTYPE(sref)) {
4305 SAVEGENERICSV(GvAV(dstr));
4307 dref = (SV*)GvAV(dstr);
4308 GvAV(dstr) = (AV*)sref;
4309 if (!GvIMPORTED_AV(dstr)
4310 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4312 GvIMPORTED_AV_on(dstr);
4317 SAVEGENERICSV(GvHV(dstr));
4319 dref = (SV*)GvHV(dstr);
4320 GvHV(dstr) = (HV*)sref;
4321 if (!GvIMPORTED_HV(dstr)
4322 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4324 GvIMPORTED_HV_on(dstr);
4329 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4330 SvREFCNT_dec(GvCV(dstr));
4331 GvCV(dstr) = Nullcv;
4332 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4333 PL_sub_generation++;
4335 SAVEGENERICSV(GvCV(dstr));
4338 dref = (SV*)GvCV(dstr);
4339 if (GvCV(dstr) != (CV*)sref) {
4340 CV* cv = GvCV(dstr);
4342 if (!GvCVGEN((GV*)dstr) &&
4343 (CvROOT(cv) || CvXSUB(cv)))
4345 /* ahem, death to those who redefine
4346 * active sort subs */
4347 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4348 PL_sortcop == CvSTART(cv))
4350 "Can't redefine active sort subroutine %s",
4351 GvENAME((GV*)dstr));
4352 /* Redefining a sub - warning is mandatory if
4353 it was a const and its value changed. */
4354 if (ckWARN(WARN_REDEFINE)
4356 && (!CvCONST((CV*)sref)
4357 || sv_cmp(cv_const_sv(cv),
4358 cv_const_sv((CV*)sref)))))
4360 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4362 ? "Constant subroutine %s::%s redefined"
4363 : "Subroutine %s::%s redefined",
4364 HvNAME(GvSTASH((GV*)dstr)),
4365 GvENAME((GV*)dstr));
4369 cv_ckproto(cv, (GV*)dstr,
4370 SvPOK(sref) ? SvPVX(sref) : Nullch);
4372 GvCV(dstr) = (CV*)sref;
4373 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4374 GvASSUMECV_on(dstr);
4375 PL_sub_generation++;
4377 if (!GvIMPORTED_CV(dstr)
4378 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4380 GvIMPORTED_CV_on(dstr);
4385 SAVEGENERICSV(GvIOp(dstr));
4387 dref = (SV*)GvIOp(dstr);
4388 GvIOp(dstr) = (IO*)sref;
4392 SAVEGENERICSV(GvFORM(dstr));
4394 dref = (SV*)GvFORM(dstr);
4395 GvFORM(dstr) = (CV*)sref;
4399 SAVEGENERICSV(GvSV(dstr));
4401 dref = (SV*)GvSV(dstr);
4403 if (!GvIMPORTED_SV(dstr)
4404 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4406 GvIMPORTED_SV_on(dstr);
4412 if (SvTAINTED(sstr))
4417 (void)SvOOK_off(dstr); /* backoff */
4419 Safefree(SvPVX(dstr));
4424 (void)SvOK_off(dstr);
4425 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4427 if (sflags & SVp_NOK) {
4429 /* Only set the public OK flag if the source has public OK. */
4430 if (sflags & SVf_NOK)
4431 SvFLAGS(dstr) |= SVf_NOK;
4432 SvNV_set(dstr, SvNVX(sstr));
4434 if (sflags & SVp_IOK) {
4435 (void)SvIOKp_on(dstr);
4436 if (sflags & SVf_IOK)
4437 SvFLAGS(dstr) |= SVf_IOK;
4438 if (sflags & SVf_IVisUV)
4440 SvIV_set(dstr, SvIVX(sstr));
4442 if (SvAMAGIC(sstr)) {
4446 else if (sflags & SVp_POK) {
4450 * Check to see if we can just swipe the string. If so, it's a
4451 * possible small lose on short strings, but a big win on long ones.
4452 * It might even be a win on short strings if SvPVX(dstr)
4453 * has to be allocated and SvPVX(sstr) has to be freed.
4456 /* Whichever path we take through the next code, we want this true,
4457 and doing it now facilitates the COW check. */
4458 (void)SvPOK_only(dstr);
4461 #ifdef PERL_COPY_ON_WRITE
4462 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4466 (sflags & SVs_TEMP) && /* slated for free anyway? */
4467 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4468 (!(flags & SV_NOSTEAL)) &&
4469 /* and we're allowed to steal temps */
4470 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4471 SvLEN(sstr) && /* and really is a string */
4472 /* and won't be needed again, potentially */
4473 !(PL_op && PL_op->op_type == OP_AASSIGN))
4474 #ifdef PERL_COPY_ON_WRITE
4475 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4476 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4477 && SvTYPE(sstr) >= SVt_PVIV)
4480 /* Failed the swipe test, and it's not a shared hash key either.
4481 Have to copy the string. */
4482 STRLEN len = SvCUR(sstr);
4483 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4484 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4485 SvCUR_set(dstr, len);
4486 *SvEND(dstr) = '\0';
4488 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4490 #ifdef PERL_COPY_ON_WRITE
4491 /* Either it's a shared hash key, or it's suitable for
4492 copy-on-write or we can swipe the string. */
4494 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4499 /* I believe I should acquire a global SV mutex if
4500 it's a COW sv (not a shared hash key) to stop
4501 it going un copy-on-write.
4502 If the source SV has gone un copy on write between up there
4503 and down here, then (assert() that) it is of the correct
4504 form to make it copy on write again */
4505 if ((sflags & (SVf_FAKE | SVf_READONLY))
4506 != (SVf_FAKE | SVf_READONLY)) {
4507 SvREADONLY_on(sstr);
4509 /* Make the source SV into a loop of 1.
4510 (about to become 2) */
4511 SV_COW_NEXT_SV_SET(sstr, sstr);
4515 /* Initial code is common. */
4516 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4518 SvFLAGS(dstr) &= ~SVf_OOK;
4519 Safefree(SvPVX(dstr) - SvIVX(dstr));
4521 else if (SvLEN(dstr))
4522 Safefree(SvPVX(dstr));
4525 #ifdef PERL_COPY_ON_WRITE
4527 /* making another shared SV. */
4528 STRLEN cur = SvCUR(sstr);
4529 STRLEN len = SvLEN(sstr);
4530 assert (SvTYPE(dstr) >= SVt_PVIV);
4532 /* SvIsCOW_normal */
4533 /* splice us in between source and next-after-source. */
4534 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4535 SV_COW_NEXT_SV_SET(sstr, dstr);
4536 SvPV_set(dstr, SvPVX(sstr));
4538 /* SvIsCOW_shared_hash */
4539 UV hash = SvUVX(sstr);
4540 DEBUG_C(PerlIO_printf(Perl_debug_log,
4541 "Copy on write: Sharing hash\n"));
4543 sharepvn(SvPVX(sstr),
4544 (sflags & SVf_UTF8?-cur:cur), hash));
4545 SvUV_set(dstr, hash);
4547 SvLEN_set(dstr, len);
4548 SvCUR_set(dstr, cur);
4549 SvREADONLY_on(dstr);
4551 /* Relesase a global SV mutex. */
4555 { /* Passes the swipe test. */
4556 SvPV_set(dstr, SvPVX(sstr));
4557 SvLEN_set(dstr, SvLEN(sstr));
4558 SvCUR_set(dstr, SvCUR(sstr));
4561 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4562 SvPV_set(sstr, Nullch);
4568 if (sflags & SVf_UTF8)
4571 if (sflags & SVp_NOK) {
4573 if (sflags & SVf_NOK)
4574 SvFLAGS(dstr) |= SVf_NOK;
4575 SvNV_set(dstr, SvNVX(sstr));
4577 if (sflags & SVp_IOK) {
4578 (void)SvIOKp_on(dstr);
4579 if (sflags & SVf_IOK)
4580 SvFLAGS(dstr) |= SVf_IOK;
4581 if (sflags & SVf_IVisUV)
4583 SvIV_set(dstr, SvIVX(sstr));
4586 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4587 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4588 smg->mg_ptr, smg->mg_len);
4589 SvRMAGICAL_on(dstr);
4592 else if (sflags & SVp_IOK) {
4593 if (sflags & SVf_IOK)
4594 (void)SvIOK_only(dstr);
4596 (void)SvOK_off(dstr);
4597 (void)SvIOKp_on(dstr);
4599 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4600 if (sflags & SVf_IVisUV)
4602 SvIV_set(dstr, SvIVX(sstr));
4603 if (sflags & SVp_NOK) {
4604 if (sflags & SVf_NOK)
4605 (void)SvNOK_on(dstr);
4607 (void)SvNOKp_on(dstr);
4608 SvNV_set(dstr, SvNVX(sstr));
4611 else if (sflags & SVp_NOK) {
4612 if (sflags & SVf_NOK)
4613 (void)SvNOK_only(dstr);
4615 (void)SvOK_off(dstr);
4618 SvNV_set(dstr, SvNVX(sstr));
4621 if (dtype == SVt_PVGV) {
4622 if (ckWARN(WARN_MISC))
4623 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4626 (void)SvOK_off(dstr);
4628 if (SvTAINTED(sstr))
4633 =for apidoc sv_setsv_mg
4635 Like C<sv_setsv>, but also handles 'set' magic.
4641 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4643 sv_setsv(dstr,sstr);
4647 #ifdef PERL_COPY_ON_WRITE
4649 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4651 STRLEN cur = SvCUR(sstr);
4652 STRLEN len = SvLEN(sstr);
4653 register char *new_pv;
4656 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4664 if (SvTHINKFIRST(dstr))
4665 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4666 else if (SvPVX(dstr))
4667 Safefree(SvPVX(dstr));
4671 (void)SvUPGRADE (dstr, SVt_PVIV);
4673 assert (SvPOK(sstr));
4674 assert (SvPOKp(sstr));
4675 assert (!SvIOK(sstr));
4676 assert (!SvIOKp(sstr));
4677 assert (!SvNOK(sstr));
4678 assert (!SvNOKp(sstr));
4680 if (SvIsCOW(sstr)) {
4682 if (SvLEN(sstr) == 0) {
4683 /* source is a COW shared hash key. */
4684 UV hash = SvUVX(sstr);
4685 DEBUG_C(PerlIO_printf(Perl_debug_log,
4686 "Fast copy on write: Sharing hash\n"));
4687 SvUV_set(dstr, hash);
4688 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4691 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4693 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4694 (void)SvUPGRADE (sstr, SVt_PVIV);
4695 SvREADONLY_on(sstr);
4697 DEBUG_C(PerlIO_printf(Perl_debug_log,
4698 "Fast copy on write: Converting sstr to COW\n"));
4699 SV_COW_NEXT_SV_SET(dstr, sstr);
4701 SV_COW_NEXT_SV_SET(sstr, dstr);
4702 new_pv = SvPVX(sstr);
4705 SvPV_set(dstr, new_pv);
4706 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4709 SvLEN_set(dstr, len);
4710 SvCUR_set(dstr, cur);
4719 =for apidoc sv_setpvn
4721 Copies a string into an SV. The C<len> parameter indicates the number of
4722 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4723 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4729 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4731 register char *dptr;
4733 SV_CHECK_THINKFIRST_COW_DROP(sv);
4739 /* len is STRLEN which is unsigned, need to copy to signed */
4742 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4744 (void)SvUPGRADE(sv, SVt_PV);
4746 SvGROW(sv, len + 1);
4748 Move(ptr,dptr,len,char);
4751 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4756 =for apidoc sv_setpvn_mg
4758 Like C<sv_setpvn>, but also handles 'set' magic.
4764 Perl_sv_setpvn_mg(pTHX_