/* 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.
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+static char *
+S_write_no_mem(pTHX)
+{
+ dVAR;
+ /* 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) {
+ 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*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
- dVAR;
-#ifdef PERL_IMPLICIT_SYS
+#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
dTHX;
+#else
+ dVAR;
#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) {
+ 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)
/* 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 I32 first = *little;
- register const char * const littleend = lend;
-
- if (!first && little >= littleend)
- return (char*)big;
- if (bigend - big < littleend - little)
- return Nullch;
- bigend -= littleend - little++;
- while (big <= bigend) {
- register const char *s, *x;
- 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;
}
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++);
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)
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
+ dVAR;
register const U8 *s;
register U32 i;
STRLEN len;
if (flags & FBMcf_TAIL) {
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
- sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
+ sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
+ dVAR;
register const unsigned char *big;
register I32 pos;
register I32 previous;
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);
}
STATIC SV *
S_mess_alloc(pTHX)
{
+ dVAR;
SV *sv;
XPVMG *any;
if (!PL_dirty)
- return sv_2mortal(newSVpvn("",0));
+ return sv_2mortal(newSVpvs(""));
if (PL_mess_sv)
return PL_mess_sv;
STATIC COP*
S_closest_cop(pTHX_ COP *cop, const OP *o)
{
+ dVAR;
/* 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)
- {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
/* 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;
}
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
+ dVAR;
SV * const sv = mess_alloc();
static const char dgd[] = " during global destruction.\n";
STATIC void
S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
{
+ dVAR;
HV *stash;
GV *gv;
CV *cv;
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
+ dVAR;
const char *message;
const int was_in_eval = PL_in_eval;
STRLEN msglen;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
+ dVAR;
const char *message;
STRLEN msglen;
I32 utf8 = 0;
bool
Perl_ckwarn(pTHX_ U32 w)
{
+ dVAR;
return
(
isLEXWARN_on
bool
Perl_ckwarn_d(pTHX_ U32 w)
{
+ dVAR;
return
isLEXWARN_off
|| PL_curcop->cop_warnings == pWARN_ALL
Perl_my_popen_list(pTHX_ 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)
+ dVAR;
int p[2];
register I32 This, that;
register Pid_t pid;
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
+ dVAR;
int p[2];
register I32 This, that;
register Pid_t pid;
return PerlProc_signal(signo, handler);
}
-static
-Signal_t
+static Signal_t
sig_trap(int signo)
{
dVAR;
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
+ dVAR;
Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
+ dVAR;
I32 result = 0;
if (!pid)
return -1;
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);
Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
const char *const *const search_ext, I32 flags)
{
+ dVAR;
const char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
#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;
Perl_getcwd_sv(pTHX_ register SV *sv)
{
#ifndef PERL_MICRO
-
+ dVAR;
#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(sv);
#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)) {
- sv_setpvn(sv, buf, strlen(buf));
+ sv_setpv(sv, buf);
return TRUE;
}
else {
pos++;
}
+ if ( alpha && !saw_period )
+ Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
+
if ( saw_period > 1 )
qv = 1; /* force quoted version processing */
SV *
Perl_new_version(pTHX_ SV *ver)
{
+ dVAR;
SV * const rv = newSV(0);
if ( sv_derived_from(ver,"version") ) /* can just copy directly */
{
/* attempt to retrieve the version array */
if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
- sv_catpvn(sv,"0",1);
+ sv_catpvs(sv,"0");
return sv;
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvn(sv,"0",1);
+ sv_catpvs(sv,"0");
return sv;
}
{
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);
}
{
digit = SvIV(*av_fetch(av, len, 0));
if ( alpha && width == 3 ) /* alpha version */
- sv_catpvn(sv,"_",1);
+ sv_catpvs(sv,"_");
Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
}
else /* len == 0 */
{
- sv_catpvn(sv,"000",3);
+ sv_catpvs(sv, "000");
}
return sv;
}
len = av_len(av);
if ( len == -1 )
{
- sv_catpvn(sv,"",0);
+ sv_catpvs(sv,"");
return sv;
}
digit = SvIV(*av_fetch(av, 0, 0));
if ( len <= 2 ) { /* short version, must be at least three */
for ( len = 2 - len; len != 0; len-- )
- sv_catpvn(sv,".0",2);
+ sv_catpvs(sv,".0");
}
return sv;
}
U32
Perl_seed(pTHX)
{
+ dVAR;
/*
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
UV
Perl_get_hash_seed(pTHX)
{
+ dVAR;
const char *s = PerlEnv_getenv("PERL_HASH_SEED");
UV myseed = 0;
" %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;
}
#endif /* PERL_MICRO */
}
+#ifdef PERL_IMPLICIT_CONTEXT
+
+/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+the global PL_my_cxt_index is incremented, and that value is assigned to
+that module's static my_cxt_index (who's address is passed as an arg).
+Then, for each interpreter this function is called for, it makes sure a
+void* slot is available to hang the static data off, by allocating or
+extending the interpreter's PL_my_cxt_list array */
+
+void *
+Perl_my_cxt_init(pTHX_ int *index, size_t size)
+{
+ dVAR;
+ void *p;
+ if (*index == -1) {
+ /* this module hasn't been allocated an index yet */
+ MUTEX_LOCK(&PL_my_ctx_mutex);
+ *index = PL_my_cxt_index++;
+ MUTEX_UNLOCK(&PL_my_ctx_mutex);
+ }
+
+ /* make sure the array is big enough */
+ if (PL_my_cxt_size <= *index) {
+ if (PL_my_cxt_size) {
+ while (PL_my_cxt_size <= *index)
+ PL_my_cxt_size *= 2;
+ Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
+ else {
+ PL_my_cxt_size = 16;
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
+ }
+ /* newSV() allocates one more than needed */
+ p = (void*)SvPVX(newSV(size-1));
+ PL_my_cxt_list[*index] = p;
+ Zero(p, size, char);
+ return p;
+}
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff