* 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 != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+ ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+# ifdef PERL_POISON
+ ((struct perl_memory_debug_header *)ptr)->size = size;
+ ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+# 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;
+ return write_no_mem();
}
/*NOTREACHED*/
}
if (!where)
return safesysmalloc(size);
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ size += sTHX;
+ if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+ /* int *nowhere = NULL; *nowhere = 0; */
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+# ifdef PERL_POISON
+ if (((struct perl_memory_debug_header *)where)->size > size) {
+ const MEM_SIZE freed_up =
+ ((struct perl_memory_debug_header *)where)->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ Poison(start_of_freed, freed_up, char);
+ }
+ ((struct perl_memory_debug_header *)where)->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 != Nullch) {
+#ifdef PERL_TRACK_MEMPOOL
+ 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;
+ return write_no_mem();
}
/*NOTREACHED*/
}
Perl_safesysfree(Malloc_t where)
{
dVAR;
-#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) {
+#ifdef PERL_TRACK_MEMPOOL
+ where = (Malloc_t)((char*)where-sTHX);
+ if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) {
+ /* int *nowhere = NULL; *nowhere = 0; */
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+# ifdef PERL_POISON
+ {
+ if (((struct perl_memory_debug_header *)where)->in_use
+ == PERL_POISON_FREE) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (((struct perl_memory_debug_header *)where)->in_use
+ != PERL_POISON_INUSE) {
+ Perl_croak_nocontext("panic: bad free ");
+ }
+ ((struct perl_memory_debug_header *)where)->in_use
+ = PERL_POISON_FREE;
+ }
+ Poison(where, ((struct perl_memory_debug_header *)where)->size, char);
+# endif
+#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) {
memset((void*)ptr, 0, size);
+#ifdef PERL_TRACK_MEMPOOL
+ ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX;
+# ifdef PERL_POISON
+ ((struct perl_memory_debug_header *)ptr)->size = size;
+ ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE;
+# 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 write_no_mem();
}
/* These must be defined when not using Perl's malloc for binary
for (x=big,s=little; *s; /**/ ) {
if (!*x)
return Nullch;
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (!*s)
Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
{
register const I32 first = *little;
- register const char *littleend = lend;
+ register const char * const littleend = lend;
if (!first && little >= littleend)
return (char*)big;
if (*big++ != first)
continue;
for (x=big,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
+ if (*s != *x)
break;
+ else {
+ s++;
+ x++;
}
}
if (s >= littleend)
{
register const char *bigbeg;
register const I32 first = *little;
- register const char *littleend = lend;
+ register const char * const littleend = lend;
if (!first && little >= littleend)
return (char*)bigend;
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)
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 memcpy(newaddr,pv,pvlen);
}
Perl_savesvpv(pTHX_ SV *sv)
{
STRLEN len;
- const char *pv = SvPV_const(sv, len);
+ const char * const pv = SvPV_const(sv, len);
register char *newaddr;
++len;
if (ckDEAD(err)) {
SV * const msv = vmess(pat, args);
STRLEN msglen;
- const char *message = SvPV_const(msv, msglen);
+ const char * const message = SvPV_const(msv, msglen);
const I32 utf8 = SvUTF8(msv);
if (PL_diehook) {
if ((entry = hv_iternext(PL_pidstatus))) {
SV * const sv = hv_iterval(PL_pidstatus,entry);
I32 len;
- const char *spid = hv_iterkey(entry,&len);
+ const char * const spid = hv_iterkey(entry,&len);
assert (len == sizeof(Pid_t));
memcpy((char *)&pid, spid, len);
{
/* Needs work for PerlIO ! */
FILE * const f = PerlIO_findFILE(ptr);
- I32 result = pclose(f);
+ const I32 result = pclose(f);
PerlIO_releaseFILE(ptr,f);
return result;
}
#endif
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
- const char *const exts[] = { SEARCH_EXTS };
+ static const char *const exts[] = { SEARCH_EXTS };
const char *const *const ext = search_ext ? search_ext : exts;
int extidx = 0, i = 0;
const char *curext = Nullch;
MGVTBL*
Perl_get_vtbl(pTHX_ int vtbl_id)
{
- const 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 (MGVTBL*)result;
}
* 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)) {
- sv_setpvn(sv, buf, strlen(buf));
+ sv_setpv(sv, buf);
return TRUE;
}
else {
int saw_period = 0;
int alpha = 0;
int width = 3;
- AV *av = newAV();
- SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+ AV * const av = newAV();
+ SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
#ifndef NODEFAULT_SHAREKEYS
{
digit = SvIV(*av_fetch(av, i, 0));
if ( width < 3 ) {
- const int denom = (int)pow(10,(3-width));
+ const int denom = (width == 2 ? 10 : 100);
const div_t term = div((int)PERL_ABS(digit),denom);
Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
}
#endif
tidy_up_and_fail:
{
- int save_errno = errno;
+ const int save_errno = errno;
if (listener != -1)
PerlLIO_close(listener);
if (connector != -1)
#ifdef PERL_GLOBAL_STRUCT
# define PERL_GLOBAL_STRUCT_INIT
# include "opcode.h" /* the ppaddr and check */
- IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
- IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
+ const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+ const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
/* PerlMem_malloc() because can't use even safesysmalloc() this early. */
plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
" %s = %"IVdf": %"UVxf"\n",
filename, linenumber, funcname, n, typesize,
typename, n * typesize, PTR2UV(newalloc));
- PerlLIO_write(2, buf, len));
+ PerlLIO_write(2, buf, len);
#endif
return newalloc;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff