3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which 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 #ifdef DEBUG_LEAKING_SCALARS
171 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
173 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
176 # define FREE_SV_DEBUG_FILE(sv)
179 #define plant_SV(p) \
181 FREE_SV_DEBUG_FILE(p); \
182 SvANY(p) = (void *)PL_sv_root; \
183 SvFLAGS(p) = SVTYPEMASK; \
188 /* sv_mutex must be held while calling uproot_SV() */
189 #define uproot_SV(p) \
192 PL_sv_root = (SV*)SvANY(p); \
197 /* make some more SVs by adding another arena */
199 /* sv_mutex must be held while calling more_sv() */
206 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
207 PL_nice_chunk = Nullch;
208 PL_nice_chunk_size = 0;
211 char *chunk; /* must use New here to match call to */
212 New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
213 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
219 /* new_SV(): return a new, empty SV head */
221 #ifdef DEBUG_LEAKING_SCALARS
222 /* provide a real function for a debugger to play with */
232 sv = S_more_sv(aTHX);
237 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
238 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
239 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
240 sv->sv_debug_inpad = 0;
241 sv->sv_debug_cloned = 0;
243 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
245 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
250 # define new_SV(p) (p)=S_new_SV(aTHX)
259 (p) = S_more_sv(aTHX); \
268 /* del_SV(): return an empty SV head to the free list */
283 S_del_sv(pTHX_ SV *p)
288 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
290 SV *svend = &sva[SvREFCNT(sva)];
291 if (p >= sv && p < svend) {
297 if (ckWARN_d(WARN_INTERNAL))
298 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
299 "Attempt to free non-arena SV: 0x%"UVxf
300 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
307 #else /* ! DEBUGGING */
309 #define del_SV(p) plant_SV(p)
311 #endif /* DEBUGGING */
315 =head1 SV Manipulation Functions
317 =for apidoc sv_add_arena
319 Given a chunk of memory, link it to the head of the list of arenas,
320 and split it into a list of free SVs.
326 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
332 /* The first SV in an arena isn't an SV. */
333 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
334 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
335 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
337 PL_sv_arenaroot = sva;
338 PL_sv_root = sva + 1;
340 svend = &sva[SvREFCNT(sva) - 1];
343 SvANY(sv) = (void *)(SV*)(sv + 1);
347 /* Must always set typemask because it's awlays checked in on cleanup
348 when the arenas are walked looking for objects. */
349 SvFLAGS(sv) = SVTYPEMASK;
356 SvFLAGS(sv) = SVTYPEMASK;
359 /* visit(): call the named function for each non-free SV in the arenas
360 * whose flags field matches the flags/mask args. */
363 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
368 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
369 register SV * const svend = &sva[SvREFCNT(sva)];
371 for (sv = sva + 1; sv < svend; ++sv) {
372 if (SvTYPE(sv) != SVTYPEMASK
373 && (sv->sv_flags & mask) == flags
386 /* called by sv_report_used() for each live SV */
389 do_report_used(pTHX_ SV *sv)
391 if (SvTYPE(sv) != SVTYPEMASK) {
392 PerlIO_printf(Perl_debug_log, "****\n");
399 =for apidoc sv_report_used
401 Dump the contents of all SVs not yet freed. (Debugging aid).
407 Perl_sv_report_used(pTHX)
410 visit(do_report_used, 0, 0);
414 /* called by sv_clean_objs() for each live SV */
417 do_clean_objs(pTHX_ SV *sv)
421 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
422 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
434 /* XXX Might want to check arrays, etc. */
437 /* called by sv_clean_objs() for each live SV */
439 #ifndef DISABLE_DESTRUCTOR_KLUDGE
441 do_clean_named_objs(pTHX_ SV *sv)
443 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
444 if ( SvOBJECT(GvSV(sv)) ||
445 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
446 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
447 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
448 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
450 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
451 SvFLAGS(sv) |= SVf_BREAK;
459 =for apidoc sv_clean_objs
461 Attempt to destroy all objects not yet freed
467 Perl_sv_clean_objs(pTHX)
469 PL_in_clean_objs = TRUE;
470 visit(do_clean_objs, SVf_ROK, SVf_ROK);
471 #ifndef DISABLE_DESTRUCTOR_KLUDGE
472 /* some barnacles may yet remain, clinging to typeglobs */
473 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
475 PL_in_clean_objs = FALSE;
478 /* called by sv_clean_all() for each live SV */
481 do_clean_all(pTHX_ SV *sv)
483 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
484 SvFLAGS(sv) |= SVf_BREAK;
485 if (PL_comppad == (AV*)sv) {
487 PL_curpad = Null(SV**);
493 =for apidoc sv_clean_all
495 Decrement the refcnt of each remaining SV, possibly triggering a
496 cleanup. This function may have to be called multiple times to free
497 SVs which are in complex self-referential hierarchies.
503 Perl_sv_clean_all(pTHX)
506 PL_in_clean_all = TRUE;
507 cleaned = visit(do_clean_all, 0,0);
508 PL_in_clean_all = FALSE;
513 =for apidoc sv_free_arenas
515 Deallocate the memory used by all arenas. Note that all the individual SV
516 heads and bodies within the arenas must already have been freed.
522 Perl_sv_free_arenas(pTHX)
526 XPV *arena, *arenanext;
528 /* Free arenas here, but be careful about fake ones. (We assume
529 contiguity of the fake ones with the corresponding real ones.) */
531 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
532 svanext = (SV*) SvANY(sva);
533 while (svanext && SvFAKE(svanext))
534 svanext = (SV*) SvANY(svanext);
537 Safefree((void *)sva);
540 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xiv_arenaroot = 0;
547 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xnv_arenaroot = 0;
554 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xrv_arenaroot = 0;
561 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpviv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvnv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvcv_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvav_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvhv_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvmg_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvgv_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvgv_arenaroot = 0;
617 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
621 PL_xpvlv_arenaroot = 0;
624 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
625 arenanext = (XPV*)arena->xpv_pv;
628 PL_xpvbm_arenaroot = 0;
634 for (he = PL_he_arenaroot; he; he = he_next) {
635 he_next = HeNEXT(he);
642 #if defined(USE_ITHREADS)
644 struct ptr_tbl_ent *pte;
645 struct ptr_tbl_ent *pte_next;
646 for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
647 pte_next = pte->next;
651 PL_pte_arenaroot = 0;
656 Safefree(PL_nice_chunk);
657 PL_nice_chunk = Nullch;
658 PL_nice_chunk_size = 0;
663 /* ---------------------------------------------------------------------
665 * support functions for report_uninit()
668 /* the maxiumum size of array or hash where we will scan looking
669 * for the undefined element that triggered the warning */
671 #define FUV_MAX_SEARCH_SIZE 1000
673 /* Look for an entry in the hash whose value has the same SV as val;
674 * If so, return a mortal copy of the key. */
677 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
683 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
684 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
689 for (i=HvMAX(hv); i>0; i--) {
691 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
692 if (HeVAL(entry) != val)
694 if ( HeVAL(entry) == &PL_sv_undef ||
695 HeVAL(entry) == &PL_sv_placeholder)
699 if (HeKLEN(entry) == HEf_SVKEY)
700 return sv_mortalcopy(HeKEY_sv(entry));
701 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
707 /* Look for an entry in the array whose value has the same SV as val;
708 * If so, return the index, otherwise return -1. */
711 S_find_array_subscript(pTHX_ AV *av, SV* val)
715 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
716 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
720 for (i=AvFILLp(av); i>=0; i--) {
721 if (svp[i] == val && svp[i] != &PL_sv_undef)
727 /* S_varname(): return the name of a variable, optionally with a subscript.
728 * If gv is non-zero, use the name of that global, along with gvtype (one
729 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
730 * targ. Depending on the value of the subscript_type flag, return:
733 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
734 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
735 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
736 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
739 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
740 SV* keyname, I32 aindex, int subscript_type)
745 SV * const name = sv_newmortal();
748 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
749 * XXX get rid of all this if gv_fullnameX() ever supports this
753 HV *hv = GvSTASH(gv);
754 sv_setpv(name, gvtype);
757 else if (!(p=HvNAME(hv)))
759 if (strNE(p, "main")) {
761 sv_catpvn(name,"::", 2);
763 if (GvNAMELEN(gv)>= 1 &&
764 ((unsigned int)*GvNAME(gv)) <= 26)
766 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
767 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
770 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
774 CV *cv = find_runcv(&u);
775 if (!cv || !CvPADLIST(cv))
777 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
778 sv = *av_fetch(av, targ, FALSE);
779 /* SvLEN in a pad name is not to be trusted */
780 sv_setpv(name, SvPV_nolen(sv));
783 if (subscript_type == FUV_SUBSCRIPT_HASH) {
786 Perl_sv_catpvf(aTHX_ name, "{%s}",
787 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
790 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
792 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
794 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
795 sv_insert(name, 0, 0, "within ", 7);
802 =for apidoc find_uninit_var
804 Find the name of the undefined variable (if any) that caused the operator o
805 to issue a "Use of uninitialized value" warning.
806 If match is true, only return a name if it's value matches uninit_sv.
807 So roughly speaking, if a unary operator (such as OP_COS) generates a
808 warning, then following the direct child of the op may yield an
809 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
810 other hand, with OP_ADD there are two branches to follow, so we only print
811 the variable name if we get an exact match.
813 The name is returned as a mortal SV.
815 Assumes that PL_op is the op that originally triggered the error, and that
816 PL_comppad/PL_curpad points to the currently executing pad.
822 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
831 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
832 uninit_sv == &PL_sv_placeholder)))
835 switch (obase->op_type) {
842 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
843 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
846 int subscript_type = FUV_SUBSCRIPT_WITHIN;
848 if (pad) { /* @lex, %lex */
849 sv = PAD_SVl(obase->op_targ);
853 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
854 /* @global, %global */
855 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
858 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
860 else /* @{expr}, %{expr} */
861 return find_uninit_var(cUNOPx(obase)->op_first,
865 /* attempt to find a match within the aggregate */
867 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
869 subscript_type = FUV_SUBSCRIPT_HASH;
872 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
874 subscript_type = FUV_SUBSCRIPT_ARRAY;
877 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
880 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
881 keysv, index, subscript_type);
885 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
887 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
888 Nullsv, 0, FUV_SUBSCRIPT_NONE);
891 gv = cGVOPx_gv(obase);
892 if (!gv || (match && GvSV(gv) != uninit_sv))
894 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
897 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
899 av = (AV*)PAD_SV(obase->op_targ);
900 if (!av || SvRMAGICAL(av))
902 svp = av_fetch(av, (I32)obase->op_private, FALSE);
903 if (!svp || *svp != uninit_sv)
906 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
907 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
910 gv = cGVOPx_gv(obase);
915 if (!av || SvRMAGICAL(av))
917 svp = av_fetch(av, (I32)obase->op_private, FALSE);
918 if (!svp || *svp != uninit_sv)
921 return S_varname(aTHX_ gv, "$", 0,
922 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
927 o = cUNOPx(obase)->op_first;
928 if (!o || o->op_type != OP_NULL ||
929 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
931 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
936 /* $a[uninit_expr] or $h{uninit_expr} */
937 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
940 o = cBINOPx(obase)->op_first;
941 kid = cBINOPx(obase)->op_last;
943 /* get the av or hv, and optionally the gv */
945 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
946 sv = PAD_SV(o->op_targ);
948 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
949 && cUNOPo->op_first->op_type == OP_GV)
951 gv = cGVOPx_gv(cUNOPo->op_first);
954 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
959 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
960 /* index is constant */
964 if (obase->op_type == OP_HELEM) {
965 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
966 if (!he || HeVAL(he) != uninit_sv)
970 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
971 if (!svp || *svp != uninit_sv)
975 if (obase->op_type == OP_HELEM)
976 return S_varname(aTHX_ gv, "%", o->op_targ,
977 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
979 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
980 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
984 /* index is an expression;
985 * attempt to find a match within the aggregate */
986 if (obase->op_type == OP_HELEM) {
987 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
989 return S_varname(aTHX_ gv, "%", o->op_targ,
990 keysv, 0, FUV_SUBSCRIPT_HASH);
993 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
995 return S_varname(aTHX_ gv, "@", o->op_targ,
996 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
1000 return S_varname(aTHX_ gv,
1001 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
1003 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
1009 /* only examine RHS */
1010 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
1013 o = cUNOPx(obase)->op_first;
1014 if (o->op_type == OP_PUSHMARK)
1017 if (!o->op_sibling) {
1018 /* one-arg version of open is highly magical */
1020 if (o->op_type == OP_GV) { /* open FOO; */
1022 if (match && GvSV(gv) != uninit_sv)
1024 return S_varname(aTHX_ gv, "$", 0,
1025 Nullsv, 0, FUV_SUBSCRIPT_NONE);
1027 /* other possibilities not handled are:
1028 * open $x; or open my $x; should return '${*$x}'
1029 * open expr; should return '$'.expr ideally
1035 /* ops where $_ may be an implicit arg */
1039 if ( !(obase->op_flags & OPf_STACKED)) {
1040 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1041 ? PAD_SVl(obase->op_targ)
1044 sv = sv_newmortal();
1053 /* skip filehandle as it can't produce 'undef' warning */
1054 o = cUNOPx(obase)->op_first;
1055 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1056 o = o->op_sibling->op_sibling;
1063 match = 1; /* XS or custom code could trigger random warnings */
1068 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1069 return sv_2mortal(newSVpv("${$/}", 0));
1074 if (!(obase->op_flags & OPf_KIDS))
1076 o = cUNOPx(obase)->op_first;
1082 /* if all except one arg are constant, or have no side-effects,
1083 * or are optimized away, then it's unambiguous */
1085 for (kid=o; kid; kid = kid->op_sibling) {
1087 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1088 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1089 || (kid->op_type == OP_PUSHMARK)
1093 if (o2) { /* more than one found */
1100 return find_uninit_var(o2, uninit_sv, match);
1104 sv = find_uninit_var(o, uninit_sv, 1);
1116 =for apidoc report_uninit
1118 Print appropriate "Use of uninitialized variable" warning
1124 Perl_report_uninit(pTHX_ SV* uninit_sv)
1127 SV* varname = Nullsv;
1129 varname = find_uninit_var(PL_op, uninit_sv,0);
1131 sv_insert(varname, 0, 0, " ", 1);
1133 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1134 varname ? SvPV_nolen(varname) : "",
1135 " in ", OP_DESC(PL_op));
1138 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1143 /* allocate another arena's worth of struct xrv */
1151 New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1152 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1153 PL_xrv_arenaroot = ptr;
1156 xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
1157 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1159 while (xrv < xrvend) {
1160 xrv->xrv_rv = (SV*)(xrv + 1);
1166 /* allocate another arena's worth of IV bodies */
1174 New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1175 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1176 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1179 xivend = &xiv[PERL_ARENA_SIZE / sizeof(IV) - 1];
1180 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1182 while (xiv < xivend) {
1183 *(IV**)xiv = (IV *)(xiv + 1);
1189 /* allocate another arena's worth of NV bodies */
1197 New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1198 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1199 PL_xnv_arenaroot = ptr;
1202 xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
1203 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1205 while (xnv < xnvend) {
1206 *(NV**)xnv = (NV*)(xnv + 1);
1212 /* allocate another arena's worth of struct xpv */
1219 New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1220 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1221 PL_xpv_arenaroot = xpv;
1223 xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
1224 PL_xpv_root = ++xpv;
1225 while (xpv < xpvend) {
1226 xpv->xpv_pv = (char*)(xpv + 1);
1232 /* allocate another arena's worth of struct xpviv */
1239 New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
1240 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1241 PL_xpviv_arenaroot = xpviv;
1243 xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
1244 PL_xpviv_root = ++xpviv;
1245 while (xpviv < xpvivend) {
1246 xpviv->xpv_pv = (char*)(xpviv + 1);
1252 /* allocate another arena's worth of struct xpvnv */
1259 New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
1260 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1261 PL_xpvnv_arenaroot = xpvnv;
1263 xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
1264 PL_xpvnv_root = ++xpvnv;
1265 while (xpvnv < xpvnvend) {
1266 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1272 /* allocate another arena's worth of struct xpvcv */
1279 New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
1280 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1281 PL_xpvcv_arenaroot = xpvcv;
1283 xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
1284 PL_xpvcv_root = ++xpvcv;
1285 while (xpvcv < xpvcvend) {
1286 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1292 /* allocate another arena's worth of struct xpvav */
1299 New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
1300 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1301 PL_xpvav_arenaroot = xpvav;
1303 xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
1304 PL_xpvav_root = ++xpvav;
1305 while (xpvav < xpvavend) {
1306 xpvav->xav_array = (char*)(xpvav + 1);
1309 xpvav->xav_array = 0;
1312 /* allocate another arena's worth of struct xpvhv */
1319 New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
1320 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1321 PL_xpvhv_arenaroot = xpvhv;
1323 xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
1324 PL_xpvhv_root = ++xpvhv;
1325 while (xpvhv < xpvhvend) {
1326 xpvhv->xhv_array = (char*)(xpvhv + 1);
1329 xpvhv->xhv_array = 0;
1332 /* allocate another arena's worth of struct xpvmg */
1339 New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
1340 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1341 PL_xpvmg_arenaroot = xpvmg;
1343 xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
1344 PL_xpvmg_root = ++xpvmg;
1345 while (xpvmg < xpvmgend) {
1346 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1352 /* allocate another arena's worth of struct xpvgv */
1359 New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
1360 xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot;
1361 PL_xpvgv_arenaroot = xpvgv;
1363 xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
1364 PL_xpvgv_root = ++xpvgv;
1365 while (xpvgv < xpvgvend) {
1366 xpvgv->xpv_pv = (char*)(xpvgv + 1);
1372 /* allocate another arena's worth of struct xpvlv */
1379 New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
1380 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1381 PL_xpvlv_arenaroot = xpvlv;
1383 xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
1384 PL_xpvlv_root = ++xpvlv;
1385 while (xpvlv < xpvlvend) {
1386 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1392 /* allocate another arena's worth of struct xpvbm */
1399 New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
1400 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1401 PL_xpvbm_arenaroot = xpvbm;
1403 xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
1404 PL_xpvbm_root = ++xpvbm;
1405 while (xpvbm < xpvbmend) {
1406 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1412 /* grab a new struct xrv from the free list, allocating more if necessary */
1422 PL_xrv_root = (XRV*)xrv->xrv_rv;
1427 /* return a struct xrv to the free list */
1430 S_del_xrv(pTHX_ XRV *p)
1433 p->xrv_rv = (SV*)PL_xrv_root;
1438 /* grab a new IV body from the free list, allocating more if necessary */
1449 * See comment in more_xiv() -- RAM.
1451 PL_xiv_root = *(IV**)xiv;
1453 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1456 /* return an IV body to the free list */
1459 S_del_xiv(pTHX_ XPVIV *p)
1461 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1463 *(IV**)xiv = PL_xiv_root;
1468 /* grab a new NV body from the free list, allocating more if necessary */
1478 PL_xnv_root = *(NV**)xnv;
1480 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1483 /* return an NV body to the free list */
1486 S_del_xnv(pTHX_ XPVNV *p)
1488 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1490 *(NV**)xnv = PL_xnv_root;
1495 /* grab a new struct xpv from the free list, allocating more if necessary */
1505 PL_xpv_root = (XPV*)xpv->xpv_pv;
1510 /* return a struct xpv to the free list */
1513 S_del_xpv(pTHX_ XPV *p)
1516 p->xpv_pv = (char*)PL_xpv_root;
1521 /* grab a new struct xpviv from the free list, allocating more if necessary */
1530 xpviv = PL_xpviv_root;
1531 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1536 /* return a struct xpviv to the free list */
1539 S_del_xpviv(pTHX_ XPVIV *p)
1542 p->xpv_pv = (char*)PL_xpviv_root;
1547 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1556 xpvnv = PL_xpvnv_root;
1557 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1562 /* return a struct xpvnv to the free list */
1565 S_del_xpvnv(pTHX_ XPVNV *p)
1568 p->xpv_pv = (char*)PL_xpvnv_root;
1573 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1582 xpvcv = PL_xpvcv_root;
1583 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1588 /* return a struct xpvcv to the free list */
1591 S_del_xpvcv(pTHX_ XPVCV *p)
1594 p->xpv_pv = (char*)PL_xpvcv_root;
1599 /* grab a new struct xpvav from the free list, allocating more if necessary */
1608 xpvav = PL_xpvav_root;
1609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1614 /* return a struct xpvav to the free list */
1617 S_del_xpvav(pTHX_ XPVAV *p)
1620 p->xav_array = (char*)PL_xpvav_root;
1625 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1634 xpvhv = PL_xpvhv_root;
1635 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1640 /* return a struct xpvhv to the free list */
1643 S_del_xpvhv(pTHX_ XPVHV *p)
1646 p->xhv_array = (char*)PL_xpvhv_root;
1651 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1660 xpvmg = PL_xpvmg_root;
1661 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1666 /* return a struct xpvmg to the free list */
1669 S_del_xpvmg(pTHX_ XPVMG *p)
1672 p->xpv_pv = (char*)PL_xpvmg_root;
1677 /* grab a new struct xpvgv from the free list, allocating more if necessary */
1686 xpvgv = PL_xpvgv_root;
1687 PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv;
1692 /* return a struct xpvgv to the free list */
1695 S_del_xpvgv(pTHX_ XPVGV *p)
1698 p->xpv_pv = (char*)PL_xpvgv_root;
1703 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1712 xpvlv = PL_xpvlv_root;
1713 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1718 /* return a struct xpvlv to the free list */
1721 S_del_xpvlv(pTHX_ XPVLV *p)
1724 p->xpv_pv = (char*)PL_xpvlv_root;
1729 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1738 xpvbm = PL_xpvbm_root;
1739 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1744 /* return a struct xpvbm to the free list */
1747 S_del_xpvbm(pTHX_ XPVBM *p)
1750 p->xpv_pv = (char*)PL_xpvbm_root;
1755 #define my_safemalloc(s) (void*)safemalloc(s)
1756 #define my_safefree(p) safefree((char*)p)
1760 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1761 #define del_XIV(p) my_safefree(p)
1763 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1764 #define del_XNV(p) my_safefree(p)
1766 #define new_XRV() my_safemalloc(sizeof(XRV))
1767 #define del_XRV(p) my_safefree(p)
1769 #define new_XPV() my_safemalloc(sizeof(XPV))
1770 #define del_XPV(p) my_safefree(p)
1772 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1773 #define del_XPVIV(p) my_safefree(p)
1775 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1776 #define del_XPVNV(p) my_safefree(p)
1778 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1779 #define del_XPVCV(p) my_safefree(p)
1781 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1782 #define del_XPVAV(p) my_safefree(p)
1784 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1785 #define del_XPVHV(p) my_safefree(p)
1787 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1788 #define del_XPVMG(p) my_safefree(p)
1790 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1791 #define del_XPVGV(p) my_safefree(p)
1793 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1794 #define del_XPVLV(p) my_safefree(p)
1796 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1797 #define del_XPVBM(p) my_safefree(p)
1801 #define new_XIV() (void*)new_xiv()
1802 #define del_XIV(p) del_xiv((XPVIV*) p)
1804 #define new_XNV() (void*)new_xnv()
1805 #define del_XNV(p) del_xnv((XPVNV*) p)
1807 #define new_XRV() (void*)new_xrv()
1808 #define del_XRV(p) del_xrv((XRV*) p)
1810 #define new_XPV() (void*)new_xpv()
1811 #define del_XPV(p) del_xpv((XPV *)p)
1813 #define new_XPVIV() (void*)new_xpviv()
1814 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1816 #define new_XPVNV() (void*)new_xpvnv()
1817 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1819 #define new_XPVCV() (void*)new_xpvcv()
1820 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1822 #define new_XPVAV() (void*)new_xpvav()
1823 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1825 #define new_XPVHV() (void*)new_xpvhv()
1826 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1828 #define new_XPVMG() (void*)new_xpvmg()
1829 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1831 #define new_XPVGV() (void*)new_xpvgv()
1832 #define del_XPVGV(p) del_xpvgv((XPVGV *)p)
1834 #define new_XPVLV() (void*)new_xpvlv()
1835 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1837 #define new_XPVBM() (void*)new_xpvbm()
1838 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1842 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1843 #define del_XPVFM(p) my_safefree(p)
1845 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1846 #define del_XPVIO(p) my_safefree(p)
1849 =for apidoc sv_upgrade
1851 Upgrade an SV to a more complex form. Generally adds a new body type to the
1852 SV, then copies across as much information as possible from the old body.
1853 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1859 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1870 if (mt != SVt_PV && SvIsCOW(sv)) {
1871 sv_force_normal_flags(sv, 0);
1874 if (SvTYPE(sv) == mt)
1885 switch (SvTYPE(sv)) {
1893 else if (mt < SVt_PVIV)
1903 pv = (char*)SvRV(sv);
1913 else if (mt == SVt_NV)
1921 del_XPVIV(SvANY(sv));
1929 del_XPVNV(SvANY(sv));
1932 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1933 there's no way that it can be safely upgraded, because perl.c
1934 expects to Safefree(SvANY(PL_mess_sv)) */
1935 assert(sv != PL_mess_sv);
1936 /* This flag bit is used to mean other things in other scalar types.
1937 Given that it only has meaning inside the pad, it shouldn't be set
1938 on anything that can get upgraded. */
1939 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1945 magic = SvMAGIC(sv);
1946 stash = SvSTASH(sv);
1947 del_XPVMG(SvANY(sv));
1950 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1953 SvFLAGS(sv) &= ~SVTYPEMASK;
1958 Perl_croak(aTHX_ "Can't upgrade to undef");
1960 SvANY(sv) = new_XIV();
1964 SvANY(sv) = new_XNV();
1968 SvANY(sv) = new_XRV();
1969 SvRV_set(sv, (SV*)pv);
1972 SvANY(sv) = new_XPVHV();
1978 HvTOTALKEYS(sv) = 0;
1979 HvPLACEHOLDERS(sv) = 0;
1981 /* Fall through... */
1984 SvANY(sv) = new_XPVAV();
1994 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1996 /* FIXME. Should be able to remove all this if()... if the above
1997 assertion is genuinely always true. */
2000 SvFLAGS(sv) &= ~SVf_OOK;
2003 SvPV_set(sv, (char*)0);
2004 SvMAGIC_set(sv, magic);
2005 SvSTASH_set(sv, stash);
2009 SvANY(sv) = new_XPVIO();
2010 Zero(SvANY(sv), 1, XPVIO);
2011 IoPAGE_LEN(sv) = 60;
2012 goto set_magic_common;
2014 SvANY(sv) = new_XPVFM();
2015 Zero(SvANY(sv), 1, XPVFM);
2016 goto set_magic_common;
2018 SvANY(sv) = new_XPVBM();
2022 goto set_magic_common;
2024 SvANY(sv) = new_XPVGV();
2030 goto set_magic_common;
2032 SvANY(sv) = new_XPVCV();
2033 Zero(SvANY(sv), 1, XPVCV);
2034 goto set_magic_common;
2036 SvANY(sv) = new_XPVLV();
2049 SvANY(sv) = new_XPVMG();
2052 SvMAGIC_set(sv, magic);
2053 SvSTASH_set(sv, stash);
2057 SvANY(sv) = new_XPVNV();
2063 SvANY(sv) = new_XPVIV();
2072 SvANY(sv) = new_XPV();
2083 =for apidoc sv_backoff
2085 Remove any string offset. You should normally use the C<SvOOK_off> macro
2092 Perl_sv_backoff(pTHX_ register SV *sv)
2096 char *s = SvPVX(sv);
2097 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2098 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2100 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2102 SvFLAGS(sv) &= ~SVf_OOK;
2109 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2110 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2111 Use the C<SvGROW> wrapper instead.
2117 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2121 #ifdef HAS_64K_LIMIT
2122 if (newlen >= 0x10000) {
2123 PerlIO_printf(Perl_debug_log,
2124 "Allocation too large: %"UVxf"\n", (UV)newlen);
2127 #endif /* HAS_64K_LIMIT */
2130 if (SvTYPE(sv) < SVt_PV) {
2131 sv_upgrade(sv, SVt_PV);
2134 else if (SvOOK(sv)) { /* pv is offset? */
2137 if (newlen > SvLEN(sv))
2138 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2139 #ifdef HAS_64K_LIMIT
2140 if (newlen >= 0x10000)
2147 if (newlen > SvLEN(sv)) { /* need more room? */
2148 if (SvLEN(sv) && s) {
2150 const STRLEN l = malloced_size((void*)SvPVX(sv));
2156 Renew(s,newlen,char);
2159 New(703, s, newlen, char);
2160 if (SvPVX(sv) && SvCUR(sv)) {
2161 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2165 SvLEN_set(sv, newlen);
2171 =for apidoc sv_setiv
2173 Copies an integer into the given SV, upgrading first if necessary.
2174 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2180 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2182 SV_CHECK_THINKFIRST_COW_DROP(sv);
2183 switch (SvTYPE(sv)) {
2185 sv_upgrade(sv, SVt_IV);
2188 sv_upgrade(sv, SVt_PVNV);
2192 sv_upgrade(sv, SVt_PVIV);
2201 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2204 (void)SvIOK_only(sv); /* validate number */
2210 =for apidoc sv_setiv_mg
2212 Like C<sv_setiv>, but also handles 'set' magic.
2218 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2225 =for apidoc sv_setuv
2227 Copies an unsigned integer into the given SV, upgrading first if necessary.
2228 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2234 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2236 /* With these two if statements:
2237 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2240 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2242 If you wish to remove them, please benchmark to see what the effect is
2244 if (u <= (UV)IV_MAX) {
2245 sv_setiv(sv, (IV)u);
2254 =for apidoc sv_setuv_mg
2256 Like C<sv_setuv>, but also handles 'set' magic.
2262 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2264 /* With these two if statements:
2265 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2268 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2270 If you wish to remove them, please benchmark to see what the effect is
2272 if (u <= (UV)IV_MAX) {
2273 sv_setiv(sv, (IV)u);
2283 =for apidoc sv_setnv
2285 Copies a double into the given SV, upgrading first if necessary.
2286 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2292 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2294 SV_CHECK_THINKFIRST_COW_DROP(sv);
2295 switch (SvTYPE(sv)) {
2298 sv_upgrade(sv, SVt_NV);
2303 sv_upgrade(sv, SVt_PVNV);
2312 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2316 (void)SvNOK_only(sv); /* validate number */
2321 =for apidoc sv_setnv_mg
2323 Like C<sv_setnv>, but also handles 'set' magic.
2329 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2335 /* Print an "isn't numeric" warning, using a cleaned-up,
2336 * printable version of the offending string
2340 S_not_a_number(pTHX_ SV *sv)
2347 dsv = sv_2mortal(newSVpv("", 0));
2348 pv = sv_uni_display(dsv, sv, 10, 0);
2351 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2352 /* each *s can expand to 4 chars + "...\0",
2353 i.e. need room for 8 chars */
2356 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2358 if (ch & 128 && !isPRINT_LC(ch)) {
2367 else if (ch == '\r') {
2371 else if (ch == '\f') {
2375 else if (ch == '\\') {
2379 else if (ch == '\0') {
2383 else if (isPRINT_LC(ch))
2400 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2401 "Argument \"%s\" isn't numeric in %s", pv,
2404 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2405 "Argument \"%s\" isn't numeric", pv);
2409 =for apidoc looks_like_number
2411 Test if the content of an SV looks like a number (or is a number).
2412 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2413 non-numeric warning), even if your atof() doesn't grok them.
2419 Perl_looks_like_number(pTHX_ SV *sv)
2421 register const char *sbegin;
2428 else if (SvPOKp(sv))
2429 sbegin = SvPV(sv, len);
2431 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2432 return grok_number(sbegin, len, NULL);
2435 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2436 until proven guilty, assume that things are not that bad... */
2441 As 64 bit platforms often have an NV that doesn't preserve all bits of
2442 an IV (an assumption perl has been based on to date) it becomes necessary
2443 to remove the assumption that the NV always carries enough precision to
2444 recreate the IV whenever needed, and that the NV is the canonical form.
2445 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2446 precision as a side effect of conversion (which would lead to insanity
2447 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2448 1) to distinguish between IV/UV/NV slots that have cached a valid
2449 conversion where precision was lost and IV/UV/NV slots that have a
2450 valid conversion which has lost no precision
2451 2) to ensure that if a numeric conversion to one form is requested that
2452 would lose precision, the precise conversion (or differently
2453 imprecise conversion) is also performed and cached, to prevent
2454 requests for different numeric formats on the same SV causing
2455 lossy conversion chains. (lossless conversion chains are perfectly
2460 SvIOKp is true if the IV slot contains a valid value
2461 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2462 SvNOKp is true if the NV slot contains a valid value
2463 SvNOK is true only if the NV value is accurate
2466 while converting from PV to NV, check to see if converting that NV to an
2467 IV(or UV) would lose accuracy over a direct conversion from PV to
2468 IV(or UV). If it would, cache both conversions, return NV, but mark
2469 SV as IOK NOKp (ie not NOK).
2471 While converting from PV to IV, check to see if converting that IV to an
2472 NV would lose accuracy over a direct conversion from PV to NV. If it
2473 would, cache both conversions, flag similarly.
2475 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2476 correctly because if IV & NV were set NV *always* overruled.
2477 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2478 changes - now IV and NV together means that the two are interchangeable:
2479 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2481 The benefit of this is that operations such as pp_add know that if
2482 SvIOK is true for both left and right operands, then integer addition
2483 can be used instead of floating point (for cases where the result won't
2484 overflow). Before, floating point was always used, which could lead to
2485 loss of precision compared with integer addition.
2487 * making IV and NV equal status should make maths accurate on 64 bit
2489 * may speed up maths somewhat if pp_add and friends start to use
2490 integers when possible instead of fp. (Hopefully the overhead in
2491 looking for SvIOK and checking for overflow will not outweigh the
2492 fp to integer speedup)
2493 * will slow down integer operations (callers of SvIV) on "inaccurate"
2494 values, as the change from SvIOK to SvIOKp will cause a call into
2495 sv_2iv each time rather than a macro access direct to the IV slot
2496 * should speed up number->string conversion on integers as IV is
2497 favoured when IV and NV are equally accurate
2499 ####################################################################
2500 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2501 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2502 On the other hand, SvUOK is true iff UV.
2503 ####################################################################
2505 Your mileage will vary depending your CPU's relative fp to integer
2509 #ifndef NV_PRESERVES_UV
2510 # define IS_NUMBER_UNDERFLOW_IV 1
2511 # define IS_NUMBER_UNDERFLOW_UV 2
2512 # define IS_NUMBER_IV_AND_UV 2
2513 # define IS_NUMBER_OVERFLOW_IV 4
2514 # define IS_NUMBER_OVERFLOW_UV 5
2516 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2518 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2520 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2522 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2523 if (SvNVX(sv) < (NV)IV_MIN) {
2524 (void)SvIOKp_on(sv);
2526 SvIV_set(sv, IV_MIN);
2527 return IS_NUMBER_UNDERFLOW_IV;
2529 if (SvNVX(sv) > (NV)UV_MAX) {
2530 (void)SvIOKp_on(sv);
2533 SvUV_set(sv, UV_MAX);
2534 return IS_NUMBER_OVERFLOW_UV;
2536 (void)SvIOKp_on(sv);
2538 /* Can't use strtol etc to convert this string. (See truth table in
2540 if (SvNVX(sv) <= (UV)IV_MAX) {
2541 SvIV_set(sv, I_V(SvNVX(sv)));
2542 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2543 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2545 /* Integer is imprecise. NOK, IOKp */
2547 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2550 SvUV_set(sv, U_V(SvNVX(sv)));
2551 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2552 if (SvUVX(sv) == UV_MAX) {
2553 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2554 possibly be preserved by NV. Hence, it must be overflow.
2556 return IS_NUMBER_OVERFLOW_UV;
2558 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2560 /* Integer is imprecise. NOK, IOKp */
2562 return IS_NUMBER_OVERFLOW_IV;
2564 #endif /* !NV_PRESERVES_UV*/
2566 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2567 * this function provided for binary compatibility only
2571 Perl_sv_2iv(pTHX_ register SV *sv)
2573 return sv_2iv_flags(sv, SV_GMAGIC);
2577 =for apidoc sv_2iv_flags
2579 Return the integer value of an SV, doing any necessary string
2580 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2581 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2587 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2591 if (SvGMAGICAL(sv)) {
2592 if (flags & SV_GMAGIC)
2597 return I_V(SvNVX(sv));
2599 if (SvPOKp(sv) && SvLEN(sv))
2602 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2603 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2609 if (SvTHINKFIRST(sv)) {
2612 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2613 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2614 return SvIV(tmpstr);
2615 return PTR2IV(SvRV(sv));
2618 sv_force_normal_flags(sv, 0);
2620 if (SvREADONLY(sv) && !SvOK(sv)) {
2621 if (ckWARN(WARN_UNINITIALIZED))
2628 return (IV)(SvUVX(sv));
2635 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2636 * without also getting a cached IV/UV from it at the same time
2637 * (ie PV->NV conversion should detect loss of accuracy and cache
2638 * IV or UV at same time to avoid this. NWC */
2640 if (SvTYPE(sv) == SVt_NV)
2641 sv_upgrade(sv, SVt_PVNV);
2643 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2644 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2645 certainly cast into the IV range at IV_MAX, whereas the correct
2646 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2648 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2649 SvIV_set(sv, I_V(SvNVX(sv)));
2650 if (SvNVX(sv) == (NV) SvIVX(sv)
2651 #ifndef NV_PRESERVES_UV
2652 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2653 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2654 /* Don't flag it as "accurately an integer" if the number
2655 came from a (by definition imprecise) NV operation, and
2656 we're outside the range of NV integer precision */
2659 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2660 DEBUG_c(PerlIO_printf(Perl_debug_log,
2661 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2667 /* IV not precise. No need to convert from PV, as NV
2668 conversion would already have cached IV if it detected
2669 that PV->IV would be better than PV->NV->IV
2670 flags already correct - don't set public IOK. */
2671 DEBUG_c(PerlIO_printf(Perl_debug_log,
2672 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2677 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2678 but the cast (NV)IV_MIN rounds to a the value less (more
2679 negative) than IV_MIN which happens to be equal to SvNVX ??
2680 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2681 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2682 (NV)UVX == NVX are both true, but the values differ. :-(
2683 Hopefully for 2s complement IV_MIN is something like
2684 0x8000000000000000 which will be exact. NWC */
2687 SvUV_set(sv, U_V(SvNVX(sv)));
2689 (SvNVX(sv) == (NV) SvUVX(sv))
2690 #ifndef NV_PRESERVES_UV
2691 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2692 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2693 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2694 /* Don't flag it as "accurately an integer" if the number
2695 came from a (by definition imprecise) NV operation, and
2696 we're outside the range of NV integer precision */
2702 DEBUG_c(PerlIO_printf(Perl_debug_log,
2703 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2707 return (IV)SvUVX(sv);
2710 else if (SvPOKp(sv) && SvLEN(sv)) {
2712 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2713 /* We want to avoid a possible problem when we cache an IV which
2714 may be later translated to an NV, and the resulting NV is not
2715 the same as the direct translation of the initial string
2716 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2717 be careful to ensure that the value with the .456 is around if the
2718 NV value is requested in the future).
2720 This means that if we cache such an IV, we need to cache the
2721 NV as well. Moreover, we trade speed for space, and do not
2722 cache the NV if we are sure it's not needed.
2725 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2726 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2727 == IS_NUMBER_IN_UV) {
2728 /* It's definitely an integer, only upgrade to PVIV */
2729 if (SvTYPE(sv) < SVt_PVIV)
2730 sv_upgrade(sv, SVt_PVIV);
2732 } else if (SvTYPE(sv) < SVt_PVNV)
2733 sv_upgrade(sv, SVt_PVNV);
2735 /* If NV preserves UV then we only use the UV value if we know that
2736 we aren't going to call atof() below. If NVs don't preserve UVs
2737 then the value returned may have more precision than atof() will
2738 return, even though value isn't perfectly accurate. */
2739 if ((numtype & (IS_NUMBER_IN_UV
2740 #ifdef NV_PRESERVES_UV
2743 )) == IS_NUMBER_IN_UV) {
2744 /* This won't turn off the public IOK flag if it was set above */
2745 (void)SvIOKp_on(sv);
2747 if (!(numtype & IS_NUMBER_NEG)) {
2749 if (value <= (UV)IV_MAX) {
2750 SvIV_set(sv, (IV)value);
2752 SvUV_set(sv, value);
2756 /* 2s complement assumption */
2757 if (value <= (UV)IV_MIN) {
2758 SvIV_set(sv, -(IV)value);
2760 /* Too negative for an IV. This is a double upgrade, but
2761 I'm assuming it will be rare. */
2762 if (SvTYPE(sv) < SVt_PVNV)
2763 sv_upgrade(sv, SVt_PVNV);
2767 SvNV_set(sv, -(NV)value);
2768 SvIV_set(sv, IV_MIN);
2772 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2773 will be in the previous block to set the IV slot, and the next
2774 block to set the NV slot. So no else here. */
2776 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2777 != IS_NUMBER_IN_UV) {
2778 /* It wasn't an (integer that doesn't overflow the UV). */
2779 SvNV_set(sv, Atof(SvPVX(sv)));
2781 if (! numtype && ckWARN(WARN_NUMERIC))
2784 #if defined(USE_LONG_DOUBLE)
2785 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2786 PTR2UV(sv), SvNVX(sv)));
2788 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2789 PTR2UV(sv), SvNVX(sv)));
2793 #ifdef NV_PRESERVES_UV
2794 (void)SvIOKp_on(sv);
2796 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2797 SvIV_set(sv, I_V(SvNVX(sv)));
2798 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2801 /* Integer is imprecise. NOK, IOKp */
2803 /* UV will not work better than IV */
2805 if (SvNVX(sv) > (NV)UV_MAX) {
2807 /* Integer is inaccurate. NOK, IOKp, is UV */
2808 SvUV_set(sv, UV_MAX);
2811 SvUV_set(sv, U_V(SvNVX(sv)));
2812 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2813 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2817 /* Integer is imprecise. NOK, IOKp, is UV */
2823 #else /* NV_PRESERVES_UV */
2824 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2825 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2826 /* The IV slot will have been set from value returned by
2827 grok_number above. The NV slot has just been set using
2830 assert (SvIOKp(sv));
2832 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2833 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2834 /* Small enough to preserve all bits. */
2835 (void)SvIOKp_on(sv);
2837 SvIV_set(sv, I_V(SvNVX(sv)));
2838 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2840 /* Assumption: first non-preserved integer is < IV_MAX,
2841 this NV is in the preserved range, therefore: */
2842 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2844 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);
2848 0 0 already failed to read UV.
2849 0 1 already failed to read UV.
2850 1 0 you won't get here in this case. IV/UV
2851 slot set, public IOK, Atof() unneeded.
2852 1 1 already read UV.
2853 so there's no point in sv_2iuv_non_preserve() attempting
2854 to use atol, strtol, strtoul etc. */
2855 if (sv_2iuv_non_preserve (sv, numtype)
2856 >= IS_NUMBER_OVERFLOW_IV)
2860 #endif /* NV_PRESERVES_UV */
2863 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2865 if (SvTYPE(sv) < SVt_IV)
2866 /* Typically the caller expects that sv_any is not NULL now. */
2867 sv_upgrade(sv, SVt_IV);
2870 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2871 PTR2UV(sv),SvIVX(sv)));
2872 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2875 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2876 * this function provided for binary compatibility only
2880 Perl_sv_2uv(pTHX_ register SV *sv)
2882 return sv_2uv_flags(sv, SV_GMAGIC);
2886 =for apidoc sv_2uv_flags
2888 Return the unsigned integer value of an SV, doing any necessary string
2889 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2890 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2896 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2900 if (SvGMAGICAL(sv)) {
2901 if (flags & SV_GMAGIC)
2906 return U_V(SvNVX(sv));
2907 if (SvPOKp(sv) && SvLEN(sv))
2910 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2911 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2917 if (SvTHINKFIRST(sv)) {
2920 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2921 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2922 return SvUV(tmpstr);
2923 return PTR2UV(SvRV(sv));
2926 sv_force_normal_flags(sv, 0);
2928 if (SvREADONLY(sv) && !SvOK(sv)) {
2929 if (ckWARN(WARN_UNINITIALIZED))
2939 return (UV)SvIVX(sv);
2943 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2944 * without also getting a cached IV/UV from it at the same time
2945 * (ie PV->NV conversion should detect loss of accuracy and cache
2946 * IV or UV at same time to avoid this. */
2947 /* IV-over-UV optimisation - choose to cache IV if possible */
2949 if (SvTYPE(sv) == SVt_NV)
2950 sv_upgrade(sv, SVt_PVNV);
2952 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2953 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2954 SvIV_set(sv, I_V(SvNVX(sv)));
2955 if (SvNVX(sv) == (NV) SvIVX(sv)
2956 #ifndef NV_PRESERVES_UV
2957 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2958 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2959 /* Don't flag it as "accurately an integer" if the number
2960 came from a (by definition imprecise) NV operation, and
2961 we're outside the range of NV integer precision */
2964 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2965 DEBUG_c(PerlIO_printf(Perl_debug_log,
2966 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2972 /* IV not precise. No need to convert from PV, as NV
2973 conversion would already have cached IV if it detected
2974 that PV->IV would be better than PV->NV->IV
2975 flags already correct - don't set public IOK. */
2976 DEBUG_c(PerlIO_printf(Perl_debug_log,
2977 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2982 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2983 but the cast (NV)IV_MIN rounds to a the value less (more
2984 negative) than IV_MIN which happens to be equal to SvNVX ??
2985 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2986 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2987 (NV)UVX == NVX are both true, but the values differ. :-(
2988 Hopefully for 2s complement IV_MIN is something like
2989 0x8000000000000000 which will be exact. NWC */
2992 SvUV_set(sv, U_V(SvNVX(sv)));
2994 (SvNVX(sv) == (NV) SvUVX(sv))
2995 #ifndef NV_PRESERVES_UV
2996 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2997 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2998 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2999 /* Don't flag it as "accurately an integer" if the number
3000 came from a (by definition imprecise) NV operation, and
3001 we're outside the range of NV integer precision */
3006 DEBUG_c(PerlIO_printf(Perl_debug_log,
3007 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
3013 else if (SvPOKp(sv) && SvLEN(sv)) {
3015 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3017 /* We want to avoid a possible problem when we cache a UV which
3018 may be later translated to an NV, and the resulting NV is not
3019 the translation of the initial data.
3021 This means that if we cache such a UV, we need to cache the
3022 NV as well. Moreover, we trade speed for space, and do not
3023 cache the NV if not needed.
3026 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3027 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3028 == IS_NUMBER_IN_UV) {
3029 /* It's definitely an integer, only upgrade to PVIV */
3030 if (SvTYPE(sv) < SVt_PVIV)
3031 sv_upgrade(sv, SVt_PVIV);
3033 } else if (SvTYPE(sv) < SVt_PVNV)
3034 sv_upgrade(sv, SVt_PVNV);
3036 /* If NV preserves UV then we only use the UV value if we know that
3037 we aren't going to call atof() below. If NVs don't preserve UVs
3038 then the value returned may have more precision than atof() will
3039 return, even though it isn't accurate. */
3040 if ((numtype & (IS_NUMBER_IN_UV
3041 #ifdef NV_PRESERVES_UV
3044 )) == IS_NUMBER_IN_UV) {
3045 /* This won't turn off the public IOK flag if it was set above */
3046 (void)SvIOKp_on(sv);
3048 if (!(numtype & IS_NUMBER_NEG)) {
3050 if (value <= (UV)IV_MAX) {
3051 SvIV_set(sv, (IV)value);
3053 /* it didn't overflow, and it was positive. */
3054 SvUV_set(sv, value);
3058 /* 2s complement assumption */
3059 if (value <= (UV)IV_MIN) {
3060 SvIV_set(sv, -(IV)value);
3062 /* Too negative for an IV. This is a double upgrade, but
3063 I'm assuming it will be rare. */
3064 if (SvTYPE(sv) < SVt_PVNV)
3065 sv_upgrade(sv, SVt_PVNV);
3069 SvNV_set(sv, -(NV)value);
3070 SvIV_set(sv, IV_MIN);
3075 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3076 != IS_NUMBER_IN_UV) {
3077 /* It wasn't an integer, or it overflowed the UV. */
3078 SvNV_set(sv, Atof(SvPVX(sv)));
3080 if (! numtype && ckWARN(WARN_NUMERIC))
3083 #if defined(USE_LONG_DOUBLE)
3084 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3085 PTR2UV(sv), SvNVX(sv)));
3087 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3088 PTR2UV(sv), SvNVX(sv)));
3091 #ifdef NV_PRESERVES_UV
3092 (void)SvIOKp_on(sv);
3094 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3095 SvIV_set(sv, I_V(SvNVX(sv)));
3096 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3099 /* Integer is imprecise. NOK, IOKp */
3101 /* UV will not work better than IV */
3103 if (SvNVX(sv) > (NV)UV_MAX) {
3105 /* Integer is inaccurate. NOK, IOKp, is UV */
3106 SvUV_set(sv, UV_MAX);
3109 SvUV_set(sv, U_V(SvNVX(sv)));
3110 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3111 NV preservse UV so can do correct comparison. */
3112 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3116 /* Integer is imprecise. NOK, IOKp, is UV */
3121 #else /* NV_PRESERVES_UV */
3122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3123 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3124 /* The UV slot will have been set from value returned by
3125 grok_number above. The NV slot has just been set using
3128 assert (SvIOKp(sv));
3130 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3131 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3132 /* Small enough to preserve all bits. */
3133 (void)SvIOKp_on(sv);
3135 SvIV_set(sv, I_V(SvNVX(sv)));
3136 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3138 /* Assumption: first non-preserved integer is < IV_MAX,
3139 this NV is in the preserved range, therefore: */
3140 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3142 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);
3145 sv_2iuv_non_preserve (sv, numtype);
3147 #endif /* NV_PRESERVES_UV */
3151 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3152 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3155 if (SvTYPE(sv) < SVt_IV)
3156 /* Typically the caller expects that sv_any is not NULL now. */
3157 sv_upgrade(sv, SVt_IV);
3161 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3162 PTR2UV(sv),SvUVX(sv)));
3163 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3169 Return the num value of an SV, doing any necessary string or integer
3170 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3177 Perl_sv_2nv(pTHX_ register SV *sv)
3181 if (SvGMAGICAL(sv)) {
3185 if (SvPOKp(sv) && SvLEN(sv)) {
3186 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3187 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3189 return Atof(SvPVX(sv));
3193 return (NV)SvUVX(sv);
3195 return (NV)SvIVX(sv);
3198 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3199 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3205 if (SvTHINKFIRST(sv)) {
3208 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3209 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3210 return SvNV(tmpstr);
3211 return PTR2NV(SvRV(sv));
3214 sv_force_normal_flags(sv, 0);
3216 if (SvREADONLY(sv) && !SvOK(sv)) {
3217 if (ckWARN(WARN_UNINITIALIZED))
3222 if (SvTYPE(sv) < SVt_NV) {
3223 if (SvTYPE(sv) == SVt_IV)
3224 sv_upgrade(sv, SVt_PVNV);
3226 sv_upgrade(sv, SVt_NV);
3227 #ifdef USE_LONG_DOUBLE
3229 STORE_NUMERIC_LOCAL_SET_STANDARD();
3230 PerlIO_printf(Perl_debug_log,
3231 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3232 PTR2UV(sv), SvNVX(sv));
3233 RESTORE_NUMERIC_LOCAL();
3237 STORE_NUMERIC_LOCAL_SET_STANDARD();
3238 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3239 PTR2UV(sv), SvNVX(sv));
3240 RESTORE_NUMERIC_LOCAL();
3244 else if (SvTYPE(sv) < SVt_PVNV)
3245 sv_upgrade(sv, SVt_PVNV);
3250 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3251 #ifdef NV_PRESERVES_UV
3254 /* Only set the public NV OK flag if this NV preserves the IV */
3255 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3256 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3257 : (SvIVX(sv) == I_V(SvNVX(sv))))
3263 else if (SvPOKp(sv) && SvLEN(sv)) {
3265 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3266 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3268 #ifdef NV_PRESERVES_UV
3269 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3270 == IS_NUMBER_IN_UV) {
3271 /* It's definitely an integer */
3272 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3274 SvNV_set(sv, Atof(SvPVX(sv)));
3277 SvNV_set(sv, Atof(SvPVX(sv)));
3278 /* Only set the public NV OK flag if this NV preserves the value in
3279 the PV at least as well as an IV/UV would.
3280 Not sure how to do this 100% reliably. */
3281 /* if that shift count is out of range then Configure's test is
3282 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3284 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3285 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3286 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3287 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3288 /* Can't use strtol etc to convert this string, so don't try.
3289 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3292 /* value has been set. It may not be precise. */
3293 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3294 /* 2s complement assumption for (UV)IV_MIN */
3295 SvNOK_on(sv); /* Integer is too negative. */
3300 if (numtype & IS_NUMBER_NEG) {
3301 SvIV_set(sv, -(IV)value);
3302 } else if (value <= (UV)IV_MAX) {
3303 SvIV_set(sv, (IV)value);
3305 SvUV_set(sv, value);
3309 if (numtype & IS_NUMBER_NOT_INT) {
3310 /* I believe that even if the original PV had decimals,
3311 they are lost beyond the limit of the FP precision.
3312 However, neither is canonical, so both only get p
3313 flags. NWC, 2000/11/25 */
3314 /* Both already have p flags, so do nothing */
3317 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3318 if (SvIVX(sv) == I_V(nv)) {
3323 /* It had no "." so it must be integer. */
3326 /* between IV_MAX and NV(UV_MAX).
3327 Could be slightly > UV_MAX */
3329 if (numtype & IS_NUMBER_NOT_INT) {
3330 /* UV and NV both imprecise. */
3332 UV nv_as_uv = U_V(nv);
3334 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3345 #endif /* NV_PRESERVES_UV */
3348 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3350 if (SvTYPE(sv) < SVt_NV)
3351 /* Typically the caller expects that sv_any is not NULL now. */
3352 /* XXX Ilya implies that this is a bug in callers that assume this
3353 and ideally should be fixed. */
3354 sv_upgrade(sv, SVt_NV);
3357 #if defined(USE_LONG_DOUBLE)
3359 STORE_NUMERIC_LOCAL_SET_STANDARD();
3360 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3361 PTR2UV(sv), SvNVX(sv));
3362 RESTORE_NUMERIC_LOCAL();
3366 STORE_NUMERIC_LOCAL_SET_STANDARD();
3367 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3368 PTR2UV(sv), SvNVX(sv));
3369 RESTORE_NUMERIC_LOCAL();
3375 /* asIV(): extract an integer from the string value of an SV.
3376 * Caller must validate PVX */
3379 S_asIV(pTHX_ SV *sv)
3382 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3384 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3385 == IS_NUMBER_IN_UV) {
3386 /* It's definitely an integer */
3387 if (numtype & IS_NUMBER_NEG) {
3388 if (value < (UV)IV_MIN)
3391 if (value < (UV)IV_MAX)
3396 if (ckWARN(WARN_NUMERIC))
3399 return I_V(Atof(SvPVX(sv)));
3402 /* asUV(): extract an unsigned integer from the string value of an SV
3403 * Caller must validate PVX */
3406 S_asUV(pTHX_ SV *sv)
3409 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3411 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3412 == IS_NUMBER_IN_UV) {
3413 /* It's definitely an integer */
3414 if (!(numtype & IS_NUMBER_NEG))
3418 if (ckWARN(WARN_NUMERIC))
3421 return U_V(Atof(SvPVX(sv)));
3425 =for apidoc sv_2pv_nolen
3427 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3428 use the macro wrapper C<SvPV_nolen(sv)> instead.
3433 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3436 return sv_2pv(sv, &n_a);
3439 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3440 * UV as a string towards the end of buf, and return pointers to start and
3443 * We assume that buf is at least TYPE_CHARS(UV) long.
3447 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3449 char *ptr = buf + TYPE_CHARS(UV);
3463 *--ptr = '0' + (char)(uv % 10);
3471 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3472 * this function provided for binary compatibility only
3476 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3478 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3482 =for apidoc sv_2pv_flags
3484 Returns a pointer to the string value of an SV, and sets *lp to its length.
3485 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3487 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3488 usually end up here too.
3494 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3499 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3500 char *tmpbuf = tbuf;
3506 if (SvGMAGICAL(sv)) {
3507 if (flags & SV_GMAGIC)
3515 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3517 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3522 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3527 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3528 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3535 if (SvTHINKFIRST(sv)) {
3538 register const char *typestr;
3539 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3540 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3541 char *pv = SvPV(tmpstr, *lp);
3551 typestr = "NULLREF";
3555 switch (SvTYPE(sv)) {
3557 if ( ((SvFLAGS(sv) &
3558 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3559 == (SVs_OBJECT|SVs_SMG))
3560 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3561 const regexp *re = (regexp *)mg->mg_obj;
3564 const char *fptr = "msix";
3569 char need_newline = 0;
3570 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3572 while((ch = *fptr++)) {
3574 reflags[left++] = ch;
3577 reflags[right--] = ch;
3582 reflags[left] = '-';
3586 mg->mg_len = re->prelen + 4 + left;
3588 * If /x was used, we have to worry about a regex
3589 * ending with a comment later being embedded
3590 * within another regex. If so, we don't want this
3591 * regex's "commentization" to leak out to the
3592 * right part of the enclosing regex, we must cap
3593 * it with a newline.
3595 * So, if /x was used, we scan backwards from the
3596 * end of the regex. If we find a '#' before we
3597 * find a newline, we need to add a newline
3598 * ourself. If we find a '\n' first (or if we
3599 * don't find '#' or '\n'), we don't need to add
3600 * anything. -jfriedl
3602 if (PMf_EXTENDED & re->reganch)
3604 const char *endptr = re->precomp + re->prelen;
3605 while (endptr >= re->precomp)
3607 const char c = *(endptr--);
3609 break; /* don't need another */
3611 /* we end while in a comment, so we
3613 mg->mg_len++; /* save space for it */
3614 need_newline = 1; /* note to add it */
3620 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3621 Copy("(?", mg->mg_ptr, 2, char);
3622 Copy(reflags, mg->mg_ptr+2, left, char);
3623 Copy(":", mg->mg_ptr+left+2, 1, char);
3624 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3626 mg->mg_ptr[mg->mg_len - 2] = '\n';
3627 mg->mg_ptr[mg->mg_len - 1] = ')';
3628 mg->mg_ptr[mg->mg_len] = 0;
3630 PL_reginterp_cnt += re->program[0].next_off;
3632 if (re->reganch & ROPT_UTF8)
3647 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3648 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3649 /* tied lvalues should appear to be
3650 * scalars for backwards compatitbility */
3651 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3652 ? "SCALAR" : "LVALUE"; break;
3653 case SVt_PVAV: typestr = "ARRAY"; break;
3654 case SVt_PVHV: typestr = "HASH"; break;
3655 case SVt_PVCV: typestr = "CODE"; break;
3656 case SVt_PVGV: typestr = "GLOB"; break;
3657 case SVt_PVFM: typestr = "FORMAT"; break;
3658 case SVt_PVIO: typestr = "IO"; break;
3659 default: typestr = "UNKNOWN"; break;
3663 const char *name = HvNAME(SvSTASH(sv));
3664 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3665 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3668 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3671 *lp = strlen(typestr);
3672 return (char *)typestr;
3674 if (SvREADONLY(sv) && !SvOK(sv)) {
3675 if (ckWARN(WARN_UNINITIALIZED))
3681 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3682 /* I'm assuming that if both IV and NV are equally valid then
3683 converting the IV is going to be more efficient */
3684 const U32 isIOK = SvIOK(sv);
3685 const U32 isUIOK = SvIsUV(sv);
3686 char buf[TYPE_CHARS(UV)];
3689 if (SvTYPE(sv) < SVt_PVIV)
3690 sv_upgrade(sv, SVt_PVIV);
3692 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3694 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3695 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3696 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3697 SvCUR_set(sv, ebuf - ptr);
3707 else if (SvNOKp(sv)) {
3708 if (SvTYPE(sv) < SVt_PVNV)
3709 sv_upgrade(sv, SVt_PVNV);
3710 /* The +20 is pure guesswork. Configure test needed. --jhi */
3711 SvGROW(sv, NV_DIG + 20);
3713 olderrno = errno; /* some Xenix systems wipe out errno here */
3715 if (SvNVX(sv) == 0.0)
3716 (void)strcpy(s,"0");
3720 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3723 #ifdef FIXNEGATIVEZERO
3724 if (*s == '-' && s[1] == '0' && !s[2])
3734 if (ckWARN(WARN_UNINITIALIZED)
3735 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3738 if (SvTYPE(sv) < SVt_PV)
3739 /* Typically the caller expects that sv_any is not NULL now. */
3740 sv_upgrade(sv, SVt_PV);
3743 *lp = s - SvPVX(sv);
3746 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3747 PTR2UV(sv),SvPVX(sv)));
3751 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3752 /* Sneaky stuff here */
3756 tsv = newSVpv(tmpbuf, 0);
3773 len = strlen(tmpbuf);
3775 #ifdef FIXNEGATIVEZERO
3776 if (len == 2 && t[0] == '-' && t[1] == '0') {
3781 (void)SvUPGRADE(sv, SVt_PV);
3783 s = SvGROW(sv, len + 1);
3786 return strcpy(s, t);
3791 =for apidoc sv_copypv
3793 Copies a stringified representation of the source SV into the
3794 destination SV. Automatically performs any necessary mg_get and
3795 coercion of numeric values into strings. Guaranteed to preserve
3796 UTF-8 flag even from overloaded objects. Similar in nature to
3797 sv_2pv[_flags] but operates directly on an SV instead of just the
3798 string. Mostly uses sv_2pv_flags to do its work, except when that
3799 would lose the UTF-8'ness of the PV.
3805 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3810 sv_setpvn(dsv,s,len);
3818 =for apidoc sv_2pvbyte_nolen
3820 Return a pointer to the byte-encoded representation of the SV.
3821 May cause the SV to be downgraded from UTF-8 as a side-effect.
3823 Usually accessed via the C<SvPVbyte_nolen> macro.
3829 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3832 return sv_2pvbyte(sv, &n_a);
3836 =for apidoc sv_2pvbyte
3838 Return a pointer to the byte-encoded representation of the SV, and set *lp
3839 to its length. May cause the SV to be downgraded from UTF-8 as a
3842 Usually accessed via the C<SvPVbyte> macro.
3848 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3850 sv_utf8_downgrade(sv,0);
3851 return SvPV(sv,*lp);
3855 =for apidoc sv_2pvutf8_nolen
3857 Return a pointer to the UTF-8-encoded representation of the SV.
3858 May cause the SV to be upgraded to UTF-8 as a side-effect.
3860 Usually accessed via the C<SvPVutf8_nolen> macro.
3866 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3869 return sv_2pvutf8(sv, &n_a);
3873 =for apidoc sv_2pvutf8
3875 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3876 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3878 Usually accessed via the C<SvPVutf8> macro.
3884 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3886 sv_utf8_upgrade(sv);
3887 return SvPV(sv,*lp);
3891 =for apidoc sv_2bool
3893 This function is only called on magical items, and is only used by
3894 sv_true() or its macro equivalent.
3900 Perl_sv_2bool(pTHX_ register SV *sv)
3909 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3910 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3911 return (bool)SvTRUE(tmpsv);
3912 return SvRV(sv) != 0;
3915 register XPV* Xpvtmp;
3916 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3917 (*Xpvtmp->xpv_pv > '0' ||
3918 Xpvtmp->xpv_cur > 1 ||
3919 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3926 return SvIVX(sv) != 0;
3929 return SvNVX(sv) != 0.0;
3936 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3937 * this function provided for binary compatibility only
3942 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3944 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3948 =for apidoc sv_utf8_upgrade
3950 Converts the PV of an SV to its UTF-8-encoded form.
3951 Forces the SV to string form if it is not already.
3952 Always sets the SvUTF8 flag to avoid future validity checks even
3953 if all the bytes have hibit clear.
3955 This is not as a general purpose byte encoding to Unicode interface:
3956 use the Encode extension for that.
3958 =for apidoc sv_utf8_upgrade_flags
3960 Converts the PV of an SV to its UTF-8-encoded form.
3961 Forces the SV to string form if it is not already.
3962 Always sets the SvUTF8 flag to avoid future validity checks even
3963 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3964 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3965 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3967 This is not as a general purpose byte encoding to Unicode interface:
3968 use the Encode extension for that.
3974 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3976 if (sv == &PL_sv_undef)
3980 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3981 (void) sv_2pv_flags(sv,&len, flags);
3985 (void) SvPV_force(sv,len);
3994 sv_force_normal_flags(sv, 0);
3997 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3998 sv_recode_to_utf8(sv, PL_encoding);
3999 else { /* Assume Latin-1/EBCDIC */
4000 /* This function could be much more efficient if we
4001 * had a FLAG in SVs to signal if there are any hibit
4002 * chars in the PV. Given that there isn't such a flag
4003 * make the loop as fast as possible. */
4004 U8 *s = (U8 *) SvPVX(sv);
4005 U8 *e = (U8 *) SvEND(sv);
4011 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
4015 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
4016 s = bytes_to_utf8((U8*)s, &len);
4018 SvPV_free(sv); /* No longer using what was there before. */
4020 SvPV_set(sv, (char*)s);
4021 SvCUR_set(sv, len - 1);
4022 SvLEN_set(sv, len); /* No longer know the real size. */
4024 /* Mark as UTF-8 even if no hibit - saves scanning loop */
4031 =for apidoc sv_utf8_downgrade
4033 Attempts to convert the PV of an SV from characters to bytes.
4034 If the PV contains a character beyond byte, this conversion will fail;
4035 in this case, either returns false or, if C<fail_ok> is not
4038 This is not as a general purpose Unicode to byte encoding interface:
4039 use the Encode extension for that.
4045 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4047 if (SvPOKp(sv) && SvUTF8(sv)) {
4053 sv_force_normal_flags(sv, 0);
4055 s = (U8 *) SvPV(sv, len);
4056 if (!utf8_to_bytes(s, &len)) {
4061 Perl_croak(aTHX_ "Wide character in %s",
4064 Perl_croak(aTHX_ "Wide character");
4075 =for apidoc sv_utf8_encode
4077 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4078 flag off so that it looks like octets again.
4084 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4086 (void) sv_utf8_upgrade(sv);
4088 sv_force_normal_flags(sv, 0);
4090 if (SvREADONLY(sv)) {
4091 Perl_croak(aTHX_ PL_no_modify);
4097 =for apidoc sv_utf8_decode
4099 If the PV of the SV is an octet sequence in UTF-8
4100 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4101 so that it looks like a character. If the PV contains only single-byte
4102 characters, the C<SvUTF8> flag stays being off.
4103 Scans PV for validity and returns false if the PV is invalid UTF-8.
4109 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4115 /* The octets may have got themselves encoded - get them back as
4118 if (!sv_utf8_downgrade(sv, TRUE))
4121 /* it is actually just a matter of turning the utf8 flag on, but
4122 * we want to make sure everything inside is valid utf8 first.
4124 c = (U8 *) SvPVX(sv);
4125 if (!is_utf8_string(c, SvCUR(sv)+1))
4127 e = (U8 *) SvEND(sv);
4130 if (!UTF8_IS_INVARIANT(ch)) {
4139 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4140 * this function provided for binary compatibility only
4144 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4146 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4150 =for apidoc sv_setsv
4152 Copies the contents of the source SV C<ssv> into the destination SV
4153 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4154 function if the source SV needs to be reused. Does not handle 'set' magic.
4155 Loosely speaking, it performs a copy-by-value, obliterating any previous
4156 content of the destination.
4158 You probably want to use one of the assortment of wrappers, such as
4159 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4160 C<SvSetMagicSV_nosteal>.
4162 =for apidoc sv_setsv_flags
4164 Copies the contents of the source SV C<ssv> into the destination SV
4165 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4166 function if the source SV needs to be reused. Does not handle 'set' magic.
4167 Loosely speaking, it performs a copy-by-value, obliterating any previous
4168 content of the destination.
4169 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4170 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4171 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4172 and C<sv_setsv_nomg> are implemented in terms of this function.
4174 You probably want to use one of the assortment of wrappers, such as
4175 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4176 C<SvSetMagicSV_nosteal>.
4178 This is the primary function for copying scalars, and most other
4179 copy-ish functions and macros use this underneath.
4185 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4187 register U32 sflags;
4193 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4195 sstr = &PL_sv_undef;
4196 stype = SvTYPE(sstr);
4197 dtype = SvTYPE(dstr);
4202 /* need to nuke the magic */
4204 SvRMAGICAL_off(dstr);
4207 /* There's a lot of redundancy below but we're going for speed here */
4212 if (dtype != SVt_PVGV) {
4213 (void)SvOK_off(dstr);
4221 sv_upgrade(dstr, SVt_IV);
4224 sv_upgrade(dstr, SVt_PVNV);
4228 sv_upgrade(dstr, SVt_PVIV);
4231 (void)SvIOK_only(dstr);
4232 SvIV_set(dstr, SvIVX(sstr));
4235 if (SvTAINTED(sstr))
4246 sv_upgrade(dstr, SVt_NV);
4251 sv_upgrade(dstr, SVt_PVNV);
4254 SvNV_set(dstr, SvNVX(sstr));
4255 (void)SvNOK_only(dstr);
4256 if (SvTAINTED(sstr))
4264 sv_upgrade(dstr, SVt_RV);
4265 else if (dtype == SVt_PVGV &&
4266 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4269 if (GvIMPORTED(dstr) != GVf_IMPORTED
4270 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4272 GvIMPORTED_on(dstr);
4281 #ifdef PERL_COPY_ON_WRITE
4282 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4283 if (dtype < SVt_PVIV)
4284 sv_upgrade(dstr, SVt_PVIV);
4291 sv_upgrade(dstr, SVt_PV);
4294 if (dtype < SVt_PVIV)
4295 sv_upgrade(dstr, SVt_PVIV);
4298 if (dtype < SVt_PVNV)
4299 sv_upgrade(dstr, SVt_PVNV);
4306 const char * const type = sv_reftype(sstr,0);
4308 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4310 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4315 if (dtype <= SVt_PVGV) {
4317 if (dtype != SVt_PVGV) {
4318 const char * const name = GvNAME(sstr);
4319 const STRLEN len = GvNAMELEN(sstr);
4320 /* don't upgrade SVt_PVLV: it can hold a glob */
4321 if (dtype != SVt_PVLV)
4322 sv_upgrade(dstr, SVt_PVGV);
4323 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4324 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4325 GvNAME(dstr) = savepvn(name, len);
4326 GvNAMELEN(dstr) = len;
4327 SvFAKE_on(dstr); /* can coerce to non-glob */
4329 /* ahem, death to those who redefine active sort subs */
4330 else if (PL_curstackinfo->si_type == PERLSI_SORT
4331 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4332 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4335 #ifdef GV_UNIQUE_CHECK
4336 if (GvUNIQUE((GV*)dstr)) {
4337 Perl_croak(aTHX_ PL_no_modify);
4341 (void)SvOK_off(dstr);
4342 GvINTRO_off(dstr); /* one-shot flag */
4344 GvGP(dstr) = gp_ref(GvGP(sstr));
4345 if (SvTAINTED(sstr))
4347 if (GvIMPORTED(dstr) != GVf_IMPORTED
4348 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4350 GvIMPORTED_on(dstr);
4358 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4360 if ((int)SvTYPE(sstr) != stype) {
4361 stype = SvTYPE(sstr);
4362 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4366 if (stype == SVt_PVLV)
4367 (void)SvUPGRADE(dstr, SVt_PVNV);
4369 (void)SvUPGRADE(dstr, (U32)stype);
4372 sflags = SvFLAGS(sstr);
4374 if (sflags & SVf_ROK) {
4375 if (dtype >= SVt_PV) {
4376 if (dtype == SVt_PVGV) {
4377 SV *sref = SvREFCNT_inc(SvRV(sstr));
4379 const int intro = GvINTRO(dstr);
4381 #ifdef GV_UNIQUE_CHECK
4382 if (GvUNIQUE((GV*)dstr)) {
4383 Perl_croak(aTHX_ PL_no_modify);
4388 GvINTRO_off(dstr); /* one-shot flag */
4389 GvLINE(dstr) = CopLINE(PL_curcop);
4390 GvEGV(dstr) = (GV*)dstr;
4393 switch (SvTYPE(sref)) {
4396 SAVEGENERICSV(GvAV(dstr));
4398 dref = (SV*)GvAV(dstr);
4399 GvAV(dstr) = (AV*)sref;
4400 if (!GvIMPORTED_AV(dstr)
4401 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4403 GvIMPORTED_AV_on(dstr);
4408 SAVEGENERICSV(GvHV(dstr));
4410 dref = (SV*)GvHV(dstr);
4411 GvHV(dstr) = (HV*)sref;
4412 if (!GvIMPORTED_HV(dstr)
4413 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4415 GvIMPORTED_HV_on(dstr);
4420 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4421 SvREFCNT_dec(GvCV(dstr));
4422 GvCV(dstr) = Nullcv;
4423 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4424 PL_sub_generation++;
4426 SAVEGENERICSV(GvCV(dstr));
4429 dref = (SV*)GvCV(dstr);
4430 if (GvCV(dstr) != (CV*)sref) {
4431 CV* cv = GvCV(dstr);
4433 if (!GvCVGEN((GV*)dstr) &&
4434 (CvROOT(cv) || CvXSUB(cv)))
4436 /* ahem, death to those who redefine
4437 * active sort subs */
4438 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4439 PL_sortcop == CvSTART(cv))
4441 "Can't redefine active sort subroutine %s",
4442 GvENAME((GV*)dstr));
4443 /* Redefining a sub - warning is mandatory if
4444 it was a const and its value changed. */
4445 if (ckWARN(WARN_REDEFINE)
4447 && (!CvCONST((CV*)sref)
4448 || sv_cmp(cv_const_sv(cv),
4449 cv_const_sv((CV*)sref)))))
4451 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4453 ? "Constant subroutine %s::%s redefined"
4454 : "Subroutine %s::%s redefined",
4455 HvNAME(GvSTASH((GV*)dstr)),
4456 GvENAME((GV*)dstr));
4460 cv_ckproto(cv, (GV*)dstr,
4461 SvPOK(sref) ? SvPVX(sref) : Nullch);
4463 GvCV(dstr) = (CV*)sref;
4464 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4465 GvASSUMECV_on(dstr);
4466 PL_sub_generation++;
4468 if (!GvIMPORTED_CV(dstr)
4469 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4471 GvIMPORTED_CV_on(dstr);
4476 SAVEGENERICSV(GvIOp(dstr));
4478 dref = (SV*)GvIOp(dstr);
4479 GvIOp(dstr) = (IO*)sref;
4483 SAVEGENERICSV(GvFORM(dstr));
4485 dref = (SV*)GvFORM(dstr);
4486 GvFORM(dstr) = (CV*)sref;
4490 SAVEGENERICSV(GvSV(dstr));
4492 dref = (SV*)GvSV(dstr);
4494 if (!GvIMPORTED_SV(dstr)
4495 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4497 GvIMPORTED_SV_on(dstr);
4503 if (SvTAINTED(sstr))
4513 (void)SvOK_off(dstr);
4514 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4516 if (sflags & SVp_NOK) {
4518 /* Only set the public OK flag if the source has public OK. */
4519 if (sflags & SVf_NOK)
4520 SvFLAGS(dstr) |= SVf_NOK;
4521 SvNV_set(dstr, SvNVX(sstr));
4523 if (sflags & SVp_IOK) {
4524 (void)SvIOKp_on(dstr);
4525 if (sflags & SVf_IOK)
4526 SvFLAGS(dstr) |= SVf_IOK;
4527 if (sflags & SVf_IVisUV)
4529 SvIV_set(dstr, SvIVX(sstr));
4531 if (SvAMAGIC(sstr)) {
4535 else if (sflags & SVp_POK) {
4539 * Check to see if we can just swipe the string. If so, it's a
4540 * possible small lose on short strings, but a big win on long ones.
4541 * It might even be a win on short strings if SvPVX(dstr)
4542 * has to be allocated and SvPVX(sstr) has to be freed.
4545 /* Whichever path we take through the next code, we want this true,
4546 and doing it now facilitates the COW check. */
4547 (void)SvPOK_only(dstr);
4550 #ifdef PERL_COPY_ON_WRITE
4551 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4555 (sflags & SVs_TEMP) && /* slated for free anyway? */
4556 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4557 (!(flags & SV_NOSTEAL)) &&
4558 /* and we're allowed to steal temps */
4559 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4560 SvLEN(sstr) && /* and really is a string */
4561 /* and won't be needed again, potentially */
4562 !(PL_op && PL_op->op_type == OP_AASSIGN))
4563 #ifdef PERL_COPY_ON_WRITE
4564 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4565 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4566 && SvTYPE(sstr) >= SVt_PVIV)
4569 /* Failed the swipe test, and it's not a shared hash key either.
4570 Have to copy the string. */
4571 STRLEN len = SvCUR(sstr);
4572 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4573 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4574 SvCUR_set(dstr, len);
4575 *SvEND(dstr) = '\0';
4577 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4579 #ifdef PERL_COPY_ON_WRITE
4580 /* Either it's a shared hash key, or it's suitable for
4581 copy-on-write or we can swipe the string. */
4583 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4588 /* I believe I should acquire a global SV mutex if
4589 it's a COW sv (not a shared hash key) to stop
4590 it going un copy-on-write.
4591 If the source SV has gone un copy on write between up there
4592 and down here, then (assert() that) it is of the correct
4593 form to make it copy on write again */
4594 if ((sflags & (SVf_FAKE | SVf_READONLY))
4595 != (SVf_FAKE | SVf_READONLY)) {
4596 SvREADONLY_on(sstr);
4598 /* Make the source SV into a loop of 1.
4599 (about to become 2) */
4600 SV_COW_NEXT_SV_SET(sstr, sstr);
4604 /* Initial code is common. */
4605 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4607 SvFLAGS(dstr) &= ~SVf_OOK;
4608 Safefree(SvPVX(dstr) - SvIVX(dstr));
4610 else if (SvLEN(dstr))
4611 Safefree(SvPVX(dstr));
4614 #ifdef PERL_COPY_ON_WRITE
4616 /* making another shared SV. */
4617 STRLEN cur = SvCUR(sstr);
4618 STRLEN len = SvLEN(sstr);
4619 assert (SvTYPE(dstr) >= SVt_PVIV);
4621 /* SvIsCOW_normal */
4622 /* splice us in between source and next-after-source. */
4623 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4624 SV_COW_NEXT_SV_SET(sstr, dstr);
4625 SvPV_set(dstr, SvPVX(sstr));
4627 /* SvIsCOW_shared_hash */
4628 UV hash = SvUVX(sstr);
4629 DEBUG_C(PerlIO_printf(Perl_debug_log,
4630 "Copy on write: Sharing hash\n"));
4632 sharepvn(SvPVX(sstr),
4633 (sflags & SVf_UTF8?-cur:cur), hash));
4634 SvUV_set(dstr, hash);
4636 SvLEN_set(dstr, len);
4637 SvCUR_set(dstr, cur);
4638 SvREADONLY_on(dstr);
4640 /* Relesase a global SV mutex. */
4644 { /* Passes the swipe test. */
4645 SvPV_set(dstr, SvPVX(sstr));
4646 SvLEN_set(dstr, SvLEN(sstr));
4647 SvCUR_set(dstr, SvCUR(sstr));
4650 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4651 SvPV_set(sstr, Nullch);
4657 if (sflags & SVf_UTF8)
4660 if (sflags & SVp_NOK) {
4662 if (sflags & SVf_NOK)
4663 SvFLAGS(dstr) |= SVf_NOK;
4664 SvNV_set(dstr, SvNVX(sstr));
4666 if (sflags & SVp_IOK) {
4667 (void)SvIOKp_on(dstr);
4668 if (sflags & SVf_IOK)
4669 SvFLAGS(dstr) |= SVf_IOK;
4670 if (sflags & SVf_IVisUV)
4672 SvIV_set(dstr, SvIVX(sstr));
4675 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4676 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4677 smg->mg_ptr, smg->mg_len);
4678 SvRMAGICAL_on(dstr);
4681 else if (sflags & SVp_IOK) {
4682 if (sflags & SVf_IOK)
4683 (void)SvIOK_only(dstr);
4685 (void)SvOK_off(dstr);
4686 (void)SvIOKp_on(dstr);
4688 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4689 if (sflags & SVf_IVisUV)
4691 SvIV_set(dstr, SvIVX(sstr));
4692 if (sflags & SVp_NOK) {
4693 if (sflags & SVf_NOK)
4694 (void)SvNOK_on(dstr);
4696 (void)SvNOKp_on(dstr);
4697 SvNV_set(dstr, SvNVX(sstr));
4700 else if (sflags & SVp_NOK) {
4701 if (sflags & SVf_NOK)
4702 (void)SvNOK_only(dstr);
4704 (void)SvOK_off(dstr);
4707 SvNV_set(dstr, SvNVX(sstr));
4710 if (dtype == SVt_PVGV) {
4711 if (ckWARN(WARN_MISC))
4712 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4715 (void)SvOK_off(dstr);
4717 if (SvTAINTED(sstr))
4722 =for apidoc sv_setsv_mg
4724 Like C<sv_setsv>, but also handles 'set' magic.
4730 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4732 sv_setsv(dstr,sstr);
4736 #ifdef PERL_COPY_ON_WRITE
4738 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4740 STRLEN cur = SvCUR(sstr);
4741 STRLEN len = SvLEN(sstr);
4742 register char *new_pv;
4745 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4753 if (SvTHINKFIRST(dstr))
4754 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4755 else if (SvPVX(dstr))
4756 Safefree(SvPVX(dstr));
4760 (void)SvUPGRADE (dstr, SVt_PVIV);
4762 assert (SvPOK(sstr));