/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
{
register I32 tolen;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_DELIMCPY;
/* This routine was donated by Corey Satten. */
char *
-Perl_instr(pTHX_ register const char *big, register const char *little)
+Perl_instr(register const char *big, register const char *little)
{
register I32 first;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INSTR;
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
+Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
PERL_ARGS_ASSERT_NINSTR;
- PERL_UNUSED_CONTEXT;
if (little >= lend)
return (char*)big;
{
/* reverse of the above--find last substring */
char *
-Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
register const I32 first = *little;
register const char * const littleend = lend;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_RNINSTR;
}
I32
-Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_IBCMP;
}
I32
-Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
+Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_IBCMP_LOCALE;
dTHX;
OP *o;
va_list args;
- PERL_ARGS_ASSERT_DIE_NOCONTEXT;
va_start(args, pat);
o = vdie(pat, &args);
va_end(args);
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);
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)
{
bool close_failed;
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)))
- SAVE_ERRNO;
+ close_failed = (PerlIO_close(ptr) == EOF);
+ SAVE_ERRNO;
#ifdef UTS
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
#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)
{
}
#endif
+#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
{
- register I32 todo;
- register const char * const frombase = from;
- PERL_UNUSED_CONTEXT;
-
PERL_ARGS_ASSERT_REPEATCPY;
- if (len == 1) {
- register const char c = *from;
- while (count-- > 0)
- *to++ = c;
- return;
- }
- while (count-- > 0) {
- for (todo = len; todo > 0; todo--) {
- *to++ = *from++;
+ if (len == 1)
+ memset(to, *from, count);
+ else if (count) {
+ register char *p = to;
+ I32 items, linear, half;
+
+ linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+ for (items = 0; items < linear; ++items) {
+ register const char *q = from;
+ I32 todo;
+ for (todo = len; todo > 0; todo--)
+ *p++ = *q++;
+ }
+
+ half = count / 2;
+ while (items <= half) {
+ I32 size = items * len;
+ memcpy(p, to, size);
+ p += size;
+ items *= 2;
}
- from = frombase;
+
+ if (count > items)
+ memcpy(p, to, (count - items) * len);
}
}
}
#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)
+# if defined(atarist) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
# endif
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;
/* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
+ while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
{
if ( *pos == '.' )
{
alpha = 1;
width = pos - last - 1; /* natural width of sub-version */
}
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ {
+ saw_period++ ;
+ last = pos;
+ }
+
pos++;
}
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
+ else if ( *pos == ',' && isDIGIT(pos[1]) )
+ s = ++pos;
else if ( isDIGIT(*pos) )
s = pos;
else {
#ifdef PERL_MEM_LOG
-/*
- * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+ * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
+ * given, and you supply your own implementation.
+ *
+ * The default implementation reads a single env var, PERL_MEM_LOG,
+ * expecting one or more of the following:
*
- * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * 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.)
+ * \d+ - fd fd to write to : must be 1st (atoi)
+ * 'm' - memlog was PERL_MEM_LOG=1
+ * 's' - svlog was PERL_SV_LOG=1
+ * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
*
- * 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.
+ * This makes the logger controllable enough that it can reasonably be
+ * added to the system perl.
*/
-/*
- * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
+/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
* the Perl_mem_log_...() will use (either via sprintf or snprintf).
*/
#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
-/*
- * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
- * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
- * in which case the environment variable PERL_MEM_LOG_FD will be
- * consulted for the file descriptor number to use.
+/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
+ * writes to. In the default logger, this is settable at runtime.
*/
#ifndef PERL_MEM_LOG_FD
# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
#endif
-#ifdef PERL_MEM_LOG_STDERR
+#ifndef PERL_MEM_LOG_NOIMPL
# ifdef DEBUG_LEAKING_SCALARS
# define SV_LOG_SERIAL_FMT " [%lu]"
# 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)
+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)
- const char *s;
-# endif
+ const char *pmlenv;
PERL_ARGS_ASSERT_MEM_LOG_COMMON;
-# ifdef PERL_MEM_LOG_ENV
- s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
- if (s ? atoi(s) : 0)
-# endif
+ pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+ if (!pmlenv)
+ return;
+ if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
{
/* 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
+
# ifdef HAS_GETTIMEOFDAY
# define MEM_LOG_TIME_FMT "%10d.%06d: "
# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
(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
{
- int fd = PERL_MEM_LOG_FD;
STRLEN len;
+ int fd = atoi(pmlenv);
+ if (!fd)
+ fd = PERL_MEM_LOG_FD;
-# ifdef PERL_MEM_LOG_ENV_FD
- if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
- fd = atoi(s);
- }
-# endif
-# ifdef PERL_MEM_LOG_TIMESTAMP
- s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
- if (!s || atoi(s)) {
+ if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
PerlLIO_write(fd, buf, len);
}
-# endif
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
filename, linenumber, funcname,
PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
break;
+ default:
+ len = 0;
}
PerlLIO_write(fd, buf, len);
}
}
}
+#endif /* !PERL_MEM_LOG_NOIMPL */
+
+#ifndef PERL_MEM_LOG_NOIMPL
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
+ mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
+#else
+/* this is suboptimal, but bug compatible. User is providing their
+ own implemenation, but is getting these functions anyway, and they
+ do nothing. But _NOIMPL users should be able to cope or fix */
+# define \
+ mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
+ /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
#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
+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)
+{
+ mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
+ NULL, NULL, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-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
- mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
-#endif
+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)
+{
+ mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
+ NULL, oldalloc, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
-Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_free(Malloc_t oldalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
-#ifdef PERL_MEM_LOG_STDERR
- mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
-#endif
+ mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
+ filename, linenumber, funcname);
return oldalloc;
}
void
-Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+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
+ mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
void
-Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+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
+ mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
+ filename, linenumber, funcname);
}
#endif /* PERL_MEM_LOG */