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_OLD_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 by default are
67 approximately 4K chunks of memory parcelled up into N heads or bodies. The
68 first slot in each arena is reserved, and is used to hold a link to the next
69 arena. In the case of heads, the unused first slot also contains some flags
70 and 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 list.
74 The following global variables are associated with arenas:
76 PL_sv_arenaroot pointer to list of SV arenas
77 PL_sv_root pointer to list of free SV structures
79 PL_foo_arenaroot pointer to list of foo arenas,
80 PL_foo_root pointer to list of free foo bodies
81 ... for foo in xiv, xnv, xrv, xpv etc.
83 Note that some of the larger and more rarely used body types (eg xpvio)
84 are not allocated using arenas, but are instead just malloc()/free()ed as
85 required. Also, if PURIFY is defined, arenas are abandoned altogether,
86 with all items individually malloc()ed. In addition, a few SV heads are
87 not allocated from an arena, but are instead directly created as static
88 or auto variables, eg PL_sv_undef. The size of arenas can be changed from
89 the default by setting PERL_ARENA_SIZE appropriately at compile time.
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..."
169 * nice_chunk and nice_chunk size need to be set
170 * and queried under the protection of sv_mutex
173 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
178 new_chunk = (void *)(chunk);
179 new_chunk_size = (chunk_size);
180 if (new_chunk_size > PL_nice_chunk_size) {
181 Safefree(PL_nice_chunk);
182 PL_nice_chunk = (char *) new_chunk;
183 PL_nice_chunk_size = new_chunk_size;
190 #ifdef DEBUG_LEAKING_SCALARS
191 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
193 # define FREE_SV_DEBUG_FILE(sv)
196 #define plant_SV(p) \
198 FREE_SV_DEBUG_FILE(p); \
199 SvANY(p) = (void *)PL_sv_root; \
200 SvFLAGS(p) = SVTYPEMASK; \
205 /* sv_mutex must be held while calling uproot_SV() */
206 #define uproot_SV(p) \
209 PL_sv_root = (SV*)SvANY(p); \
214 /* make some more SVs by adding another arena */
216 /* sv_mutex must be held while calling more_sv() */
223 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
224 PL_nice_chunk = Nullch;
225 PL_nice_chunk_size = 0;
228 char *chunk; /* must use New here to match call to */
229 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
230 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
236 /* new_SV(): return a new, empty SV head */
238 #ifdef DEBUG_LEAKING_SCALARS
239 /* provide a real function for a debugger to play with */
249 sv = S_more_sv(aTHX);
254 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
255 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
256 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
257 sv->sv_debug_inpad = 0;
258 sv->sv_debug_cloned = 0;
259 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
263 # define new_SV(p) (p)=S_new_SV(aTHX)
272 (p) = S_more_sv(aTHX); \
281 /* del_SV(): return an empty SV head to the free list */
296 S_del_sv(pTHX_ SV *p)
301 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
302 const SV * const sv = sva + 1;
303 const SV * const svend = &sva[SvREFCNT(sva)];
304 if (p >= sv && p < svend) {
310 if (ckWARN_d(WARN_INTERNAL))
311 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
312 "Attempt to free non-arena SV: 0x%"UVxf
313 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
320 #else /* ! DEBUGGING */
322 #define del_SV(p) plant_SV(p)
324 #endif /* DEBUGGING */
328 =head1 SV Manipulation Functions
330 =for apidoc sv_add_arena
332 Given a chunk of memory, link it to the head of the list of arenas,
333 and split it into a list of free SVs.
339 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
345 /* The first SV in an arena isn't an SV. */
346 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
347 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
348 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
350 PL_sv_arenaroot = sva;
351 PL_sv_root = sva + 1;
353 svend = &sva[SvREFCNT(sva) - 1];
356 SvANY(sv) = (void *)(SV*)(sv + 1);
360 /* Must always set typemask because it's awlays checked in on cleanup
361 when the arenas are walked looking for objects. */
362 SvFLAGS(sv) = SVTYPEMASK;
369 SvFLAGS(sv) = SVTYPEMASK;
372 /* visit(): call the named function for each non-free SV in the arenas
373 * whose flags field matches the flags/mask args. */
376 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
381 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
382 register const SV * const svend = &sva[SvREFCNT(sva)];
384 for (sv = sva + 1; sv < svend; ++sv) {
385 if (SvTYPE(sv) != SVTYPEMASK
386 && (sv->sv_flags & mask) == flags
399 /* called by sv_report_used() for each live SV */
402 do_report_used(pTHX_ SV *sv)
404 if (SvTYPE(sv) != SVTYPEMASK) {
405 PerlIO_printf(Perl_debug_log, "****\n");
412 =for apidoc sv_report_used
414 Dump the contents of all SVs not yet freed. (Debugging aid).
420 Perl_sv_report_used(pTHX)
423 visit(do_report_used, 0, 0);
427 /* called by sv_clean_objs() for each live SV */
430 do_clean_objs(pTHX_ SV *ref)
433 SV * const target = SvRV(ref);
434 if (SvOBJECT(target)) {
435 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
436 if (SvWEAKREF(ref)) {
437 sv_del_backref(target, ref);
443 SvREFCNT_dec(target);
448 /* XXX Might want to check arrays, etc. */
451 /* called by sv_clean_objs() for each live SV */
453 #ifndef DISABLE_DESTRUCTOR_KLUDGE
455 do_clean_named_objs(pTHX_ SV *sv)
457 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
459 #ifdef PERL_DONT_CREATE_GVSV
462 SvOBJECT(GvSV(sv))) ||
463 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
464 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
465 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
466 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
468 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
469 SvFLAGS(sv) |= SVf_BREAK;
477 =for apidoc sv_clean_objs
479 Attempt to destroy all objects not yet freed
485 Perl_sv_clean_objs(pTHX)
487 PL_in_clean_objs = TRUE;
488 visit(do_clean_objs, SVf_ROK, SVf_ROK);
489 #ifndef DISABLE_DESTRUCTOR_KLUDGE
490 /* some barnacles may yet remain, clinging to typeglobs */
491 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
493 PL_in_clean_objs = FALSE;
496 /* called by sv_clean_all() for each live SV */
499 do_clean_all(pTHX_ SV *sv)
501 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
502 SvFLAGS(sv) |= SVf_BREAK;
503 if (PL_comppad == (AV*)sv) {
505 PL_curpad = Null(SV**);
511 =for apidoc sv_clean_all
513 Decrement the refcnt of each remaining SV, possibly triggering a
514 cleanup. This function may have to be called multiple times to free
515 SVs which are in complex self-referential hierarchies.
521 Perl_sv_clean_all(pTHX)
524 PL_in_clean_all = TRUE;
525 cleaned = visit(do_clean_all, 0,0);
526 PL_in_clean_all = FALSE;
531 S_free_arena(pTHX_ void **root) {
533 void ** const next = *(void **)root;
540 =for apidoc sv_free_arenas
542 Deallocate the memory used by all arenas. Note that all the individual SV
543 heads and bodies within the arenas must already have been freed.
548 #define free_arena(name) \
550 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
551 PL_ ## name ## _arenaroot = 0; \
552 PL_ ## name ## _root = 0; \
556 Perl_sv_free_arenas(pTHX)
561 /* Free arenas here, but be careful about fake ones. (We assume
562 contiguity of the fake ones with the corresponding real ones.) */
564 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
565 svanext = (SV*) SvANY(sva);
566 while (svanext && SvFAKE(svanext))
567 svanext = (SV*) SvANY(svanext);
585 #if defined(USE_ITHREADS)
589 Safefree(PL_nice_chunk);
590 PL_nice_chunk = Nullch;
591 PL_nice_chunk_size = 0;
596 /* ---------------------------------------------------------------------
598 * support functions for report_uninit()
601 /* the maxiumum size of array or hash where we will scan looking
602 * for the undefined element that triggered the warning */
604 #define FUV_MAX_SEARCH_SIZE 1000
606 /* Look for an entry in the hash whose value has the same SV as val;
607 * If so, return a mortal copy of the key. */
610 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
616 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
617 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
622 for (i=HvMAX(hv); i>0; i--) {
624 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
625 if (HeVAL(entry) != val)
627 if ( HeVAL(entry) == &PL_sv_undef ||
628 HeVAL(entry) == &PL_sv_placeholder)
632 if (HeKLEN(entry) == HEf_SVKEY)
633 return sv_mortalcopy(HeKEY_sv(entry));
634 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
640 /* Look for an entry in the array whose value has the same SV as val;
641 * If so, return the index, otherwise return -1. */
644 S_find_array_subscript(pTHX_ AV *av, SV* val)
648 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
649 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
653 for (i=AvFILLp(av); i>=0; i--) {
654 if (svp[i] == val && svp[i] != &PL_sv_undef)
660 /* S_varname(): return the name of a variable, optionally with a subscript.
661 * If gv is non-zero, use the name of that global, along with gvtype (one
662 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
663 * targ. Depending on the value of the subscript_type flag, return:
666 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
667 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
668 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
669 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
672 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
673 SV* keyname, I32 aindex, int subscript_type)
676 SV * const name = sv_newmortal();
682 /* as gv_fullname4(), but add literal '^' for $^FOO names */
684 gv_fullname4(name, gv, buffer, 0);
686 if ((unsigned int)SvPVX(name)[1] <= 26) {
688 buffer[1] = SvPVX(name)[1] + 'A' - 1;
690 /* Swap the 1 unprintable control character for the 2 byte pretty
691 version - ie substr($name, 1, 1) = $buffer; */
692 sv_insert(name, 1, 1, buffer, 2);
697 CV * const cv = find_runcv(&unused);
701 if (!cv || !CvPADLIST(cv))
703 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
704 sv = *av_fetch(av, targ, FALSE);
705 /* SvLEN in a pad name is not to be trusted */
706 sv_setpv(name, SvPV_nolen_const(sv));
709 if (subscript_type == FUV_SUBSCRIPT_HASH) {
710 SV * const sv = NEWSV(0,0);
712 Perl_sv_catpvf(aTHX_ name, "{%s}",
713 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
716 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
718 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
720 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
721 sv_insert(name, 0, 0, "within ", 7);
728 =for apidoc find_uninit_var
730 Find the name of the undefined variable (if any) that caused the operator o
731 to issue a "Use of uninitialized value" warning.
732 If match is true, only return a name if it's value matches uninit_sv.
733 So roughly speaking, if a unary operator (such as OP_COS) generates a
734 warning, then following the direct child of the op may yield an
735 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
736 other hand, with OP_ADD there are two branches to follow, so we only print
737 the variable name if we get an exact match.
739 The name is returned as a mortal SV.
741 Assumes that PL_op is the op that originally triggered the error, and that
742 PL_comppad/PL_curpad points to the currently executing pad.
748 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
756 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
757 uninit_sv == &PL_sv_placeholder)))
760 switch (obase->op_type) {
767 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
768 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
771 int subscript_type = FUV_SUBSCRIPT_WITHIN;
773 if (pad) { /* @lex, %lex */
774 sv = PAD_SVl(obase->op_targ);
778 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
779 /* @global, %global */
780 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
783 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
785 else /* @{expr}, %{expr} */
786 return find_uninit_var(cUNOPx(obase)->op_first,
790 /* attempt to find a match within the aggregate */
792 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
794 subscript_type = FUV_SUBSCRIPT_HASH;
797 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
799 subscript_type = FUV_SUBSCRIPT_ARRAY;
802 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
805 return varname(gv, hash ? '%' : '@', obase->op_targ,
806 keysv, index, subscript_type);
810 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
812 return varname(Nullgv, '$', obase->op_targ,
813 Nullsv, 0, FUV_SUBSCRIPT_NONE);
816 gv = cGVOPx_gv(obase);
817 if (!gv || (match && GvSV(gv) != uninit_sv))
819 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
822 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
825 av = (AV*)PAD_SV(obase->op_targ);
826 if (!av || SvRMAGICAL(av))
828 svp = av_fetch(av, (I32)obase->op_private, FALSE);
829 if (!svp || *svp != uninit_sv)
832 return varname(Nullgv, '$', obase->op_targ,
833 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
836 gv = cGVOPx_gv(obase);
842 if (!av || SvRMAGICAL(av))
844 svp = av_fetch(av, (I32)obase->op_private, FALSE);
845 if (!svp || *svp != uninit_sv)
848 return varname(gv, '$', 0,
849 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
854 o = cUNOPx(obase)->op_first;
855 if (!o || o->op_type != OP_NULL ||
856 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
858 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
863 /* $a[uninit_expr] or $h{uninit_expr} */
864 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
867 o = cBINOPx(obase)->op_first;
868 kid = cBINOPx(obase)->op_last;
870 /* get the av or hv, and optionally the gv */
872 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
873 sv = PAD_SV(o->op_targ);
875 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
876 && cUNOPo->op_first->op_type == OP_GV)
878 gv = cGVOPx_gv(cUNOPo->op_first);
881 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
886 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
887 /* index is constant */
891 if (obase->op_type == OP_HELEM) {
892 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
893 if (!he || HeVAL(he) != uninit_sv)
897 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
898 if (!svp || *svp != uninit_sv)
902 if (obase->op_type == OP_HELEM)
903 return varname(gv, '%', o->op_targ,
904 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
906 return varname(gv, '@', o->op_targ, Nullsv,
907 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
911 /* index is an expression;
912 * attempt to find a match within the aggregate */
913 if (obase->op_type == OP_HELEM) {
914 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
916 return varname(gv, '%', o->op_targ,
917 keysv, 0, FUV_SUBSCRIPT_HASH);
920 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
922 return varname(gv, '@', o->op_targ,
923 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
928 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
930 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
936 /* only examine RHS */
937 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
940 o = cUNOPx(obase)->op_first;
941 if (o->op_type == OP_PUSHMARK)
944 if (!o->op_sibling) {
945 /* one-arg version of open is highly magical */
947 if (o->op_type == OP_GV) { /* open FOO; */
949 if (match && GvSV(gv) != uninit_sv)
951 return varname(gv, '$', 0,
952 Nullsv, 0, FUV_SUBSCRIPT_NONE);
954 /* other possibilities not handled are:
955 * open $x; or open my $x; should return '${*$x}'
956 * open expr; should return '$'.expr ideally
962 /* ops where $_ may be an implicit arg */
966 if ( !(obase->op_flags & OPf_STACKED)) {
967 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
968 ? PAD_SVl(obase->op_targ)
972 sv_setpvn(sv, "$_", 2);
980 /* skip filehandle as it can't produce 'undef' warning */
981 o = cUNOPx(obase)->op_first;
982 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
983 o = o->op_sibling->op_sibling;
990 match = 1; /* XS or custom code could trigger random warnings */
995 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
996 return sv_2mortal(newSVpvn("${$/}", 5));
1001 if (!(obase->op_flags & OPf_KIDS))
1003 o = cUNOPx(obase)->op_first;
1009 /* if all except one arg are constant, or have no side-effects,
1010 * or are optimized away, then it's unambiguous */
1012 for (kid=o; kid; kid = kid->op_sibling) {
1014 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1015 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1016 || (kid->op_type == OP_PUSHMARK)
1020 if (o2) { /* more than one found */
1027 return find_uninit_var(o2, uninit_sv, match);
1031 sv = find_uninit_var(o, uninit_sv, 1);
1043 =for apidoc report_uninit
1045 Print appropriate "Use of uninitialized variable" warning
1051 Perl_report_uninit(pTHX_ SV* uninit_sv)
1054 SV* varname = Nullsv;
1056 varname = find_uninit_var(PL_op, uninit_sv,0);
1058 sv_insert(varname, 0, 0, " ", 1);
1060 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1061 varname ? SvPV_nolen_const(varname) : "",
1062 " in ", OP_DESC(PL_op));
1065 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1070 S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
1074 const size_t count = PERL_ARENA_SIZE/size;
1075 Newx(start, count*size, char);
1076 *((void **) start) = *arena_root;
1077 *arena_root = (void *)start;
1079 end = start + (count-1) * size;
1081 /* The initial slot is used to link the arenas together, so it isn't to be
1082 linked into the list of ready-to-use bodies. */
1086 *root = (void *)start;
1088 while (start < end) {
1089 char * const next = start + size;
1090 *(void**) start = (void *)next;
1093 *(void **)start = 0;
1098 /* grab a new thing from the free list, allocating more if necessary */
1100 /* 1st, the inline version */
1102 #define new_body_inline(xpv, arena_root, root, size) \
1105 xpv = *((void **)(root)) \
1106 ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \
1107 *(root) = *(void**)(xpv); \
1111 /* now use the inline version in the proper function */
1114 S_new_body(pTHX_ void **arena_root, void **root, size_t size)
1117 new_body_inline(xpv, arena_root, root, size);
1121 /* return a thing to the free list */
1123 #define del_body(thing, root) \
1125 void **thing_copy = (void **)thing; \
1127 *thing_copy = *root; \
1128 *root = (void*)thing_copy; \
1132 /* Conventionally we simply malloc() a big block of memory, then divide it
1133 up into lots of the thing that we're allocating.
1135 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1138 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1139 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1142 #define new_body_type(TYPE,lctype) \
1143 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1144 (void**)&PL_ ## lctype ## _root, \
1147 #define del_body_type(p,TYPE,lctype) \
1148 del_body((void*)p, (void**)&PL_ ## lctype ## _root)
1150 /* But for some types, we cheat. The type starts with some members that are
1151 never accessed. So we allocate the substructure, starting at the first used
1152 member, then adjust the pointer back in memory by the size of the bit not
1153 allocated, so it's as if we allocated the full structure.
1154 (But things will all go boom if you write to the part that is "not there",
1155 because you'll be overwriting the last members of the preceding structure
1158 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1159 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1160 and the pointer is unchanged. If the allocated structure is smaller (no
1161 initial NV actually allocated) then the net effect is to subtract the size
1162 of the NV from the pointer, to return a new pointer as if an initial NV were
1165 This is the same trick as was used for NV and IV bodies. Ironically it
1166 doesn't need to be used for NV bodies any more, because NV is now at the
1167 start of the structure. IV bodies don't need it either, because they are
1168 no longer allocated. */
1170 #define new_body_allocated(TYPE,lctype,member) \
1171 (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1172 (void**)&PL_ ## lctype ## _root, \
1173 sizeof(lctype ## _allocated)) - \
1174 STRUCT_OFFSET(TYPE, member) \
1175 + STRUCT_OFFSET(lctype ## _allocated, member))
1178 #define del_body_allocated(p,TYPE,lctype,member) \
1179 del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
1180 - STRUCT_OFFSET(lctype ## _allocated, member)), \
1181 (void**)&PL_ ## lctype ## _root)
1183 #define my_safemalloc(s) (void*)safemalloc(s)
1184 #define my_safefree(p) safefree((char*)p)
1188 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1189 #define del_XNV(p) my_safefree(p)
1191 #define new_XPV() my_safemalloc(sizeof(XPV))
1192 #define del_XPV(p) my_safefree(p)
1194 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1195 #define del_XPVIV(p) my_safefree(p)
1197 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1198 #define del_XPVNV(p) my_safefree(p)
1200 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1201 #define del_XPVCV(p) my_safefree(p)
1203 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1204 #define del_XPVAV(p) my_safefree(p)
1206 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1207 #define del_XPVHV(p) my_safefree(p)
1209 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1210 #define del_XPVMG(p) my_safefree(p)
1212 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1213 #define del_XPVGV(p) my_safefree(p)
1215 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1216 #define del_XPVLV(p) my_safefree(p)
1218 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1219 #define del_XPVBM(p) my_safefree(p)
1223 #define new_XNV() new_body_type(NV, xnv)
1224 #define del_XNV(p) del_body_type(p, NV, xnv)
1226 #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1227 #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
1229 #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1230 #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
1232 #define new_XPVNV() new_body_type(XPVNV, xpvnv)
1233 #define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
1235 #define new_XPVCV() new_body_type(XPVCV, xpvcv)
1236 #define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
1238 #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1239 #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
1241 #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1242 #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1244 #define new_XPVMG() new_body_type(XPVMG, xpvmg)
1245 #define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
1247 #define new_XPVGV() new_body_type(XPVGV, xpvgv)
1248 #define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
1250 #define new_XPVLV() new_body_type(XPVLV, xpvlv)
1251 #define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
1253 #define new_XPVBM() new_body_type(XPVBM, xpvbm)
1254 #define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
1258 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1259 #define del_XPVFM(p) my_safefree(p)
1261 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1262 #define del_XPVIO(p) my_safefree(p)
1265 =for apidoc sv_upgrade
1267 Upgrade an SV to a more complex form. Generally adds a new body type to the
1268 SV, then copies across as much information as possible from the old body.
1269 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1275 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1277 void** old_body_arena;
1278 size_t old_body_offset;
1279 size_t old_body_length; /* Well, the length to copy. */
1281 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1282 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1284 bool zero_nv = TRUE;
1287 size_t new_body_length;
1288 size_t new_body_offset;
1289 void** new_body_arena;
1290 void** new_body_arenaroot;
1291 const U32 old_type = SvTYPE(sv);
1293 if (mt != SVt_PV && SvIsCOW(sv)) {
1294 sv_force_normal_flags(sv, 0);
1297 if (SvTYPE(sv) == mt)
1300 if (SvTYPE(sv) > mt)
1301 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1302 (int)SvTYPE(sv), (int)mt);
1305 old_body = SvANY(sv);
1307 old_body_offset = 0;
1308 old_body_length = 0;
1309 new_body_offset = 0;
1310 new_body_length = ~0;
1312 /* Copying structures onto other structures that have been neatly zeroed
1313 has a subtle gotcha. Consider XPVMG
1315 +------+------+------+------+------+-------+-------+
1316 | NV | CUR | LEN | IV | MAGIC | STASH |
1317 +------+------+------+------+------+-------+-------+
1318 0 4 8 12 16 20 24 28
1320 where NVs are aligned to 8 bytes, so that sizeof that structure is
1321 actually 32 bytes long, with 4 bytes of padding at the end:
1323 +------+------+------+------+------+-------+-------+------+
1324 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1325 +------+------+------+------+------+-------+-------+------+
1326 0 4 8 12 16 20 24 28 32
1328 so what happens if you allocate memory for this structure:
1330 +------+------+------+------+------+-------+-------+------+------+...
1331 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1332 +------+------+------+------+------+-------+-------+------+------+...
1333 0 4 8 12 16 20 24 28 32 36
1335 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1336 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1337 started out as zero once, but it's quite possible that it isn't. So now,
1338 rather than a nicely zeroed GP, you have it pointing somewhere random.
1341 (In fact, GP ends up pointing at a previous GP structure, because the
1342 principle cause of the padding in XPVMG getting garbage is a copy of
1343 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1345 So we are careful and work out the size of used parts of all the
1348 switch (SvTYPE(sv)) {
1354 else if (mt < SVt_PVIV)
1356 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1357 old_body_length = sizeof(IV);
1360 old_body_arena = (void **) &PL_xnv_root;
1361 old_body_length = sizeof(NV);
1362 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1371 old_body_arena = (void **) &PL_xpv_root;
1372 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1373 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1374 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1375 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1379 else if (mt == SVt_NV)
1383 old_body_arena = (void **) &PL_xpviv_root;
1384 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1385 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1386 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
1387 + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
1391 old_body_arena = (void **) &PL_xpvnv_root;
1392 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1393 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1394 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1399 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1400 there's no way that it can be safely upgraded, because perl.c
1401 expects to Safefree(SvANY(PL_mess_sv)) */
1402 assert(sv != PL_mess_sv);
1403 /* This flag bit is used to mean other things in other scalar types.
1404 Given that it only has meaning inside the pad, it shouldn't be set
1405 on anything that can get upgraded. */
1406 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1407 old_body_arena = (void **) &PL_xpvmg_root;
1408 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1409 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1410 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1415 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1418 SvFLAGS(sv) &= ~SVTYPEMASK;
1423 Perl_croak(aTHX_ "Can't upgrade to undef");
1425 assert(old_type == SVt_NULL);
1426 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1430 assert(old_type == SVt_NULL);
1431 SvANY(sv) = new_XNV();
1435 assert(old_type == SVt_NULL);
1436 SvANY(sv) = &sv->sv_u.svu_rv;
1440 SvANY(sv) = new_XPVHV();
1443 HvTOTALKEYS(sv) = 0;
1448 SvANY(sv) = new_XPVAV();
1455 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1456 The target created by newSVrv also is, and it can have magic.
1457 However, it never has SvPVX set.
1459 if (old_type >= SVt_RV) {
1460 assert(SvPVX_const(sv) == 0);
1463 /* Could put this in the else clause below, as PVMG must have SvPVX
1464 0 already (the assertion above) */
1465 SvPV_set(sv, (char*)0);
1467 if (old_type >= SVt_PVMG) {
1468 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1469 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1477 new_body = new_XPVIO();
1478 new_body_length = sizeof(XPVIO);
1481 new_body = new_XPVFM();
1482 new_body_length = sizeof(XPVFM);
1486 new_body_length = sizeof(XPVBM);
1487 new_body_arena = (void **) &PL_xpvbm_root;
1488 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
1491 new_body_length = sizeof(XPVGV);
1492 new_body_arena = (void **) &PL_xpvgv_root;
1493 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
1496 new_body_length = sizeof(XPVCV);
1497 new_body_arena = (void **) &PL_xpvcv_root;
1498 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
1501 new_body_length = sizeof(XPVLV);
1502 new_body_arena = (void **) &PL_xpvlv_root;
1503 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
1506 new_body_length = sizeof(XPVMG);
1507 new_body_arena = (void **) &PL_xpvmg_root;
1508 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
1511 new_body_length = sizeof(XPVNV);
1512 new_body_arena = (void **) &PL_xpvnv_root;
1513 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
1516 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1517 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1518 new_body_length = sizeof(XPVIV) - new_body_offset;
1519 new_body_arena = (void **) &PL_xpviv_root;
1520 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
1521 /* XXX Is this still needed? Was it ever needed? Surely as there is
1522 no route from NV to PVIV, NOK can never be true */
1526 goto new_body_no_NV;
1528 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1529 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1530 new_body_length = sizeof(XPV) - new_body_offset;
1531 new_body_arena = (void **) &PL_xpv_root;
1532 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
1534 /* PV and PVIV don't have an NV slot. */
1535 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1540 assert(new_body_length);
1542 /* This points to the start of the allocated area. */
1543 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
1546 /* We always allocated the full length item with PURIFY */
1547 new_body_length += new_body_offset;
1548 new_body_offset = 0;
1549 new_body = my_safemalloc(new_body_length);
1553 Zero(new_body, new_body_length, char);
1554 new_body = ((char *)new_body) - new_body_offset;
1555 SvANY(sv) = new_body;
1557 if (old_body_length) {
1558 Copy((char *)old_body + old_body_offset,
1559 (char *)new_body + old_body_offset,
1560 old_body_length, char);
1563 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1569 IoPAGE_LEN(sv) = 60;
1570 if (old_type < SVt_RV)
1574 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1578 if (old_body_arena) {
1580 my_safefree(old_body);
1582 del_body((void*)((char*)old_body + old_body_offset),
1589 =for apidoc sv_backoff
1591 Remove any string offset. You should normally use the C<SvOOK_off> macro
1598 Perl_sv_backoff(pTHX_ register SV *sv)
1601 assert(SvTYPE(sv) != SVt_PVHV);
1602 assert(SvTYPE(sv) != SVt_PVAV);
1604 const char * const s = SvPVX_const(sv);
1605 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1606 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1608 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1610 SvFLAGS(sv) &= ~SVf_OOK;
1617 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1618 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1619 Use the C<SvGROW> wrapper instead.
1625 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1629 #ifdef HAS_64K_LIMIT
1630 if (newlen >= 0x10000) {
1631 PerlIO_printf(Perl_debug_log,
1632 "Allocation too large: %"UVxf"\n", (UV)newlen);
1635 #endif /* HAS_64K_LIMIT */
1638 if (SvTYPE(sv) < SVt_PV) {
1639 sv_upgrade(sv, SVt_PV);
1640 s = SvPVX_mutable(sv);
1642 else if (SvOOK(sv)) { /* pv is offset? */
1644 s = SvPVX_mutable(sv);
1645 if (newlen > SvLEN(sv))
1646 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1647 #ifdef HAS_64K_LIMIT
1648 if (newlen >= 0x10000)
1653 s = SvPVX_mutable(sv);
1655 if (newlen > SvLEN(sv)) { /* need more room? */
1656 newlen = PERL_STRLEN_ROUNDUP(newlen);
1657 if (SvLEN(sv) && s) {
1659 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1665 s = saferealloc(s, newlen);
1668 s = safemalloc(newlen);
1669 if (SvPVX_const(sv) && SvCUR(sv)) {
1670 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1674 SvLEN_set(sv, newlen);
1680 =for apidoc sv_setiv
1682 Copies an integer into the given SV, upgrading first if necessary.
1683 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1689 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1691 SV_CHECK_THINKFIRST_COW_DROP(sv);
1692 switch (SvTYPE(sv)) {
1694 sv_upgrade(sv, SVt_IV);
1697 sv_upgrade(sv, SVt_PVNV);
1701 sv_upgrade(sv, SVt_PVIV);
1710 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1713 (void)SvIOK_only(sv); /* validate number */
1719 =for apidoc sv_setiv_mg
1721 Like C<sv_setiv>, but also handles 'set' magic.
1727 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1734 =for apidoc sv_setuv
1736 Copies an unsigned integer into the given SV, upgrading first if necessary.
1737 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1743 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1745 /* With these two if statements:
1746 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1749 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1751 If you wish to remove them, please benchmark to see what the effect is
1753 if (u <= (UV)IV_MAX) {
1754 sv_setiv(sv, (IV)u);
1763 =for apidoc sv_setuv_mg
1765 Like C<sv_setuv>, but also handles 'set' magic.
1771 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1780 =for apidoc sv_setnv
1782 Copies a double into the given SV, upgrading first if necessary.
1783 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1789 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1791 SV_CHECK_THINKFIRST_COW_DROP(sv);
1792 switch (SvTYPE(sv)) {
1795 sv_upgrade(sv, SVt_NV);
1800 sv_upgrade(sv, SVt_PVNV);
1809 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1813 (void)SvNOK_only(sv); /* validate number */
1818 =for apidoc sv_setnv_mg
1820 Like C<sv_setnv>, but also handles 'set' magic.
1826 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1832 /* Print an "isn't numeric" warning, using a cleaned-up,
1833 * printable version of the offending string
1837 S_not_a_number(pTHX_ SV *sv)
1844 dsv = sv_2mortal(newSVpvn("", 0));
1845 pv = sv_uni_display(dsv, sv, 10, 0);
1848 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1849 /* each *s can expand to 4 chars + "...\0",
1850 i.e. need room for 8 chars */
1852 const char *s, *end;
1853 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1856 if (ch & 128 && !isPRINT_LC(ch)) {
1865 else if (ch == '\r') {
1869 else if (ch == '\f') {
1873 else if (ch == '\\') {
1877 else if (ch == '\0') {
1881 else if (isPRINT_LC(ch))
1898 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1899 "Argument \"%s\" isn't numeric in %s", pv,
1902 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1903 "Argument \"%s\" isn't numeric", pv);
1907 =for apidoc looks_like_number
1909 Test if the content of an SV looks like a number (or is a number).
1910 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1911 non-numeric warning), even if your atof() doesn't grok them.
1917 Perl_looks_like_number(pTHX_ SV *sv)
1919 register const char *sbegin;
1923 sbegin = SvPVX_const(sv);
1926 else if (SvPOKp(sv))
1927 sbegin = SvPV_const(sv, len);
1929 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1930 return grok_number(sbegin, len, NULL);
1933 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1934 until proven guilty, assume that things are not that bad... */
1939 As 64 bit platforms often have an NV that doesn't preserve all bits of
1940 an IV (an assumption perl has been based on to date) it becomes necessary
1941 to remove the assumption that the NV always carries enough precision to
1942 recreate the IV whenever needed, and that the NV is the canonical form.
1943 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1944 precision as a side effect of conversion (which would lead to insanity
1945 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1946 1) to distinguish between IV/UV/NV slots that have cached a valid
1947 conversion where precision was lost and IV/UV/NV slots that have a
1948 valid conversion which has lost no precision
1949 2) to ensure that if a numeric conversion to one form is requested that
1950 would lose precision, the precise conversion (or differently
1951 imprecise conversion) is also performed and cached, to prevent
1952 requests for different numeric formats on the same SV causing
1953 lossy conversion chains. (lossless conversion chains are perfectly
1958 SvIOKp is true if the IV slot contains a valid value
1959 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1960 SvNOKp is true if the NV slot contains a valid value
1961 SvNOK is true only if the NV value is accurate
1964 while converting from PV to NV, check to see if converting that NV to an
1965 IV(or UV) would lose accuracy over a direct conversion from PV to
1966 IV(or UV). If it would, cache both conversions, return NV, but mark
1967 SV as IOK NOKp (ie not NOK).
1969 While converting from PV to IV, check to see if converting that IV to an
1970 NV would lose accuracy over a direct conversion from PV to NV. If it
1971 would, cache both conversions, flag similarly.
1973 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1974 correctly because if IV & NV were set NV *always* overruled.
1975 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1976 changes - now IV and NV together means that the two are interchangeable:
1977 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1979 The benefit of this is that operations such as pp_add know that if
1980 SvIOK is true for both left and right operands, then integer addition
1981 can be used instead of floating point (for cases where the result won't
1982 overflow). Before, floating point was always used, which could lead to
1983 loss of precision compared with integer addition.
1985 * making IV and NV equal status should make maths accurate on 64 bit
1987 * may speed up maths somewhat if pp_add and friends start to use
1988 integers when possible instead of fp. (Hopefully the overhead in
1989 looking for SvIOK and checking for overflow will not outweigh the
1990 fp to integer speedup)
1991 * will slow down integer operations (callers of SvIV) on "inaccurate"
1992 values, as the change from SvIOK to SvIOKp will cause a call into
1993 sv_2iv each time rather than a macro access direct to the IV slot
1994 * should speed up number->string conversion on integers as IV is
1995 favoured when IV and NV are equally accurate
1997 ####################################################################
1998 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1999 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2000 On the other hand, SvUOK is true iff UV.
2001 ####################################################################
2003 Your mileage will vary depending your CPU's relative fp to integer
2007 #ifndef NV_PRESERVES_UV
2008 # define IS_NUMBER_UNDERFLOW_IV 1
2009 # define IS_NUMBER_UNDERFLOW_UV 2
2010 # define IS_NUMBER_IV_AND_UV 2
2011 # define IS_NUMBER_OVERFLOW_IV 4
2012 # define IS_NUMBER_OVERFLOW_UV 5
2014 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2016 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2018 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2020 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2021 if (SvNVX(sv) < (NV)IV_MIN) {
2022 (void)SvIOKp_on(sv);
2024 SvIV_set(sv, IV_MIN);
2025 return IS_NUMBER_UNDERFLOW_IV;
2027 if (SvNVX(sv) > (NV)UV_MAX) {
2028 (void)SvIOKp_on(sv);
2031 SvUV_set(sv, UV_MAX);
2032 return IS_NUMBER_OVERFLOW_UV;
2034 (void)SvIOKp_on(sv);
2036 /* Can't use strtol etc to convert this string. (See truth table in
2038 if (SvNVX(sv) <= (UV)IV_MAX) {
2039 SvIV_set(sv, I_V(SvNVX(sv)));
2040 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2041 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2043 /* Integer is imprecise. NOK, IOKp */
2045 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2048 SvUV_set(sv, U_V(SvNVX(sv)));
2049 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2050 if (SvUVX(sv) == UV_MAX) {
2051 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2052 possibly be preserved by NV. Hence, it must be overflow.
2054 return IS_NUMBER_OVERFLOW_UV;
2056 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2058 /* Integer is imprecise. NOK, IOKp */
2060 return IS_NUMBER_OVERFLOW_IV;
2062 #endif /* !NV_PRESERVES_UV*/
2065 =for apidoc sv_2iv_flags
2067 Return the integer value of an SV, doing any necessary string
2068 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2069 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2075 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2079 if (SvGMAGICAL(sv)) {
2080 if (flags & SV_GMAGIC)
2085 return I_V(SvNVX(sv));
2087 if (SvPOKp(sv) && SvLEN(sv))
2090 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2091 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2097 if (SvTHINKFIRST(sv)) {
2100 SV * const tmpstr=AMG_CALLun(sv,numer);
2101 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2102 return SvIV(tmpstr);
2105 return PTR2IV(SvRV(sv));
2108 sv_force_normal_flags(sv, 0);
2110 if (SvREADONLY(sv) && !SvOK(sv)) {
2111 if (ckWARN(WARN_UNINITIALIZED))
2118 return (IV)(SvUVX(sv));
2125 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2126 * without also getting a cached IV/UV from it at the same time
2127 * (ie PV->NV conversion should detect loss of accuracy and cache
2128 * IV or UV at same time to avoid this. NWC */
2130 if (SvTYPE(sv) == SVt_NV)
2131 sv_upgrade(sv, SVt_PVNV);
2133 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2134 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2135 certainly cast into the IV range at IV_MAX, whereas the correct
2136 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2138 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2139 SvIV_set(sv, I_V(SvNVX(sv)));
2140 if (SvNVX(sv) == (NV) SvIVX(sv)
2141 #ifndef NV_PRESERVES_UV
2142 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2143 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2144 /* Don't flag it as "accurately an integer" if the number
2145 came from a (by definition imprecise) NV operation, and
2146 we're outside the range of NV integer precision */
2149 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2150 DEBUG_c(PerlIO_printf(Perl_debug_log,
2151 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2157 /* IV not precise. No need to convert from PV, as NV
2158 conversion would already have cached IV if it detected
2159 that PV->IV would be better than PV->NV->IV
2160 flags already correct - don't set public IOK. */
2161 DEBUG_c(PerlIO_printf(Perl_debug_log,
2162 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2167 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2168 but the cast (NV)IV_MIN rounds to a the value less (more
2169 negative) than IV_MIN which happens to be equal to SvNVX ??
2170 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2171 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2172 (NV)UVX == NVX are both true, but the values differ. :-(
2173 Hopefully for 2s complement IV_MIN is something like
2174 0x8000000000000000 which will be exact. NWC */
2177 SvUV_set(sv, U_V(SvNVX(sv)));
2179 (SvNVX(sv) == (NV) SvUVX(sv))
2180 #ifndef NV_PRESERVES_UV
2181 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2182 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2183 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2184 /* Don't flag it as "accurately an integer" if the number
2185 came from a (by definition imprecise) NV operation, and
2186 we're outside the range of NV integer precision */
2192 DEBUG_c(PerlIO_printf(Perl_debug_log,
2193 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2197 return (IV)SvUVX(sv);
2200 else if (SvPOKp(sv) && SvLEN(sv)) {
2202 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2203 /* We want to avoid a possible problem when we cache an IV which
2204 may be later translated to an NV, and the resulting NV is not
2205 the same as the direct translation of the initial string
2206 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2207 be careful to ensure that the value with the .456 is around if the
2208 NV value is requested in the future).
2210 This means that if we cache such an IV, we need to cache the
2211 NV as well. Moreover, we trade speed for space, and do not
2212 cache the NV if we are sure it's not needed.
2215 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2216 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2217 == IS_NUMBER_IN_UV) {
2218 /* It's definitely an integer, only upgrade to PVIV */
2219 if (SvTYPE(sv) < SVt_PVIV)
2220 sv_upgrade(sv, SVt_PVIV);
2222 } else if (SvTYPE(sv) < SVt_PVNV)
2223 sv_upgrade(sv, SVt_PVNV);
2225 /* If NV preserves UV then we only use the UV value if we know that
2226 we aren't going to call atof() below. If NVs don't preserve UVs
2227 then the value returned may have more precision than atof() will
2228 return, even though value isn't perfectly accurate. */
2229 if ((numtype & (IS_NUMBER_IN_UV
2230 #ifdef NV_PRESERVES_UV
2233 )) == IS_NUMBER_IN_UV) {
2234 /* This won't turn off the public IOK flag if it was set above */
2235 (void)SvIOKp_on(sv);
2237 if (!(numtype & IS_NUMBER_NEG)) {
2239 if (value <= (UV)IV_MAX) {
2240 SvIV_set(sv, (IV)value);
2242 SvUV_set(sv, value);
2246 /* 2s complement assumption */
2247 if (value <= (UV)IV_MIN) {
2248 SvIV_set(sv, -(IV)value);
2250 /* Too negative for an IV. This is a double upgrade, but
2251 I'm assuming it will be rare. */
2252 if (SvTYPE(sv) < SVt_PVNV)
2253 sv_upgrade(sv, SVt_PVNV);
2257 SvNV_set(sv, -(NV)value);
2258 SvIV_set(sv, IV_MIN);
2262 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2263 will be in the previous block to set the IV slot, and the next
2264 block to set the NV slot. So no else here. */
2266 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2267 != IS_NUMBER_IN_UV) {
2268 /* It wasn't an (integer that doesn't overflow the UV). */
2269 SvNV_set(sv, Atof(SvPVX_const(sv)));
2271 if (! numtype && ckWARN(WARN_NUMERIC))
2274 #if defined(USE_LONG_DOUBLE)
2275 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2276 PTR2UV(sv), SvNVX(sv)));
2278 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2279 PTR2UV(sv), SvNVX(sv)));
2283 #ifdef NV_PRESERVES_UV
2284 (void)SvIOKp_on(sv);
2286 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2287 SvIV_set(sv, I_V(SvNVX(sv)));
2288 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2291 /* Integer is imprecise. NOK, IOKp */
2293 /* UV will not work better than IV */
2295 if (SvNVX(sv) > (NV)UV_MAX) {
2297 /* Integer is inaccurate. NOK, IOKp, is UV */
2298 SvUV_set(sv, UV_MAX);
2301 SvUV_set(sv, U_V(SvNVX(sv)));
2302 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2303 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2307 /* Integer is imprecise. NOK, IOKp, is UV */
2313 #else /* NV_PRESERVES_UV */
2314 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2315 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2316 /* The IV slot will have been set from value returned by
2317 grok_number above. The NV slot has just been set using
2320 assert (SvIOKp(sv));
2322 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2323 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2324 /* Small enough to preserve all bits. */
2325 (void)SvIOKp_on(sv);
2327 SvIV_set(sv, I_V(SvNVX(sv)));
2328 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2330 /* Assumption: first non-preserved integer is < IV_MAX,
2331 this NV is in the preserved range, therefore: */
2332 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2334 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);
2338 0 0 already failed to read UV.
2339 0 1 already failed to read UV.
2340 1 0 you won't get here in this case. IV/UV
2341 slot set, public IOK, Atof() unneeded.
2342 1 1 already read UV.
2343 so there's no point in sv_2iuv_non_preserve() attempting
2344 to use atol, strtol, strtoul etc. */
2345 if (sv_2iuv_non_preserve (sv, numtype)
2346 >= IS_NUMBER_OVERFLOW_IV)
2350 #endif /* NV_PRESERVES_UV */
2353 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2355 if (SvTYPE(sv) < SVt_IV)
2356 /* Typically the caller expects that sv_any is not NULL now. */
2357 sv_upgrade(sv, SVt_IV);
2360 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2361 PTR2UV(sv),SvIVX(sv)));
2362 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2365 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2366 * this function provided for binary compatibility only
2370 Perl_sv_2uv(pTHX_ register SV *sv)
2372 return sv_2uv_flags(sv, SV_GMAGIC);
2376 =for apidoc sv_2uv_flags
2378 Return the unsigned integer value of an SV, doing any necessary string
2379 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2380 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2386 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2390 if (SvGMAGICAL(sv)) {
2391 if (flags & SV_GMAGIC)
2396 return U_V(SvNVX(sv));
2397 if (SvPOKp(sv) && SvLEN(sv))
2400 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2401 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2407 if (SvTHINKFIRST(sv)) {
2410 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2411 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2412 return SvUV(tmpstr);
2413 return PTR2UV(SvRV(sv));
2416 sv_force_normal_flags(sv, 0);
2418 if (SvREADONLY(sv) && !SvOK(sv)) {
2419 if (ckWARN(WARN_UNINITIALIZED))
2429 return (UV)SvIVX(sv);
2433 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2434 * without also getting a cached IV/UV from it at the same time
2435 * (ie PV->NV conversion should detect loss of accuracy and cache
2436 * IV or UV at same time to avoid this. */
2437 /* IV-over-UV optimisation - choose to cache IV if possible */
2439 if (SvTYPE(sv) == SVt_NV)
2440 sv_upgrade(sv, SVt_PVNV);
2442 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2443 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2444 SvIV_set(sv, I_V(SvNVX(sv)));
2445 if (SvNVX(sv) == (NV) SvIVX(sv)
2446 #ifndef NV_PRESERVES_UV
2447 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2448 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2449 /* Don't flag it as "accurately an integer" if the number
2450 came from a (by definition imprecise) NV operation, and
2451 we're outside the range of NV integer precision */
2454 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2455 DEBUG_c(PerlIO_printf(Perl_debug_log,
2456 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2462 /* IV not precise. No need to convert from PV, as NV
2463 conversion would already have cached IV if it detected
2464 that PV->IV would be better than PV->NV->IV
2465 flags already correct - don't set public IOK. */
2466 DEBUG_c(PerlIO_printf(Perl_debug_log,
2467 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2472 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2473 but the cast (NV)IV_MIN rounds to a the value less (more
2474 negative) than IV_MIN which happens to be equal to SvNVX ??
2475 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2476 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2477 (NV)UVX == NVX are both true, but the values differ. :-(
2478 Hopefully for 2s complement IV_MIN is something like
2479 0x8000000000000000 which will be exact. NWC */
2482 SvUV_set(sv, U_V(SvNVX(sv)));
2484 (SvNVX(sv) == (NV) SvUVX(sv))
2485 #ifndef NV_PRESERVES_UV
2486 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2487 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2488 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2489 /* Don't flag it as "accurately an integer" if the number
2490 came from a (by definition imprecise) NV operation, and
2491 we're outside the range of NV integer precision */
2496 DEBUG_c(PerlIO_printf(Perl_debug_log,
2497 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2503 else if (SvPOKp(sv) && SvLEN(sv)) {
2505 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2507 /* We want to avoid a possible problem when we cache a UV which
2508 may be later translated to an NV, and the resulting NV is not
2509 the translation of the initial data.
2511 This means that if we cache such a UV, we need to cache the
2512 NV as well. Moreover, we trade speed for space, and do not
2513 cache the NV if not needed.
2516 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2517 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2518 == IS_NUMBER_IN_UV) {
2519 /* It's definitely an integer, only upgrade to PVIV */
2520 if (SvTYPE(sv) < SVt_PVIV)
2521 sv_upgrade(sv, SVt_PVIV);
2523 } else if (SvTYPE(sv) < SVt_PVNV)
2524 sv_upgrade(sv, SVt_PVNV);
2526 /* If NV preserves UV then we only use the UV value if we know that
2527 we aren't going to call atof() below. If NVs don't preserve UVs
2528 then the value returned may have more precision than atof() will
2529 return, even though it isn't accurate. */
2530 if ((numtype & (IS_NUMBER_IN_UV
2531 #ifdef NV_PRESERVES_UV
2534 )) == IS_NUMBER_IN_UV) {
2535 /* This won't turn off the public IOK flag if it was set above */
2536 (void)SvIOKp_on(sv);
2538 if (!(numtype & IS_NUMBER_NEG)) {
2540 if (value <= (UV)IV_MAX) {
2541 SvIV_set(sv, (IV)value);
2543 /* it didn't overflow, and it was positive. */
2544 SvUV_set(sv, value);
2548 /* 2s complement assumption */
2549 if (value <= (UV)IV_MIN) {
2550 SvIV_set(sv, -(IV)value);
2552 /* Too negative for an IV. This is a double upgrade, but
2553 I'm assuming it will be rare. */
2554 if (SvTYPE(sv) < SVt_PVNV)
2555 sv_upgrade(sv, SVt_PVNV);
2559 SvNV_set(sv, -(NV)value);
2560 SvIV_set(sv, IV_MIN);
2565 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2566 != IS_NUMBER_IN_UV) {
2567 /* It wasn't an integer, or it overflowed the UV. */
2568 SvNV_set(sv, Atof(SvPVX_const(sv)));
2570 if (! numtype && ckWARN(WARN_NUMERIC))
2573 #if defined(USE_LONG_DOUBLE)
2574 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2575 PTR2UV(sv), SvNVX(sv)));
2577 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2578 PTR2UV(sv), SvNVX(sv)));
2581 #ifdef NV_PRESERVES_UV
2582 (void)SvIOKp_on(sv);
2584 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2585 SvIV_set(sv, I_V(SvNVX(sv)));
2586 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2589 /* Integer is imprecise. NOK, IOKp */
2591 /* UV will not work better than IV */
2593 if (SvNVX(sv) > (NV)UV_MAX) {
2595 /* Integer is inaccurate. NOK, IOKp, is UV */
2596 SvUV_set(sv, UV_MAX);
2599 SvUV_set(sv, U_V(SvNVX(sv)));
2600 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2601 NV preservse UV so can do correct comparison. */
2602 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2606 /* Integer is imprecise. NOK, IOKp, is UV */
2611 #else /* NV_PRESERVES_UV */
2612 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2613 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2614 /* The UV slot will have been set from value returned by
2615 grok_number above. The NV slot has just been set using
2618 assert (SvIOKp(sv));
2620 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2621 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2622 /* Small enough to preserve all bits. */
2623 (void)SvIOKp_on(sv);
2625 SvIV_set(sv, I_V(SvNVX(sv)));
2626 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2628 /* Assumption: first non-preserved integer is < IV_MAX,
2629 this NV is in the preserved range, therefore: */
2630 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2632 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);
2635 sv_2iuv_non_preserve (sv, numtype);
2637 #endif /* NV_PRESERVES_UV */
2641 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2642 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2645 if (SvTYPE(sv) < SVt_IV)
2646 /* Typically the caller expects that sv_any is not NULL now. */
2647 sv_upgrade(sv, SVt_IV);
2651 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2652 PTR2UV(sv),SvUVX(sv)));
2653 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2659 Return the num value of an SV, doing any necessary string or integer
2660 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2667 Perl_sv_2nv(pTHX_ register SV *sv)
2671 if (SvGMAGICAL(sv)) {
2675 if (SvPOKp(sv) && SvLEN(sv)) {
2676 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2677 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2679 return Atof(SvPVX_const(sv));
2683 return (NV)SvUVX(sv);
2685 return (NV)SvIVX(sv);
2688 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2689 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2695 if (SvTHINKFIRST(sv)) {
2698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2699 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2700 return SvNV(tmpstr);
2701 return PTR2NV(SvRV(sv));
2704 sv_force_normal_flags(sv, 0);
2706 if (SvREADONLY(sv) && !SvOK(sv)) {
2707 if (ckWARN(WARN_UNINITIALIZED))
2712 if (SvTYPE(sv) < SVt_NV) {
2713 if (SvTYPE(sv) == SVt_IV)
2714 sv_upgrade(sv, SVt_PVNV);
2716 sv_upgrade(sv, SVt_NV);
2717 #ifdef USE_LONG_DOUBLE
2719 STORE_NUMERIC_LOCAL_SET_STANDARD();
2720 PerlIO_printf(Perl_debug_log,
2721 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2722 PTR2UV(sv), SvNVX(sv));
2723 RESTORE_NUMERIC_LOCAL();
2727 STORE_NUMERIC_LOCAL_SET_STANDARD();
2728 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2729 PTR2UV(sv), SvNVX(sv));
2730 RESTORE_NUMERIC_LOCAL();
2734 else if (SvTYPE(sv) < SVt_PVNV)
2735 sv_upgrade(sv, SVt_PVNV);
2740 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2741 #ifdef NV_PRESERVES_UV
2744 /* Only set the public NV OK flag if this NV preserves the IV */
2745 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2746 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2747 : (SvIVX(sv) == I_V(SvNVX(sv))))
2753 else if (SvPOKp(sv) && SvLEN(sv)) {
2755 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2756 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2758 #ifdef NV_PRESERVES_UV
2759 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2760 == IS_NUMBER_IN_UV) {
2761 /* It's definitely an integer */
2762 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2764 SvNV_set(sv, Atof(SvPVX_const(sv)));
2767 SvNV_set(sv, Atof(SvPVX_const(sv)));
2768 /* Only set the public NV OK flag if this NV preserves the value in
2769 the PV at least as well as an IV/UV would.
2770 Not sure how to do this 100% reliably. */
2771 /* if that shift count is out of range then Configure's test is
2772 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2774 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2775 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2776 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2777 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2778 /* Can't use strtol etc to convert this string, so don't try.
2779 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2782 /* value has been set. It may not be precise. */
2783 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2784 /* 2s complement assumption for (UV)IV_MIN */
2785 SvNOK_on(sv); /* Integer is too negative. */
2790 if (numtype & IS_NUMBER_NEG) {
2791 SvIV_set(sv, -(IV)value);
2792 } else if (value <= (UV)IV_MAX) {
2793 SvIV_set(sv, (IV)value);
2795 SvUV_set(sv, value);
2799 if (numtype & IS_NUMBER_NOT_INT) {
2800 /* I believe that even if the original PV had decimals,
2801 they are lost beyond the limit of the FP precision.
2802 However, neither is canonical, so both only get p
2803 flags. NWC, 2000/11/25 */
2804 /* Both already have p flags, so do nothing */
2806 const NV nv = SvNVX(sv);
2807 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2808 if (SvIVX(sv) == I_V(nv)) {
2813 /* It had no "." so it must be integer. */
2816 /* between IV_MAX and NV(UV_MAX).
2817 Could be slightly > UV_MAX */
2819 if (numtype & IS_NUMBER_NOT_INT) {
2820 /* UV and NV both imprecise. */
2822 const UV nv_as_uv = U_V(nv);
2824 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2835 #endif /* NV_PRESERVES_UV */
2838 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2840 if (SvTYPE(sv) < SVt_NV)
2841 /* Typically the caller expects that sv_any is not NULL now. */
2842 /* XXX Ilya implies that this is a bug in callers that assume this
2843 and ideally should be fixed. */
2844 sv_upgrade(sv, SVt_NV);
2847 #if defined(USE_LONG_DOUBLE)
2849 STORE_NUMERIC_LOCAL_SET_STANDARD();
2850 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2851 PTR2UV(sv), SvNVX(sv));
2852 RESTORE_NUMERIC_LOCAL();
2856 STORE_NUMERIC_LOCAL_SET_STANDARD();
2857 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2858 PTR2UV(sv), SvNVX(sv));
2859 RESTORE_NUMERIC_LOCAL();
2865 /* asIV(): extract an integer from the string value of an SV.
2866 * Caller must validate PVX */
2869 S_asIV(pTHX_ SV *sv)
2872 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2874 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2875 == IS_NUMBER_IN_UV) {
2876 /* It's definitely an integer */
2877 if (numtype & IS_NUMBER_NEG) {
2878 if (value < (UV)IV_MIN)
2881 if (value < (UV)IV_MAX)
2886 if (ckWARN(WARN_NUMERIC))
2889 return I_V(Atof(SvPVX_const(sv)));
2892 /* asUV(): extract an unsigned integer from the string value of an SV
2893 * Caller must validate PVX */
2896 S_asUV(pTHX_ SV *sv)
2899 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2901 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2902 == IS_NUMBER_IN_UV) {
2903 /* It's definitely an integer */
2904 if (!(numtype & IS_NUMBER_NEG))
2908 if (ckWARN(WARN_NUMERIC))
2911 return U_V(Atof(SvPVX_const(sv)));
2915 =for apidoc sv_2pv_nolen
2917 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2918 use the macro wrapper C<SvPV_nolen(sv)> instead.
2923 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2925 return sv_2pv(sv, 0);
2928 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2929 * UV as a string towards the end of buf, and return pointers to start and
2932 * We assume that buf is at least TYPE_CHARS(UV) long.
2936 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2938 char *ptr = buf + TYPE_CHARS(UV);
2939 char * const ebuf = ptr;
2952 *--ptr = '0' + (char)(uv % 10);
2961 =for apidoc sv_2pv_flags
2963 Returns a pointer to the string value of an SV, and sets *lp to its length.
2964 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2966 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2967 usually end up here too.
2973 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2978 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2979 char *tmpbuf = tbuf;
2986 if (SvGMAGICAL(sv)) {
2987 if (flags & SV_GMAGIC)
2992 if (flags & SV_MUTABLE_RETURN)
2993 return SvPVX_mutable(sv);
2994 if (flags & SV_CONST_RETURN)
2995 return (char *)SvPVX_const(sv);
3000 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3002 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3007 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3012 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3013 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3021 if (SvTHINKFIRST(sv)) {
3024 register const char *typestr;
3025 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3026 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3028 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3031 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3032 if (flags & SV_CONST_RETURN) {
3033 pv = (char *) SvPVX_const(tmpstr);
3035 pv = (flags & SV_MUTABLE_RETURN)
3036 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3039 *lp = SvCUR(tmpstr);
3041 pv = sv_2pv_flags(tmpstr, lp, flags);
3052 typestr = "NULLREF";
3056 switch (SvTYPE(sv)) {
3058 if ( ((SvFLAGS(sv) &
3059 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3060 == (SVs_OBJECT|SVs_SMG))
3061 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3062 const regexp *re = (regexp *)mg->mg_obj;
3065 const char *fptr = "msix";
3070 char need_newline = 0;
3071 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3073 while((ch = *fptr++)) {
3075 reflags[left++] = ch;
3078 reflags[right--] = ch;
3083 reflags[left] = '-';
3087 mg->mg_len = re->prelen + 4 + left;
3089 * If /x was used, we have to worry about a regex
3090 * ending with a comment later being embedded
3091 * within another regex. If so, we don't want this
3092 * regex's "commentization" to leak out to the
3093 * right part of the enclosing regex, we must cap
3094 * it with a newline.
3096 * So, if /x was used, we scan backwards from the
3097 * end of the regex. If we find a '#' before we
3098 * find a newline, we need to add a newline
3099 * ourself. If we find a '\n' first (or if we
3100 * don't find '#' or '\n'), we don't need to add
3101 * anything. -jfriedl
3103 if (PMf_EXTENDED & re->reganch)
3105 const char *endptr = re->precomp + re->prelen;
3106 while (endptr >= re->precomp)
3108 const char c = *(endptr--);
3110 break; /* don't need another */
3112 /* we end while in a comment, so we
3114 mg->mg_len++; /* save space for it */
3115 need_newline = 1; /* note to add it */
3121 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3122 Copy("(?", mg->mg_ptr, 2, char);
3123 Copy(reflags, mg->mg_ptr+2, left, char);
3124 Copy(":", mg->mg_ptr+left+2, 1, char);
3125 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3127 mg->mg_ptr[mg->mg_len - 2] = '\n';
3128 mg->mg_ptr[mg->mg_len - 1] = ')';
3129 mg->mg_ptr[mg->mg_len] = 0;
3131 PL_reginterp_cnt += re->program[0].next_off;
3133 if (re->reganch & ROPT_UTF8)
3149 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3150 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3151 /* tied lvalues should appear to be
3152 * scalars for backwards compatitbility */
3153 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3154 ? "SCALAR" : "LVALUE"; break;
3155 case SVt_PVAV: typestr = "ARRAY"; break;
3156 case SVt_PVHV: typestr = "HASH"; break;
3157 case SVt_PVCV: typestr = "CODE"; break;
3158 case SVt_PVGV: typestr = "GLOB"; break;
3159 case SVt_PVFM: typestr = "FORMAT"; break;
3160 case SVt_PVIO: typestr = "IO"; break;
3161 default: typestr = "UNKNOWN"; break;
3165 const char *name = HvNAME_get(SvSTASH(sv));
3166 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3167 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3170 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3174 *lp = strlen(typestr);
3175 return (char *)typestr;
3177 if (SvREADONLY(sv) && !SvOK(sv)) {
3178 if (ckWARN(WARN_UNINITIALIZED))
3185 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3186 /* I'm assuming that if both IV and NV are equally valid then
3187 converting the IV is going to be more efficient */
3188 const U32 isIOK = SvIOK(sv);
3189 const U32 isUIOK = SvIsUV(sv);
3190 char buf[TYPE_CHARS(UV)];
3193 if (SvTYPE(sv) < SVt_PVIV)
3194 sv_upgrade(sv, SVt_PVIV);
3196 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3198 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3199 /* inlined from sv_setpvn */
3200 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3201 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3202 SvCUR_set(sv, ebuf - ptr);
3212 else if (SvNOKp(sv)) {
3213 if (SvTYPE(sv) < SVt_PVNV)
3214 sv_upgrade(sv, SVt_PVNV);
3215 /* The +20 is pure guesswork. Configure test needed. --jhi */
3216 s = SvGROW_mutable(sv, NV_DIG + 20);
3217 olderrno = errno; /* some Xenix systems wipe out errno here */
3219 if (SvNVX(sv) == 0.0)
3220 (void)strcpy(s,"0");
3224 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3227 #ifdef FIXNEGATIVEZERO
3228 if (*s == '-' && s[1] == '0' && !s[2])
3238 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3242 if (SvTYPE(sv) < SVt_PV)
3243 /* Typically the caller expects that sv_any is not NULL now. */
3244 sv_upgrade(sv, SVt_PV);
3248 const STRLEN len = s - SvPVX_const(sv);
3254 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3255 PTR2UV(sv),SvPVX_const(sv)));
3256 if (flags & SV_CONST_RETURN)
3257 return (char *)SvPVX_const(sv);
3258 if (flags & SV_MUTABLE_RETURN)
3259 return SvPVX_mutable(sv);
3263 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3264 /* Sneaky stuff here */
3268 tsv = newSVpv(tmpbuf, 0);
3281 t = SvPVX_const(tsv);
3286 len = strlen(tmpbuf);
3288 #ifdef FIXNEGATIVEZERO
3289 if (len == 2 && t[0] == '-' && t[1] == '0') {
3294 SvUPGRADE(sv, SVt_PV);
3297 s = SvGROW_mutable(sv, len + 1);
3300 return memcpy(s, t, len + 1);
3305 =for apidoc sv_copypv
3307 Copies a stringified representation of the source SV into the
3308 destination SV. Automatically performs any necessary mg_get and
3309 coercion of numeric values into strings. Guaranteed to preserve
3310 UTF-8 flag even from overloaded objects. Similar in nature to
3311 sv_2pv[_flags] but operates directly on an SV instead of just the
3312 string. Mostly uses sv_2pv_flags to do its work, except when that
3313 would lose the UTF-8'ness of the PV.
3319 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3322 const char * const s = SvPV_const(ssv,len);
3323 sv_setpvn(dsv,s,len);
3331 =for apidoc sv_2pvbyte_nolen
3333 Return a pointer to the byte-encoded representation of the SV.
3334 May cause the SV to be downgraded from UTF-8 as a side-effect.
3336 Usually accessed via the C<SvPVbyte_nolen> macro.
3342 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3344 return sv_2pvbyte(sv, 0);
3348 =for apidoc sv_2pvbyte
3350 Return a pointer to the byte-encoded representation of the SV, and set *lp
3351 to its length. May cause the SV to be downgraded from UTF-8 as a
3354 Usually accessed via the C<SvPVbyte> macro.
3360 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3362 sv_utf8_downgrade(sv,0);
3363 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3367 =for apidoc sv_2pvutf8_nolen
3369 Return a pointer to the UTF-8-encoded representation of the SV.
3370 May cause the SV to be upgraded to UTF-8 as a side-effect.
3372 Usually accessed via the C<SvPVutf8_nolen> macro.
3378 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3380 return sv_2pvutf8(sv, 0);
3384 * =for apidoc sv_2pvutf8
3386 * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3387 * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3389 * Usually accessed via the C<SvPVutf8> macro.
3395 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3397 sv_utf8_upgrade(sv);
3398 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3403 =for apidoc sv_2bool
3405 This function is only called on magical items, and is only used by
3406 sv_true() or its macro equivalent.
3412 Perl_sv_2bool(pTHX_ register SV *sv)
3420 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3421 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3422 return (bool)SvTRUE(tmpsv);
3423 return SvRV(sv) != 0;
3426 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3428 (*sv->sv_u.svu_pv > '0' ||
3429 Xpvtmp->xpv_cur > 1 ||
3430 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3437 return SvIVX(sv) != 0;
3440 return SvNVX(sv) != 0.0;
3447 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3448 * this function provided for binary compatibility only
3453 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3455 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3459 =for apidoc sv_utf8_upgrade
3461 Converts the PV of an SV to its UTF-8-encoded form.
3462 Forces the SV to string form if it is not already.
3463 Always sets the SvUTF8 flag to avoid future validity checks even
3464 if all the bytes have hibit clear.
3466 This is not as a general purpose byte encoding to Unicode interface:
3467 use the Encode extension for that.
3469 =for apidoc sv_utf8_upgrade_flags
3471 Converts the PV of an SV to its UTF-8-encoded form.
3472 Forces the SV to string form if it is not already.
3473 Always sets the SvUTF8 flag to avoid future validity checks even
3474 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3475 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3476 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3478 This is not as a general purpose byte encoding to Unicode interface:
3479 use the Encode extension for that.
3485 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3487 if (sv == &PL_sv_undef)
3491 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3492 (void) sv_2pv_flags(sv,&len, flags);
3496 (void) SvPV_force(sv,len);
3505 sv_force_normal_flags(sv, 0);
3508 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3509 sv_recode_to_utf8(sv, PL_encoding);
3510 else { /* Assume Latin-1/EBCDIC */
3511 /* This function could be much more efficient if we
3512 * had a FLAG in SVs to signal if there are any hibit
3513 * chars in the PV. Given that there isn't such a flag
3514 * make the loop as fast as possible. */
3515 const U8 *s = (U8 *) SvPVX_const(sv);
3516 const U8 *e = (U8 *) SvEND(sv);
3522 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3526 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3527 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3529 SvPV_free(sv); /* No longer using what was there before. */
3531 SvPV_set(sv, (char*)recoded);
3532 SvCUR_set(sv, len - 1);
3533 SvLEN_set(sv, len); /* No longer know the real size. */
3535 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3542 =for apidoc sv_utf8_downgrade
3544 Attempts to convert the PV of an SV from characters to bytes.
3545 If the PV contains a character beyond byte, this conversion will fail;
3546 in this case, either returns false or, if C<fail_ok> is not
3549 This is not as a general purpose Unicode to byte encoding interface:
3550 use the Encode extension for that.
3556 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3558 if (SvPOKp(sv) && SvUTF8(sv)) {
3564 sv_force_normal_flags(sv, 0);
3566 s = (U8 *) SvPV(sv, len);
3567 if (!utf8_to_bytes(s, &len)) {
3572 Perl_croak(aTHX_ "Wide character in %s",
3575 Perl_croak(aTHX_ "Wide character");
3586 =for apidoc sv_utf8_encode
3588 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3589 flag off so that it looks like octets again.
3595 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3597 (void) sv_utf8_upgrade(sv);
3599 sv_force_normal_flags(sv, 0);
3601 if (SvREADONLY(sv)) {
3602 Perl_croak(aTHX_ PL_no_modify);
3608 =for apidoc sv_utf8_decode
3610 If the PV of the SV is an octet sequence in UTF-8
3611 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3612 so that it looks like a character. If the PV contains only single-byte
3613 characters, the C<SvUTF8> flag stays being off.
3614 Scans PV for validity and returns false if the PV is invalid UTF-8.
3620 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3626 /* The octets may have got themselves encoded - get them back as
3629 if (!sv_utf8_downgrade(sv, TRUE))
3632 /* it is actually just a matter of turning the utf8 flag on, but
3633 * we want to make sure everything inside is valid utf8 first.
3635 c = (const U8 *) SvPVX_const(sv);
3636 if (!is_utf8_string(c, SvCUR(sv)+1))
3638 e = (const U8 *) SvEND(sv);
3641 if (!UTF8_IS_INVARIANT(ch)) {
3651 =for apidoc sv_setsv
3653 Copies the contents of the source SV C<ssv> into the destination SV
3654 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3655 function if the source SV needs to be reused. Does not handle 'set' magic.
3656 Loosely speaking, it performs a copy-by-value, obliterating any previous
3657 content of the destination.
3659 You probably want to use one of the assortment of wrappers, such as
3660 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3661 C<SvSetMagicSV_nosteal>.
3663 =for apidoc sv_setsv_flags
3665 Copies the contents of the source SV C<ssv> into the destination SV
3666 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3667 function if the source SV needs to be reused. Does not handle 'set' magic.
3668 Loosely speaking, it performs a copy-by-value, obliterating any previous
3669 content of the destination.
3670 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3671 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3672 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3673 and C<sv_setsv_nomg> are implemented in terms of this function.
3675 You probably want to use one of the assortment of wrappers, such as
3676 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3677 C<SvSetMagicSV_nosteal>.
3679 This is the primary function for copying scalars, and most other
3680 copy-ish functions and macros use this underneath.
3686 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3688 register U32 sflags;
3694 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3696 sstr = &PL_sv_undef;
3697 stype = SvTYPE(sstr);
3698 dtype = SvTYPE(dstr);
3703 /* need to nuke the magic */
3705 SvRMAGICAL_off(dstr);
3708 /* There's a lot of redundancy below but we're going for speed here */
3713 if (dtype != SVt_PVGV) {
3714 (void)SvOK_off(dstr);
3722 sv_upgrade(dstr, SVt_IV);
3725 sv_upgrade(dstr, SVt_PVNV);
3729 sv_upgrade(dstr, SVt_PVIV);
3732 (void)SvIOK_only(dstr);
3733 SvIV_set(dstr, SvIVX(sstr));
3736 if (SvTAINTED(sstr))
3747 sv_upgrade(dstr, SVt_NV);
3752 sv_upgrade(dstr, SVt_PVNV);
3755 SvNV_set(dstr, SvNVX(sstr));
3756 (void)SvNOK_only(dstr);
3757 if (SvTAINTED(sstr))
3765 sv_upgrade(dstr, SVt_RV);
3766 else if (dtype == SVt_PVGV &&
3767 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3770 if (GvIMPORTED(dstr) != GVf_IMPORTED
3771 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3773 GvIMPORTED_on(dstr);
3782 #ifdef PERL_OLD_COPY_ON_WRITE
3783 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3784 if (dtype < SVt_PVIV)
3785 sv_upgrade(dstr, SVt_PVIV);
3792 sv_upgrade(dstr, SVt_PV);
3795 if (dtype < SVt_PVIV)
3796 sv_upgrade(dstr, SVt_PVIV);
3799 if (dtype < SVt_PVNV)
3800 sv_upgrade(dstr, SVt_PVNV);
3807 const char * const type = sv_reftype(sstr,0);
3809 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3811 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3816 if (dtype <= SVt_PVGV) {
3818 if (dtype != SVt_PVGV) {
3819 const char * const name = GvNAME(sstr);
3820 const STRLEN len = GvNAMELEN(sstr);
3821 /* don't upgrade SVt_PVLV: it can hold a glob */
3822 if (dtype != SVt_PVLV)
3823 sv_upgrade(dstr, SVt_PVGV);
3824 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3825 GvSTASH(dstr) = GvSTASH(sstr);
3827 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3828 GvNAME(dstr) = savepvn(name, len);
3829 GvNAMELEN(dstr) = len;
3830 SvFAKE_on(dstr); /* can coerce to non-glob */
3832 /* ahem, death to those who redefine active sort subs */
3833 else if (PL_curstackinfo->si_type == PERLSI_SORT
3834 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3835 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3838 #ifdef GV_UNIQUE_CHECK
3839 if (GvUNIQUE((GV*)dstr)) {
3840 Perl_croak(aTHX_ PL_no_modify);
3844 (void)SvOK_off(dstr);
3845 GvINTRO_off(dstr); /* one-shot flag */
3847 GvGP(dstr) = gp_ref(GvGP(sstr));
3848 if (SvTAINTED(sstr))
3850 if (GvIMPORTED(dstr) != GVf_IMPORTED
3851 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3853 GvIMPORTED_on(dstr);
3861 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3863 if ((int)SvTYPE(sstr) != stype) {
3864 stype = SvTYPE(sstr);
3865 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3869 if (stype == SVt_PVLV)
3870 SvUPGRADE(dstr, SVt_PVNV);
3872 SvUPGRADE(dstr, (U32)stype);
3875 sflags = SvFLAGS(sstr);
3877 if (sflags & SVf_ROK) {
3878 if (dtype >= SVt_PV) {
3879 if (dtype == SVt_PVGV) {
3880 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3882 const int intro = GvINTRO(dstr);
3884 #ifdef GV_UNIQUE_CHECK
3885 if (GvUNIQUE((GV*)dstr)) {
3886 Perl_croak(aTHX_ PL_no_modify);
3891 GvINTRO_off(dstr); /* one-shot flag */
3892 GvLINE(dstr) = CopLINE(PL_curcop);
3893 GvEGV(dstr) = (GV*)dstr;
3896 switch (SvTYPE(sref)) {
3899 SAVEGENERICSV(GvAV(dstr));
3901 dref = (SV*)GvAV(dstr);
3902 GvAV(dstr) = (AV*)sref;
3903 if (!GvIMPORTED_AV(dstr)
3904 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3906 GvIMPORTED_AV_on(dstr);
3911 SAVEGENERICSV(GvHV(dstr));
3913 dref = (SV*)GvHV(dstr);
3914 GvHV(dstr) = (HV*)sref;
3915 if (!GvIMPORTED_HV(dstr)
3916 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3918 GvIMPORTED_HV_on(dstr);
3923 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3924 SvREFCNT_dec(GvCV(dstr));
3925 GvCV(dstr) = Nullcv;
3926 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3927 PL_sub_generation++;
3929 SAVEGENERICSV(GvCV(dstr));
3932 dref = (SV*)GvCV(dstr);
3933 if (GvCV(dstr) != (CV*)sref) {
3934 CV* const cv = GvCV(dstr);
3936 if (!GvCVGEN((GV*)dstr) &&
3937 (CvROOT(cv) || CvXSUB(cv)))
3939 /* ahem, death to those who redefine
3940 * active sort subs */
3941 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3942 PL_sortcop == CvSTART(cv))
3944 "Can't redefine active sort subroutine %s",
3945 GvENAME((GV*)dstr));
3946 /* Redefining a sub - warning is mandatory if
3947 it was a const and its value changed. */
3948 if (ckWARN(WARN_REDEFINE)
3950 && (!CvCONST((CV*)sref)
3951 || sv_cmp(cv_const_sv(cv),
3952 cv_const_sv((CV*)sref)))))
3954 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3956 ? "Constant subroutine %s::%s redefined"
3957 : "Subroutine %s::%s redefined",
3958 HvNAME_get(GvSTASH((GV*)dstr)),
3959 GvENAME((GV*)dstr));
3963 cv_ckproto(cv, (GV*)dstr,
3965 ? SvPVX_const(sref) : Nullch);
3967 GvCV(dstr) = (CV*)sref;
3968 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3969 GvASSUMECV_on(dstr);
3970 PL_sub_generation++;
3972 if (!GvIMPORTED_CV(dstr)
3973 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3975 GvIMPORTED_CV_on(dstr);
3980 SAVEGENERICSV(GvIOp(dstr));
3982 dref = (SV*)GvIOp(dstr);
3983 GvIOp(dstr) = (IO*)sref;
3987 SAVEGENERICSV(GvFORM(dstr));
3989 dref = (SV*)GvFORM(dstr);
3990 GvFORM(dstr) = (CV*)sref;
3994 SAVEGENERICSV(GvSV(dstr));
3996 dref = (SV*)GvSV(dstr);
3998 if (!GvIMPORTED_SV(dstr)
3999 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4001 GvIMPORTED_SV_on(dstr);
4007 if (SvTAINTED(sstr))
4011 if (SvPVX_const(dstr)) {
4017 (void)SvOK_off(dstr);
4018 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4020 if (sflags & SVp_NOK) {
4022 /* Only set the public OK flag if the source has public OK. */
4023 if (sflags & SVf_NOK)
4024 SvFLAGS(dstr) |= SVf_NOK;
4025 SvNV_set(dstr, SvNVX(sstr));
4027 if (sflags & SVp_IOK) {
4028 (void)SvIOKp_on(dstr);
4029 if (sflags & SVf_IOK)
4030 SvFLAGS(dstr) |= SVf_IOK;
4031 if (sflags & SVf_IVisUV)
4033 SvIV_set(dstr, SvIVX(sstr));
4035 if (SvAMAGIC(sstr)) {
4039 else if (sflags & SVp_POK) {
4043 * Check to see if we can just swipe the string. If so, it's a
4044 * possible small lose on short strings, but a big win on long ones.
4045 * It might even be a win on short strings if SvPVX_const(dstr)
4046 * has to be allocated and SvPVX_const(sstr) has to be freed.
4049 /* Whichever path we take through the next code, we want this true,
4050 and doing it now facilitates the COW check. */
4051 (void)SvPOK_only(dstr);
4054 /* We're not already COW */
4055 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4056 #ifndef PERL_OLD_COPY_ON_WRITE
4057 /* or we are, but dstr isn't a suitable target. */
4058 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4063 (sflags & SVs_TEMP) && /* slated for free anyway? */
4064 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4065 (!(flags & SV_NOSTEAL)) &&
4066 /* and we're allowed to steal temps */
4067 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4068 SvLEN(sstr) && /* and really is a string */
4069 /* and won't be needed again, potentially */
4070 !(PL_op && PL_op->op_type == OP_AASSIGN))
4071 #ifdef PERL_OLD_COPY_ON_WRITE
4072 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4073 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4074 && SvTYPE(sstr) >= SVt_PVIV)
4077 /* Failed the swipe test, and it's not a shared hash key either.
4078 Have to copy the string. */
4079 STRLEN len = SvCUR(sstr);
4080 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4081 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4082 SvCUR_set(dstr, len);
4083 *SvEND(dstr) = '\0';
4085 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4087 /* Either it's a shared hash key, or it's suitable for
4088 copy-on-write or we can swipe the string. */
4090 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4094 #ifdef PERL_OLD_COPY_ON_WRITE
4096 /* I believe I should acquire a global SV mutex if
4097 it's a COW sv (not a shared hash key) to stop
4098 it going un copy-on-write.
4099 If the source SV has gone un copy on write between up there
4100 and down here, then (assert() that) it is of the correct
4101 form to make it copy on write again */
4102 if ((sflags & (SVf_FAKE | SVf_READONLY))
4103 != (SVf_FAKE | SVf_READONLY)) {
4104 SvREADONLY_on(sstr);
4106 /* Make the source SV into a loop of 1.
4107 (about to become 2) */
4108 SV_COW_NEXT_SV_SET(sstr, sstr);
4112 /* Initial code is common. */
4113 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4118 /* making another shared SV. */
4119 STRLEN cur = SvCUR(sstr);
4120 STRLEN len = SvLEN(sstr);
4121 #ifdef PERL_OLD_COPY_ON_WRITE
4123 assert (SvTYPE(dstr) >= SVt_PVIV);
4124 /* SvIsCOW_normal */
4125 /* splice us in between source and next-after-source. */
4126 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4127 SV_COW_NEXT_SV_SET(sstr, dstr);
4128 SvPV_set(dstr, SvPVX_mutable(sstr));
4132 /* SvIsCOW_shared_hash */
4133 DEBUG_C(PerlIO_printf(Perl_debug_log,
4134 "Copy on write: Sharing hash\n"));
4136 assert (SvTYPE(dstr) >= SVt_PV);
4138 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4140 SvLEN_set(dstr, len);
4141 SvCUR_set(dstr, cur);
4142 SvREADONLY_on(dstr);
4144 /* Relesase a global SV mutex. */
4147 { /* Passes the swipe test. */
4148 SvPV_set(dstr, SvPVX_mutable(sstr));
4149 SvLEN_set(dstr, SvLEN(sstr));
4150 SvCUR_set(dstr, SvCUR(sstr));
4153 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4154 SvPV_set(sstr, Nullch);
4160 if (sflags & SVf_UTF8)
4162 if (sflags & SVp_NOK) {
4164 if (sflags & SVf_NOK)
4165 SvFLAGS(dstr) |= SVf_NOK;
4166 SvNV_set(dstr, SvNVX(sstr));
4168 if (sflags & SVp_IOK) {
4169 (void)SvIOKp_on(dstr);
4170 if (sflags & SVf_IOK)
4171 SvFLAGS(dstr) |= SVf_IOK;
4172 if (sflags & SVf_IVisUV)
4174 SvIV_set(dstr, SvIVX(sstr));
4177 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4178 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4179 smg->mg_ptr, smg->mg_len);
4180 SvRMAGICAL_on(dstr);
4183 else if (sflags & SVp_IOK) {
4184 if (sflags & SVf_IOK)
4185 (void)SvIOK_only(dstr);
4187 (void)SvOK_off(dstr);
4188 (void)SvIOKp_on(dstr);
4190 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4191 if (sflags & SVf_IVisUV)
4193 SvIV_set(dstr, SvIVX(sstr));
4194 if (sflags & SVp_NOK) {
4195 if (sflags & SVf_NOK)
4196 (void)SvNOK_on(dstr);
4198 (void)SvNOKp_on(dstr);
4199 SvNV_set(dstr, SvNVX(sstr));
4202 else if (sflags & SVp_NOK) {
4203 if (sflags & SVf_NOK)
4204 (void)SvNOK_only(dstr);
4206 (void)SvOK_off(dstr);
4209 SvNV_set(dstr, SvNVX(sstr));
4212 if (dtype == SVt_PVGV) {
4213 if (ckWARN(WARN_MISC))
4214 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4217 (void)SvOK_off(dstr);
4219 if (SvTAINTED(sstr))
4224 =for apidoc sv_setsv_mg
4226 Like C<sv_setsv>, but also handles 'set' magic.
4232 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4234 sv_setsv(dstr,sstr);
4238 #ifdef PERL_OLD_COPY_ON_WRITE
4240 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4242 STRLEN cur = SvCUR(sstr);
4243 STRLEN len = SvLEN(sstr);
4244 register char *new_pv;
4247 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4255 if (SvTHINKFIRST(dstr))
4256 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4257 else if (SvPVX_const(dstr))
4258 Safefree(SvPVX_const(dstr));
4262 SvUPGRADE(dstr, SVt_PVIV);
4264 assert (SvPOK(sstr));
4265 assert (SvPOKp(sstr));
4266 assert (!SvIOK(sstr));
4267 assert (!SvIOKp(sstr));
4268 assert (!SvNOK(sstr));
4269 assert (!SvNOKp(sstr));
4271 if (SvIsCOW(sstr)) {
4273 if (SvLEN(sstr) == 0) {
4274 /* source is a COW shared hash key. */
4275 DEBUG_C(PerlIO_printf(Perl_debug_log,
4276 "Fast copy on write: Sharing hash\n"));
4277 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4280 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4282 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4283 SvUPGRADE(sstr, SVt_PVIV);
4284 SvREADONLY_on(sstr);
4286 DEBUG_C(PerlIO_printf(Perl_debug_log,
4287 "Fast copy on write: Converting sstr to COW\n"));
4288 SV_COW_NEXT_SV_SET(dstr, sstr);
4290 SV_COW_NEXT_SV_SET(sstr, dstr);
4291 new_pv = SvPVX_mutable(sstr);
4294 SvPV_set(dstr, new_pv);
4295 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4298 SvLEN_set(dstr, len);
4299 SvCUR_set(dstr, cur);
4308 =for apidoc sv_setpvn
4310 Copies a string into an SV. The C<len> parameter indicates the number of
4311 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4312 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4318 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4320 register char *dptr;
4322 SV_CHECK_THINKFIRST_COW_DROP(sv);
4328 /* len is STRLEN which is unsigned, need to copy to signed */
4331 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4333 SvUPGRADE(sv, SVt_PV);
4335 dptr = SvGROW(sv, len + 1);
4336 Move(ptr,dptr,len,char);
4339 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4344 =for apidoc sv_setpvn_mg
4346 Like C<sv_setpvn>, but also handles 'set' magic.
4352 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4354 sv_setpvn(sv,ptr,len);
4359 =for apidoc sv_setpv
4361 Copies a string into an SV. The string must be null-terminated. Does not
4362 handle 'set' magic. See C<sv_setpv_mg>.
4368 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4370 register STRLEN len;
4372 SV_CHECK_THINKFIRST_COW_DROP(sv);
4378 SvUPGRADE(sv, SVt_PV);
4380 SvGROW(sv, len + 1);
4381 Move(ptr,SvPVX(sv),len+1,char);
4383 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4388 =for apidoc sv_setpv_mg
4390 Like C<sv_setpv>, but also handles 'set' magic.
4396 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4403 =for apidoc sv_usepvn
4405 Tells an SV to use C<ptr> to find its string value. Normally the string is
4406 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4407 The C<ptr> should point to memory that was allocated by C<malloc>. The
4408 string length, C<len>, must be supplied. This function will realloc the
4409 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4410 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4411 See C<sv_usepvn_mg>.
4417 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4420 SV_CHECK_THINKFIRST_COW_DROP(sv);
4421 SvUPGRADE(sv, SVt_PV);
4426 if (SvPVX_const(sv))
4429 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4430 ptr = saferealloc (ptr, allocate);
4433 SvLEN_set(sv, allocate);
4435 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4440 =for apidoc sv_usepvn_mg
4442 Like C<sv_usepvn>, but also handles 'set' magic.
4448 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4450 sv_usepvn(sv,ptr,len);
4454 #ifdef PERL_OLD_COPY_ON_WRITE
4455 /* Need to do this *after* making the SV normal, as we need the buffer
4456 pointer to remain valid until after we've copied it. If we let go too early,
4457 another thread could invalidate it by unsharing last of the same hash key
4458 (which it can do by means other than releasing copy-on-write Svs)
4459 or by changing the other copy-on-write SVs in the loop. */
4461 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4463 if (len) { /* this SV was SvIsCOW_normal(sv) */
4464 /* we need to find the SV pointing to us. */
4465 SV * const current = SV_COW_NEXT_SV(after);
4467 if (current == sv) {
4468 /* The SV we point to points back to us (there were only two of us
4470 Hence other SV is no longer copy on write either. */
4472 SvREADONLY_off(after);
4474 /* We need to follow the pointers around the loop. */
4476 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4479 /* don't loop forever if the structure is bust, and we have
4480 a pointer into a closed loop. */
4481 assert (current != after);
4482 assert (SvPVX_const(current) == pvx);
4484 /* Make the SV before us point to the SV after us. */
4485 SV_COW_NEXT_SV_SET(current, after);
4488 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4493 Perl_sv_release_IVX(pTHX_ register SV *sv)
4496 sv_force_normal_flags(sv, 0);
4502 =for apidoc sv_force_normal_flags
4504 Undo various types of fakery on an SV: if the PV is a shared string, make
4505 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4506 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4507 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4508 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4509 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4510 set to some other value.) In addition, the C<flags> parameter gets passed to
4511 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4512 with flags set to 0.
4518 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4520 #ifdef PERL_OLD_COPY_ON_WRITE
4521 if (SvREADONLY(sv)) {
4522 /* At this point I believe I should acquire a global SV mutex. */
4524 const char * const pvx = SvPVX_const(sv);
4525 const STRLEN len = SvLEN(sv);
4526 const STRLEN cur = SvCUR(sv);
4527 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4529 PerlIO_printf(Perl_debug_log,
4530 "Copy on write: Force normal %ld\n",
4536 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4537 SvPV_set(sv, (char*)0);
4539 if (flags & SV_COW_DROP_PV) {
4540 /* OK, so we don't need to copy our buffer. */
4543 SvGROW(sv, cur + 1);
4544 Move(pvx,SvPVX(sv),cur,char);
4548 sv_release_COW(sv, pvx, len, next);
4553 else if (IN_PERL_RUNTIME)
4554 Perl_croak(aTHX_ PL_no_modify);
4555 /* At this point I believe that I can drop the global SV mutex. */
4558 if (SvREADONLY(sv)) {
4560 const char * const pvx = SvPVX_const(sv);
4561 const STRLEN len = SvCUR(sv);
4564 SvPV_set(sv, Nullch);
4566 SvGROW(sv, len + 1);
4567 Move(pvx,SvPVX(sv),len,char);
4569 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4571 else if (IN_PERL_RUNTIME)
4572 Perl_croak(aTHX_ PL_no_modify);
4576 sv_unref_flags(sv, flags);
4577 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4582 =for apidoc sv_force_normal
4584 Undo various types of fakery on an SV: if the PV is a shared string, make
4585 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4586 an xpvmg. See also C<sv_force_normal_flags>.
4592 Perl_sv_force_normal(pTHX_ register SV *sv)
4594 sv_force_normal_flags(sv, 0);
4600 Efficient removal of characters from the beginning of the string buffer.
4601 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4602 the string buffer. The C<ptr> becomes the first character of the adjusted
4603 string. Uses the "OOK hack".
4604 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4605 refer to the same chunk of data.
4611 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4613 register STRLEN delta;
4614 if (!ptr || !SvPOKp(sv))
4616 delta = ptr - SvPVX_const(sv);
4617 SV_CHECK_THINKFIRST(sv);
4618 if (SvTYPE(sv) < SVt_PVIV)
4619 sv_upgrade(sv,SVt_PVIV);
4622 if (!SvLEN(sv)) { /* make