/* 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.
*/
/*
- * "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.
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) {
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) {
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;
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);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
- const int e = errno;
+ dSAVED_ERRNO;
#endif
PerlIO * const serr = Perl_error_log;
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
- errno = e;
+ RESTORE_ERRNO;
#endif
}
}
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
POPSTACK;
LEAVE;
return TRUE;
return message;
}
-OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+static OP *
+S_vdie(pTHX_ const char* pat, va_list *args)
{
dVAR;
const char *message;
{
dTHX;
va_list args;
- PERL_ARGS_ASSERT_CROAK_NOCONTEXT;
va_start(args, pat);
vcroak(pat, &args);
/* NOTREACHED */
If you want to throw an exception object, assign the object to
C<$@> and then pass C<NULL> to croak():
- errsv = get_sv("@", TRUE);
+ errsv = get_sv("@", GV_ADD);
sv_setsv(errsv, exception_object);
croak(NULL);
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i=setenv_getix(nam); /* where does it go? */
+ register I32 i;
+ register const I32 len = strlen(nam);
int nlen, vlen;
+ /* where does it go? */
+ for (i = 0; environ[i]; i++) {
+ if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ break;
+ }
+
if (environ == PL_origenviron) { /* need we copy environment? */
I32 j;
I32 max;
#endif /* WIN32 || NETWARE */
-#ifndef PERL_MICRO
-I32
-Perl_setenv_getix(pTHX_ const char *nam)
-{
- register I32 i;
- register const I32 len = strlen(nam);
-
- PERL_ARGS_ASSERT_SETENV_GETIX;
- PERL_UNUSED_CONTEXT;
-
- for (i = 0; environ[i]; i++) {
- if (
-#ifdef WIN32
- strnicmp(environ[i],nam,len) == 0
-#else
- strnEQ(environ[i],nam,len)
-#endif
- && environ[i][len] == '=')
- break; /* strnEQ must come first to avoid */
- } /* potential SEGV's */
- return i;
-}
-#endif /* !PERL_MICRO */
-
#endif /* !VMS && !EPOC*/
#ifdef UNLINK_ALL_VERSIONS
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
dVAR;
int p[2];
register I32 This, that;
}
return NULL;
}
+ if (ckWARN(WARN_PIPE))
+ Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
else
PerlLIO_close(p[that]); /* close child's end of pipe */
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
}
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PerlLIO_close(pp[1]);
}
if (!doexec)
- Perl_croak(aTHX_ "Can't fork");
+ Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
return NULL;
}
+ if (ckWARN(WARN_PIPE))
+ Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
sleep(5);
}
if (pid == 0) {
else
PerlLIO_close(p[that]);
- LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
- UNLOCK_FDPID_MUTEX;
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
-#ifdef MACOS_TRADITIONAL
-/* We don't want restart behavior on MacOS */
-#undef SA_RESTART
-#endif
-
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
Pid_t pid;
Pid_t pid2;
bool close_failed;
- int saved_errno = 0;
-#ifdef WIN32
- int saved_win32_errno;
-#endif
+ dSAVEDERRNO;
- LOCK_FDPID_MUTEX;
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
- UNLOCK_FDPID_MUTEX;
pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
return my_syspclose(ptr);
}
#endif
- if ((close_failed = (PerlIO_close(ptr) == EOF))) {
- saved_errno = errno;
-#ifdef WIN32
- saved_win32_errno = GetLastError();
-#endif
- }
+ close_failed = (PerlIO_close(ptr) == EOF);
+ SAVE_ERRNO;
#ifdef UTS
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
- SETERRNO(saved_errno, 0);
+ RESTORE_ERRNO;
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
#endif
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
#ifdef PERL_USES_PL_PIDSTATUS
void
-Perl_pidgone(pTHX_ Pid_t pid, int status)
+S_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
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)
}
#endif
-#ifdef MACOS_TRADITIONAL
- if (dosearch && !strchr(scriptname, ':') &&
- (s = PerlEnv_getenv("Commands")))
-#else
if (dosearch && !strchr(scriptname, '/')
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
&& (s = PerlEnv_getenv("PATH")))
-#endif
{
bool seen_dot = 0;
bufend = s + strlen(s);
while (s < bufend) {
-#ifdef MACOS_TRADITIONAL
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
- ',',
- &len);
-#else
#if defined(atarist) || defined(DOSISH)
for (len = 0; *s
# ifdef atarist
':',
&len);
#endif /* ! (atarist || DOSISH) */
-#endif /* MACOS_TRADITIONAL */
if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
-#ifdef MACOS_TRADITIONAL
- if (len && tmpbuf[len - 1] != ':')
- tmpbuf[len++] = ':';
-#else
if (len
# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
tmpbuf[len++] = '/';
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
-#endif
(void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
#endif /* !VMS */
continue;
if (S_ISREG(PL_statbuf.st_mode)
&& cando(S_IRUSR,TRUE,&PL_statbuf)
-#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
+#if !defined(DOSISH)
&& cando(S_IXUSR,TRUE,&PL_statbuf)
#endif
)
for (;;) {
DIR *dir;
+ int namelen;
odev = cdev;
oino = cino;
while ((dp = PerlDir_read(dir)) != NULL) {
#ifdef DIRNAMLEN
- const int namelen = dp->d_namlen;
+ namelen = dp->d_namlen;
#else
- const int namelen = strlen(dp->d_name);
+ namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
if (SV_CWD_ISDOT(dp)) {
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++;
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)
/* 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);
/* 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") ) {
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++ )
{
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
/* 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
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;
}
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 )
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);
+ }
}
/*
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);
errno = ECONNABORTED;
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (sockets[0] != -1)
PerlLIO_close(sockets[0]);
if (sockets[1] != -1)
PerlLIO_close(sockets[1]);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
#endif
tidy_up_and_fail:
{
- const int save_errno = errno;
+ dSAVE_ERRNO;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
PerlLIO_close(connector);
if (acceptor != -1)
PerlLIO_close(acceptor);
- errno = save_errno;
+ RESTORE_ERRNO;
return -1;
}
}
* 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.
*/
/*
# 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
{
* 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
+ * gettimeofday() (see ext/Time-HiRes), the easiest way is
* probably that they would be used to fill in the struct
* 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;
}
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 */
/*
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);
}
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;