/* sv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * "I wonder what the Entish is for 'yes' and 'no'," he thought. * * * This file contains the code that creates, manipulates and destroys * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the * structure of an SV, so their creation and destruction is handled * here; higher-level functions are in av.c, hv.c, and so on. Opcode * level functions (eg. substr, split, join) for each of the types are * in the pp*.c files. */ #include "EXTERN.h" #define PERL_IN_SV_C #include "perl.h" #include "regcomp.h" #define FCALL *f #ifdef __Lynx__ /* Missing proto on LynxOS */ char *gconvert(double, int, int, char *); #endif #ifdef PERL_UTF8_CACHE_ASSERT /* The cache element 0 is the Unicode offset; * the cache element 1 is the byte offset of the element 0; * the cache element 2 is the Unicode length of the substring; * the cache element 3 is the byte length of the substring; * The checking of the substring side would be good * but substr() has enough code paths to make my head spin; * if adding more checks watch out for the following tests: * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t * lib/utf8.t lib/Unicode/Collate/t/index.t * --jhi */ #define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END #else #define ASSERT_UTF8_CACHE(cache) NOOP #endif #ifdef PERL_OLD_COPY_ON_WRITE #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- on-write. */ #endif /* ============================================================================ =head1 Allocation and deallocation of SVs. An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv, av, hv...) contains type and reference count information, as well as a pointer to the body (struct xrv, xpv, xpviv...), which contains fields specific to each type. Normally, this allocation is done using arenas, which by default are approximately 4K chunks of memory parcelled up into N heads or bodies. The first slot in each arena is reserved, and is used to hold a link to the next arena. In the case of heads, the unused first slot also contains some flags and a note of the number of slots. Snaked through each arena chain is a linked list of free items; when this becomes empty, an extra arena is allocated and divided up into N items which are threaded into the free list. The following global variables are associated with arenas: PL_sv_arenaroot pointer to list of SV arenas PL_sv_root pointer to list of free SV structures PL_foo_arenaroot pointer to list of foo arenas, PL_foo_root pointer to list of free foo bodies ... for foo in xiv, xnv, xrv, xpv etc. Note that some of the larger and more rarely used body types (eg xpvio) are not allocated using arenas, but are instead just malloc()/free()ed as required. Also, if PURIFY is defined, arenas are abandoned altogether, with all items individually malloc()ed. In addition, a few SV heads are not allocated from an arena, but are instead directly created as static or auto variables, eg PL_sv_undef. The size of arenas can be changed from the default by setting PERL_ARENA_SIZE appropriately at compile time. The SV arena serves the secondary purpose of allowing still-live SVs to be located and destroyed during final cleanup. At the lowest level, the macros new_SV() and del_SV() grab and free an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() to return the SV to the free list with error checking.) new_SV() calls more_sv() / sv_add_arena() to add an extra arena if the free list is empty. SVs in the free list have their SvTYPE field set to all ones. Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc that allocate and return individual body types. Normally these are mapped to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be instead mapped directly to malloc()/free() if PURIFY is defined. The new/del functions remove from, or add to, the appropriate PL_foo_root list, and call more_xiv() etc to add a new arena if the list is empty. At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the start of the interpreter. Note that this also clears PL_he_arenaroot, which is otherwise dealt with in hv.c. Manipulation of any of the PL_*root pointers is protected by enclosing LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing if threads are enabled. The function visit() scans the SV arenas list, and calls a specified function for each SV it finds which is still live - ie which has an SvTYPE other than all 1's, and a non-zero SvREFCNT. visit() is used by the following functions (specified as [function that calls visit()] / [function called by visit() for each SV]): sv_report_used() / do_report_used() dump all remaining SVs (debugging aid) sv_clean_objs() / do_clean_objs(),do_clean_named_objs() Attempt to free all objects pointed to by RVs, and, unless DISABLE_DESTRUCTOR_KLUDGE is defined, try to do the same for all objects indirectly referenced by typeglobs too. Called once from perl_destruct(), prior to calling sv_clean_all() below. sv_clean_all() / do_clean_all() SvREFCNT_dec(sv) each remaining SV, possibly triggering an sv_free(). It also sets the SVf_BREAK flag on the SV to indicate that the refcnt has been artificially lowered, and thus stopping sv_free() from giving spurious warnings about SVs which unexpectedly have a refcnt of zero. called repeatedly from perl_destruct() until there are no SVs left. =head2 Summary Private API to rest of sv.c new_SV(), del_SV(), new_XIV(), del_XIV(), new_XNV(), del_XNV(), etc Public API: sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() =cut ============================================================================ */ /* * "A time to plant, and a time to uproot what was planted..." */ /* * nice_chunk and nice_chunk size need to be set * and queried under the protection of sv_mutex */ void Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) 27360 { 27360 void *new_chunk; 27360 U32 new_chunk_size; LOCK_SV_MUTEX; 27360 new_chunk = (void *)(chunk); 27360 new_chunk_size = (chunk_size); 27360 if (new_chunk_size > PL_nice_chunk_size) { 20939 Safefree(PL_nice_chunk); 20939 PL_nice_chunk = (char *) new_chunk; 20939 PL_nice_chunk_size = new_chunk_size; } else { 6421 Safefree(chunk); } UNLOCK_SV_MUTEX; } #ifdef DEBUG_LEAKING_SCALARS # ifdef NETWARE # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file) # else # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file) # endif #else # define FREE_SV_DEBUG_FILE(sv) #endif #define plant_SV(p) \ STMT_START { \ FREE_SV_DEBUG_FILE(p); \ SvANY(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ PL_sv_root = (p); \ --PL_sv_count; \ } STMT_END /* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ STMT_START { \ (p) = PL_sv_root; \ PL_sv_root = (SV*)SvANY(p); \ ++PL_sv_count; \ } STMT_END /* make some more SVs by adding another arena */ /* sv_mutex must be held while calling more_sv() */ STATIC SV* S_more_sv(pTHX) 110123 { 110123 SV* sv; 110123 if (PL_nice_chunk) { 18375 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); 18375 PL_nice_chunk = Nullch; 18375 PL_nice_chunk_size = 0; } else { 91748 char *chunk; /* must use New here to match call to */ 91748 New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ 91748 sv_add_arena(chunk, PERL_ARENA_SIZE, 0); } 110123 uproot_SV(sv); 110123 return sv; } /* new_SV(): return a new, empty SV head */ #ifdef DEBUG_LEAKING_SCALARS /* provide a real function for a debugger to play with */ STATIC SV* S_new_SV(pTHX) { SV* sv; LOCK_SV_MUTEX; if (PL_sv_root) uproot_SV(sv); else sv = S_more_sv(aTHX); UNLOCK_SV_MUTEX; SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ? (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; # ifdef NETWARE sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; # else sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; # endif return sv; } # define new_SV(p) (p)=S_new_SV(aTHX) #else # define new_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ if (PL_sv_root) \ uproot_SV(p); \ else \ (p) = S_more_sv(aTHX); \ UNLOCK_SV_MUTEX; \ SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ } STMT_END #endif /* del_SV(): return an empty SV head to the free list */ #ifdef DEBUGGING #define del_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ if (DEBUG_D_TEST) \ del_sv(p); \ else \ plant_SV(p); \ UNLOCK_SV_MUTEX; \ } STMT_END STATIC void S_del_sv(pTHX_ SV *p) ###### { ###### if (DEBUG_D_TEST) { ###### SV* sva; ###### bool ok = 0; ###### for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { ###### const SV * const sv = sva + 1; ###### const SV * const svend = &sva[SvREFCNT(sva)]; ###### if (p >= sv && p < svend) { ###### ok = 1; ###### break; } } ###### if (!ok) { ###### if (ckWARN_d(WARN_INTERNAL)) ###### Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-arena SV: 0x%"UVxf pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); ###### return; } } ###### plant_SV(p); } #else /* ! DEBUGGING */ #define del_SV(p) plant_SV(p) #endif /* DEBUGGING */ /* =head1 SV Manipulation Functions =for apidoc sv_add_arena Given a chunk of memory, link it to the head of the list of arenas, and split it into a list of free SVs. =cut */ void Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) 110123 { 110123 SV* sva = (SV*)ptr; 110123 register SV* sv; 110123 register SV* svend; /* The first SV in an arena isn't an SV. */ 110123 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ 110123 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ 110123 SvFLAGS(sva) = flags; /* FAKE if not to be freed */ 110123 PL_sv_arenaroot = sva; 110123 PL_sv_root = sva + 1; 110123 svend = &sva[SvREFCNT(sva) - 1]; 110123 sv = sva + 1; 24562683 while (sv < svend) { 24452560 SvANY(sv) = (void *)(SV*)(sv + 1); #ifdef DEBUGGING 24452560 SvREFCNT(sv) = 0; #endif /* Must always set typemask because it's awlays checked in on cleanup when the arenas are walked looking for objects. */ 24452560 SvFLAGS(sv) = SVTYPEMASK; 24452560 sv++; } 110123 SvANY(sv) = 0; #ifdef DEBUGGING 110123 SvREFCNT(sv) = 0; #endif 110123 SvFLAGS(sv) = SVTYPEMASK; } /* visit(): call the named function for each non-free SV in the arenas * whose flags field matches the flags/mask args. */ STATIC I32 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) 10605 { 10605 SV* sva; 10605 I32 visited = 0; 340578 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { 329973 register const SV * const svend = &sva[SvREFCNT(sva)]; 329973 register SV* sv; 73465595 for (sv = sva + 1; sv < svend; ++sv) { 73135622 if (SvTYPE(sv) != SVTYPEMASK && (sv->sv_flags & mask) == flags && SvREFCNT(sv)) { 8819028 (FCALL)(aTHX_ sv); 8819028 ++visited; } } } 10605 return visited; } #ifdef DEBUGGING /* called by sv_report_used() for each live SV */ static void do_report_used(pTHX_ SV *sv) ###### { ###### if (SvTYPE(sv) != SVTYPEMASK) { ###### PerlIO_printf(Perl_debug_log, "****\n"); ###### sv_dump(sv); } } #endif /* =for apidoc sv_report_used Dump the contents of all SVs not yet freed. (Debugging aid). =cut */ void Perl_sv_report_used(pTHX) ###### { #ifdef DEBUGGING ###### visit(do_report_used, 0, 0); #endif } /* called by sv_clean_objs() for each live SV */ static void do_clean_objs(pTHX_ SV *ref) 1670847 { 1670847 SV* target; 1670847 if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) { 46751 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); 46751 if (SvWEAKREF(ref)) { ###### sv_del_backref(target, ref); ###### SvWEAKREF_off(ref); ###### SvRV_set(ref, NULL); } else { 46751 SvROK_off(ref); 46751 SvRV_set(ref, NULL); 46751 SvREFCNT_dec(target); } } /* XXX Might want to check arrays, etc. */ } /* called by sv_clean_objs() for each live SV */ #ifndef DISABLE_DESTRUCTOR_KLUDGE static void do_clean_named_objs(pTHX_ SV *sv) 1153703 { 1153703 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { 1031864 if (( #ifdef PERL_DONT_CREATE_GVSV GvSV(sv) && #endif SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || (GvIO(sv) && SvOBJECT(GvIO(sv))) || (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { 24281 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); 24281 SvFLAGS(sv) |= SVf_BREAK; 24281 SvREFCNT_dec(sv); } } } #endif /* =for apidoc sv_clean_objs Attempt to destroy all objects not yet freed =cut */ void Perl_sv_clean_objs(pTHX) 2213 { 2213 PL_in_clean_objs = TRUE; 2213 visit(do_clean_objs, SVf_ROK, SVf_ROK); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ 2213 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK); #endif 2213 PL_in_clean_objs = FALSE; } /* called by sv_clean_all() for each live SV */ static void do_clean_all(pTHX_ SV *sv) 5994478 { 5994478 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); 5994478 SvFLAGS(sv) |= SVf_BREAK; 5994478 if (PL_comppad == (AV*)sv) { 2 PL_comppad = Nullav; 2 PL_curpad = Null(SV**); } 5994478 SvREFCNT_dec(sv); } /* =for apidoc sv_clean_all Decrement the refcnt of each remaining SV, possibly triggering a cleanup. This function may have to be called multiple times to free SVs which are in complex self-referential hierarchies. =cut */ I32 Perl_sv_clean_all(pTHX) 6179 { 6179 I32 cleaned; 6179 PL_in_clean_all = TRUE; 6179 cleaned = visit(do_clean_all, 0,0); 6179 PL_in_clean_all = FALSE; 6179 return cleaned; } static void 54588 S_free_arena(pTHX_ void **root) { 168271 while (root) { 113683 void ** const next = *(void **)root; 113683 Safefree(root); 113683 root = next; } } /* =for apidoc sv_free_arenas Deallocate the memory used by all arenas. Note that all the individual SV heads and bodies within the arenas must already have been freed. =cut */ #define free_arena(name) \ STMT_START { \ S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \ PL_ ## name ## _arenaroot = 0; \ PL_ ## name ## _root = 0; \ } STMT_END void Perl_sv_free_arenas(pTHX) 4549 { 4549 SV* sva; 4549 SV* svanext; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ 115323 for (sva = PL_sv_arenaroot; sva; sva = svanext) { 110774 svanext = (SV*) SvANY(sva); 110774 while (svanext && SvFAKE(svanext)) ###### svanext = (SV*) SvANY(svanext); 110774 if (!SvFAKE(sva)) 110774 Safefree(sva); } 4549 free_arena(xnv); 4549 free_arena(xpv); 4549 free_arena(xpviv); 4549 free_arena(xpvnv); 4549 free_arena(xpvcv); 4549 free_arena(xpvav); 4549 free_arena(xpvhv); 4549 free_arena(xpvmg); 4549 free_arena(xpvgv); 4549 free_arena(xpvlv); 4549 free_arena(xpvbm); 4549 free_arena(he); #if defined(USE_ITHREADS) free_arena(pte); #endif 4549 Safefree(PL_nice_chunk); 4549 PL_nice_chunk = Nullch; 4549 PL_nice_chunk_size = 0; 4549 PL_sv_arenaroot = 0; 4549 PL_sv_root = 0; } /* --------------------------------------------------------------------- * * support functions for report_uninit() */ /* the maxiumum size of array or hash where we will scan looking * for the undefined element that triggered the warning */ #define FUV_MAX_SEARCH_SIZE 1000 /* Look for an entry in the hash whose value has the same SV as val; * If so, return a mortal copy of the key. */ STATIC SV* S_find_hash_subscript(pTHX_ HV *hv, SV* val) 332 { dVAR; 332 register HE **array; 332 I32 i; 332 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) 218 return Nullsv; 114 array = HvARRAY(hv); 522 for (i=HvMAX(hv); i>0; i--) { 520 register HE *entry; 684 for (entry = array[i]; entry; entry = HeNEXT(entry)) { 276 if (HeVAL(entry) != val) 164 continue; 112 if ( HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_placeholder) 112 continue; 112 if (!HeKEY(entry)) ###### return Nullsv; 112 if (HeKLEN(entry) == HEf_SVKEY) ###### return sv_mortalcopy(HeKEY_sv(entry)); 112 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); } } 2 return Nullsv; } /* Look for an entry in the array whose value has the same SV as val; * If so, return the index, otherwise return -1. */ STATIC I32 S_find_array_subscript(pTHX_ AV *av, SV* val) 28 { 28 SV** svp; 28 I32 i; 28 if (!av || SvMAGICAL(av) || !AvARRAY(av) || (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) 15 return -1; 13 svp = AvARRAY(av); 1228 for (i=AvFILLp(av); i>=0; i--) { 1228 if (svp[i] == val && svp[i] != &PL_sv_undef) 13 return i; } ###### return -1; } /* S_varname(): return the name of a variable, optionally with a subscript. * If gv is non-zero, use the name of that global, along with gvtype (one * of "$", "@", "%"); otherwise use the name of the lexical at pad offset * targ. Depending on the value of the subscript_type flag, return: */ #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ STATIC SV* S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, SV* keyname, I32 aindex, int subscript_type) 2749 { 2749 SV * const name = sv_newmortal(); 2749 if (gv) { /* simulate gv_fullname4(), but add literal '^' for $^FOO names * XXX get rid of all this if gv_fullnameX() ever supports this * directly */ 263 const char *p; 263 HV * const hv = GvSTASH(gv); 263 if (!hv) ###### p = "???"; 263 else if (!(p=HvNAME_get(hv))) ###### p = "__ANON__"; 263 if (strEQ(p, "main")) 263 sv_setpvn(name, &gvtype, 1); else ###### Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p); 263 if (GvNAMELEN(gv)>= 1 && ((unsigned int)*GvNAME(gv)) <= 26) { /* handle $^FOO */ 2 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1); 2 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1); } else 261 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv)); } else { 2486 U32 unused; 2486 CV * const cv = find_runcv(&unused); 2486 SV *sv; 2486 AV *av; 2486 if (!cv || !CvPADLIST(cv)) ###### return Nullsv; 2486 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); 2486 sv = *av_fetch(av, targ, FALSE); /* SvLEN in a pad name is not to be trusted */ 2486 sv_setpv(name, SvPV_nolen_const(sv)); } 2749 if (subscript_type == FUV_SUBSCRIPT_HASH) { 119 SV * const sv = NEWSV(0,0); 119 *SvPVX(name) = '$'; 119 Perl_sv_catpvf(aTHX_ name, "{%s}", pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); 119 SvREFCNT_dec(sv); } 2630 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { 53 *SvPVX(name) = '$'; 53 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); } 2577 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) 172 sv_insert(name, 0, 0, "within ", 7); 2749 return name; } /* =for apidoc find_uninit_var Find the name of the undefined variable (if any) that caused the operator o to issue a "Use of uninitialized value" warning. If match is true, only return a name if it's value matches uninit_sv. So roughly speaking, if a unary operator (such as OP_COS) generates a warning, then following the direct child of the op may yield an OP_PADSV or OP_GV that gives the name of the undefined variable. On the other hand, with OP_ADD there are two branches to follow, so we only print the variable name if we get an exact match. The name is returned as a mortal SV. Assumes that PL_op is the op that originally triggered the error, and that PL_comppad/PL_curpad points to the currently executing pad. =cut */ STATIC SV * S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) 9372 { dVAR; 9372 SV *sv; 9372 AV *av; 9372 GV *gv; 9372 OP *o, *o2, *kid; 9372 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || uninit_sv == &PL_sv_placeholder))) 92 return Nullsv; 9280 switch (obase->op_type) { case OP_RV2AV: case OP_RV2HV: case OP_PADAV: case OP_PADHV: { 339 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); 339 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); 339 I32 index = 0; 339 SV *keysv = Nullsv; 339 int subscript_type = FUV_SUBSCRIPT_WITHIN; 339 if (pad) { /* @lex, %lex */ 326 sv = PAD_SVl(obase->op_targ); 326 gv = Nullgv; } else { 13 if (cUNOPx(obase)->op_first->op_type == OP_GV) { /* @global, %global */ 7 gv = cGVOPx_gv(cUNOPx(obase)->op_first); 7 if (!gv) ###### break; 7 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); } else /* @{expr}, %{expr} */ 6 return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, match); } /* attempt to find a match within the aggregate */ 333 if (hash) { 320 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); 320 if (keysv) 107 subscript_type = FUV_SUBSCRIPT_HASH; } else { 13 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); 13 if (index >= 0) 8 subscript_type = FUV_SUBSCRIPT_ARRAY; } 333 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) 55 break; 278 return varname(gv, hash ? '%' : '@', obase->op_targ, keysv, index, subscript_type); } case OP_PADSV: 2419 if (match && PAD_SVl(obase->op_targ) != uninit_sv) 232 break; 2187 return varname(Nullgv, '$', obase->op_targ, Nullsv, 0, FUV_SUBSCRIPT_NONE); case OP_GVSV: 404 gv = cGVOPx_gv(obase); 404 if (!gv || (match && GvSV(gv) != uninit_sv)) 217 break; 217 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); case OP_AELEMFAST: 28 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ 14 if (match) { 8 SV **svp; 8 av = (AV*)PAD_SV(obase->op_targ); 8 if (!av || SvRMAGICAL(av)) 4 break; 4 svp = av_fetch(av, (I32)obase->op_private, FALSE); 4 if (!svp || *svp != uninit_sv) 8 break; } 8 return varname(Nullgv, '$', obase->op_targ, Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); } else { 14 gv = cGVOPx_gv(obase); 14 if (!gv) ###### break; 14 if (match) { 5 SV **svp; 5 av = GvAV(gv); 5 if (!av || SvRMAGICAL(av)) 5 break; 5 svp = av_fetch(av, (I32)obase->op_private, FALSE); 5 if (!svp || *svp != uninit_sv) 11 break; } 11 return varname(gv, '$', 0, Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); } 4 break; case OP_EXISTS: 4 o = cUNOPx(obase)->op_first; 4 if (!o || o->op_type != OP_NULL || ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) 4 break; 4 return find_uninit_var(cBINOPo->op_last, uninit_sv, match); case OP_AELEM: case OP_HELEM: 80 if (PL_op == obase) /* $a[uninit_expr] or $h{uninit_expr} */ 11 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); 69 gv = Nullgv; 69 o = cBINOPx(obase)->op_first; 69 kid = cBINOPx(obase)->op_last; /* get the av or hv, and optionally the gv */ 69 sv = Nullsv; 69 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { 39 sv = PAD_SV(o->op_targ); } 30 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) && cUNOPo->op_first->op_type == OP_GV) { 30 gv = cGVOPx_gv(cUNOPo->op_first); 30 if (!gv) ###### break; 30 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); } 69 if (!sv) ###### break; 69 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { /* index is constant */ 42 if (match) { 26 if (SvMAGICAL(sv)) 8 break; 18 if (obase->op_type == OP_HELEM) { 6 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); 6 if (!he || HeVAL(he) != uninit_sv) 12 break; } else { 12 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); 12 if (!svp || *svp != uninit_sv) 28 break; } } 28 if (obase->op_type == OP_HELEM) 7 return varname(gv, '%', o->op_targ, cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); else 21 return varname(gv, '@', o->op_targ, Nullsv, SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); ; } else { /* index is an expression; * attempt to find a match within the aggregate */ 27 if (obase->op_type == OP_HELEM) { 12 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); 12 if (keysv) 5 return varname(gv, '%', o->op_targ, keysv, 0, FUV_SUBSCRIPT_HASH); } else { 15 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); 15 if (index >= 0) 5 return varname(gv, '@', o->op_targ, Nullsv, index, FUV_SUBSCRIPT_ARRAY); } 17 if (match) 8 break; 9 return varname(gv, (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) ? '@' : '%', o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); } 1 break; case OP_AASSIGN: /* only examine RHS */ 1 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); case OP_OPEN: 7 o = cUNOPx(obase)->op_first; 7 if (o->op_type == OP_PUSHMARK) 7 o = o->op_sibling; 7 if (!o->op_sibling) { /* one-arg version of open is highly magical */ 4 if (o->op_type == OP_GV) { /* open FOO; */ 1 gv = cGVOPx_gv(o); 1 if (match && GvSV(gv) != uninit_sv) ###### break; 1 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); } /* other possibilities not handled are: * open $x; or open my $x; should return '${*$x}' * open expr; should return '$'.expr ideally */ 44 break; } 44 goto do_op; /* ops where $_ may be an implicit arg */ case OP_TRANS: case OP_SUBST: case OP_MATCH: 44 if ( !(obase->op_flags & OPf_STACKED)) { 28 if (uninit_sv == ((obase->op_private & OPpTARGET_MY) ? PAD_SVl(obase->op_targ) : DEFSV)) { 24 sv = sv_newmortal(); 24 sv_setpvn(sv, "$_", 2); 24 return sv; } } 30 goto do_op; case OP_PRTF: case OP_PRINT: /* skip filehandle as it can't produce 'undef' warning */ 30 o = cUNOPx(obase)->op_first; 30 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) 16 o = o->op_sibling->op_sibling; 16 goto do_op2; case OP_RV2SV: case OP_CUSTOM: case OP_ENTERSUB: 15 match = 1; /* XS or custom code could trigger random warnings */ 15 goto do_op; case OP_SCHOMP: case OP_CHOMP: 10 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) 3 return sv_2mortal(newSVpvn("${$/}", 5)); /* FALL THROUGH */ default: do_op: 5944 if (!(obase->op_flags & OPf_KIDS)) 2029 break; 3915 o = cUNOPx(obase)->op_first; do_op2: 3945 if (!o) ###### break; /* if all except one arg are constant, or have no side-effects, * or are optimized away, then it's unambiguous */ 3945 o2 = Nullop; 8661 for (kid=o; kid; kid = kid->op_sibling) { 7031 if (kid && ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) || (kid->op_type == OP_PUSHMARK) ) ) 6254 continue; 6254 if (o2) { /* more than one found */ 2315 o2 = Nullop; 2315 break; } 3939 o2 = kid; } 3945 if (o2) 1624 return find_uninit_var(o2, uninit_sv, match); /* scan all args */ 5013 while (o) { 4849 sv = find_uninit_var(o, uninit_sv, 1); 4849 if (sv) 2157 return sv; 2692 o = o->op_sibling; } 2701 break; } 2701 return Nullsv; } /* =for apidoc report_uninit Print appropriate "Use of uninitialized variable" warning =cut */ void Perl_report_uninit(pTHX_ SV* uninit_sv) 2877 { 2877 if (PL_op) { 2877 SV* varname = Nullsv; 2877 if (uninit_sv) { 2877 varname = find_uninit_var(PL_op, uninit_sv,0); 2877 if (varname) 2776 sv_insert(varname, 0, 0, " ", 1); } 2877 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, varname ? SvPV_nolen_const(varname) : "", " in ", OP_DESC(PL_op)); } else ###### Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "", ""); } STATIC void * S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) 97801 { 97801 char *start; 97801 const char *end; 97801 const size_t count = PERL_ARENA_SIZE/size; 97801 New(0, start, count*size, char); 97801 *((void **) start) = *arena_root; 97801 *arena_root = (void *)start; 97801 end = start + (count-1) * size; /* The initial slot is used to link the arenas together, so it isn't to be linked into the list of ready-to-use bodies. */ 97801 start += size; 97801 *root = (void *)start; 20690665 while (start < end) { 20592864 char * const next = start + size; 20592864 *(void**) start = (void *)next; 20592864 start = next; } 97801 *(void **)start = 0; 97801 return *root; } /* grab a new thing from the free list, allocating more if necessary */ STATIC void * S_new_body(pTHX_ void **arena_root, void **root, size_t size) 57898079 { 57898079 void *xpv; LOCK_SV_MUTEX; 57898079 xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size); 57898079 *root = *(void**)xpv; UNLOCK_SV_MUTEX; 57898079 return xpv; } /* return a thing to the free list */ #define del_body(thing, root) \ STMT_START { \ void **thing_copy = (void **)thing; \ LOCK_SV_MUTEX; \ *thing_copy = *root; \ *root = (void*)thing_copy; \ UNLOCK_SV_MUTEX; \ } STMT_END /* Conventionally we simply malloc() a big block of memory, then divide it up into lots of the thing that we're allocating. This macro will expand to call to S_new_body. So for XPVBM (with ithreads), it would become S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot), (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0) */ #define new_body(TYPE,lctype) \ S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ (void**)&PL_ ## lctype ## _root, \ sizeof(TYPE)) #define del_body_type(p,TYPE,lctype) \ del_body((void*)p, (void**)&PL_ ## lctype ## _root) /* But for some types, we cheat. The type starts with some members that are never accessed. So we allocate the substructure, starting at the first used member, then adjust the pointer back in memory by the size of the bit not allocated, so it's as if we allocated the full structure. (But things will all go boom if you write to the part that is "not there", because you'll be overwriting the last members of the preceding structure in memory.) We calculate the correction using the STRUCT_OFFSET macro. For example, if xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, and the pointer is unchanged. If the allocated structure is smaller (no initial NV actually allocated) then the net effect is to subtract the size of the NV from the pointer, to return a new pointer as if an initial NV were actually allocated. This is the same trick as was used for NV and IV bodies. Ironically it doesn't need to be used for NV bodies any more, because NV is now at the start of the structure. IV bodies don't need it either, because they are no longer allocated. */ #define new_body_allocated(TYPE,lctype,member) \ (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ (void**)&PL_ ## lctype ## _root, \ sizeof(lctype ## _allocated)) - \ STRUCT_OFFSET(TYPE, member) \ + STRUCT_OFFSET(lctype ## _allocated, member)) #define del_body_allocated(p,TYPE,lctype,member) \ del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \ - STRUCT_OFFSET(lctype ## _allocated, member)), \ (void**)&PL_ ## lctype ## _root) #define my_safemalloc(s) (void*)safemalloc(s) #define my_safefree(p) safefree((char*)p) #ifdef PURIFY #define new_XNV() my_safemalloc(sizeof(XPVNV)) #define del_XNV(p) my_safefree(p) #define new_XPV() my_safemalloc(sizeof(XPV)) #define del_XPV(p) my_safefree(p) #define new_XPVIV() my_safemalloc(sizeof(XPVIV)) #define del_XPVIV(p) my_safefree(p) #define new_XPVNV() my_safemalloc(sizeof(XPVNV)) #define del_XPVNV(p) my_safefree(p) #define new_XPVCV() my_safemalloc(sizeof(XPVCV)) #define del_XPVCV(p) my_safefree(p) #define new_XPVAV() my_safemalloc(sizeof(XPVAV)) #define del_XPVAV(p) my_safefree(p) #define new_XPVHV() my_safemalloc(sizeof(XPVHV)) #define del_XPVHV(p) my_safefree(p) #define new_XPVMG() my_safemalloc(sizeof(XPVMG)) #define del_XPVMG(p) my_safefree(p) #define new_XPVGV() my_safemalloc(sizeof(XPVGV)) #define del_XPVGV(p) my_safefree(p) #define new_XPVLV() my_safemalloc(sizeof(XPVLV)) #define del_XPVLV(p) my_safefree(p) #define new_XPVBM() my_safemalloc(sizeof(XPVBM)) #define del_XPVBM(p) my_safefree(p) #else /* !PURIFY */ #define new_XNV() new_body(NV, xnv) #define del_XNV(p) del_body_type(p, NV, xnv) #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur) #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur) #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur) #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur) #define new_XPVNV() new_body(XPVNV, xpvnv) #define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv) #define new_XPVCV() new_body(XPVCV, xpvcv) #define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv) #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill) #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill) #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill) #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill) #define new_XPVMG() new_body(XPVMG, xpvmg) #define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg) #define new_XPVGV() new_body(XPVGV, xpvgv) #define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv) #define new_XPVLV() new_body(XPVLV, xpvlv) #define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv) #define new_XPVBM() new_body(XPVBM, xpvbm) #define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm) #endif /* PURIFY */ #define new_XPVFM() my_safemalloc(sizeof(XPVFM)) #define del_XPVFM(p) my_safefree(p) #define new_XPVIO() my_safemalloc(sizeof(XPVIO)) #define del_XPVIO(p) my_safefree(p) /* =for apidoc sv_upgrade Upgrade an SV to a more complex form. Generally adds a new body type to the SV, then copies across as much information as possible from the old body. You generally want to use the C macro wrapper. See also C. =cut */ void Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) 86785603 { 86785603 void** old_body_arena; 86785603 size_t old_body_offset; 86785603 size_t old_body_length; /* Well, the length to copy. */ 86785603 void* old_body; #ifndef NV_ZERO_IS_ALLBITS_ZERO /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct 0.0 for us. */ bool zero_nv = TRUE; #endif 86785603 void* new_body; 86785603 size_t new_body_length; 86785603 size_t new_body_offset; 86785603 void** new_body_arena; 86785603 void** new_body_arenaroot; 86785603 const U32 old_type = SvTYPE(sv); 86785603 if (mt != SVt_PV && SvIsCOW(sv)) { 3 sv_force_normal_flags(sv, 0); } 86785603 if (SvTYPE(sv) == mt) 4459 return; 86781144 if (SvTYPE(sv) > mt) ###### Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", (int)SvTYPE(sv), (int)mt); 86781144 old_body = SvANY(sv); 86781144 old_body_arena = 0; 86781144 old_body_offset = 0; 86781144 old_body_length = 0; 86781144 new_body_offset = 0; 86781144 new_body_length = ~0; /* Copying structures onto other structures that have been neatly zeroed has a subtle gotcha. Consider XPVMG +------+------+------+------+------+-------+-------+ | NV | CUR | LEN | IV | MAGIC | STASH | +------+------+------+------+------+-------+-------+ 0 4 8 12 16 20 24 28 where NVs are aligned to 8 bytes, so that sizeof that structure is actually 32 bytes long, with 4 bytes of padding at the end: +------+------+------+------+------+-------+-------+------+ | NV | CUR | LEN | IV | MAGIC | STASH | ??? | +------+------+------+------+------+-------+-------+------+ 0 4 8 12 16 20 24 28 32 so what happens if you allocate memory for this structure: +------+------+------+------+------+-------+-------+------+------+... | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | +------+------+------+------+------+-------+-------+------+------+... 0 4 8 12 16 20 24 28 32 36 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you expect, because you copy the area marked ??? onto GP. Now, ??? may have started out as zero once, but it's quite possible that it isn't. So now, rather than a nicely zeroed GP, you have it pointing somewhere random. Bugs ensue. (In fact, GP ends up pointing at a previous GP structure, because the principle cause of the padding in XPVMG getting garbage is a copy of sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) So we are careful and work out the size of used parts of all the structures. */ 86781144 switch (SvTYPE(sv)) { case SVt_NULL: 1820351 break; case SVt_IV: 1820351 if (mt == SVt_NV) 581 mt = SVt_PVNV; 1819770 else if (mt < SVt_PVIV) 21998 mt = SVt_PVIV; 1820351 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv); 1820351 old_body_length = sizeof(IV); 1820351 break; case SVt_NV: 77987 old_body_arena = (void **) &PL_xnv_root; 77987 old_body_length = sizeof(NV); #ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; #endif 77987 if (mt < SVt_PVNV) 12 mt = SVt_PVNV; 12 break; case SVt_RV: 5797837 break; case SVt_PV: 5797837 old_body_arena = (void **) &PL_xpv_root; 5797837 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - STRUCT_OFFSET(xpv_allocated, xpv_cur); 5797837 old_body_length = STRUCT_OFFSET(XPV, xpv_len) + sizeof (((XPV*)SvANY(sv))->xpv_len) - old_body_offset; 5797837 if (mt <= SVt_IV) ###### mt = SVt_PVIV; 5797837 else if (mt == SVt_NV) ###### mt = SVt_PVNV; ###### break; case SVt_PVIV: 50410 old_body_arena = (void **) &PL_xpviv_root; 50410 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - STRUCT_OFFSET(xpviv_allocated, xpv_cur); 50410 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u) + sizeof (((XPVIV*)SvANY(sv))->xiv_u) - old_body_offset; 50410 break; case SVt_PVNV: 1764 old_body_arena = (void **) &PL_xpvnv_root; 1764 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u) + sizeof (((XPVNV*)SvANY(sv))->xiv_u); #ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; #endif 1764 break; case SVt_PVMG: /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, there's no way that it can be safely upgraded, because perl.c expects to Safefree(SvANY(PL_mess_sv)) */ 37321 assert(sv != PL_mess_sv); /* This flag bit is used to mean other things in other scalar types. Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ 37321 assert((SvFLAGS(sv) & SVpad_TYPED) == 0); 37321 old_body_arena = (void **) &PL_xpvmg_root; 37321 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash) + sizeof (((XPVMG*)SvANY(sv))->xmg_stash); #ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; #endif 37321 break; default: ###### Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); } 86781144 SvFLAGS(sv) &= ~SVTYPEMASK; 86781144 SvFLAGS(sv) |= mt; 86781144 switch (mt) { case SVt_NULL: ###### Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: 22115837 assert(old_type == SVt_NULL); 22115837 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); 22115837 SvIV_set(sv, 0); 22115837 return; case SVt_NV: 1669529 assert(old_type == SVt_NULL); 1669529 SvANY(sv) = new_XNV(); 1669529 SvNV_set(sv, 0); 1669529 return; case SVt_RV: 6721187 assert(old_type == SVt_NULL); 6721187 SvANY(sv) = &sv->sv_u.svu_rv; 6721187 SvRV_set(sv, 0); 6721187 return; case SVt_PVHV: 1306224 SvANY(sv) = new_XPVHV(); 1306224 HvFILL(sv) = 0; 1306224 HvMAX(sv) = 0; 1306224 HvTOTALKEYS(sv) = 0; 1306224 goto hv_av_common; case SVt_PVAV: 4065780 SvANY(sv) = new_XPVAV(); 4065780 AvMAX(sv) = -1; 4065780 AvFILLp(sv) = -1; 4065780 AvALLOC(sv) = 0; 4065780 AvREAL_only(sv); hv_av_common: /* SVt_NULL isn't the only thing upgraded to AV or HV. The target created by newSVrv also is, and it can have magic. However, it never has SvPVX set. */ 5372004 if (old_type >= SVt_RV) { 21276 assert(SvPVX_const(sv) == 0); } /* Could put this in the else clause below, as PVMG must have SvPVX 0 already (the assertion above) */ 5372004 SvPV_set(sv, (char*)0); 5372004 if (old_type >= SVt_PVMG) { 21276 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic); 21276 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); } else { 5350728 SvMAGIC_set(sv, 0); 5350728 SvSTASH_set(sv, 0); } 5350728 break; case SVt_PVIO: 39393 new_body = new_XPVIO(); 39393 new_body_length = sizeof(XPVIO); 39393 goto zero; case SVt_PVFM: 9129 new_body = new_XPVFM(); 9129 new_body_length = sizeof(XPVFM); 9129 goto zero; case SVt_PVBM: 232693 new_body_length = sizeof(XPVBM); 232693 new_body_arena = (void **) &PL_xpvbm_root; 232693 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; 232693 goto new_body; case SVt_PVGV: 1462808 new_body_length = sizeof(XPVGV); 1462808 new_body_arena = (void **) &PL_xpvgv_root; 1462808 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; 1462808 goto new_body; case SVt_PVCV: 781202 new_body_length = sizeof(XPVCV); 781202 new_body_arena = (void **) &PL_xpvcv_root; 781202 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; 781202 goto new_body; case SVt_PVLV: 480976 new_body_length = sizeof(XPVLV); 480976 new_body_arena = (void **) &PL_xpvlv_root; 480976 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; 480976 goto new_body; case SVt_PVMG: 6035096 new_body_length = sizeof(XPVMG); 6035096 new_body_arena = (void **) &PL_xpvmg_root; 6035096 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; 6035096 goto new_body; case SVt_PVNV: 3173409 new_body_length = sizeof(XPVNV); 3173409 new_body_arena = (void **) &PL_xpvnv_root; 3173409 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; 3173409 goto new_body; case SVt_PVIV: 4924769 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - STRUCT_OFFSET(xpviv_allocated, xpv_cur); 4924769 new_body_length = sizeof(XPVIV) - new_body_offset; 4924769 new_body_arena = (void **) &PL_xpviv_root; 4924769 new_body_arenaroot = (void **) &PL_xpviv_arenaroot; /* XXX Is this still needed? Was it ever needed? Surely as there is no route from NV to PVIV, NOK can never be true */ 4924769 if (SvNIOK(sv)) 1410032 (void)SvIOK_on(sv); 4924769 SvNOK_off(sv); 4924769 goto new_body_no_NV; case SVt_PV: 33763112 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - STRUCT_OFFSET(xpv_allocated, xpv_cur); 33763112 new_body_length = sizeof(XPV) - new_body_offset; 33763112 new_body_arena = (void **) &PL_xpv_root; 33763112 new_body_arenaroot = (void **) &PL_xpv_arenaroot; new_body_no_NV: /* PV and PVIV don't have an NV slot. */ #ifndef NV_ZERO_IS_ALLBITS_ZERO zero_nv = FALSE; #endif new_body: 50854065 assert(new_body_length); #ifndef PURIFY /* This points to the start of the allocated area. */ 50854065 new_body = S_new_body(aTHX_ new_body_arenaroot, new_body_arena, new_body_length); #else /* We always allocated the full length item with PURIFY */ new_body_length += new_body_offset; new_body_offset = 0; new_body = my_safemalloc(new_body_length); #endif zero: 50902587 Zero(new_body, new_body_length, char); 50902587 new_body = ((char *)new_body) - new_body_offset; 50902587 SvANY(sv) = new_body; 50902587 if (old_body_length) { Copy((char *)old_body + old_body_offset, (char *)new_body + old_body_offset, 7764394 old_body_length, char); } #ifndef NV_ZERO_IS_ALLBITS_ZERO if (zero_nv) SvNV_set(sv, 0); #endif 50902587 if (mt == SVt_PVIO) 39393 IoPAGE_LEN(sv) = 60; 50902587 if (old_type < SVt_RV) 44989656 SvPV_set(sv, 0); 44989656 break; default: ###### Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt); } 56274591 if (old_body_arena) { #ifdef PURIFY my_safefree(old_body); #else del_body((void*)((char*)old_body + old_body_offset), 5965319 old_body_arena); #endif } } /* =for apidoc sv_backoff Remove any string offset. You should normally use the C macro wrapper instead. =cut */ int Perl_sv_backoff(pTHX_ register SV *sv) 249730 { 249730 assert(SvOOK(sv)); 249730 assert(SvTYPE(sv) != SVt_PVHV); 249730 assert(SvTYPE(sv) != SVt_PVAV); 249730 if (SvIVX(sv)) { 249527 const char * const s = SvPVX_const(sv); 249527 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); 249527 SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); 249527 SvIV_set(sv, 0); 249527 Move(s, SvPVX(sv), SvCUR(sv)+1, char); } 249730 SvFLAGS(sv) &= ~SVf_OOK; 249730 return 0; } /* =for apidoc sv_grow Expands the character buffer in the SV. If necessary, uses C and upgrades the SV to C. Returns a pointer to the character buffer. Use the C wrapper instead. =cut */ char * Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) 42813860 { 42813860 register char *s; #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, "Allocation too large: %"UVxf"\n", (UV)newlen); my_exit(1); } #endif /* HAS_64K_LIMIT */ 42813860 if (SvROK(sv)) ###### sv_unref(sv); 42813860 if (SvTYPE(sv) < SVt_PV) { 4504 sv_upgrade(sv, SVt_PV); 4504 s = SvPVX_mutable(sv); } 42809356 else if (SvOOK(sv)) { /* pv is offset? */ 9748 sv_backoff(sv); 9748 s = SvPVX_mutable(sv); 9748 if (newlen > SvLEN(sv)) 596 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) newlen = 0xFFFF; #endif } else 42799608 s = SvPVX_mutable(sv); 42813860 if (newlen > SvLEN(sv)) { /* need more room? */ 42804264 newlen = PERL_STRLEN_ROUNDUP(newlen); 42804264 if (SvLEN(sv) && s) { #ifdef MYMALLOC const STRLEN l = malloced_size((void*)SvPVX_const(sv)); if (newlen <= l) { SvLEN_set(sv, l); return s; } else #endif 6684289 s = saferealloc(s, newlen); } else { 36119975 s = safemalloc(newlen); 36119975 if (SvPVX_const(sv) && SvCUR(sv)) { 55 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); } } 42804264 SvPV_set(sv, s); 42804264 SvLEN_set(sv, newlen); } 42813860 return s; } /* =for apidoc sv_setiv Copies an integer into the given SV, upgrading first if necessary. Does not handle 'set' magic. See also C. =cut */ void Perl_sv_setiv(pTHX_ register SV *sv, IV i) 77038730 { 77038730 SV_CHECK_THINKFIRST_COW_DROP(sv); 77038730 switch (SvTYPE(sv)) { case SVt_NULL: 5302918 sv_upgrade(sv, SVt_IV); 5302918 break; case SVt_NV: 94 sv_upgrade(sv, SVt_PVNV); 94 break; case SVt_RV: case SVt_PV: 49 sv_upgrade(sv, SVt_PVIV); 49 break; case SVt_PVGV: case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: ###### Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), OP_DESC(PL_op)); } 77038730 (void)SvIOK_only(sv); /* validate number */ 77038730 SvIV_set(sv, i); 77038730 SvTAINT(sv); } /* =for apidoc sv_setiv_mg Like C, but also handles 'set' magic. =cut */ void Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) 13 { 13 sv_setiv(sv,i); 13 SvSETMAGIC(sv); } /* =for apidoc sv_setuv Copies an unsigned integer into the given SV, upgrading first if necessary. Does not handle 'set' magic. See also C. =cut */ void Perl_sv_setuv(pTHX_ register SV *sv, UV u) 32637341 { /* With these two if statements: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 without u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 If you wish to remove them, please benchmark to see what the effect is */ 32637341 if (u <= (UV)IV_MAX) { 32546899 sv_setiv(sv, (IV)u); 32546899 return; } 90442 sv_setiv(sv, 0); 90442 SvIsUV_on(sv); 90442 SvUV_set(sv, u); } /* =for apidoc sv_setuv_mg Like C, but also handles 'set' magic. =cut */ void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) 14 { /* With these two if statements: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 without u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 If you wish to remove them, please benchmark to see what the effect is */ 14 if (u <= (UV)IV_MAX) { 14 sv_setiv(sv, (IV)u); } else { ###### sv_setiv(sv, 0); ###### SvIsUV_on(sv); ###### sv_setuv(sv,u); } 14 SvSETMAGIC(sv); } /* =for apidoc sv_setnv Copies a double into the given SV, upgrading first if necessary. Does not handle 'set' magic. See also C. =cut */ void Perl_sv_setnv(pTHX_ register SV *sv, NV num) 5173748 { 5173748 SV_CHECK_THINKFIRST_COW_DROP(sv); 5173748 switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: 876086 sv_upgrade(sv, SVt_NV); 876086 break; case SVt_RV: case SVt_PV: case SVt_PVIV: 14 sv_upgrade(sv, SVt_PVNV); 14 break; case SVt_PVGV: case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: ###### Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), OP_NAME(PL_op)); } 5173748 SvNV_set(sv, num); 5173748 (void)SvNOK_only(sv); /* validate number */ 5173748 SvTAINT(sv); } /* =for apidoc sv_setnv_mg Like C, but also handles 'set' magic. =cut */ void Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) 13 { 13 sv_setnv(sv,num); 13 SvSETMAGIC(sv); } /* Print an "isn't numeric" warning, using a cleaned-up, * printable version of the offending string */ STATIC void S_not_a_number(pTHX_ SV *sv) 16 { 16 SV *dsv; 16 char tmpbuf[64]; 16 const char *pv; 16 if (DO_UTF8(sv)) { 2 dsv = sv_2mortal(newSVpvn("", 0)); 2 pv = sv_uni_display(dsv, sv, 10, 0); } else { 14 char *d = tmpbuf; 14 char *limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ 14 const char *s, *end; 78 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { 64 int ch = *s & 0xFF; 64 if (ch & 128 && !isPRINT_LC(ch)) { ###### *d++ = 'M'; ###### *d++ = '-'; ###### ch &= 127; } 64 if (ch == '\n') { ###### *d++ = '\\'; ###### *d++ = 'n'; } 64 else if (ch == '\r') { ###### *d++ = '\\'; ###### *d++ = 'r'; } 64 else if (ch == '\f') { ###### *d++ = '\\'; ###### *d++ = 'f'; } 64 else if (ch == '\\') { ###### *d++ = '\\'; ###### *d++ = '\\'; } 64 else if (ch == '\0') { 1 *d++ = '\\'; 1 *d++ = '0'; } 63 else if (isPRINT_LC(ch)) 63 *d++ = ch; else { ###### *d++ = '^'; ###### *d++ = toCTRL(ch); } } 14 if (s < end) { ###### *d++ = '.'; ###### *d++ = '.'; ###### *d++ = '.'; } 14 *d = '\0'; 14 pv = tmpbuf; } 16 if (PL_op) 16 Perl_warner(aTHX_ packWARN(WARN_NUMERIC), "Argument \"%s\" isn't numeric in %s", pv, OP_DESC(PL_op)); else ###### Perl_warner(aTHX_ packWARN(WARN_NUMERIC), "Argument \"%s\" isn't numeric", pv); } /* =for apidoc looks_like_number Test if the content of an SV looks like a number (or is a number). C and C are treated as numbers (so will not issue a non-numeric warning), even if your atof() doesn't grok them. =cut */ I32 Perl_looks_like_number(pTHX_ SV *sv) 86 { 86 register const char *sbegin; 86 STRLEN len; 86 if (SvPOK(sv)) { 84 sbegin = SvPVX_const(sv); 84 len = SvCUR(sv); } 2 else if (SvPOKp(sv)) 1 sbegin = SvPV_const(sv, len); else 1 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); 85 return grok_number(sbegin, len, NULL); } /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ /* NV_PRESERVES_UV: As 64 bit platforms often have an NV that doesn't preserve all bits of an IV (an assumption perl has been based on to date) it becomes necessary to remove the assumption that the NV always carries enough precision to recreate the IV whenever needed, and that the NV is the canonical form. Instead, IV/UV and NV need to be given equal rights. So as to not lose precision as a side effect of conversion (which would lead to insanity and the dragon(s) in t/op/numconvert.t getting very angry) the intent is 1) to distinguish between IV/UV/NV slots that have cached a valid conversion where precision was lost and IV/UV/NV slots that have a valid conversion which has lost no precision 2) to ensure that if a numeric conversion to one form is requested that would lose precision, the precise conversion (or differently imprecise conversion) is also performed and cached, to prevent requests for different numeric formats on the same SV causing lossy conversion chains. (lossless conversion chains are perfectly acceptable (still)) flags are used: SvIOKp is true if the IV slot contains a valid value SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) SvNOKp is true if the NV slot contains a valid value SvNOK is true only if the NV value is accurate so while converting from PV to NV, check to see if converting that NV to an IV(or UV) would lose accuracy over a direct conversion from PV to IV(or UV). If it would, cache both conversions, return NV, but mark SV as IOK NOKp (ie not NOK). While converting from PV to IV, check to see if converting that IV to an NV would lose accuracy over a direct conversion from PV to NV. If it would, cache both conversions, flag similarly. Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite correctly because if IV & NV were set NV *always* overruled. Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning changes - now IV and NV together means that the two are interchangeable: SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; The benefit of this is that operations such as pp_add know that if SvIOK is true for both left and right operands, then integer addition can be used instead of floating point (for cases where the result won't overflow). Before, floating point was always used, which could lead to loss of precision compared with integer addition. * making IV and NV equal status should make maths accurate on 64 bit platforms * may speed up maths somewhat if pp_add and friends start to use integers when possible instead of fp. (Hopefully the overhead in looking for SvIOK and checking for overflow will not outweigh the fp to integer speedup) * will slow down integer operations (callers of SvIV) on "inaccurate" values, as the change from SvIOK to SvIOKp will cause a call into sv_2iv each time rather than a macro access direct to the IV slot * should speed up number->string conversion on integers as IV is favoured when IV and NV are equally accurate #################################################################### You had better be using SvIOK_notUV if you want an IV for arithmetic: SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. On the other hand, SvUOK is true iff UV. #################################################################### Your mileage will vary depending your CPU's relative fp to integer performance ratio. */ #ifndef NV_PRESERVES_UV # define IS_NUMBER_UNDERFLOW_IV 1 # define IS_NUMBER_UNDERFLOW_UV 2 # define IS_NUMBER_IV_AND_UV 2 # define IS_NUMBER_OVERFLOW_IV 4 # define IS_NUMBER_OVERFLOW_UV 5 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); SvIV_set(sv, IV_MIN); return IS_NUMBER_UNDERFLOW_IV; } if (SvNVX(sv) > (NV)UV_MAX) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); SvIsUV_on(sv); SvUV_set(sv, UV_MAX); return IS_NUMBER_OVERFLOW_UV; } (void)SvIOKp_on(sv); (void)SvNOK_on(sv); /* Can't use strtol etc to convert this string. (See truth table in sv_2iv */ if (SvNVX(sv) <= (UV)IV_MAX) { SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); /* Integer is precise. NOK, IOK */ } else { /* Integer is imprecise. NOK, IOKp */ } return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; } SvIsUV_on(sv); SvUV_set(sv, U_V(SvNVX(sv))); if ((NV)(SvUVX(sv)) == SvNVX(sv)) { if (SvUVX(sv) == UV_MAX) { /* As we know that NVs don't preserve UVs, UV_MAX cannot possibly be preserved by NV. Hence, it must be overflow. NOK, IOKp */ return IS_NUMBER_OVERFLOW_UV; } SvIOK_on(sv); /* Integer is precise. NOK, UOK */ } else { /* Integer is imprecise. NOK, IOKp */ } return IS_NUMBER_OVERFLOW_IV; } #endif /* !NV_PRESERVES_UV*/ /* sv_2iv() is now a macro using Perl_sv_2iv_flags(); * this function provided for binary compatibility only */ IV Perl_sv_2iv(pTHX_ register SV *sv) ###### { ###### return sv_2iv_flags(sv, SV_GMAGIC); } /* =for apidoc sv_2iv_flags Return the integer value of an SV, doing any necessary string conversion. If flags includes SV_GMAGIC, does an mg_get() first. Normally used via the C and C macros. =cut */ IV Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) 4688460 { 4688460 if (!sv) ###### return 0; 4688460 if (SvGMAGICAL(sv)) { 11412 if (flags & SV_GMAGIC) 11399 mg_get(sv); 11412 if (SvIOKp(sv)) 11197 return SvIVX(sv); 215 if (SvNOKp(sv)) { 14 return I_V(SvNVX(sv)); } 201 if (SvPOKp(sv) && SvLEN(sv)) 188 return asIV(sv); 13 if (!SvROK(sv)) { 13 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 13 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) 10 report_uninit(sv); } 13 return 0; } } 4677048 if (SvTHINKFIRST(sv)) { 21737 if (SvROK(sv)) { 349 SV* tmpstr; 349 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) 323 return SvIV(tmpstr); 26 return PTR2IV(SvRV(sv)); } 21388 if (SvIsCOW(sv)) { 17783 sv_force_normal_flags(sv, 0); } 21388 if (SvREADONLY(sv) && !SvOK(sv)) { 117 if (ckWARN(WARN_UNINITIALIZED)) 5 report_uninit(sv); 117 return 0; } } 4676582 if (SvIOKp(sv)) { 46431 if (SvIsUV(sv)) { 490 return (IV)(SvUVX(sv)); } else { 45941 return SvIVX(sv); } } 4630151 if (SvNOKp(sv)) { /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv * without also getting a cached IV/UV from it at the same time * (ie PV->NV conversion should detect loss of accuracy and cache * IV or UV at same time to avoid this. NWC */ 3763876 if (SvTYPE(sv) == SVt_NV) 46410 sv_upgrade(sv, SVt_PVNV); 3763876 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost certainly cast into the IV range at IV_MAX, whereas the correct answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary cases go to UV */ 3763876 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 2836720 SvIV_set(sv, I_V(SvNVX(sv))); 2836720 if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && (((UV)1 << NV_PRESERVES_UV_BITS) > (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) /* Don't flag it as "accurately an integer" if the number came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif ) { 1834156 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), 1834156 SvIVX(sv))); } else { /* IV not precise. No need to convert from PV, as NV conversion would already have cached IV if it detected that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), 1002564 SvIVX(sv))); } /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, but the cast (NV)IV_MIN rounds to a the value less (more negative) than IV_MIN which happens to be equal to SvNVX ?? Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and (NV)UVX == NVX are both true, but the values differ. :-( Hopefully for 2s complement IV_MIN is something like 0x8000000000000000 which will be exact. NWC */ } else { 927156 SvUV_set(sv, U_V(SvNVX(sv))); 927156 if ( (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) /* Don't flag it as "accurately an integer" if the number came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif ) 267 SvIOK_on(sv); 927156 SvIsUV_on(sv); ret_iv_max: DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", PTR2UV(sv), SvUVX(sv), 929064 SvUVX(sv))); 929064 return (IV)SvUVX(sv); } } 866275 else if (SvPOKp(sv) && SvLEN(sv)) { 843969 UV value; 843969 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); /* We want to avoid a possible problem when we cache an IV which may be later translated to an NV, and the resulting NV is not the same as the direct translation of the initial string (eg 123.456 can shortcut to the IV 123 with atol(), but we must be careful to ensure that the value with the .456 is around if the NV value is requested in the future). This means that if we cache such an IV, we need to cache the NV as well. Moreover, we trade speed for space, and do not cache the NV if we are sure it's not needed. */ /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ 843969 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer, only upgrade to PVIV */ 833578 if (SvTYPE(sv) < SVt_PVIV) 404791 sv_upgrade(sv, SVt_PVIV); 833578 (void)SvIOK_on(sv); 10391 } else if (SvTYPE(sv) < SVt_PVNV) 5076 sv_upgrade(sv, SVt_PVNV); /* If NV preserves UV then we only use the UV value if we know that we aren't going to call atof() below. If NVs don't preserve UVs then the value returned may have more precision than atof() will return, even though value isn't perfectly accurate. */ 843969 if ((numtype & (IS_NUMBER_IN_UV #ifdef NV_PRESERVES_UV | IS_NUMBER_NOT_INT #endif )) == IS_NUMBER_IN_UV) { /* This won't turn off the public IOK flag if it was set above */ 833578 (void)SvIOKp_on(sv); 833578 if (!(numtype & IS_NUMBER_NEG)) { /* positive */; 820370 if (value <= (UV)IV_MAX) { 816217 SvIV_set(sv, (IV)value); } else { 4153 SvUV_set(sv, value); 4153 SvIsUV_on(sv); } } else { /* 2s complement assumption */ 13208 if (value <= (UV)IV_MIN) { 11274 SvIV_set(sv, -(IV)value); } else { /* Too negative for an IV. This is a double upgrade, but I'm assuming it will be rare. */ 1934 if (SvTYPE(sv) < SVt_PVNV) ###### sv_upgrade(sv, SVt_PVNV); 1934 SvNOK_on(sv); 1934 SvIOK_off(sv); 1934 SvIOKp_on(sv); 1934 SvNV_set(sv, -(NV)value); 1934 SvIV_set(sv, IV_MIN); } } } /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we will be in the previous block to set the IV slot, and the next block to set the NV slot. So no else here. */ 843969 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an (integer that doesn't overflow the UV). */ 10391 SvNV_set(sv, Atof(SvPVX_const(sv))); 10391 if (! numtype && ckWARN(WARN_NUMERIC)) 14 not_a_number(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", 10389 PTR2UV(sv), SvNVX(sv))); #endif #ifdef NV_PRESERVES_UV 10389 (void)SvIOKp_on(sv); 10389 (void)SvNOK_on(sv); 10389 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 8481 SvIV_set(sv, I_V(SvNVX(sv))); 8481 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 5767 SvIOK_on(sv); } else { /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { 1908 if (SvNVX(sv) > (NV)UV_MAX) { 1908 SvIsUV_on(sv); /* Integer is inaccurate. NOK, IOKp, is UV */ 1908 SvUV_set(sv, UV_MAX); 1908 SvIsUV_on(sv); } else { ###### SvUV_set(sv, U_V(SvNVX(sv))); /* 0xFFFFFFFFFFFFFFFF not an issue in here */ ###### if ((NV)(SvUVX(sv)) == SvNVX(sv)) { ###### SvIOK_on(sv); ###### SvIsUV_on(sv); } else { /* Integer is imprecise. NOK, IOKp, is UV */ ###### SvIsUV_on(sv); } } ###### goto ret_iv_max; } #else /* NV_PRESERVES_UV */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { /* The IV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { /* Small enough to preserve all bits. */ (void)SvIOKp_on(sv); SvNOK_on(sv); SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) SvIOK_on(sv); /* Assumption: first non-preserved integer is < IV_MAX, this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { 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); } } else { /* IN_UV NOT_INT 0 0 already failed to read UV. 0 1 already failed to read UV. 1 0 you won't get here in this case. IV/UV slot set, public IOK, Atof() unneeded. 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ if (sv_2iuv_non_preserve (sv, numtype) >= IS_NUMBER_OVERFLOW_IV) goto ret_iv_max; } } #endif /* NV_PRESERVES_UV */ } } else { 22306 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) 111 report_uninit(sv); 22306 if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ 58 sv_upgrade(sv, SVt_IV); 22306 return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", 3678779 PTR2UV(sv),SvIVX(sv))); 3678779 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } /* sv_2uv() is now a macro using Perl_sv_2uv_flags(); * this function provided for binary compatibility only */ UV Perl_sv_2uv(pTHX_ register SV *sv) ###### { ###### return sv_2uv_flags(sv, SV_GMAGIC); } /* =for apidoc sv_2uv_flags Return the unsigned integer value of an SV, doing any necessary string conversion. If flags includes SV_GMAGIC, does an mg_get() first. Normally used via the C and C macros. =cut */ UV Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) 97628 { 97628 if (!sv) ###### return 0; 97628 if (SvGMAGICAL(sv)) { 27718 if (flags & SV_GMAGIC) 46 mg_get(sv); 27718 if (SvIOKp(sv)) 27703 return SvUVX(sv); 15 if (SvNOKp(sv)) 8 return U_V(SvNVX(sv)); 7 if (SvPOKp(sv) && SvLEN(sv)) ###### return asUV(sv); 7 if (!SvROK(sv)) { 7 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 7 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) 6 report_uninit(sv); } 7 return 0; } } 69910 if (SvTHINKFIRST(sv)) { 36 if (SvROK(sv)) { ###### SV* tmpstr; ###### if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) ###### return SvUV(tmpstr); ###### return PTR2UV(SvRV(sv)); } 36 if (SvIsCOW(sv)) { 18 sv_force_normal_flags(sv, 0); } 36 if (SvREADONLY(sv) && !SvOK(sv)) { 4 if (ckWARN(WARN_UNINITIALIZED)) 2 report_uninit(sv); 4 return 0; } } 69906 if (SvIOKp(sv)) { 449 if (SvIsUV(sv)) { 118 return SvUVX(sv); } else { 331 return (UV)SvIVX(sv); } } 69457 if (SvNOKp(sv)) { /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv * without also getting a cached IV/UV from it at the same time * (ie PV->NV conversion should detect loss of accuracy and cache * IV or UV at same time to avoid this. */ /* IV-over-UV optimisation - choose to cache IV if possible */ 54080 if (SvTYPE(sv) == SVt_NV) 21 sv_upgrade(sv, SVt_PVNV); 54080 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ 54080 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 43639 SvIV_set(sv, I_V(SvNVX(sv))); 43639 if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && (((UV)1 << NV_PRESERVES_UV_BITS) > (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) /* Don't flag it as "accurately an integer" if the number came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif ) { 27863 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), 27863 SvIVX(sv))); } else { /* IV not precise. No need to convert from PV, as NV conversion would already have cached IV if it detected that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), 15776 SvIVX(sv))); } /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, but the cast (NV)IV_MIN rounds to a the value less (more negative) than IV_MIN which happens to be equal to SvNVX ?? Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and (NV)UVX == NVX are both true, but the values differ. :-( Hopefully for 2s complement IV_MIN is something like 0x8000000000000000 which will be exact. NWC */ } else { 10441 SvUV_set(sv, U_V(SvNVX(sv))); 10441 if ( (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) /* Don't flag it as "accurately an integer" if the number came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif ) 10116 SvIOK_on(sv); 10441 SvIsUV_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n", PTR2UV(sv), SvUVX(sv), 10441 SvUVX(sv))); } } 15377 else if (SvPOKp(sv) && SvLEN(sv)) { 15355 UV value; 15355 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); /* We want to avoid a possible problem when we cache a UV which may be later translated to an NV, and the resulting NV is not the translation of the initial data. This means that if we cache such a UV, we need to cache the NV as well. Moreover, we trade speed for space, and do not cache the NV if not needed. */ /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ 15355 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer, only upgrade to PVIV */ 13438 if (SvTYPE(sv) < SVt_PVIV) 622 sv_upgrade(sv, SVt_PVIV); 13438 (void)SvIOK_on(sv); 1917 } else if (SvTYPE(sv) < SVt_PVNV) 7 sv_upgrade(sv, SVt_PVNV); /* If NV preserves UV then we only use the UV value if we know that we aren't going to call atof() below. If NVs don't preserve UVs then the value returned may have more precision than atof() will return, even though it isn't accurate. */ 15355 if ((numtype & (IS_NUMBER_IN_UV #ifdef NV_PRESERVES_UV | IS_NUMBER_NOT_INT #endif )) == IS_NUMBER_IN_UV) { /* This won't turn off the public IOK flag if it was set above */ 13438 (void)SvIOKp_on(sv); 13438 if (!(numtype & IS_NUMBER_NEG)) { /* positive */; 7675 if (value <= (UV)IV_MAX) { 5562 SvIV_set(sv, (IV)value); } else { /* it didn't overflow, and it was positive. */ 2113 SvUV_set(sv, value); 2113 SvIsUV_on(sv); } } else { /* 2s complement assumption */ 5763 if (value <= (UV)IV_MIN) { 4833 SvIV_set(sv, -(IV)value); } else { /* Too negative for an IV. This is a double upgrade, but I'm assuming it will be rare. */ 930 if (SvTYPE(sv) < SVt_PVNV) ###### sv_upgrade(sv, SVt_PVNV); 930 SvNOK_on(sv); 930 SvIOK_off(sv); 930 SvIOKp_on(sv); 930 SvNV_set(sv, -(NV)value); 930 SvIV_set(sv, IV_MIN); } } } 15355 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) != IS_NUMBER_IN_UV) { /* It wasn't an integer, or it overflowed the UV. */ 1917 SvNV_set(sv, Atof(SvPVX_const(sv))); 1917 if (! numtype && ckWARN(WARN_NUMERIC)) 1 not_a_number(sv); #if defined(USE_LONG_DOUBLE) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n", 1917 PTR2UV(sv), SvNVX(sv))); #endif #ifdef NV_PRESERVES_UV 1917 (void)SvIOKp_on(sv); 1917 (void)SvNOK_on(sv); 1917 if (SvNVX(sv) < (NV)IV_MAX + 0.5) { 946 SvIV_set(sv, I_V(SvNVX(sv))); 946 if ((NV)(SvIVX(sv)) == SvNVX(sv)) { 22 SvIOK_on(sv); } else { /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { 971 if (SvNVX(sv) > (NV)UV_MAX) { 971 SvIsUV_on(sv); /* Integer is inaccurate. NOK, IOKp, is UV */ 971 SvUV_set(sv, UV_MAX); 971 SvIsUV_on(sv); } else { ###### SvUV_set(sv, U_V(SvNVX(sv))); /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs NV preservse UV so can do correct comparison. */ ###### if ((NV)(SvUVX(sv)) == SvNVX(sv)) { ###### SvIOK_on(sv); ###### SvIsUV_on(sv); } else { /* Integer is imprecise. NOK, IOKp, is UV */ ###### SvIsUV_on(sv); } } } #else /* NV_PRESERVES_UV */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { /* The UV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { /* Small enough to preserve all bits. */ (void)SvIOKp_on(sv); SvNOK_on(sv); SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) SvIOK_on(sv); /* Assumption: first non-preserved integer is < IV_MAX, this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { 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); } } else sv_2iuv_non_preserve (sv, numtype); } #endif /* NV_PRESERVES_UV */ } } else { 22 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 22 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) 8 report_uninit(sv); } 22 if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ 6 sv_upgrade(sv, SVt_IV); 22 return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", 69435 PTR2UV(sv),SvUVX(sv))); 69435 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } /* =for apidoc sv_2nv Return the num value of an SV, doing any necessary string or integer conversion, magic etc. Normally used via the C and C macros. =cut */ NV Perl_sv_2nv(pTHX_ register SV *sv) 3990162 { 3990162 if (!sv) ###### return 0.0; 3990162 if (SvGMAGICAL(sv)) { 465245 mg_get(sv); 465245 if (SvNOKp(sv)) 4903 return SvNVX(sv); 460342 if (SvPOKp(sv) && SvLEN(sv)) { 275 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) 1 not_a_number(sv); 275 return Atof(SvPVX_const(sv)); } 460067 if (SvIOKp(sv)) { 459913 if (SvIsUV(sv)) ###### return (NV)SvUVX(sv); else 459913 return (NV)SvIVX(sv); } 154 if (!SvROK(sv)) { 154 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 154 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) 9 report_uninit(sv); } 154 return (NV)0; } } 3524917 if (SvTHINKFIRST(sv)) { 1969278 if (SvROK(sv)) { 1957766 SV* tmpstr; 1957766 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) 1187 return SvNV(tmpstr); 1956579 return PTR2NV(SvRV(sv)); } 11512 if (SvIsCOW(sv)) { 3140 sv_force_normal_flags(sv, 0); } 11512 if (SvREADONLY(sv) && !SvOK(sv)) { 585 if (ckWARN(WARN_UNINITIALIZED)) 27 report_uninit(sv); 585 return 0.0; } } 1566566 if (SvTYPE(sv) < SVt_NV) { 346096 if (SvTYPE(sv) == SVt_IV) 345991 sv_upgrade(sv, SVt_PVNV); else 105 sv_upgrade(sv, SVt_NV); #ifdef USE_LONG_DOUBLE DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); 346096 }); #endif } 1220470 else if (SvTYPE(sv) < SVt_PVNV) 52765 sv_upgrade(sv, SVt_PVNV); 1566566 if (SvNOKp(sv)) { 3 return SvNVX(sv); } 1566563 if (SvIOKp(sv)) { 1550431 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV 1550431 SvNOK_on(sv); #else /* Only set the public NV OK flag if this NV preserves the IV */ /* Check it's not 0xFFFFFFFFFFFFFFFF */ if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) : (SvIVX(sv) == I_V(SvNVX(sv)))) SvNOK_on(sv); else SvNOKp_on(sv); #endif } 16132 else if (SvPOKp(sv) && SvLEN(sv)) { 14868 UV value; 14868 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 14868 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype) ###### not_a_number(sv); #ifdef NV_PRESERVES_UV 14868 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer */ 9501 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else 5367 SvNV_set(sv, Atof(SvPVX_const(sv))); 14868 SvNOK_on(sv); #else SvNV_set(sv, Atof(SvPVX_const(sv))); /* Only set the public NV OK flag if this NV preserves the value in the PV at least as well as an IV/UV would. Not sure how to do this 100% reliably. */ /* if that shift count is out of range then Configure's test is wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == UV_BITS */ if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { SvNOK_on(sv); /* Definitely small enough to preserve all bits */ } else if (!(numtype & IS_NUMBER_IN_UV)) { /* Can't use strtol etc to convert this string, so don't try. sv_2iv and sv_2uv will use the NV to convert, not the PV. */ SvNOK_on(sv); } else { /* value has been set. It may not be precise. */ if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { /* 2s complement assumption for (UV)IV_MIN */ SvNOK_on(sv); /* Integer is too negative. */ } else { SvNOKp_on(sv); SvIOKp_on(sv); if (numtype & IS_NUMBER_NEG) { SvIV_set(sv, -(IV)value); } else if (value <= (UV)IV_MAX) { SvIV_set(sv, (IV)value); } else { SvUV_set(sv, value); SvIsUV_on(sv); } if (numtype & IS_NUMBER_NOT_INT) { /* I believe that even if the original PV had decimals, they are lost beyond the limit of the FP precision. However, neither is canonical, so both only get p flags. NWC, 2000/11/25 */ /* Both already have p flags, so do nothing */ } else { const NV nv = SvNVX(sv); if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { SvNOK_on(sv); SvIOK_on(sv); } else { SvIOK_on(sv); /* It had no "." so it must be integer. */ } } else { /* between IV_MAX and NV(UV_MAX). Could be slightly > UV_MAX */ if (numtype & IS_NUMBER_NOT_INT) { /* UV and NV both imprecise. */ } else { const UV nv_as_uv = U_V(nv); if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); SvIOK_on(sv); } else { SvIOK_on(sv); } } } } } } #endif /* NV_PRESERVES_UV */ } else { 1264 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) 122 report_uninit(sv); 1264 if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ /* XXX Ilya implies that this is a bug in callers that assume this and ideally should be fixed. */ ###### sv_upgrade(sv, SVt_NV); 1264 return 0.0; } #if defined(USE_LONG_DOUBLE) DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); 1565299 }); #endif 1565299 return SvNVX(sv); } /* asIV(): extract an integer from the string value of an SV. * Caller must validate PVX */ STATIC IV S_asIV(pTHX_ SV *sv) 188 { 188 UV value; 188 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); 188 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer */ 187 if (numtype & IS_NUMBER_NEG) { ###### if (value < (UV)IV_MIN) ###### return -(IV)value; } else { 187 if (value < (UV)IV_MAX) 187 return (IV)value; } } 1 if (!numtype) { 1 if (ckWARN(WARN_NUMERIC)) ###### not_a_number(sv); } 1 return I_V(Atof(SvPVX_const(sv))); } /* asUV(): extract an unsigned integer from the string value of an SV * Caller must validate PVX */ STATIC UV S_asUV(pTHX_ SV *sv) ###### { ###### UV value; ###### const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); ###### if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { /* It's definitely an integer */ ###### if (!(numtype & IS_NUMBER_NEG)) ###### return value; } ###### if (!numtype) { ###### if (ckWARN(WARN_NUMERIC)) ###### not_a_number(sv); } ###### return U_V(Atof(SvPVX_const(sv))); } /* =for apidoc sv_2pv_nolen Like C, but doesn't return the length too. You should usually use the macro wrapper C instead. =cut */ char * Perl_sv_2pv_nolen(pTHX_ register SV *sv) ###### { ###### return sv_2pv(sv, 0); } /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. * * We assume that buf is at least TYPE_CHARS(UV) long. */ static char * uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) 2919319 { 2919319 char *ptr = buf + TYPE_CHARS(UV); 2919319 char *ebuf = ptr; 2919319 int sign; 2919319 if (is_uv) 5629 sign = 0; 2913690 else if (iv >= 0) { 2905142 uv = iv; 2905142 sign = 0; } else { 8548 uv = -iv; 8548 sign = 1; } 9350132 do { 9350132 *--ptr = '0' + (char)(uv % 10); 9350132 } while (uv /= 10); 2919319 if (sign) 8548 *--ptr = '-'; 2919319 *peob = ebuf; 2919319 return ptr; } /* sv_2pv() is now a macro using Perl_sv_2pv_flags(); * this function provided for binary compatibility only */ char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) ###### { ###### return sv_2pv_flags(sv, lp, SV_GMAGIC); } /* =for apidoc sv_2pv_flags Returns a pointer to the string value of an SV, and sets *lp to its length. If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string if necessary. Normally invoked via the C macro. C and C usually end up here too. =cut */ char * Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) 8795333 { 8795333 register char *s; 8795333 int olderrno; 8795333 SV *tsv, *origsv; 8795333 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ 8795333 char *tmpbuf = tbuf; 8795333 if (!sv) { ###### if (lp) ###### *lp = 0; ###### return (char *)""; } 8795333 if (SvGMAGICAL(sv)) { 5635326 if (flags & SV_GMAGIC) 5618308 mg_get(sv); 5635320 if (SvPOKp(sv)) { 5628991 if (lp) 5622798 *lp = SvCUR(sv); 5628991 if (flags & SV_MUTABLE_RETURN) 1782 return SvPVX_mutable(sv); 5627209 if (flags & SV_CONST_RETURN) 5608766 return (char *)SvPVX_const(sv); 18443 return SvPVX(sv); } 6329 if (SvIOKp(sv)) { 5949 if (SvIsUV(sv)) ###### (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)); else 5949 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); 5949 tsv = Nullsv; 5949 goto tokensave; } 380 if (SvNOKp(sv)) { 12 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); 12 tsv = Nullsv; 12 goto tokensave; } 368 if (!SvROK(sv)) { 354 if (!(SvFLAGS(sv) & SVs_PADTMP)) { 354 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) 53 report_uninit(sv); } 354 if (lp) 306 *lp = 0; 354 return (char *)""; } } 3160021 if (SvTHINKFIRST(sv)) { 139156 if (SvROK(sv)) { 119012 SV* tmpstr; 119012 register const char *typestr; 119012 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { /* Unwrap this: */ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */ 10854 char *pv; 10854 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { 10837 if (flags & SV_CONST_RETURN) { 10718 pv = (char *) SvPVX_const(tmpstr); } else { 119 pv = (flags & SV_MUTABLE_RETURN) ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); } 10837 if (lp) 10837 *lp = SvCUR(tmpstr); } else { 17 pv = sv_2pv_flags(tmpstr, lp, flags); } 10854 if (SvUTF8(tmpstr)) 3 SvUTF8_on(sv); else 10851 SvUTF8_off(sv); 10854 return pv; } 108158 origsv = sv; 108158 sv = (SV*)SvRV(sv); 108158 if (!sv) ###### typestr = "NULLREF"; else { 108158 MAGIC *mg; 108158 switch (SvTYPE(sv)) { case SVt_PVMG: 72748 if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { 70163 const regexp *re = (regexp *)mg->mg_obj; 70163 if (!mg->mg_ptr) { 11899 const char *fptr = "msix"; 11899 char reflags[6]; 11899 char ch; 11899 int left = 0; 11899 int right = 4; 11899 char need_newline = 0; 11899 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); 59495 while((ch = *fptr++)) { 47596 if(reganch & 1) { 1433 reflags[left++] = ch; } else { 46163 reflags[right--] = ch; } 47596 reganch >>= 1; } 11899 if(left != 4) { 11898 reflags[left] = '-'; 11898 left = 5; } 11899 mg->mg_len = re->prelen + 4 + left; /* * If /x was used, we have to worry about a regex * ending with a comment later being embedded * within another regex. If so, we don't want this * regex's "commentization" to leak out to the * right part of the enclosing regex, we must cap * it with a newline. * * So, if /x was used, we scan backwards from the * end of the regex. If we find a '#' before we * find a newline, we need to add a newline * ourself. If we find a '\n' first (or if we * don't find '#' or '\n'), we don't need to add * anything. -jfriedl */ 11899 if (PMf_EXTENDED & re->reganch) { 256 const char *endptr = re->precomp + re->prelen; 18120 while (endptr >= re->precomp) { 17904 const char c = *(endptr--); 17904 if (c == '\n') 38 break; /* don't need another */ 17866 if (c == '#') { /* we end while in a comment, so we need a newline */ 2 mg->mg_len++; /* save space for it */ 2 need_newline = 1; /* note to add it */ break; } } } 11899 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); 11899 Copy("(?", mg->mg_ptr, 2, char); 11899 Copy(reflags, mg->mg_ptr+2, left, char); 11899 Copy(":", mg->mg_ptr+left+2, 1, char); 11899 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); 11899 if (need_newline) 2 mg->mg_ptr[mg->mg_len - 2] = '\n'; 11899 mg->mg_ptr[mg->mg_len - 1] = ')'; 11899 mg->mg_ptr[mg->mg_len] = 0; } 70163 PL_reginterp_cnt += re->program[0].next_off; 70163 if (re->reganch & ROPT_UTF8) 4 SvUTF8_on(origsv); else 70159 SvUTF8_off(origsv); 70163 if (lp) 70163 *lp = mg->mg_len; 70163 return mg->mg_ptr; } /* Fall through */ case SVt_NULL: case SVt_IV: case SVt_NV: case SVt_RV: case SVt_PV: case SVt_PVIV: case SVt_PVNV: 8799 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break; 23 case SVt_PVLV: typestr = SvROK(sv) ? "REF" /* tied lvalues should appear to be * scalars for backwards compatitbility */ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') 23 ? "SCALAR" : "LVALUE"; break; 24283 case SVt_PVAV: typestr = "ARRAY"; break; 2760 case SVt_PVHV: typestr = "HASH"; break; 1959 case SVt_PVCV: typestr = "CODE"; break; 168 case SVt_PVGV: typestr = "GLOB"; break; ###### case SVt_PVFM: typestr = "FORMAT"; break; 3 case SVt_PVIO: typestr = "IO"; break; ###### default: typestr = "UNKNOWN"; break; } 37995 tsv = NEWSV(0,0); 37995 if (SvOBJECT(sv)) { 2661 const char *name = HvNAME_get(SvSTASH(sv)); 2661 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", name ? name : "__ANON__" , typestr, PTR2UV(sv)); } else 35334 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv)); 35334 goto tokensaveref; } ###### if (lp) ###### *lp = strlen(typestr); ###### return (char *)typestr; } 20144 if (SvREADONLY(sv) && !SvOK(sv)) { 105 if (ckWARN(WARN_UNINITIALIZED)) 16 report_uninit(sv); 105 if (lp) 99 *lp = 0; 105 return (char *)""; } } 3040904 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ 2919319 const U32 isIOK = SvIOK(sv); 2919319 const U32 isUIOK = SvIsUV(sv); 2919319 char buf[TYPE_CHARS(UV)]; 2919319 char *ebuf, *ptr; 2919319 if (SvTYPE(sv) < SVt_PVIV) 1387710 sv_upgrade(sv, SVt_PVIV); 2919319 if (isUIOK) 5629 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); else 2913690 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); /* inlined from sv_setpvn */ 2919319 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); 2919319 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); 2919319 SvCUR_set(sv, ebuf - ptr); 2919319 s = SvEND(sv); 2919319 *s = '\0'; 2919319 if (isIOK) 2916427 SvIOK_on(sv); else 2892 SvIOKp_on(sv); 2919319 if (isUIOK) 5629 SvIsUV_on(sv); } 121585 else if (SvNOKp(sv)) { 52933 if (SvTYPE(sv) < SVt_PVNV) 27633 sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ 52933 s = SvGROW_mutable(sv, NV_DIG + 20); 52933 olderrno = errno; /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) (void)strcpy(s,"0"); else #endif /*apollo*/ { 52933 Gconvert(SvNVX(sv), NV_DIG, 0, s); } 52933 errno = olderrno; #ifdef FIXNEGATIVEZERO if (*s == '-' && s[1] == '0' && !s[2]) strcpy(s,"0"); #endif 431770 while (*s) s++; #ifdef hcx if (s[-1] == '.') *--s = '\0'; #endif } else { 68652 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) 2468 report_uninit(sv); 68634 if (lp) 68579 *lp = 0; 68634 if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ 454 sv_upgrade(sv, SVt_PV); 68634 return (char *)""; } { 2972252 STRLEN len = s - SvPVX_const(sv); 2972252 if (lp) 2972148 *lp = len; 2972252 SvCUR_set(sv, len); } 2972252 SvPOK_on(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", 2972252 PTR2UV(sv),SvPVX_const(sv))); 2972252 if (flags & SV_CONST_RETURN) 2947356 return (char *)SvPVX_const(sv); 24896 if (flags & SV_MUTABLE_RETURN) 761 return SvPVX_mutable(sv); 24135 return SvPVX(sv); tokensave: 5961 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ /* Sneaky stuff here */ tokensaveref: 37995 if (!tsv) ###### tsv = newSVpv(tmpbuf, 0); 37995 sv_2mortal(tsv); 37995 if (lp) 37975 *lp = SvCUR(tsv); 37995 return SvPVX(tsv); } else { dVAR; 5961 STRLEN len; 5961 const char *t; 5961 if (tsv) { ###### sv_2mortal(tsv); ###### t = SvPVX_const(tsv); ###### len = SvCUR(tsv); } else { 5961 t = tmpbuf; 5961 len = strlen(tmpbuf); } #ifdef FIXNEGATIVEZERO if (len == 2 && t[0] == '-' && t[1] == '0') { t = "0"; len = 1; } #endif 5961 SvUPGRADE(sv, SVt_PV); 5961 if (lp) 5941 *lp = len; 5961 s = SvGROW_mutable(sv, len + 1); 5961 SvCUR_set(sv, len); 5961 SvPOKp_on(sv); 5961 return memcpy(s, t, len + 1); } } /* =for apidoc sv_copypv Copies a stringified representation of the source SV into the destination SV. Automatically performs any necessary mg_get and coercion of numeric values into strings. Guaranteed to preserve UTF-8 flag even from overloaded objects. Similar in nature to sv_2pv[_flags] but operates directly on an SV instead of just the string. Mostly uses sv_2pv_flags to do its work, except when that would lose the UTF-8'ness of the PV. =cut */ void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) 485504 { 485504 STRLEN len; 485504 const char * const s = SvPV_const(ssv,len); 485504 sv_setpvn(dsv,s,len); 485504 if (SvUTF8(ssv)) 3456 SvUTF8_on(dsv); else 482048 SvUTF8_off(dsv); } /* =for apidoc sv_2pvbyte_nolen Return a pointer to the byte-encoded representation of the SV. May cause the SV to be downgraded from UTF-8 as a side-effect. Usually accessed via the C macro. =cut */ char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) ###### { ###### return sv_2pvbyte(sv, 0); } /* =for apidoc sv_2pvbyte Return a pointer to the byte-encoded representation of the SV, and set *lp to its length. May cause the SV to be downgraded from UTF-8 as a side-effect. Usually accessed via the C macro. =cut */ char * Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) 2931 { 2931 sv_utf8_downgrade(sv,0); 2929 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } /* =for apidoc sv_2pvutf8_nolen Return a pointer to the UTF-8-encoded representation of the SV. May cause the SV to be upgraded to UTF-8 as a side-effect. Usually accessed via the C macro. =cut */ char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) ###### { ###### return sv_2pvutf8(sv, 0); } /* =for apidoc sv_2pvutf8 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. Usually accessed via the C macro. =cut */ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) 52 { 52 sv_utf8_upgrade(sv); 52 return SvPV(sv,*lp); } /* =for apidoc sv_2bool This function is only called on magical items, and is only used by sv_true() or its macro equivalent. =cut */ bool Perl_sv_2bool(pTHX_ register SV *sv) 5995807 { 5995807 if (SvGMAGICAL(sv)) 207584 mg_get(sv); 5995807 if (!SvOK(sv)) 3121906 return 0; 2873901 if (SvROK(sv)) { 2689449 SV* tmpsv; 2689449 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) 2073 return (bool)SvTRUE(tmpsv); 2687374 return SvRV(sv) != 0; } 184452 if (SvPOKp(sv)) { 93556 register XPV* const Xpvtmp = (XPV*)SvANY(sv); 93556 if (Xpvtmp && (*sv->sv_u.svu_pv > '0' || Xpvtmp->xpv_cur > 1 || (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) 32564 return 1; else 60992 return 0; } else { 90896 if (SvIOKp(sv)) 90896 return SvIVX(sv) != 0; else { ###### if (SvNOKp(sv)) ###### return SvNVX(sv) != 0.0; else ###### return FALSE; } } } /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); * this function provided for binary compatibility only */ STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) ###### { ###### return sv_utf8_upgrade_flags(sv, SV_GMAGIC); } /* =for apidoc sv_utf8_upgrade Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. =for apidoc sv_utf8_upgrade_flags Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. If C has C bit set, will C on C if appropriate, else not. C and C are implemented in terms of this function. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. =cut */ STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 470138 { 470138 if (sv == &PL_sv_undef) ###### return 0; 470138 if (!SvPOK(sv)) { 28 STRLEN len = 0; 28 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { ###### (void) sv_2pv_flags(sv,&len, flags); ###### if (SvUTF8(sv)) ###### return len; } else { 28 (void) SvPV_force(sv,len); } } 470138 if (SvUTF8(sv)) { 285456 return SvCUR(sv); } 184682 if (SvIsCOW(sv)) { 4 sv_force_normal_flags(sv, 0); } 184682 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) 406 sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any hibit * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ 184276 const U8 *s = (U8 *) SvPVX_const(sv); 184276 const U8 *e = (U8 *) SvEND(sv); 184276 const U8 *t = s; 184276 int hibit = 0; 2201436 while (t < e) { 2028152 const U8 ch = *t++; 2028152 if ((hibit = !NATIVE_IS_INVARIANT(ch))) 184276 break; } 184276 if (hibit) { 10992 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ 10992 U8 * const recoded = bytes_to_utf8((U8*)s, &len); 10992 SvPV_free(sv); /* No longer using what was there before. */ 10992 SvPV_set(sv, (char*)recoded); 10992 SvCUR_set(sv, len - 1); 10992 SvLEN_set(sv, len); /* No longer know the real size. */ } /* Mark as UTF-8 even if no hibit - saves scanning loop */ 184276 SvUTF8_on(sv); } 184680 return SvCUR(sv); } /* =for apidoc sv_utf8_downgrade Attempts to convert the PV of an SV from characters to bytes. If the PV contains a character beyond byte, this conversion will fail; in this case, either returns false or, if C is not true, croaks. This is not as a general purpose Unicode to byte encoding interface: use the Encode extension for that. =cut */ bool Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) 6828 { 6828 if (SvPOKp(sv) && SvUTF8(sv)) { 3031 if (SvCUR(sv)) { 3031 U8 *s; 3031 STRLEN len; 3031 if (SvIsCOW(sv)) { ###### sv_force_normal_flags(sv, 0); } 3031 s = (U8 *) SvPV(sv, len); 3031 if (!utf8_to_bytes(s, &len)) { 40 if (fail_ok) 31 return FALSE; else { 9 if (PL_op) 9 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op)); else ###### Perl_croak(aTHX_ "Wide character"); } } 2991 SvCUR_set(sv, len); } } 6788 SvUTF8_off(sv); 6788 return TRUE; } /* =for apidoc sv_utf8_encode Converts the PV of an SV to UTF-8, but then turns the C flag off so that it looks like octets again. =cut */ void Perl_sv_utf8_encode(pTHX_ register SV *sv) 268352 { 268352 (void) sv_utf8_upgrade(sv); 268352 if (SvIsCOW(sv)) { 1 sv_force_normal_flags(sv, 0); } 268352 if (SvREADONLY(sv)) { 1 Perl_croak(aTHX_ PL_no_modify); } 268351 SvUTF8_off(sv); } /* =for apidoc sv_utf8_decode If the PV of the SV is an octet sequence in UTF-8 and contains a multiple-byte character, the C flag is turned on so that it looks like a character. If the PV contains only single-byte characters, the C flag stays being off. Scans PV for validity and returns false if the PV is invalid UTF-8. =cut */ bool Perl_sv_utf8_decode(pTHX_ register SV *sv) 17 { 17 if (SvPOKp(sv)) { 17 const U8 *c; 17 const U8 *e; /* The octets may have got themselves encoded - get them back as * bytes */ 17 if (!sv_utf8_downgrade(sv, TRUE)) ###### return FALSE; /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ 17 c = (const U8 *) SvPVX_const(sv); 17 if (!is_utf8_string(c, SvCUR(sv)+1)) ###### return FALSE; 17 e = (const U8 *) SvEND(sv); 22 while (c < e) { 20 U8 ch = *c++; 20 if (!UTF8_IS_INVARIANT(ch)) { 15 SvUTF8_on(sv); break; } } } 17 return TRUE; } /* sv_setsv() is now a macro using Perl_sv_setsv_flags(); * this function provided for binary compatibility only */ void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) ###### { ###### sv_setsv_flags(dstr, sstr, SV_GMAGIC); } /* =for apidoc sv_setsv Copies the contents of the source SV C into the destination SV C. The source SV may be destroyed if it is mortal, so don't use this function if the source SV needs to be reused. Does not handle 'set' magic. Loosely speaking, it performs a copy-by-value, obliterating any previous content of the destination. You probably want to use one of the assortment of wrappers, such as C, C, C and C. =for apidoc sv_setsv_flags Copies the contents of the source SV C into the destination SV C. The source SV may be destroyed if it is mortal, so don't use this function if the source SV needs to be reused. Does not handle 'set' magic. Loosely speaking, it performs a copy-by-value, obliterating any previous content of the destination. If the C parameter has the C bit set, will C on C if appropriate, else not. If the C parameter has the C bit set then the buffers of temps will not be stolen. and C are implemented in terms of this function. You probably want to use one of the assortment of wrappers, such as C, C, C and C. This is the primary function for copying scalars, and most other copy-ish functions and macros use this underneath. =cut */ void Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 97031387 { 97031387 register U32 sflags; 97031387 register int dtype; 97031387 register int stype; 97031387 if (sstr == dstr) 522 return; 97030865 SV_CHECK_THINKFIRST_COW_DROP(dstr); 97030842 if (!sstr) 99 sstr = &PL_sv_undef; 97030842 stype = SvTYPE(sstr); 97030842 dtype = SvTYPE(dstr); 97030842 SvAMAGIC_off(dstr); 97030842 if ( SvVOK(dstr) ) { /* need to nuke the magic */ 37 mg_free(dstr); 37 SvRMAGICAL_off(dstr); } /* There's a lot of redundancy below but we're going for speed here */ 97030842 switch (stype) { case SVt_NULL: undef_sstr: 3985914 if (dtype != SVt_PVGV) { 3985910 (void)SvOK_off(dstr); 41 return; } 40748825 break; case SVt_IV: 40748825 if (SvIOK(sstr)) { 40733757 switch (dtype) { case SVt_NULL: 16511045 sv_upgrade(dstr, SVt_IV); 16511045 break; case SVt_NV: 581 sv_upgrade(dstr, SVt_PVNV); 581 break; case SV