X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=aebc8efa7567d5c3d6cad40d70e2ae4b4583ea5b;hb=9f2f055aa1e8c86d97b5ea42473ab1747f518f3a;hp=a6b5c1c2268d4b12a13f23ba7bd09122e731df6f;hpb=52a5bfab8876f302d269f1bfa46eae1998f0d3ca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index a6b5c1c..aebc8ef 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * - * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,8 +9,10 @@ */ /* - * "Very useful, no doubt, that was to Saruman; yet it seems that he was - * not content." --Gandalf + * 'Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content.' --Gandalf to Pippin + * + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -274,12 +276,12 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if (size && (count <= MEM_SIZE_MAX / size)) total_size = size * count; else - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); #ifdef PERL_TRACK_MEMPOOL if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) total_size += sTHX; else - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); #endif #ifdef HAS_64K_LIMIT if (total_size > 0xffff) { @@ -440,9 +442,9 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const if (little >= lend) return (char*)big; { - const char first = *little++; + const char first = *little; const char *s, *x; - bigend -= lend - little; + bigend -= lend - little++; OUTER: while (big <= bigend) { if (*big++ == first) { @@ -1243,7 +1245,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { dSP; ENTER; @@ -1257,7 +1259,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); - PUSHs(SvTIED_obj((SV*)io, mg)); + PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); mPUSHp(message, msglen); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1324,7 +1326,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); POPSTACK; LEAVE; return TRUE; @@ -3108,13 +3110,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) @@ -4305,11 +4307,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos = s; if ( qv ) - (void)hv_stores((HV *)hv, "qv", newSViv(qv)); + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); if ( alpha ) - (void)hv_stores((HV *)hv, "alpha", newSViv(alpha)); + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - (void)hv_stores((HV *)hv, "width", newSViv(width)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4403,7 +4405,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) Compiler in question is: gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) for ( len = 2 - len; len > 0; len-- ) - av_push((AV *)sv, newSViv(0)); + av_push(MUTABLE_AV(sv), newSViv(0)); */ len = 2 - len; while (len-- > 0) @@ -4413,8 +4415,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* need to save off the current version string for later */ if ( vinf ) { SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); - (void)hv_stores((HV *)hv, "original", orig); - (void)hv_stores((HV *)hv, "vinf", newSViv(1)); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); } else if ( s > start ) { SV * orig = newSVpvn(start,s-start); @@ -4422,15 +4424,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* need to insert a v to be consistent */ sv_insert(orig, 0, 0, "v", 1); } - (void)hv_stores((HV *)hv, "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); } else { - (void)hv_stores((HV *)hv, "original", newSVpvn("0",1)); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); av_push(av, newSViv(0)); } /* And finally, store the AV in the hash */ - (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { @@ -4472,25 +4474,25 @@ Perl_new_version(pTHX_ SV *ver) ver = SvRV(ver); /* Begin copying all of the elements */ - if ( hv_exists((HV *)ver, "qv", 2) ) - (void)hv_stores((HV *)hv, "qv", newSViv(1)); + if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - if ( hv_exists((HV *)ver, "alpha", 5) ) - (void)hv_stores((HV *)hv, "alpha", newSViv(1)); + if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); - if ( hv_exists((HV*)ver, "width", 5 ) ) + if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) { - const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - (void)hv_stores((HV *)hv, "width", newSViv(width)); + const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); } - if ( hv_exists((HV*)ver, "original", 8 ) ) + if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) { - SV * pv = *hv_fetchs((HV*)ver, "original", FALSE); - (void)hv_stores((HV *)hv, "original", newSVsv(pv)); + SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); } - sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4498,7 +4500,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); return rv; } #ifdef SvVOK @@ -4646,8 +4648,8 @@ Perl_vverify(pTHX_ SV *vs) /* see if the appropriate elements exist */ if ( SvTYPE(vs) == SVt_PVHV - && hv_exists((HV*)vs, "version", 7) - && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) + && hv_exists(MUTABLE_HV(vs), "version", 7) + && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) return TRUE; else @@ -4686,16 +4688,16 @@ Perl_vnumify(pTHX_ SV *vs) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); + if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) + width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { + if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { sv_catpvs(sv,"0"); return sv; } @@ -4766,9 +4768,9 @@ Perl_vnormal(pTHX_ SV *vs) if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); + av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); len = av_len(av); if ( len == -1 ) @@ -4814,21 +4816,28 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - SV *pv; - PERL_ARGS_ASSERT_VSTRINGIFY; if ( SvROK(vs) ) vs = SvRV(vs); - + if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - pv = *hv_fetchs((HV*)vs, "original", FALSE); - if ( SvPOK(pv) ) - return newSVsv(pv); - else - return &PL_sv_undef; + if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { + SV *pv; + pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); + if ( SvPOK(pv) ) + return newSVsv(pv); + else + return &PL_sv_undef; + } + else { + if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) + return vnormal(vs); + else + return vnumify(vs); + } } /* @@ -4864,13 +4873,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); - if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); - if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) ralpha = TRUE; l = av_len(lav); @@ -5512,9 +5521,15 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. * * PERL_MEM_LOG_ENV: if defined, during run time the environment - * variable PERL_MEM_LOG will be consulted, and if the integer value - * of that is true, the logging will happen. (The default is to - * always log if the PERL_MEM_LOG define was in effect.) + * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and + * if the integer value of that is true, the logging will happen. + * (The default is to always log if the PERL_MEM_LOG define was + * in effect.) + * + * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged + * before every memory logging entry. This can be turned off at run + * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP + * to zero. */ /* @@ -5533,15 +5548,27 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ #endif -Malloc_t -Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) -{ #ifdef PERL_MEM_LOG_STDERR + +# ifdef DEBUG_LEAKING_SCALARS +# define SV_LOG_SERIAL_FMT " [%lu]" +# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial +# else +# define SV_LOG_SERIAL_FMT +# define _SV_LOG_SERIAL_ARG(sv) +# endif + +static void +S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; + const char *s; # endif + + PERL_ARGS_ASSERT_MEM_LOG_COMMON; + # ifdef PERL_MEM_LOG_ENV - s = getenv("PERL_MEM_LOG"); + s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG"); if (s ? atoi(s) : 0) # endif { @@ -5549,9 +5576,16 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t * so we'll use stdio and low-level IO instead. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; # ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; # ifdef HAS_GETTIMEOFDAY +# define MEM_LOG_TIME_FMT "%10d.%06d: " +# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec + struct timeval tv; gettimeofday(&tv, 0); +# else +# define MEM_LOG_TIME_FMT "%10d: " +# define MEM_LOG_TIME_ARG (int)when + Time_t when; + (void)time(&when); # endif /* If there are other OS specific ways of hires time than * gettimeofday() (see ext/Time/HiRes), the easiest way is @@ -5559,73 +5593,73 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t * timeval. */ # endif { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " + int fd = PERL_MEM_LOG_FD; + STRLEN len; + +# ifdef PERL_MEM_LOG_ENV_FD + if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) { + fd = atoi(s); + } # endif - "alloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, +# ifdef PERL_MEM_LOG_TIMESTAMP + s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP"); + if (!s || atoi(s)) { + len = my_snprintf(buf, sizeof(buf), + MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); + PerlLIO_write(fd, buf, len); + } # endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -#endif + switch (mlt) { + case MLT_ALLOC: + len = my_snprintf(buf, sizeof(buf), + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(newalloc)); + break; + case MLT_REALLOC: + len = my_snprintf(buf, sizeof(buf), + "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + break; + case MLT_FREE: + len = my_snprintf(buf, sizeof(buf), + "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + break; + case MLT_NEW_SV: + case MLT_DEL_SV: + len = my_snprintf(buf, sizeof(buf), + "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", + mlt == MLT_NEW_SV ? "new" : "del", + filename, linenumber, funcname, + PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); + break; + } + PerlLIO_write(fd, buf, len); } } +} +#endif + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname); #endif return newalloc; } Malloc_t -Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) { #ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "realloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(oldalloc), - PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } + mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname); #endif return newalloc; } @@ -5634,46 +5668,27 @@ Malloc_t Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) { #ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "free: %s:%d:%s: %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, - PTR2UV(oldalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } + mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); #endif return oldalloc; } +void +Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + +void +Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + #endif /* PERL_MEM_LOG */ /* @@ -5992,10 +6007,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) { + !( (SvTYPE(*svp) == SVt_PVGV) + && (GvCV((const GV *)*svp) == cv) )))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - SV * const tmp = newRV((SV*)cv); + SV * const tmp = newRV(MUTABLE_SV(cv)); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } @@ -6037,7 +6053,7 @@ Perl_get_re_arg(pTHX_ SV *sv) { if (SvMAGICAL(sv)) mg_get(sv); if (SvROK(sv) && - (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */ + (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */ SvTYPE(tmpsv) == SVt_REGEXP) { return (REGEXP*) tmpsv;