/* util.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
#endif
#endif
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+int putenv(char *);
+#endif
+
#ifdef I_SYS_WAIT
# include <sys/wait.h>
#endif
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+static char *
+S_write_no_mem(pTHX)
+{
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
+ my_exit(1);
+ NORETURN_FUNCTION_END;
+}
+
/* paranoid version of system's malloc() */
Malloc_t
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
+#ifdef PERL_TRACK_MEMPOOL
+ size += sTHX;
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: malloc");
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != NULL) {
+#ifdef PERL_TRACK_MEMPOOL
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+ Poison(((char *)ptr), size, char);
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
+}
else if (PL_nomemok)
- return Nullch;
+ return NULL;
else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
+ return write_no_mem();
}
/*NOTREACHED*/
}
if (!where)
return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ size += sTHX;
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
+# ifdef PERL_POISON
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ Poison(start_of_freed, freed_up, char);
+ }
+ header->size = size;
+# endif
+ }
+#endif
#ifdef DEBUGGING
if ((long)size < 0)
Perl_croak_nocontext("panic: realloc");
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- if (ptr != Nullch)
+ if (ptr != NULL) {
+#ifdef PERL_TRACK_MEMPOOL
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+# ifdef PERL_POISON
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ Poison(start_of_fresh, fresh, char);
+ }
+# endif
+
+ header->next->prev = header;
+ header->prev->next = header;
+
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+#endif
return ptr;
+ }
else if (PL_nomemok)
- return Nullch;
+ return NULL;
else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
+ return write_no_mem();
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
dTHX;
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
- /*SUPPRESS 701*/
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+ if (!header->prev) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (!(header->next) || header->next->prev != header
+ || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free");
+ }
+ /* Unlink us from the chain. */
+ header->next->prev = header->prev;
+ header->prev->next = header->next;
+# ifdef PERL_POISON
+ Poison(where, header->size, char);
+# endif
+ /* Trigger the duplicate free warning. */
+ header->next = NULL;
+ }
+#endif
PerlMem_free(where);
}
}
Perl_croak_nocontext("panic: calloc");
#endif
size *= count;
+#ifdef PERL_TRACK_MEMPOOL
+ size += sTHX;
+#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
- if (ptr != Nullch) {
+ if (ptr != NULL) {
memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
+#endif
return ptr;
}
else if (PL_nomemok)
- return Nullch;
- else {
- /* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
- return Nullch;
- }
- /*NOTREACHED*/
+ return NULL;
+ return write_no_mem();
}
/* These must be defined when not using Perl's malloc for binary
if (to < toend)
*to = '\0';
*retlen = tolen;
- return from;
+ return (char *)from;
}
/* return ptr to little string in big string, NULL if not found */
char *
Perl_instr(pTHX_ register const char *big, register const char *little)
{
- register const char *s, *x;
register I32 first;
if (!little)
if (!first)
return (char*)big;
while (*big) {
+ register const char *s, *x;
if (*big++ != first)
continue;
for (x=big,s=little; *s; /**/ ) {
if (!*x)
- return Nullch;
- if (*s++ != *x++) {
- s--;
+ return NULL;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (!*s)
return (char*)(big-1);
}
- return Nullch;
+ return NULL;
}
/* same as instr but allow embedded nulls */
char *
-Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
+Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
{
- register const char *s, *x;
- register I32 first = *little;
- register const char *littleend = lend;
-
- if (!first && little >= littleend)
- return (char*)big;
- if (bigend - big < littleend - little)
- return Nullch;
- bigend -= littleend - little++;
- while (big <= bigend) {
- if (*big++ != first)
- continue;
- for (x=big,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s >= littleend)
- return (char*)(big-1);
+ if (little >= lend)
+ return (char*)big;
+ {
+ char first = *little++;
+ const char *s, *x;
+ bigend -= lend - little;
+ OUTER:
+ while (big <= bigend) {
+ if (*big++ != first)
+ goto OUTER;
+ for (x=big,s=little; s < lend; x++,s++) {
+ if (*s != *x)
+ goto OUTER;
+ }
+ return (char*)(big-1);
+ }
}
- return Nullch;
+ return NULL;
}
/* reverse of the above--find last substring */
Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
{
register const char *bigbeg;
- register const char *s, *x;
- register I32 first = *little;
- register const char *littleend = lend;
+ register const I32 first = *little;
+ register const char * const littleend = lend;
- if (!first && little >= littleend)
+ if (little >= littleend)
return (char*)bigend;
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
+ register const char *s, *x;
if (*big-- != first)
continue;
for (x=big+2,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ x++;
+ s++;
}
}
if (s >= littleend)
return (char*)(big+1);
}
- return Nullch;
+ return NULL;
}
#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
- register U8 *s;
- register U8 *table;
+ register const U8 *s;
register U32 i;
STRLEN len;
I32 rarest = 0;
U32 frequency = 256;
if (flags & FBMcf_TAIL) {
- MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
- sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
+ MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+ sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
- s = (U8*)SvPV_force(sv, len);
+ s = (U8*)SvPV_force_mutable(sv, len);
(void)SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
if (len > 2) {
- U8 mlen;
- unsigned char *sb;
+ const unsigned char *sb;
+ const U8 mlen = (len>255) ? 255 : (U8)len;
+ register U8 *table;
- if (len > 255)
- mlen = 255;
- else
- mlen = (U8)len;
Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
- table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
+ table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
s = table - 1 - FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
table[-1] = (U8)flags;
s--, i++;
}
}
- sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
+ sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
SvVALID_on(sv);
- s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
+ s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
if (PL_freq[s[i]] < frequency) {
rarest = i;
=for apidoc fbm_instr
Returns the location of the SV in the string delimited by C<str> and
-C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
+C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
then.
{
register unsigned char *s;
STRLEN l;
- register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
+ register const unsigned char *little
+ = (const unsigned char *)SvPV_const(littlestr,l);
register STRLEN littlelen = l;
- register I32 multiline = flags & FBMrf_MULTILINE;
+ register const I32 multiline = flags & FBMrf_MULTILINE;
if ((STRLEN)(bigend - big) < littlelen) {
if ( SvTAIL(littlestr)
|| (*big == *little &&
memEQ((char *)big, (char *)little, littlelen - 1))))
return (char*)big;
- return Nullch;
+ return NULL;
}
if (littlelen <= 2) { /* Special-cased */
}
if (SvTAIL(littlestr))
return (char *) bigend;
- return Nullch;
+ return NULL;
}
if (!littlelen)
return (char*)big; /* Cannot be SvTAIL! */
return (char*)bigend - 2;
if (bigend[-1] == *little)
return (char*)bigend - 1;
- return Nullch;
+ return NULL;
}
{
/* This should be better than FBM if c1 == c2, and almost
as good otherwise: maybe better since we do less indirection.
And we save a lot of memory by caching no table. */
- register unsigned char c1 = little[0];
- register unsigned char c2 = little[1];
+ const unsigned char c1 = little[0];
+ const unsigned char c2 = little[1];
s = big + 1;
bigend--;
check_1char_anchor: /* One char and anchor! */
if (SvTAIL(littlestr) && (*bigend == *little))
return (char *)bigend; /* bigend is already decremented. */
- return Nullch;
+ return NULL;
}
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
{
return (char*)s + 1; /* how sweet it is */
}
- return Nullch;
+ return NULL;
}
if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
- char *b = ninstr((char*)big,(char*)bigend,
+ char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
{
return (char*)s;
}
- return Nullch;
+ return NULL;
}
return b;
}
{ /* Do actual FBM. */
- register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
- register unsigned char *oldlittle;
+ register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+ register const unsigned char *oldlittle;
if (littlelen > (STRLEN)(bigend - big))
- return Nullch;
+ return NULL;
--littlelen; /* Last char found by table lookup */
s = big + littlelen;
register I32 tmp;
top2:
- /*SUPPRESS 560*/
if ((tmp = table[*s])) {
if ((s += tmp) < bigend)
goto top2;
goto check_end;
}
else { /* less expensive than calling strncmp() */
- register unsigned char *olds = s;
+ register unsigned char * const olds = s;
tmp = littlelen;
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
- return Nullch;
+ return NULL;
}
}
/* start_shift, end_shift are positive quantities which give offsets
of ends of some substring of bigstr.
- If `last' we want the last occurrence.
+ If "last" we want the last occurrence.
old_posp is the way of communication between consequent calls if
the next call needs to find the .
The initial *old_posp should be -1.
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- register unsigned char *s, *x;
- register unsigned char *big;
+ register const unsigned char *big;
register I32 pos;
register I32 previous;
register I32 first;
- register unsigned char *little;
+ register const unsigned char *little;
register I32 stop_pos;
- register unsigned char *littleend;
+ register const unsigned char *littleend;
I32 found = 0;
if (*old_posp == -1
cant_find:
if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
- little = (unsigned char *)(SvPVX(littlestr));
+ little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
goto check_tail;
}
- return Nullch;
+ return NULL;
}
- little = (unsigned char *)(SvPVX(littlestr));
+ little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
/* The value of pos we can start at: */
previous = BmPREVIOUS(littlestr);
- big = (unsigned char *)(SvPVX(bigstr));
+ big = (const unsigned char *)(SvPVX_const(bigstr));
/* The value of pos we can stop at: */
stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
if (previous + start_shift > stop_pos) {
if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
goto check_tail;
#endif
- return Nullch;
+ return NULL;
}
while (pos < previous + start_shift) {
if (!(pos += PL_screamnext[pos]))
}
big -= previous;
do {
+ register const unsigned char *s, *x;
if (pos >= stop_pos) break;
if (big[pos] != first)
continue;
return (char *)(big+(*old_posp));
check_tail:
if (!SvTAIL(littlestr) || (end_shift > 0))
- return Nullch;
+ return NULL;
/* Ignore the trailing "\n". This code is not microoptimized */
- big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
+ big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
stop_pos = littleend - little; /* Actual littlestr len */
if (stop_pos == 0)
return (char*)big;
&& ((stop_pos == 1) ||
memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
return (char*)big;
- return Nullch;
+ return NULL;
}
I32
Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
{
- register U8 *a = (U8 *)s1;
- register U8 *b = (U8 *)s2;
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
while (len--) {
if (*a != *b && *a != PL_fold[*b])
return 1;
I32
Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
{
- register U8 *a = (U8 *)s1;
- register U8 *b = (U8 *)s2;
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
return 1;
char *
Perl_savepv(pTHX_ const char *pv)
{
- register char *newaddr;
if (!pv)
- return Nullch;
+ return NULL;
+ else {
+ char *newaddr;
+ const STRLEN pvlen = strlen(pv)+1;
+ Newx(newaddr,pvlen,char);
+ return memcpy(newaddr,pv,pvlen);
+ }
- New(902,newaddr,strlen(pv)+1,char);
- return strcpy(newaddr,pv);
}
/* same thing but with a known length */
{
register char *newaddr;
- New(903,newaddr,len+1,char);
+ Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
/* might not be null terminated */
newaddr[len] = '\0';
- return CopyD(pv,newaddr,len,char);
+ return (char *) CopyD(pv,newaddr,len,char);
}
else {
- return ZeroD(newaddr,len+1,char);
+ return (char *) ZeroD(newaddr,len+1,char);
}
}
Perl_savesharedpv(pTHX_ const char *pv)
{
register char *newaddr;
+ STRLEN pvlen;
if (!pv)
- return Nullch;
+ return NULL;
- newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
+ pvlen = strlen(pv)+1;
+ newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
- PL_no_mem, strlen(PL_no_mem));
- my_exit(1);
+ return write_no_mem();
}
- return strcpy(newaddr,pv);
+ return memcpy(newaddr,pv,pvlen);
}
/*
=for apidoc savesvpv
-A version of C<savepv()>/C<savepvn() which gets the string to duplicate from
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
the passed in SV using C<SvPV()>
=cut
Perl_savesvpv(pTHX_ SV *sv)
{
STRLEN len;
- const char *pv = SvPV(sv, len);
+ const char * const pv = SvPV_const(sv, len);
register char *newaddr;
- New(903,newaddr,++len,char);
- return CopyD(pv,newaddr,len,char);
+ ++len;
+ Newx(newaddr,len,char);
+ return (char *) CopyD(pv,newaddr,len,char);
}
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvn("",0));
+ return sv_2mortal(newSVpvs(""));
if (PL_mess_sv)
return PL_mess_sv;
/* Create as PVMG now, to avoid any upgrading later */
- New(905, sv, 1, SV);
- Newz(905, any, 1, XPVMG);
+ Newx(sv, 1, SV);
+ Newxz(any, 1, XPVMG);
SvFLAGS(sv) = SVt_PVMG;
SvANY(sv) = (void*)any;
SvREFCNT(sv) = 1 << 30; /* practically infinite */
char *
Perl_vform(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ SV * const sv = mess_alloc();
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return SvPVX(sv);
}
return retval;
}
-STATIC COP*
-S_closest_cop(pTHX_ COP *cop, OP *o)
+STATIC const COP*
+S_closest_cop(pTHX_ const COP *cop, const OP *o)
{
/* Look for PL_op starting from o. cop is the last COP we've seen. */
- if (!o || o == PL_op) return cop;
+ if (!o || o == PL_op)
+ return cop;
if (o->op_flags & OPf_KIDS) {
- OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
- {
- COP *new_cop;
+ const OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
* the get the file and line number. */
if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
- cop = (COP *)kid;
+ cop = (const COP *)kid;
/* Keep searching, and return when we've found something. */
new_cop = closest_cop(cop, kid);
- if (new_cop) return new_cop;
+ if (new_cop)
+ return new_cop;
}
}
/* Nothing found. */
- return 0;
+ return NULL;
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- SV *sv = mess_alloc();
- static char dgd[] = " during global destruction.\n";
- COP *cop;
+ SV * const sv = mess_alloc();
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-
/*
* Try and find the file and line for PL_op. This will usually be
* PL_curcop, but it might be a cop that has been optimised away. We
* from the sibling of PL_curcop.
*/
- cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
- if (!cop) cop = PL_curcop;
+ const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+ if (!cop)
+ cop = PL_curcop;
if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
OutCopFILE(cop), (IV)CopLINE(cop));
if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
- bool line_mode = (RsSIMPLE(PL_rs) &&
- SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
+ const bool line_mode = (RsSIMPLE(PL_rs) &&
+ SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
- PL_last_in_gv == PL_argvgv ?
- "" : GvNAME(PL_last_in_gv),
+ PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
if (thr->tid)
Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
#endif
- sv_catpv(sv, PL_dirty ? dgd : ".\n");
+ if (PL_dirty)
+ sv_catpvs(sv, " during global destruction");
+ sv_catpvs(sv, ".\n");
}
return sv;
}
save_re_context();
SAVESPTR(PL_stderrgv);
- PL_stderrgv = Nullgv;
+ PL_stderrgv = NULL;
PUSHSTACKi(PERLSI_MAGIC);
else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
- int e = errno;
+ const int e = errno;
#endif
- PerlIO *serr = Perl_error_log;
+ PerlIO * const serr = Perl_error_log;
PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
}
}
-/* Common code used by vcroak, vdie and vwarner */
-
-void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
+/* Common code used by vcroak, vdie, vwarn and vwarner */
-char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
- I32* utf8)
-{
- char *message;
-
- if (pat) {
- SV *msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV(PL_errors, *msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV(msv,*msglen);
- *utf8 = SvUTF8(msv);
- }
- else {
- message = Nullch;
- }
-
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die/croak: message = %s\ndiehook = %p\n",
- thr, message, PL_diehook));
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8);
- }
- return message;
-}
-
-void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
{
HV *stash;
GV *gv;
CV *cv;
- /* sv_2cv might call Perl_croak() */
- SV *olddiehook = PL_diehook;
+ SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+ /* sv_2cv might call Perl_croak() or Perl_warner() */
+ SV * const oldhook = *hook;
+
+ assert(oldhook);
- assert(PL_diehook);
ENTER;
- SAVESPTR(PL_diehook);
- PL_diehook = Nullsv;
- cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ SAVESPTR(*hook);
+ *hook = NULL;
+ cv = sv_2cv(oldhook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
ENTER;
save_re_context();
- if (message) {
+ if (warn) {
+ SAVESPTR(*hook);
+ *hook = NULL;
+ }
+ if (warn || message) {
msg = newSVpvn(message, msglen);
SvFLAGS(msg) |= utf8;
SvREADONLY_on(msg);
msg = ERRSV;
}
- PUSHSTACKi(PERLSI_DIEHOOK);
+ PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
call_sv((SV*)cv, G_DISCARD);
POPSTACK;
LEAVE;
+ return TRUE;
+ }
+ return FALSE;
+}
+
+/* Whilst this should really be STATIC, it was not in 5.8.7, hence something
+ may have linked against it. */
+char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+ I32* utf8)
+{
+ const char *message;
+
+ if (pat) {
+ SV * const msv = vmess(pat, args);
+ if (PL_errors && SvCUR(PL_errors)) {
+ sv_catsv(PL_errors, msv);
+ message = SvPV_const(PL_errors, *msglen);
+ SvCUR_set(PL_errors, 0);
+ }
+ else
+ message = SvPV_const(msv,*msglen);
+ *utf8 = SvUTF8(msv);
+ }
+ else {
+ message = NULL;
+ }
+
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "%p: die/croak: message = %s\ndiehook = %p\n",
+ thr, message, PL_diehook));
+ if (PL_diehook) {
+ S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
}
+ /* Cast because we're not changing function prototypes in maint, and this
+ function isn't actually static. */
+ return (char *) message;
}
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
- char *message;
- int was_in_eval = PL_in_eval;
+ const char *message;
+ const int was_in_eval = PL_in_eval;
STRLEN msglen;
I32 utf8 = 0;
message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
- PL_restartop = die_where(message, msglen);
+ PL_restartop = die_where((char *)message, msglen);
SvFLAGS(ERRSV) |= utf8;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
- char *message;
+ const char *message;
STRLEN msglen;
I32 utf8 = 0;
message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
+ PL_restartop = die_where((char *) message, msglen);
SvFLAGS(ERRSV) |= utf8;
JMPENV_JUMP(3);
}
else if (!message)
- message = SvPVx(ERRSV, msglen);
+ message = SvPVx_const(ERRSV, msglen);
write_to_stderr(message, msglen);
my_failure_exit();
sidestepping the normal C order of execution. See C<warn>.
If you want to throw an exception object, assign the object to
-C<$@> and then pass C<Nullch> to croak():
+C<$@> and then pass C<NULL> to croak():
errsv = get_sv("@", TRUE);
sv_setsv(errsv, exception_object);
- croak(Nullch);
+ croak(NULL);
=cut
*/
void
Perl_vwarn(pTHX_ const char* pat, va_list *args)
{
- char *message;
- HV *stash;
- GV *gv;
- CV *cv;
- SV *msv;
STRLEN msglen;
- I32 utf8 = 0;
-
- msv = vmess(pat, args);
- utf8 = SvUTF8(msv);
- message = SvPV(msv, msglen);
+ SV * const msv = vmess(pat, args);
+ const I32 utf8 = SvUTF8(msv);
+ const char * const message = SvPV_const(msv, msglen);
if (PL_warnhook) {
- /* sv_2cv might call Perl_warn() */
- SV *oldwarnhook = PL_warnhook;
- ENTER;
- SAVESPTR(PL_warnhook);
- PL_warnhook = Nullsv;
- cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
- LEAVE;
- if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
- dSP;
- SV *msg;
-
- ENTER;
- save_re_context();
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
-
- PUSHSTACKi(PERLSI_WARNHOOK);
- PUSHMARK(SP);
- XPUSHs(msg);
- PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
- POPSTACK;
- LEAVE;
+ if (vdie_common(message, msglen, utf8, TRUE))
return;
- }
}
write_to_stderr(message, msglen);
void
Perl_warner_nocontext(U32 err, const char *pat, ...)
{
- dTHX;
+ dTHX;
va_list args;
va_start(args, pat);
vwarner(err, pat, &args);
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
if (ckDEAD(err)) {
- SV *msv = vmess(pat, args);
+ SV * const msv = vmess(pat, args);
STRLEN msglen;
- char *message = SvPV(msv, msglen);
- I32 utf8 = SvUTF8(msv);
+ const char * const message = SvPV_const(msv, msglen);
+ const I32 utf8 = SvUTF8(msv);
#ifdef USE_5005THREADS
DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
#endif /* USE_5005THREADS */
if (PL_diehook) {
assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8);
+ S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
}
if (PL_in_eval) {
- PL_restartop = die_where(message, msglen);
+ PL_restartop = die_where((char *) message, msglen);
SvFLAGS(ERRSV) |= utf8;
JMPENV_JUMP(3);
}
}
}
+/* implements the ckWARN? macros */
+
+bool
+Perl_ckwarn(pTHX_ U32 w)
+{
+ return
+ (
+ isLEXWARN_on
+ && PL_curcop->cop_warnings != pWARN_NONE
+ && (
+ PL_curcop->cop_warnings == pWARN_ALL
+ || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+ || (unpackWARN2(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+ || (unpackWARN3(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+ || (unpackWARN4(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+ )
+ )
+ ||
+ (
+ isLEXWARN_off && PL_dowarn & G_WARN_ON
+ )
+ ;
+}
+
+/* implements the ckWARN?_d macro */
+
+bool
+Perl_ckwarn_d(pTHX_ U32 w)
+{
+ return
+ isLEXWARN_off
+ || PL_curcop->cop_warnings == pWARN_ALL
+ || (
+ PL_curcop->cop_warnings != pWARN_NONE
+ && (
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+ || (unpackWARN2(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+ || (unpackWARN3(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+ || (unpackWARN4(w) &&
+ isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+ )
+ )
+ ;
+}
+
+
+
/* since we've already done strlen() for both nam and val
* we can use that info to make things faster than
* sprintf(s, "%s=%s", nam, val)
I32 max;
char **tmpenv;
- /*SUPPRESS 530*/
for (max = i; environ[max]; max++) ;
tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
- int len = strlen(environ[j]);
+ const int len = strlen(environ[j]);
tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
Copy(environ[j], tmpenv[j], len+1, char);
}
- tmpenv[max] = Nullch;
+ tmpenv[max] = NULL;
environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
}
if (!environ[i]) { /* does not exist yet */
environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
- environ[i+1] = Nullch; /* make sure it's null terminated */
+ environ[i+1] = NULL; /* make sure it's null terminated */
}
else
safesysfree(environ[i]);
my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined( EPOC)
- setenv(nam, val, 1);
+# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ (void)setenv(nam, val, 1);
+ }
+# else /* ! HAS_UNSETENV */
+ (void)setenv(nam, val, 1);
+# endif /* HAS_UNSETENV */
# else
- char *new_env;
- int nlen = strlen(nam), vlen;
- if (!val) {
- val = "";
- }
- vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(new_env, nam, nlen, val, vlen);
- (void)putenv(new_env);
+# if defined(HAS_UNSETENV)
+ if (val == NULL) {
+ (void)unsetenv(nam);
+ } else {
+ const int nlen = strlen(nam);
+ const int vlen = strlen(val);
+ char * const new_env =
+ (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+ }
+# else /* ! HAS_UNSETENV */
+ char *new_env;
+ const int nlen = strlen(nam);
+ int vlen;
+ if (!val) {
+ val = "";
+ }
+ vlen = strlen(val);
+ new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(new_env, nam, nlen, val, vlen);
+ (void)putenv(new_env);
+# endif /* HAS_UNSETENV */
# endif /* __CYGWIN__ */
#ifndef PERL_USE_SAFE_PUTENV
}
#else /* WIN32 || NETWARE */
void
-Perl_my_setenv(pTHX_ char *nam,char *val)
+Perl_my_setenv(pTHX_ char *nam, char *val)
{
register char *envstr;
- int nlen = strlen(nam), vlen;
+ const int nlen = strlen(nam);
+ int vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- New(904, envstr, nlen+vlen+2, char);
+ Newx(envstr, nlen+vlen+2, char);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
I32
Perl_setenv_getix(pTHX_ char *nam)
{
- register I32 i, len = strlen(nam);
+ register I32 i;
+ register const I32 len = strlen(nam);
for (i = 0; environ[i]; i++) {
if (
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
- char *retval = to;
+ char * const retval = to;
if (from - to >= 0) {
while (len--)
void *
Perl_my_memset(register char *loc, register I32 ch, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = ch;
char *
Perl_my_bzero(register char *loc, register I32 len)
{
- char *retval = loc;
+ char * const retval = loc;
while (len--)
*loc++ = 0;
I32
Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
{
- register U8 *a = (U8 *)s1;
- register U8 *b = (U8 *)s2;
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
register I32 tmp;
while (len--) {
- if (tmp = *a++ - *b++)
+ if ((tmp = *a++ - *b++))
return tmp;
}
return 0;
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
/* Try for another pipe pair for error return */
if (PerlProc_pipe(pp) >= 0)
did_pipes = 1;
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
}
- return Nullfp;
+ return NULL;
}
sleep(5);
}
}
}
#endif
- do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
+ do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
PerlProc__exit(1);
#undef THIS
#undef THAT
sv = *av_fetch(PL_fdpid,p[This],TRUE);
UNLOCK_FDPID_MUTEX;
(void)SvUPGRADE(sv,SVt_IV);
- SvIVX(sv) = pid;
+ SvIV_set(sv, pid);
PL_forkprocess = pid;
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
register I32 This, that;
register Pid_t pid;
SV *sv;
- I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
+ const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
int pp[2];
taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe(p) < 0)
- return Nullfp;
+ return NULL;
if (doexec && PerlProc_pipe(pp) >= 0)
did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
}
if (!doexec)
Perl_croak(aTHX_ "Can't fork");
- return Nullfp;
+ return NULL;
}
sleep(5);
}
#ifndef OS2
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
- int fd;
-
#ifndef NOFILE
#define NOFILE 20
#endif
PerlProc__exit(1);
}
#endif /* defined OS2 */
- /*SUPPRESS 560*/
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
#endif
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
- return Nullfp;
+ return NULL;
#undef THIS
#undef THAT
}
sv = *av_fetch(PL_fdpid,p[This],TRUE);
UNLOCK_FDPID_MUTEX;
(void)SvUPGRADE(sv,SVt_IV);
- SvIVX(sv) = pid;
+ SvIV_set(sv, pid);
PL_forkprocess = pid;
if (did_pipes && pid > 0) {
int errkid;
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
errno = errkid; /* Propagate errno from kid */
- return Nullfp;
+ return NULL;
}
}
if (did_pipes)
PerlIO_printf(Perl_debug_log," %d",fd);
}
PerlIO_printf(Perl_debug_log,"\n");
+ return;
}
#endif /* DUMP_FDS */
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
if (sigaction(signo, &act, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
Sighandler_t
struct sigaction oact;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
int
return -1;
#endif
- act.sa_handler = handler;
+ act.sa_handler = (void(*)(int))handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
- if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
act.sa_flags |= SA_NOCLDWAIT;
#endif
return sigaction(signo, &act, save);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
return PerlProc_signal(signo, handler);
}
-static int sig_trapped; /* XXX signals are process-wide anyway, so we
- ignore the implications of this for threading */
+static int PL_sig_trapped; /* XXX signals are process-wide anyway, so we
+ ignore the implications of this for threading */
-static
-Signal_t
+static Signal_t
sig_trap(int signo)
{
- sig_trapped++;
+ PL_sig_trapped++;
}
Sighandler_t
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
- sig_trapped = 0;
+ PL_sig_trapped = 0;
oldsig = PerlProc_signal(signo, sig_trap);
PerlProc_signal(signo, oldsig);
- if (sig_trapped)
+ if (PL_sig_trapped)
PerlProc_kill(PerlProc_getpid(), signo);
return oldsig;
}
return -1;
#endif
*save = PerlProc_signal(signo, handler);
- return (*save == SIG_ERR) ? -1 : 0;
+ return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
int
if (PL_curinterp != aTHX)
return -1;
#endif
- return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
Pid_t pid2;
bool close_failed;
int saved_errno = 0;
-#ifdef VMS
- int saved_vaxc_errno;
-#endif
#ifdef WIN32
int saved_win32_errno;
#endif
#endif
if ((close_failed = (PerlIO_close(ptr) == EOF))) {
saved_errno = errno;
-#ifdef VMS
- saved_vaxc_errno = vaxc$errno;
-#endif
#ifdef WIN32
saved_win32_errno = GetLastError();
#endif
if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
#ifndef PERL_MICRO
- rsignal_save(SIGHUP, SIG_IGN, &hstat);
- rsignal_save(SIGINT, SIG_IGN, &istat);
- rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+ rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
+ rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
#endif
do {
pid2 = wait4pid(pid, &status, 0);
rsignal_restore(SIGQUIT, &qstat);
#endif
if (close_failed) {
- SETERRNO(saved_errno, saved_vaxc_errno);
+ SETERRNO(saved_errno, 0);
return -1;
}
return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
- I32 result;
+ I32 result = 0;
if (!pid)
return -1;
#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
{
- SV *sv;
- SV** svp;
char spid[TYPE_CHARS(IV)];
if (pid > 0) {
- sprintf(spid, "%"IVdf, (IV)pid);
- svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
+ const I32 len = my_sprintf(spid, "%"IVdf, (IV)pid);
+ SV * const * const svp = hv_fetch(PL_pidstatus,spid,len,FALSE);
+
if (svp && *svp != &PL_sv_undef) {
*statusp = SvIVX(*svp);
(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
hv_iterinit(PL_pidstatus);
if ((entry = hv_iternext(PL_pidstatus))) {
+ SV * const sv = hv_iterval(PL_pidstatus,entry);
+ I32 len;
+
pid = atoi(hv_iterkey(entry,(I32*)statusp));
- sv = hv_iterval(PL_pidstatus,entry);
*statusp = SvIVX(sv);
- sprintf(spid, "%"IVdf, (IV)pid);
- (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ len = my_sprintf(spid, "%"IVdf, (IV)pid);
+ /* The hash iterator is currently on this entry, so simply
+ calling hv_delete would trigger the lazy delete, which on
+ aggregate does more work, beacuse next call to hv_iterinit()
+ would spot the flag, and have to call the delete routine,
+ while in the meantime any new entries can't re-use that
+ memory. */
+ hv_iterinit(PL_pidstatus);
+ (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
return pid;
}
}
goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
- result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+ result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
goto finish;
#endif
#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
hard_way:
+#endif
{
if (flags)
Perl_croak(aTHX_ "Can't do waitpid with flags");
}
}
#endif
+#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
finish:
+#endif
if (result < 0 && errno == EINTR) {
PERL_ASYNC_CHECK();
}
#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
void
-/*SUPPRESS 590*/
Perl_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
char spid[TYPE_CHARS(IV)];
+ const size_t len = my_sprintf(spid, "%"IVdf, (IV)pid);
- sprintf(spid, "%"IVdf, (IV)pid);
- sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
+ sv = *hv_fetch(PL_pidstatus,spid,len,TRUE);
(void)SvUPGRADE(sv,SVt_IV);
- SvIVX(sv) = status;
+ SvIV_set(sv, status);
return;
}
#endif
{
/* Needs work for PerlIO ! */
- FILE *f = PerlIO_findFILE(ptr);
- I32 result = pclose(f);
+ FILE * const f = PerlIO_findFILE(ptr);
+ const I32 result = pclose(f);
PerlIO_releaseFILE(ptr,f);
return result;
}
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
/* Needs work for PerlIO ! */
- FILE *f = PerlIO_findFILE(ptr);
+ FILE * const f = PerlIO_findFILE(ptr);
I32 result = djgpp_pclose(f);
result = (result << 8) & 0xff00;
PerlIO_releaseFILE(ptr,f);
Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
{
register I32 todo;
- register const char *frombase = from;
+ register const char * const frombase = from;
if (len == 1) {
register const char c = *from;
char *fb = strrchr(b,'/');
Stat_t tmpstatbuf1;
Stat_t tmpstatbuf2;
- SV *tmpsv = sv_newmortal();
+ SV * const tmpsv = sv_newmortal();
if (fa)
fa++;
if (strNE(a,b))
return FALSE;
if (fa == a)
- sv_setpv(tmpsv, ".");
+ sv_setpvn(tmpsv, ".", 1);
else
sv_setpvn(tmpsv, a, fa - a);
- if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
+ if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
- sv_setpv(tmpsv, ".");
+ sv_setpvn(tmpsv, ".", 1);
else
sv_setpvn(tmpsv, b, fb - b);
- if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
+ if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
#endif /* !HAS_RENAME */
char*
-Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
+Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext,
+ I32 flags)
{
- char *xfound = Nullch;
- char *xfailed = Nullch;
+ const char *xfound = NULL;
+ char *xfailed = NULL;
char tmpbuf[MAXPATHLEN];
register char *s;
I32 len = 0;
#endif
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
- char *exts[] = { SEARCH_EXTS };
- char **ext = search_ext ? search_ext : exts;
+ static const char *const exts[] = { SEARCH_EXTS };
+ const char *const *const ext =
+ search_ext ? (const char *const *const)search_ext : exts;
int extidx = 0, i = 0;
- char *curext = Nullch;
+ const char *curext = NULL;
#else
+ PERL_UNUSED_ARG(search_ext);
# define MAX_EXT_LEN 0
#endif
# ifdef ALWAYS_DEFTYPES
len = strlen(scriptname);
if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
- int hasdir, idx = 0, deftypes = 1;
+ int idx = 0, deftypes = 1;
bool seen_dot = 1;
- hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+ const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
# else
if (dosearch) {
- int hasdir, idx = 0, deftypes = 1;
+ int idx = 0, deftypes = 1;
bool seen_dot = 1;
- hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+ const int hasdir = (strpbrk(scriptname,":[</") != NULL);
# endif
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
len = strlen(scriptname);
if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
break;
+ /* FIXME? Convert to memcpy */
cur = strcpy(tmpbuf, scriptname);
}
} while (extidx >= 0 && ext[extidx] /* try an extension? */
tmpbuf[len++] = ':';
#else
if (len
-#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
-#endif
+# endif
)
tmpbuf[len++] = '/';
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
#endif
+#ifdef HAS_STRLCAT
+ (void)strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
+#else
+ /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
+ */
(void)strcpy(tmpbuf + len, scriptname);
+#endif /* #ifdef HAS_STRLCAT */
#endif /* !VMS */
#ifdef SEARCH_EXTS
(xfailed ? "" : " on PATH"),
(xfailed || seen_dot) ? "" : ", '.' not in PATH");
}
- scriptname = Nullch;
+ scriptname = NULL;
}
- if (xfailed)
- Safefree(xfailed);
- scriptname = xfound;
+ Safefree(xfailed);
+ /* Cast because we're not changing function prototypes in maint. */
+ scriptname = (char *) xfound;
}
- return (scriptname ? savepv(scriptname) : Nullch);
+ return (scriptname ? savepv(scriptname) : NULL);
}
#ifndef PERL_GET_CONTEXT_DEFINED
if (pthread_setspecific(PL_thr_key, t))
Perl_croak_nocontext("panic: pthread_setspecific");
# endif
+#else
+ PERL_UNUSED_ARG(t);
#endif
}
PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
PL_restartop = 0;
- PL_statname = NEWSV(66,0);
+ PL_statname = newSV(0);
PL_errors = newSVpvn("", 0);
PL_maxscream = -1;
PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
}
#endif /* USE_5005THREADS */
-#ifdef PERL_GLOBAL_STRUCT
+#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
struct perl_vars *
Perl_GetVars(pTHX)
{
char **
Perl_get_op_names(pTHX)
{
- return PL_op_name;
+ return (char **)PL_op_name;
}
char **
Perl_get_op_descs(pTHX)
{
- return PL_op_desc;
+ return (char **)PL_op_desc;
}
char *
Perl_get_no_modify(pTHX)
{
- return (char*)PL_no_modify;
+ /* Cast because we're not changing function prototypes in maint. */
+ return (char *) PL_no_modify;
}
U32 *
Perl_get_opargs(pTHX)
{
- return PL_opargs;
+ return (U32 *)PL_opargs;
}
PPADDR_t*
char *
Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
{
- char *env_trans = PerlEnv_getenv(env_elem);
+ char * const env_trans = PerlEnv_getenv(env_elem);
if (env_trans)
*len = strlen(env_trans);
return env_trans;
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- MGVTBL* result = Null(MGVTBL*);
+ const MGVTBL* result;
switch(vtbl_id) {
case want_vtbl_sv:
case want_vtbl_utf8:
result = &PL_vtbl_utf8;
break;
+ default:
+ result = Null(MGVTBL*);
+ break;
}
- return result;
+ return (MGVTBL*)result;
}
I32
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
- char *func =
+ const char * const func =
op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op];
- char *pars = OP_IS_FILETEST(op) ? "" : "()";
- char *type = OP_IS_SOCKET(op)
+ const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+ const char * const type = OP_IS_SOCKET(op)
|| (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
? "socket" : "filehandle";
- char *name = NULL;
-
- if (gv && isGV(gv)) {
- name = GvENAME(gv);
- }
+ const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
- const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+ const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
}
}
else {
- char *vile;
+ const char *vile;
I32 warn_type;
if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
Perl_ebcdic_control(pTHX_ int ch)
{
if (ch > 'a') {
- char *ctlp;
+ const char *ctlp;
if (islower(ch))
ch = toupper(ch);
{
#ifdef HAS_TM_TM_ZONE
Time_t now;
+ const struct tm* my_tm;
(void)time(&now);
- Copy(localtime(&now), ptm, 1, struct tm);
+ my_tm = localtime(&now);
+ if (my_tm)
+ Copy(my_tm, ptm, 1, struct tm);
+#else
+ PERL_UNUSED_ARG(ptm);
#endif
}
} STMT_END;
#endif
buflen = 64;
- New(0, buf, buflen, char);
+ Newx(buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
/*
** The following is needed to handle to the situation where
return buf;
else {
/* Possibly buf overflowed - try again with a bigger buf */
- int fmtlen = strlen(fmt);
- int bufsize = fmtlen + buflen;
+ const int fmtlen = strlen(fmt);
+ const int bufsize = fmtlen + buflen;
- New(0, buf, bufsize, char);
+ Newx(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
buf = NULL;
break;
}
- bufsize *= 2;
- Renew(buf, bufsize, char);
+ Renew(buf, bufsize*2, char);
}
return buf;
}
#else
Perl_croak(aTHX_ "panic: no strftime");
+ return NULL;
#endif
}
* size from the heap if they are given a NULL buffer pointer.
* The problem is that this behaviour is not portable. */
if (getcwd(buf, sizeof(buf) - 1)) {
- STRLEN len = strlen(buf);
- sv_setpvn(sv, buf, len);
+ sv_setpv(sv, buf);
return TRUE;
}
else {
Stat_t statbuf;
int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
- int namelen, pathlen=0;
- DIR *dir;
+ int pathlen=0;
Direntry_t *dp;
(void)SvUPGRADE(sv, SVt_PV);
cino = orig_cino;
for (;;) {
+ DIR *dir;
odev = cdev;
oino = cino;
while ((dp = PerlDir_read(dir)) != NULL) {
#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
+ const int namelen = dp->d_namlen;
#else
- namelen = strlen(dp->d_name);
+ const int namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
if (SV_CWD_ISDOT(dp)) {
if (pathlen) {
/* shift down */
- Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
+ Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
}
/* prepend current directory to the front */
*SvEND(sv) = '\0';
SvPOK_only(sv);
- if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
SV_CWD_RETURN_UNDEF;
}
}
fd_set rset;
FD_ZERO(&rset);
- FD_SET(sockets[0], &rset);
- FD_SET(sockets[1], &rset);
+ FD_SET((unsigned int)sockets[0], &rset);
+ FD_SET((unsigned int)sockets[1], &rset);
got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
if (got != 2 || !FD_ISSET(sockets[0], &rset)
errno = ECONNABORTED;
tidy_up_and_fail:
{
- int save_errno = errno;
+ const int save_errno = errno;
if (sockets[0] != -1)
PerlLIO_close(sockets[0]);
if (sockets[1] != -1)
return 0;
abort_tidy_up_and_fail:
- errno = ECONNABORTED; /* I hope this is portable and appropriate. */
+#ifdef ECONNABORTED
+ errno = ECONNABORTED; /* This would be the standard thing to do. */
+#else
+# ifdef ECONNREFUSED
+ errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
+# else
+ errno = ETIMEDOUT; /* Desperation time. */
+# endif
+#endif
tidy_up_and_fail:
{
- int save_errno = errno;
+ const int save_errno = errno;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
=for apidoc sv_nosharing
Dummy routine which "shares" an SV when there is no sharing module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
+Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
+Exists to avoid test for a NULL function pointer and because it could
+potentially warn under some level of strict-ness.
=cut
*/
void
Perl_sv_nosharing(pTHX_ SV *sv)
{
-}
-
-/*
-=for apidoc sv_nolocking
-
-Dummy routine which "locks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nolocking(pTHX_ SV *sv)
-{
-}
-
-
-/*
-=for apidoc sv_nounlocking
-
-Dummy routine which "unlocks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nounlocking(pTHX_ SV *sv)
-{
+ PERL_UNUSED_ARG(sv);
}
U32
Perl_parse_unicode_opts(pTHX_ char **popt)
{
- char *p = *popt;
+ const char *p = *popt;
U32 opt = 0;
if (*p) {
opt |= PERL_UNICODE_LOCALE_FLAG; break;
case PERL_UNICODE_ARGV:
opt |= PERL_UNICODE_ARGV_FLAG; break;
+ case PERL_UNICODE_UTF8CACHEASSERT:
+ opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
if (*p != '\n' && *p != '\r')
Perl_croak(aTHX_
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
- *popt = p;
+ /* Cast because we're not changing function prototypes in maint. */
+ *popt = (char *) p;
return opt;
}
#endif
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
- if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
+ if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
u = 0;
PerlLIO_close(fd);
if (u)
UV
Perl_get_hash_seed(pTHX)
{
- char *s = PerlEnv_getenv("PERL_HASH_SEED");
+ const char *s = PerlEnv_getenv("PERL_HASH_SEED");
UV myseed = 0;
if (s)
return myseed;
}
+
+#ifdef USE_ITHREADS
+bool
+Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
+{
+ const char * const stashpv = CopSTASHPV(c);
+ const char * const name = HvNAME_get(hv);
+
+ if (stashpv == name)
+ return TRUE;
+ if (stashpv && name)
+ if (strEQ(stashpv, name))
+ return TRUE;
+ return FALSE;
+}
+#endif
+
+void
+Perl_my_clearenv(pTHX)
+{
+#if ! defined(PERL_MICRO)
+# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
+ PerlEnv_clearenv();
+# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
+# if defined(USE_ENVIRON_ARRAY)
+# if defined(USE_ITHREADS)
+ /* only the parent thread can clobber the process environment */
+ if (PL_curinterp == aTHX)
+# endif /* USE_ITHREADS */
+ {
+# if ! defined(PERL_USE_SAFE_PUTENV)
+ if ( !PL_use_safe_putenv) {
+ I32 i;
+ if (environ == PL_origenviron)
+ environ = (char**)safesysmalloc(sizeof(char*));
+ else
+ for (i = 0; environ[i]; i++)
+ (void)safesysfree(environ[i]);
+ }
+ environ[0] = NULL;
+# else /* PERL_USE_SAFE_PUTENV */
+# if defined(HAS_CLEARENV)
+ (void)clearenv();
+# elif defined(HAS_UNSETENV)
+ int bsiz = 80; /* Most envvar names will be shorter than this. */
+ char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ while (*environ != NULL) {
+ char *e = strchr(*environ, '=');
+ int l = e ? e - *environ : strlen(*environ);
+ if (bsiz < l + 1) {
+ (void)safesysfree(buf);
+ bsiz = l + 1;
+ buf = (char*)safesysmalloc(bsiz * sizeof(char));
+ }
+ strncpy(buf, *environ, l);
+ *(buf + l) = '\0';
+ (void)unsetenv(buf);
+ }
+ (void)safesysfree(buf);
+# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
+ /* Just null environ and accept the leakage. */
+ *environ = NULL;
+# endif /* HAS_CLEARENV || HAS_UNSETENV */
+# endif /* ! PERL_USE_SAFE_PUTENV */
+ }
+# endif /* USE_ENVIRON_ARRAY */
+# endif /* PERL_IMPLICIT_SYS || WIN32 */
+#endif /* PERL_MICRO */
+}
+
+/*
+=for apidoc my_sprintf
+
+The C library C<sprintf>, wrapped if necessary, to ensure that it will return
+the length of the string written to the buffer. Only rare pre-ANSI systems
+need the wrapper function - usually this is a direct call to C<sprintf>.
+
+=cut
+*/
+#ifndef SPRINTF_RETURNS_STRLEN
+int
+Perl_my_sprintf(char *buffer, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ vsprintf(buffer, pat, args);
+ va_end(args);
+ return strlen(buffer);
+}
+#endif
+
+#ifdef PERL_MEM_LOG
+
+#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
+
+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
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#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)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf,
+ "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+ filename, linenumber, funcname,
+ n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return newalloc;
+}
+
+Malloc_t
+Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+ /* We can't use PerlIO for obvious reasons. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+ filename, linenumber, funcname, PTR2UV(oldalloc));
+ PerlLIO_write(2, buf, strlen(buf));
+#endif
+ return oldalloc;
+}
+
+#endif /* PERL_MEM_LOG */
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff