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);
2366 =for apidoc sv_2uv_flags
2368 Return the unsigned integer value of an SV, doing any necessary string
2369 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2370 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2376 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2380 if (SvGMAGICAL(sv)) {
2381 if (flags & SV_GMAGIC)
2386 return U_V(SvNVX(sv));
2387 if (SvPOKp(sv) && SvLEN(sv))
2390 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2391 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2397 if (SvTHINKFIRST(sv)) {
2400 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2401 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2402 return SvUV(tmpstr);
2403 return PTR2UV(SvRV(sv));
2406 sv_force_normal_flags(sv, 0);
2408 if (SvREADONLY(sv) && !SvOK(sv)) {
2409 if (ckWARN(WARN_UNINITIALIZED))
2419 return (UV)SvIVX(sv);
2423 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2424 * without also getting a cached IV/UV from it at the same time
2425 * (ie PV->NV conversion should detect loss of accuracy and cache
2426 * IV or UV at same time to avoid this. */
2427 /* IV-over-UV optimisation - choose to cache IV if possible */
2429 if (SvTYPE(sv) == SVt_NV)
2430 sv_upgrade(sv, SVt_PVNV);
2432 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2433 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2434 SvIV_set(sv, I_V(SvNVX(sv)));
2435 if (SvNVX(sv) == (NV) SvIVX(sv)
2436 #ifndef NV_PRESERVES_UV
2437 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2438 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2439 /* Don't flag it as "accurately an integer" if the number
2440 came from a (by definition imprecise) NV operation, and
2441 we're outside the range of NV integer precision */
2444 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2445 DEBUG_c(PerlIO_printf(Perl_debug_log,
2446 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2452 /* IV not precise. No need to convert from PV, as NV
2453 conversion would already have cached IV if it detected
2454 that PV->IV would be better than PV->NV->IV
2455 flags already correct - don't set public IOK. */
2456 DEBUG_c(PerlIO_printf(Perl_debug_log,
2457 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2462 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2463 but the cast (NV)IV_MIN rounds to a the value less (more
2464 negative) than IV_MIN which happens to be equal to SvNVX ??
2465 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2466 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2467 (NV)UVX == NVX are both true, but the values differ. :-(
2468 Hopefully for 2s complement IV_MIN is something like
2469 0x8000000000000000 which will be exact. NWC */
2472 SvUV_set(sv, U_V(SvNVX(sv)));
2474 (SvNVX(sv) == (NV) SvUVX(sv))
2475 #ifndef NV_PRESERVES_UV
2476 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2477 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2478 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2479 /* Don't flag it as "accurately an integer" if the number
2480 came from a (by definition imprecise) NV operation, and
2481 we're outside the range of NV integer precision */
2486 DEBUG_c(PerlIO_printf(Perl_debug_log,
2487 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2493 else if (SvPOKp(sv) && SvLEN(sv)) {
2495 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2497 /* We want to avoid a possible problem when we cache a UV which
2498 may be later translated to an NV, and the resulting NV is not
2499 the translation of the initial data.
2501 This means that if we cache such a UV, we need to cache the
2502 NV as well. Moreover, we trade speed for space, and do not
2503 cache the NV if not needed.
2506 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2507 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2508 == IS_NUMBER_IN_UV) {
2509 /* It's definitely an integer, only upgrade to PVIV */
2510 if (SvTYPE(sv) < SVt_PVIV)
2511 sv_upgrade(sv, SVt_PVIV);
2513 } else if (SvTYPE(sv) < SVt_PVNV)
2514 sv_upgrade(sv, SVt_PVNV);
2516 /* If NV preserves UV then we only use the UV value if we know that
2517 we aren't going to call atof() below. If NVs don't preserve UVs
2518 then the value returned may have more precision than atof() will
2519 return, even though it isn't accurate. */
2520 if ((numtype & (IS_NUMBER_IN_UV
2521 #ifdef NV_PRESERVES_UV
2524 )) == IS_NUMBER_IN_UV) {
2525 /* This won't turn off the public IOK flag if it was set above */
2526 (void)SvIOKp_on(sv);
2528 if (!(numtype & IS_NUMBER_NEG)) {
2530 if (value <= (UV)IV_MAX) {
2531 SvIV_set(sv, (IV)value);
2533 /* it didn't overflow, and it was positive. */
2534 SvUV_set(sv, value);
2538 /* 2s complement assumption */
2539 if (value <= (UV)IV_MIN) {
2540 SvIV_set(sv, -(IV)value);
2542 /* Too negative for an IV. This is a double upgrade, but
2543 I'm assuming it will be rare. */
2544 if (SvTYPE(sv) < SVt_PVNV)
2545 sv_upgrade(sv, SVt_PVNV);
2549 SvNV_set(sv, -(NV)value);
2550 SvIV_set(sv, IV_MIN);
2555 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2556 != IS_NUMBER_IN_UV) {
2557 /* It wasn't an integer, or it overflowed the UV. */
2558 SvNV_set(sv, Atof(SvPVX_const(sv)));
2560 if (! numtype && ckWARN(WARN_NUMERIC))
2563 #if defined(USE_LONG_DOUBLE)
2564 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2565 PTR2UV(sv), SvNVX(sv)));
2567 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2568 PTR2UV(sv), SvNVX(sv)));
2571 #ifdef NV_PRESERVES_UV
2572 (void)SvIOKp_on(sv);
2574 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2575 SvIV_set(sv, I_V(SvNVX(sv)));
2576 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2579 /* Integer is imprecise. NOK, IOKp */
2581 /* UV will not work better than IV */
2583 if (SvNVX(sv) > (NV)UV_MAX) {
2585 /* Integer is inaccurate. NOK, IOKp, is UV */
2586 SvUV_set(sv, UV_MAX);
2589 SvUV_set(sv, U_V(SvNVX(sv)));
2590 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2591 NV preservse UV so can do correct comparison. */
2592 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2596 /* Integer is imprecise. NOK, IOKp, is UV */
2601 #else /* NV_PRESERVES_UV */
2602 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2603 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2604 /* The UV slot will have been set from value returned by
2605 grok_number above. The NV slot has just been set using
2608 assert (SvIOKp(sv));
2610 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2611 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2612 /* Small enough to preserve all bits. */
2613 (void)SvIOKp_on(sv);
2615 SvIV_set(sv, I_V(SvNVX(sv)));
2616 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2618 /* Assumption: first non-preserved integer is < IV_MAX,
2619 this NV is in the preserved range, therefore: */
2620 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2622 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);
2625 sv_2iuv_non_preserve (sv, numtype);
2627 #endif /* NV_PRESERVES_UV */
2631 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2632 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2635 if (SvTYPE(sv) < SVt_IV)
2636 /* Typically the caller expects that sv_any is not NULL now. */
2637 sv_upgrade(sv, SVt_IV);
2641 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2642 PTR2UV(sv),SvUVX(sv)));
2643 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2649 Return the num value of an SV, doing any necessary string or integer
2650 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2657 Perl_sv_2nv(pTHX_ register SV *sv)
2661 if (SvGMAGICAL(sv)) {
2665 if (SvPOKp(sv) && SvLEN(sv)) {
2666 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2667 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2669 return Atof(SvPVX_const(sv));
2673 return (NV)SvUVX(sv);
2675 return (NV)SvIVX(sv);
2678 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2679 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2685 if (SvTHINKFIRST(sv)) {
2688 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2689 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2690 return SvNV(tmpstr);
2691 return PTR2NV(SvRV(sv));
2694 sv_force_normal_flags(sv, 0);
2696 if (SvREADONLY(sv) && !SvOK(sv)) {
2697 if (ckWARN(WARN_UNINITIALIZED))
2702 if (SvTYPE(sv) < SVt_NV) {
2703 if (SvTYPE(sv) == SVt_IV)
2704 sv_upgrade(sv, SVt_PVNV);
2706 sv_upgrade(sv, SVt_NV);
2707 #ifdef USE_LONG_DOUBLE
2709 STORE_NUMERIC_LOCAL_SET_STANDARD();
2710 PerlIO_printf(Perl_debug_log,
2711 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2712 PTR2UV(sv), SvNVX(sv));
2713 RESTORE_NUMERIC_LOCAL();
2717 STORE_NUMERIC_LOCAL_SET_STANDARD();
2718 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2719 PTR2UV(sv), SvNVX(sv));
2720 RESTORE_NUMERIC_LOCAL();
2724 else if (SvTYPE(sv) < SVt_PVNV)
2725 sv_upgrade(sv, SVt_PVNV);
2730 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2731 #ifdef NV_PRESERVES_UV
2734 /* Only set the public NV OK flag if this NV preserves the IV */
2735 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2736 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2737 : (SvIVX(sv) == I_V(SvNVX(sv))))
2743 else if (SvPOKp(sv) && SvLEN(sv)) {
2745 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2746 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2748 #ifdef NV_PRESERVES_UV
2749 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2750 == IS_NUMBER_IN_UV) {
2751 /* It's definitely an integer */
2752 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2754 SvNV_set(sv, Atof(SvPVX_const(sv)));
2757 SvNV_set(sv, Atof(SvPVX_const(sv)));
2758 /* Only set the public NV OK flag if this NV preserves the value in
2759 the PV at least as well as an IV/UV would.
2760 Not sure how to do this 100% reliably. */
2761 /* if that shift count is out of range then Configure's test is
2762 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2764 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2765 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2766 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2767 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2768 /* Can't use strtol etc to convert this string, so don't try.
2769 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2772 /* value has been set. It may not be precise. */
2773 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2774 /* 2s complement assumption for (UV)IV_MIN */
2775 SvNOK_on(sv); /* Integer is too negative. */
2780 if (numtype & IS_NUMBER_NEG) {
2781 SvIV_set(sv, -(IV)value);
2782 } else if (value <= (UV)IV_MAX) {
2783 SvIV_set(sv, (IV)value);
2785 SvUV_set(sv, value);
2789 if (numtype & IS_NUMBER_NOT_INT) {
2790 /* I believe that even if the original PV had decimals,
2791 they are lost beyond the limit of the FP precision.
2792 However, neither is canonical, so both only get p
2793 flags. NWC, 2000/11/25 */
2794 /* Both already have p flags, so do nothing */
2796 const NV nv = SvNVX(sv);
2797 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2798 if (SvIVX(sv) == I_V(nv)) {
2803 /* It had no "." so it must be integer. */
2806 /* between IV_MAX and NV(UV_MAX).
2807 Could be slightly > UV_MAX */
2809 if (numtype & IS_NUMBER_NOT_INT) {
2810 /* UV and NV both imprecise. */
2812 const UV nv_as_uv = U_V(nv);
2814 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2825 #endif /* NV_PRESERVES_UV */
2828 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2830 if (SvTYPE(sv) < SVt_NV)
2831 /* Typically the caller expects that sv_any is not NULL now. */
2832 /* XXX Ilya implies that this is a bug in callers that assume this
2833 and ideally should be fixed. */
2834 sv_upgrade(sv, SVt_NV);
2837 #if defined(USE_LONG_DOUBLE)
2839 STORE_NUMERIC_LOCAL_SET_STANDARD();
2840 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2841 PTR2UV(sv), SvNVX(sv));
2842 RESTORE_NUMERIC_LOCAL();
2846 STORE_NUMERIC_LOCAL_SET_STANDARD();
2847 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2848 PTR2UV(sv), SvNVX(sv));
2849 RESTORE_NUMERIC_LOCAL();
2855 /* asIV(): extract an integer from the string value of an SV.
2856 * Caller must validate PVX */
2859 S_asIV(pTHX_ SV *sv)
2862 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2864 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2865 == IS_NUMBER_IN_UV) {
2866 /* It's definitely an integer */
2867 if (numtype & IS_NUMBER_NEG) {
2868 if (value < (UV)IV_MIN)
2871 if (value < (UV)IV_MAX)
2876 if (ckWARN(WARN_NUMERIC))
2879 return I_V(Atof(SvPVX_const(sv)));
2882 /* asUV(): extract an unsigned integer from the string value of an SV
2883 * Caller must validate PVX */
2886 S_asUV(pTHX_ SV *sv)
2889 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2891 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2892 == IS_NUMBER_IN_UV) {
2893 /* It's definitely an integer */
2894 if (!(numtype & IS_NUMBER_NEG))
2898 if (ckWARN(WARN_NUMERIC))
2901 return U_V(Atof(SvPVX_const(sv)));
2904 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2905 * UV as a string towards the end of buf, and return pointers to start and
2908 * We assume that buf is at least TYPE_CHARS(UV) long.
2912 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2914 char *ptr = buf + TYPE_CHARS(UV);
2915 char * const ebuf = ptr;
2928 *--ptr = '0' + (char)(uv % 10);
2937 =for apidoc sv_2pv_flags
2939 Returns a pointer to the string value of an SV, and sets *lp to its length.
2940 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2942 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2943 usually end up here too.
2949 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2954 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2955 char *tmpbuf = tbuf;
2962 if (SvGMAGICAL(sv)) {
2963 if (flags & SV_GMAGIC)
2968 if (flags & SV_MUTABLE_RETURN)
2969 return SvPVX_mutable(sv);
2970 if (flags & SV_CONST_RETURN)
2971 return (char *)SvPVX_const(sv);
2976 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2978 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2983 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2988 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2989 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2997 if (SvTHINKFIRST(sv)) {
3000 register const char *typestr;
3001 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3002 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3004 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3007 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3008 if (flags & SV_CONST_RETURN) {
3009 pv = (char *) SvPVX_const(tmpstr);
3011 pv = (flags & SV_MUTABLE_RETURN)
3012 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3015 *lp = SvCUR(tmpstr);
3017 pv = sv_2pv_flags(tmpstr, lp, flags);
3028 typestr = "NULLREF";
3032 switch (SvTYPE(sv)) {
3034 if ( ((SvFLAGS(sv) &
3035 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3036 == (SVs_OBJECT|SVs_SMG))
3037 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3038 const regexp *re = (regexp *)mg->mg_obj;
3041 const char *fptr = "msix";
3046 char need_newline = 0;
3047 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3049 while((ch = *fptr++)) {
3051 reflags[left++] = ch;
3054 reflags[right--] = ch;
3059 reflags[left] = '-';
3063 mg->mg_len = re->prelen + 4 + left;
3065 * If /x was used, we have to worry about a regex
3066 * ending with a comment later being embedded
3067 * within another regex. If so, we don't want this
3068 * regex's "commentization" to leak out to the
3069 * right part of the enclosing regex, we must cap
3070 * it with a newline.
3072 * So, if /x was used, we scan backwards from the
3073 * end of the regex. If we find a '#' before we
3074 * find a newline, we need to add a newline
3075 * ourself. If we find a '\n' first (or if we
3076 * don't find '#' or '\n'), we don't need to add
3077 * anything. -jfriedl
3079 if (PMf_EXTENDED & re->reganch)
3081 const char *endptr = re->precomp + re->prelen;
3082 while (endptr >= re->precomp)
3084 const char c = *(endptr--);
3086 break; /* don't need another */
3088 /* we end while in a comment, so we
3090 mg->mg_len++; /* save space for it */
3091 need_newline = 1; /* note to add it */
3097 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3098 Copy("(?", mg->mg_ptr, 2, char);
3099 Copy(reflags, mg->mg_ptr+2, left, char);
3100 Copy(":", mg->mg_ptr+left+2, 1, char);
3101 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3103 mg->mg_ptr[mg->mg_len - 2] = '\n';
3104 mg->mg_ptr[mg->mg_len - 1] = ')';
3105 mg->mg_ptr[mg->mg_len] = 0;
3107 PL_reginterp_cnt += re->program[0].next_off;
3109 if (re->reganch & ROPT_UTF8)
3125 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3126 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3127 /* tied lvalues should appear to be
3128 * scalars for backwards compatitbility */
3129 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3130 ? "SCALAR" : "LVALUE"; break;
3131 case SVt_PVAV: typestr = "ARRAY"; break;
3132 case SVt_PVHV: typestr = "HASH"; break;
3133 case SVt_PVCV: typestr = "CODE"; break;
3134 case SVt_PVGV: typestr = "GLOB"; break;
3135 case SVt_PVFM: typestr = "FORMAT"; break;
3136 case SVt_PVIO: typestr = "IO"; break;
3137 default: typestr = "UNKNOWN"; break;
3141 const char *name = HvNAME_get(SvSTASH(sv));
3142 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3143 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3146 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3150 *lp = strlen(typestr);
3151 return (char *)typestr;
3153 if (SvREADONLY(sv) && !SvOK(sv)) {
3154 if (ckWARN(WARN_UNINITIALIZED))
3161 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3162 /* I'm assuming that if both IV and NV are equally valid then
3163 converting the IV is going to be more efficient */
3164 const U32 isIOK = SvIOK(sv);
3165 const U32 isUIOK = SvIsUV(sv);
3166 char buf[TYPE_CHARS(UV)];
3169 if (SvTYPE(sv) < SVt_PVIV)
3170 sv_upgrade(sv, SVt_PVIV);
3172 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3174 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3175 /* inlined from sv_setpvn */
3176 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3177 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3178 SvCUR_set(sv, ebuf - ptr);
3188 else if (SvNOKp(sv)) {
3189 if (SvTYPE(sv) < SVt_PVNV)
3190 sv_upgrade(sv, SVt_PVNV);
3191 /* The +20 is pure guesswork. Configure test needed. --jhi */
3192 s = SvGROW_mutable(sv, NV_DIG + 20);
3193 olderrno = errno; /* some Xenix systems wipe out errno here */
3195 if (SvNVX(sv) == 0.0)
3196 (void)strcpy(s,"0");
3200 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3203 #ifdef FIXNEGATIVEZERO
3204 if (*s == '-' && s[1] == '0' && !s[2])
3214 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3218 if (SvTYPE(sv) < SVt_PV)
3219 /* Typically the caller expects that sv_any is not NULL now. */
3220 sv_upgrade(sv, SVt_PV);
3224 const STRLEN len = s - SvPVX_const(sv);
3230 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3231 PTR2UV(sv),SvPVX_const(sv)));
3232 if (flags & SV_CONST_RETURN)
3233 return (char *)SvPVX_const(sv);
3234 if (flags & SV_MUTABLE_RETURN)
3235 return SvPVX_mutable(sv);
3239 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3240 /* Sneaky stuff here */
3244 tsv = newSVpv(tmpbuf, 0);
3257 t = SvPVX_const(tsv);
3262 len = strlen(tmpbuf);
3264 #ifdef FIXNEGATIVEZERO
3265 if (len == 2 && t[0] == '-' && t[1] == '0') {
3270 SvUPGRADE(sv, SVt_PV);
3273 s = SvGROW_mutable(sv, len + 1);
3276 return memcpy(s, t, len + 1);
3281 =for apidoc sv_copypv
3283 Copies a stringified representation of the source SV into the
3284 destination SV. Automatically performs any necessary mg_get and
3285 coercion of numeric values into strings. Guaranteed to preserve
3286 UTF-8 flag even from overloaded objects. Similar in nature to
3287 sv_2pv[_flags] but operates directly on an SV instead of just the
3288 string. Mostly uses sv_2pv_flags to do its work, except when that
3289 would lose the UTF-8'ness of the PV.
3295 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3298 const char * const s = SvPV_const(ssv,len);
3299 sv_setpvn(dsv,s,len);
3307 =for apidoc sv_2pvbyte
3309 Return a pointer to the byte-encoded representation of the SV, and set *lp
3310 to its length. May cause the SV to be downgraded from UTF-8 as a
3313 Usually accessed via the C<SvPVbyte> macro.
3319 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3321 sv_utf8_downgrade(sv,0);
3322 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3326 * =for apidoc sv_2pvutf8
3328 * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3329 * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3331 * Usually accessed via the C<SvPVutf8> macro.
3337 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3339 sv_utf8_upgrade(sv);
3340 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3345 =for apidoc sv_2bool
3347 This function is only called on magical items, and is only used by
3348 sv_true() or its macro equivalent.
3354 Perl_sv_2bool(pTHX_ register SV *sv)
3362 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3363 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3364 return (bool)SvTRUE(tmpsv);
3365 return SvRV(sv) != 0;
3368 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3370 (*sv->sv_u.svu_pv > '0' ||
3371 Xpvtmp->xpv_cur > 1 ||
3372 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3379 return SvIVX(sv) != 0;
3382 return SvNVX(sv) != 0.0;
3390 =for apidoc sv_utf8_upgrade
3392 Converts the PV of an SV to its UTF-8-encoded form.
3393 Forces the SV to string form if it is not already.
3394 Always sets the SvUTF8 flag to avoid future validity checks even
3395 if all the bytes have hibit clear.
3397 This is not as a general purpose byte encoding to Unicode interface:
3398 use the Encode extension for that.
3400 =for apidoc sv_utf8_upgrade_flags
3402 Converts the PV of an SV to its UTF-8-encoded form.
3403 Forces the SV to string form if it is not already.
3404 Always sets the SvUTF8 flag to avoid future validity checks even
3405 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3406 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3407 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3409 This is not as a general purpose byte encoding to Unicode interface:
3410 use the Encode extension for that.
3416 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3418 if (sv == &PL_sv_undef)
3422 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3423 (void) sv_2pv_flags(sv,&len, flags);
3427 (void) SvPV_force(sv,len);
3436 sv_force_normal_flags(sv, 0);
3439 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3440 sv_recode_to_utf8(sv, PL_encoding);
3441 else { /* Assume Latin-1/EBCDIC */
3442 /* This function could be much more efficient if we
3443 * had a FLAG in SVs to signal if there are any hibit
3444 * chars in the PV. Given that there isn't such a flag
3445 * make the loop as fast as possible. */
3446 const U8 *s = (U8 *) SvPVX_const(sv);
3447 const U8 *e = (U8 *) SvEND(sv);
3453 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3457 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3458 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3460 SvPV_free(sv); /* No longer using what was there before. */
3462 SvPV_set(sv, (char*)recoded);
3463 SvCUR_set(sv, len - 1);
3464 SvLEN_set(sv, len); /* No longer know the real size. */
3466 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3473 =for apidoc sv_utf8_downgrade
3475 Attempts to convert the PV of an SV from characters to bytes.
3476 If the PV contains a character beyond byte, this conversion will fail;
3477 in this case, either returns false or, if C<fail_ok> is not
3480 This is not as a general purpose Unicode to byte encoding interface:
3481 use the Encode extension for that.
3487 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3489 if (SvPOKp(sv) && SvUTF8(sv)) {
3495 sv_force_normal_flags(sv, 0);
3497 s = (U8 *) SvPV(sv, len);
3498 if (!utf8_to_bytes(s, &len)) {
3503 Perl_croak(aTHX_ "Wide character in %s",
3506 Perl_croak(aTHX_ "Wide character");
3517 =for apidoc sv_utf8_encode
3519 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3520 flag off so that it looks like octets again.
3526 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3528 (void) sv_utf8_upgrade(sv);
3530 sv_force_normal_flags(sv, 0);
3532 if (SvREADONLY(sv)) {
3533 Perl_croak(aTHX_ PL_no_modify);
3539 =for apidoc sv_utf8_decode
3541 If the PV of the SV is an octet sequence in UTF-8
3542 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3543 so that it looks like a character. If the PV contains only single-byte
3544 characters, the C<SvUTF8> flag stays being off.
3545 Scans PV for validity and returns false if the PV is invalid UTF-8.
3551 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3557 /* The octets may have got themselves encoded - get them back as
3560 if (!sv_utf8_downgrade(sv, TRUE))
3563 /* it is actually just a matter of turning the utf8 flag on, but
3564 * we want to make sure everything inside is valid utf8 first.
3566 c = (const U8 *) SvPVX_const(sv);
3567 if (!is_utf8_string(c, SvCUR(sv)+1))
3569 e = (const U8 *) SvEND(sv);
3572 if (!UTF8_IS_INVARIANT(ch)) {
3582 =for apidoc sv_setsv
3584 Copies the contents of the source SV C<ssv> into the destination SV
3585 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3586 function if the source SV needs to be reused. Does not handle 'set' magic.
3587 Loosely speaking, it performs a copy-by-value, obliterating any previous
3588 content of the destination.
3590 You probably want to use one of the assortment of wrappers, such as
3591 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3592 C<SvSetMagicSV_nosteal>.
3594 =for apidoc sv_setsv_flags
3596 Copies the contents of the source SV C<ssv> into the destination SV
3597 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3598 function if the source SV needs to be reused. Does not handle 'set' magic.
3599 Loosely speaking, it performs a copy-by-value, obliterating any previous
3600 content of the destination.
3601 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3602 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3603 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3604 and C<sv_setsv_nomg> are implemented in terms of this function.
3606 You probably want to use one of the assortment of wrappers, such as
3607 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3608 C<SvSetMagicSV_nosteal>.
3610 This is the primary function for copying scalars, and most other
3611 copy-ish functions and macros use this underneath.
3617 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3619 register U32 sflags;
3625 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3627 sstr = &PL_sv_undef;
3628 stype = SvTYPE(sstr);
3629 dtype = SvTYPE(dstr);
3634 /* need to nuke the magic */
3636 SvRMAGICAL_off(dstr);
3639 /* There's a lot of redundancy below but we're going for speed here */
3644 if (dtype != SVt_PVGV) {
3645 (void)SvOK_off(dstr);
3653 sv_upgrade(dstr, SVt_IV);
3656 sv_upgrade(dstr, SVt_PVNV);
3660 sv_upgrade(dstr, SVt_PVIV);
3663 (void)SvIOK_only(dstr);
3664 SvIV_set(dstr, SvIVX(sstr));
3667 if (SvTAINTED(sstr))
3678 sv_upgrade(dstr, SVt_NV);
3683 sv_upgrade(dstr, SVt_PVNV);
3686 SvNV_set(dstr, SvNVX(sstr));
3687 (void)SvNOK_only(dstr);
3688 if (SvTAINTED(sstr))
3696 sv_upgrade(dstr, SVt_RV);
3697 else if (dtype == SVt_PVGV &&
3698 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3701 if (GvIMPORTED(dstr) != GVf_IMPORTED
3702 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3704 GvIMPORTED_on(dstr);
3713 #ifdef PERL_OLD_COPY_ON_WRITE
3714 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3715 if (dtype < SVt_PVIV)
3716 sv_upgrade(dstr, SVt_PVIV);
3723 sv_upgrade(dstr, SVt_PV);
3726 if (dtype < SVt_PVIV)
3727 sv_upgrade(dstr, SVt_PVIV);
3730 if (dtype < SVt_PVNV)
3731 sv_upgrade(dstr, SVt_PVNV);
3738 const char * const type = sv_reftype(sstr,0);
3740 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3742 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3747 if (dtype <= SVt_PVGV) {
3749 if (dtype != SVt_PVGV) {
3750 const char * const name = GvNAME(sstr);
3751 const STRLEN len = GvNAMELEN(sstr);
3752 /* don't upgrade SVt_PVLV: it can hold a glob */
3753 if (dtype != SVt_PVLV)
3754 sv_upgrade(dstr, SVt_PVGV);
3755 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3756 GvSTASH(dstr) = GvSTASH(sstr);
3758 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3759 GvNAME(dstr) = savepvn(name, len);
3760 GvNAMELEN(dstr) = len;
3761 SvFAKE_on(dstr); /* can coerce to non-glob */
3763 /* ahem, death to those who redefine active sort subs */
3764 else if (PL_curstackinfo->si_type == PERLSI_SORT
3765 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3766 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3769 #ifdef GV_UNIQUE_CHECK
3770 if (GvUNIQUE((GV*)dstr)) {
3771 Perl_croak(aTHX_ PL_no_modify);
3775 (void)SvOK_off(dstr);
3776 GvINTRO_off(dstr); /* one-shot flag */
3778 GvGP(dstr) = gp_ref(GvGP(sstr));
3779 if (SvTAINTED(sstr))
3781 if (GvIMPORTED(dstr) != GVf_IMPORTED
3782 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3784 GvIMPORTED_on(dstr);
3792 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3794 if ((int)SvTYPE(sstr) != stype) {
3795 stype = SvTYPE(sstr);
3796 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3800 if (stype == SVt_PVLV)
3801 SvUPGRADE(dstr, SVt_PVNV);
3803 SvUPGRADE(dstr, (U32)stype);
3806 sflags = SvFLAGS(sstr);
3808 if (sflags & SVf_ROK) {
3809 if (dtype >= SVt_PV) {
3810 if (dtype == SVt_PVGV) {
3811 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3813 const int intro = GvINTRO(dstr);
3815 #ifdef GV_UNIQUE_CHECK
3816 if (GvUNIQUE((GV*)dstr)) {
3817 Perl_croak(aTHX_ PL_no_modify);
3822 GvINTRO_off(dstr); /* one-shot flag */
3823 GvLINE(dstr) = CopLINE(PL_curcop);
3824 GvEGV(dstr) = (GV*)dstr;
3827 switch (SvTYPE(sref)) {
3830 SAVEGENERICSV(GvAV(dstr));
3832 dref = (SV*)GvAV(dstr);
3833 GvAV(dstr) = (AV*)sref;
3834 if (!GvIMPORTED_AV(dstr)
3835 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3837 GvIMPORTED_AV_on(dstr);
3842 SAVEGENERICSV(GvHV(dstr));
3844 dref = (SV*)GvHV(dstr);
3845 GvHV(dstr) = (HV*)sref;
3846 if (!GvIMPORTED_HV(dstr)
3847 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3849 GvIMPORTED_HV_on(dstr);
3854 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3855 SvREFCNT_dec(GvCV(dstr));
3856 GvCV(dstr) = Nullcv;
3857 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3858 PL_sub_generation++;
3860 SAVEGENERICSV(GvCV(dstr));
3863 dref = (SV*)GvCV(dstr);
3864 if (GvCV(dstr) != (CV*)sref) {
3865 CV* const cv = GvCV(dstr);
3867 if (!GvCVGEN((GV*)dstr) &&
3868 (CvROOT(cv) || CvXSUB(cv)))
3870 /* ahem, death to those who redefine
3871 * active sort subs */
3872 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3873 PL_sortcop == CvSTART(cv))
3875 "Can't redefine active sort subroutine %s",
3876 GvENAME((GV*)dstr));
3877 /* Redefining a sub - warning is mandatory if
3878 it was a const and its value changed. */
3879 if (ckWARN(WARN_REDEFINE)
3881 && (!CvCONST((CV*)sref)
3882 || sv_cmp(cv_const_sv(cv),
3883 cv_const_sv((CV*)sref)))))
3885 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3887 ? "Constant subroutine %s::%s redefined"
3888 : "Subroutine %s::%s redefined",
3889 HvNAME_get(GvSTASH((GV*)dstr)),
3890 GvENAME((GV*)dstr));
3894 cv_ckproto(cv, (GV*)dstr,
3896 ? SvPVX_const(sref) : Nullch);
3898 GvCV(dstr) = (CV*)sref;
3899 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3900 GvASSUMECV_on(dstr);
3901 PL_sub_generation++;
3903 if (!GvIMPORTED_CV(dstr)
3904 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3906 GvIMPORTED_CV_on(dstr);
3911 SAVEGENERICSV(GvIOp(dstr));
3913 dref = (SV*)GvIOp(dstr);
3914 GvIOp(dstr) = (IO*)sref;
3918 SAVEGENERICSV(GvFORM(dstr));
3920 dref = (SV*)GvFORM(dstr);
3921 GvFORM(dstr) = (CV*)sref;
3925 SAVEGENERICSV(GvSV(dstr));
3927 dref = (SV*)GvSV(dstr);
3929 if (!GvIMPORTED_SV(dstr)
3930 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3932 GvIMPORTED_SV_on(dstr);
3938 if (SvTAINTED(sstr))
3942 if (SvPVX_const(dstr)) {
3948 (void)SvOK_off(dstr);
3949 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3951 if (sflags & SVp_NOK) {
3953 /* Only set the public OK flag if the source has public OK. */
3954 if (sflags & SVf_NOK)
3955 SvFLAGS(dstr) |= SVf_NOK;
3956 SvNV_set(dstr, SvNVX(sstr));
3958 if (sflags & SVp_IOK) {
3959 (void)SvIOKp_on(dstr);
3960 if (sflags & SVf_IOK)
3961 SvFLAGS(dstr) |= SVf_IOK;
3962 if (sflags & SVf_IVisUV)
3964 SvIV_set(dstr, SvIVX(sstr));
3966 if (SvAMAGIC(sstr)) {
3970 else if (sflags & SVp_POK) {
3974 * Check to see if we can just swipe the string. If so, it's a
3975 * possible small lose on short strings, but a big win on long ones.
3976 * It might even be a win on short strings if SvPVX_const(dstr)
3977 * has to be allocated and SvPVX_const(sstr) has to be freed.
3980 /* Whichever path we take through the next code, we want this true,
3981 and doing it now facilitates the COW check. */
3982 (void)SvPOK_only(dstr);
3985 /* We're not already COW */
3986 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3987 #ifndef PERL_OLD_COPY_ON_WRITE
3988 /* or we are, but dstr isn't a suitable target. */
3989 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3994 (sflags & SVs_TEMP) && /* slated for free anyway? */
3995 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3996 (!(flags & SV_NOSTEAL)) &&
3997 /* and we're allowed to steal temps */
3998 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3999 SvLEN(sstr) && /* and really is a string */
4000 /* and won't be needed again, potentially */
4001 !(PL_op && PL_op->op_type == OP_AASSIGN))
4002 #ifdef PERL_OLD_COPY_ON_WRITE
4003 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4004 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4005 && SvTYPE(sstr) >= SVt_PVIV)
4008 /* Failed the swipe test, and it's not a shared hash key either.
4009 Have to copy the string. */
4010 STRLEN len = SvCUR(sstr);
4011 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4012 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4013 SvCUR_set(dstr, len);
4014 *SvEND(dstr) = '\0';
4016 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4018 /* Either it's a shared hash key, or it's suitable for
4019 copy-on-write or we can swipe the string. */
4021 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4025 #ifdef PERL_OLD_COPY_ON_WRITE
4027 /* I believe I should acquire a global SV mutex if
4028 it's a COW sv (not a shared hash key) to stop
4029 it going un copy-on-write.
4030 If the source SV has gone un copy on write between up there
4031 and down here, then (assert() that) it is of the correct
4032 form to make it copy on write again */
4033 if ((sflags & (SVf_FAKE | SVf_READONLY))
4034 != (SVf_FAKE | SVf_READONLY)) {
4035 SvREADONLY_on(sstr);
4037 /* Make the source SV into a loop of 1.
4038 (about to become 2) */
4039 SV_COW_NEXT_SV_SET(sstr, sstr);
4043 /* Initial code is common. */
4044 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4049 /* making another shared SV. */
4050 STRLEN cur = SvCUR(sstr);
4051 STRLEN len = SvLEN(sstr);
4052 #ifdef PERL_OLD_COPY_ON_WRITE
4054 assert (SvTYPE(dstr) >= SVt_PVIV);
4055 /* SvIsCOW_normal */
4056 /* splice us in between source and next-after-source. */
4057 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4058 SV_COW_NEXT_SV_SET(sstr, dstr);
4059 SvPV_set(dstr, SvPVX_mutable(sstr));
4063 /* SvIsCOW_shared_hash */
4064 DEBUG_C(PerlIO_printf(Perl_debug_log,
4065 "Copy on write: Sharing hash\n"));
4067 assert (SvTYPE(dstr) >= SVt_PV);
4069 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4071 SvLEN_set(dstr, len);
4072 SvCUR_set(dstr, cur);
4073 SvREADONLY_on(dstr);
4075 /* Relesase a global SV mutex. */
4078 { /* Passes the swipe test. */
4079 SvPV_set(dstr, SvPVX_mutable(sstr));
4080 SvLEN_set(dstr, SvLEN(sstr));
4081 SvCUR_set(dstr, SvCUR(sstr));
4084 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4085 SvPV_set(sstr, Nullch);
4091 if (sflags & SVf_UTF8)
4093 if (sflags & SVp_NOK) {
4095 if (sflags & SVf_NOK)
4096 SvFLAGS(dstr) |= SVf_NOK;
4097 SvNV_set(dstr, SvNVX(sstr));
4099 if (sflags & SVp_IOK) {
4100 (void)SvIOKp_on(dstr);
4101 if (sflags & SVf_IOK)
4102 SvFLAGS(dstr) |= SVf_IOK;
4103 if (sflags & SVf_IVisUV)
4105 SvIV_set(dstr, SvIVX(sstr));
4108 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4109 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4110 smg->mg_ptr, smg->mg_len);
4111 SvRMAGICAL_on(dstr);
4114 else if (sflags & SVp_IOK) {
4115 if (sflags & SVf_IOK)
4116 (void)SvIOK_only(dstr);
4118 (void)SvOK_off(dstr);
4119 (void)SvIOKp_on(dstr);
4121 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4122 if (sflags & SVf_IVisUV)
4124 SvIV_set(dstr, SvIVX(sstr));
4125 if (sflags & SVp_NOK) {
4126 if (sflags & SVf_NOK)
4127 (void)SvNOK_on(dstr);
4129 (void)SvNOKp_on(dstr);
4130 SvNV_set(dstr, SvNVX(sstr));
4133 else if (sflags & SVp_NOK) {
4134 if (sflags & SVf_NOK)
4135 (void)SvNOK_only(dstr);
4137 (void)SvOK_off(dstr);
4140 SvNV_set(dstr, SvNVX(sstr));
4143 if (dtype == SVt_PVGV) {
4144 if (ckWARN(WARN_MISC))
4145 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4148 (void)SvOK_off(dstr);
4150 if (SvTAINTED(sstr))
4155 =for apidoc sv_setsv_mg
4157 Like C<sv_setsv>, but also handles 'set' magic.
4163 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4165 sv_setsv(dstr,sstr);
4169 #ifdef PERL_OLD_COPY_ON_WRITE
4171 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4173 STRLEN cur = SvCUR(sstr);
4174 STRLEN len = SvLEN(sstr);
4175 register char *new_pv;
4178 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4186 if (SvTHINKFIRST(dstr))
4187 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4188 else if (SvPVX_const(dstr))
4189 Safefree(SvPVX_const(dstr));
4193 SvUPGRADE(dstr, SVt_PVIV);
4195 assert (SvPOK(sstr));
4196 assert (SvPOKp(sstr));
4197 assert (!SvIOK(sstr));
4198 assert (!SvIOKp(sstr));
4199 assert (!SvNOK(sstr));
4200 assert (!SvNOKp(sstr));
4202 if (SvIsCOW(sstr)) {
4204 if (SvLEN(sstr) == 0) {
4205 /* source is a COW shared hash key. */
4206 DEBUG_C(PerlIO_printf(Perl_debug_log,
4207 "Fast copy on write: Sharing hash\n"));
4208 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4211 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4213 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4214 SvUPGRADE(sstr, SVt_PVIV);
4215 SvREADONLY_on(sstr);
4217 DEBUG_C(PerlIO_printf(Perl_debug_log,
4218 "Fast copy on write: Converting sstr to COW\n"));
4219 SV_COW_NEXT_SV_SET(dstr, sstr);
4221 SV_COW_NEXT_SV_SET(sstr, dstr);
4222 new_pv = SvPVX_mutable(sstr);
4225 SvPV_set(dstr, new_pv);
4226 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4229 SvLEN_set(dstr, len);
4230 SvCUR_set(dstr, cur);
4239 =for apidoc sv_setpvn
4241 Copies a string into an SV. The C<len> parameter indicates the number of
4242 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4243 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4249 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4251 register char *dptr;
4253 SV_CHECK_THINKFIRST_COW_DROP(sv);
4259 /* len is STRLEN which is unsigned, need to copy to signed */
4262 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4264 SvUPGRADE(sv, SVt_PV);
4266 dptr = SvGROW(sv, len + 1);
4267 Move(ptr,dptr,len,char);
4270 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4275 =for apidoc sv_setpvn_mg
4277 Like C<sv_setpvn>, but also handles 'set' magic.
4283 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4285 sv_setpvn(sv,ptr,len);
4290 =for apidoc sv_setpv
4292 Copies a string into an SV. The string must be null-terminated. Does not
4293 handle 'set' magic. See C<sv_setpv_mg>.
4299 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4301 register STRLEN len;
4303 SV_CHECK_THINKFIRST_COW_DROP(sv);
4309 SvUPGRADE(sv, SVt_PV);
4311 SvGROW(sv, len + 1);
4312 Move(ptr,SvPVX(sv),len+1,char);
4314 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4319 =for apidoc sv_setpv_mg
4321 Like C<sv_setpv>, but also handles 'set' magic.
4327 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4334 =for apidoc sv_usepvn
4336 Tells an SV to use C<ptr> to find its string value. Normally the string is
4337 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4338 The C<ptr> should point to memory that was allocated by C<malloc>. The
4339 string length, C<len>, must be supplied. This function will realloc the
4340 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4341 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4342 See C<sv_usepvn_mg>.
4348 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4351 SV_CHECK_THINKFIRST_COW_DROP(sv);
4352 SvUPGRADE(sv, SVt_PV);
4357 if (SvPVX_const(sv))
4360 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4361 ptr = saferealloc (ptr, allocate);
4364 SvLEN_set(sv, allocate);
4366 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4371 =for apidoc sv_usepvn_mg
4373 Like C<sv_usepvn>, but also handles 'set' magic.
4379 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4381 sv_usepvn(sv,ptr,len);
4385 #ifdef PERL_OLD_COPY_ON_WRITE
4386 /* Need to do this *after* making the SV normal, as we need the buffer
4387 pointer to remain valid until after we've copied it. If we let go too early,
4388 another thread could invalidate it by unsharing last of the same hash key
4389 (which it can do by means other than releasing copy-on-write Svs)
4390 or by changing the other copy-on-write SVs in the loop. */
4392 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4394 if (len) { /* this SV was SvIsCOW_normal(sv) */
4395 /* we need to find the SV pointing to us. */
4396 SV * const current = SV_COW_NEXT_SV(after);
4398 if (current == sv) {
4399 /* The SV we point to points back to us (there were only two of us
4401 Hence other SV is no longer copy on write either. */
4403 SvREADONLY_off(after);
4405 /* We need to follow the pointers around the loop. */
4407 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4410 /* don't loop forever if the structure is bust, and we have
4411 a pointer into a closed loop. */
4412 assert (current != after);
4413 assert (SvPVX_const(current) == pvx);
4415 /* Make the SV before us point to the SV after us. */
4416 SV_COW_NEXT_SV_SET(current, after);
4419 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4424 Perl_sv_release_IVX(pTHX_ register SV *sv)
4427 sv_force_normal_flags(sv, 0);
4433 =for apidoc sv_force_normal_flags
4435 Undo various types of fakery on an SV: if the PV is a shared string, make
4436 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4437 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4438 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4439 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4440 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4441 set to some other value.) In addition, the C<flags> parameter gets passed to
4442 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4443 with flags set to 0.
4449 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4451 #ifdef PERL_OLD_COPY_ON_WRITE
4452 if (SvREADONLY(sv)) {
4453 /* At this point I believe I should acquire a global SV mutex. */
4455 const char * const pvx = SvPVX_const(sv);
4456 const STRLEN len = SvLEN(sv);
4457 const STRLEN cur = SvCUR(sv);
4458 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4460 PerlIO_printf(Perl_debug_log,
4461 "Copy on write: Force normal %ld\n",
4467 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4468 SvPV_set(sv, (char*)0);
4470 if (flags & SV_COW_DROP_PV) {
4471 /* OK, so we don't need to copy our buffer. */
4474 SvGROW(sv, cur + 1);
4475 Move(pvx,SvPVX(sv),cur,char);
4479 sv_release_COW(sv, pvx, len, next);
4484 else if (IN_PERL_RUNTIME)
4485 Perl_croak(aTHX_ PL_no_modify);
4486 /* At this point I believe that I can drop the global SV mutex. */
4489 if (SvREADONLY(sv)) {
4491 const char * const pvx = SvPVX_const(sv);
4492 const STRLEN len = SvCUR(sv);
4495 SvPV_set(sv, Nullch);
4497 SvGROW(sv, len + 1);
4498 Move(pvx,SvPVX(sv),len,char);
4500 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4502 else if (IN_PERL_RUNTIME)
4503 Perl_croak(aTHX_ PL_no_modify);
4507 sv_unref_flags(sv, flags);
4508 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4515 Efficient removal of characters from the beginning of the string buffer.
4516 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4517 the string buffer. The C<ptr> becomes the first character of the adjusted
4518 string. Uses the "OOK hack".
4519 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4520 refer to the same chunk of data.
4526 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4528 register STRLEN delta;
4529 if (!ptr || !SvPOKp(sv))
4531 delta = ptr - SvPVX_const(sv);
4532 SV_CHECK_THINKFIRST(sv);
4533 if (SvTYPE(sv) < SVt_PVIV)
4534 sv_upgrade(sv,SVt_PVIV);
4537 if (!SvLEN(sv)) { /* make copy of shared string */
4538 const char *pvx = SvPVX_const(sv);
4539 const STRLEN len = SvCUR(sv);
4540 SvGROW(sv, len + 1);
4541 Move(pvx,SvPVX(sv),len,char);
4545 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4546 and we do that anyway inside the SvNIOK_off
4548 SvFLAGS(sv) |= SVf_OOK;
4551 SvLEN_set(sv, SvLEN(sv) - delta);
4552 SvCUR_set(sv, SvCUR(sv) - delta);
4553 SvPV_set(sv, SvPVX(sv) + delta);
4554 SvIV_set(sv, SvIVX(sv) + delta);
4558 =for apidoc sv_catpvn
4560 Concatenates the string onto the end of the string which is in the SV. The
4561 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4562 status set, then the bytes appended should be valid UTF-8.
4563 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4565 =for apidoc sv_catpvn_flags
4567 Concatenates the string onto the end of the string which is in the SV. The
4568 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4569 status set, then the bytes appended should be valid UTF-8.
4570 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4571 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4572 in terms of this function.
4578 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4581 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4583 SvGROW(dsv, dlen + slen + 1);
4585 sstr = SvPVX_const(dsv);
4586 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4587 SvCUR_set(dsv, SvCUR(dsv) + slen);
4589 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4591 if (flags & SV_SMAGIC)
4596 =for apidoc sv_catsv
4598 Concatenates the string from SV C<ssv> onto the end of the string in
4599 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4600 not 'set' magic. See C<sv_catsv_mg>.
4602 =for apidoc sv_catsv_flags
4604 Concatenates the string from SV C<ssv> onto the end of the string in
4605 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4606 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>