#define FLUSH
#ifdef LEAKTEST
-static void xstat _((void));
-#endif
-#ifdef USE_THREADS
-static U32 threadnum = 0;
-#endif /* USE_THREADS */
+static void xstat _((int));
+long xcount[MAXXCOUNT];
+long lastxcount[MAXXCOUNT];
+long xycount[MAXXCOUNT][MAXYCOUNT];
+long lastxycount[MAXXCOUNT][MAXYCOUNT];
+
+#endif
#ifndef MYMALLOC
if ((long)size < 0)
croak("panic: malloc");
#endif
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#else
{
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
- Malloc_t realloc();
+ Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
#ifdef HAS_64K_LIMIT
my_exit(1);
}
#endif /* HAS_64K_LIMIT */
+ if (!size) {
+ safefree(where);
+ return NULL;
+ }
+
if (!where)
- croak("Null realloc");
+ return safemalloc(size);
#ifdef DEBUGGING
if ((long)size < 0)
croak("panic: realloc");
#endif
- ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+ ptr = PerlMem_realloc(where,size);
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
#endif
if (where) {
/*SUPPRESS 701*/
- free(where);
+ PerlMem_free(where);
}
}
croak("panic: calloc");
#endif
size *= count;
- ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#else
#ifdef LEAKTEST
-#define ALIGN sizeof(long)
+struct mem_test_strut {
+ union {
+ long type;
+ char c[2];
+ } u;
+ long size;
+};
+
+# define ALIGN sizeof(struct mem_test_strut)
+
+# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
+# define typeof_chunk(ch) \
+ (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
+# define set_typeof_chunk(ch,t) \
+ (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
+#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
+ ? MAXYCOUNT - 1 \
+ : ( (size) > 40 \
+ ? ((size) - 1)/8 + 5 \
+ : ((size) - 1)/4))
Malloc_t
safexmalloc(I32 x, MEM_SIZE size)
{
- register Malloc_t where;
+ register char* where = (char*)safemalloc(size + ALIGN);
- where = safemalloc(size + ALIGN);
- xcount[x]++;
- where[0] = x % 100;
- where[1] = x / 100;
- return where + ALIGN;
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
}
Malloc_t
-safexrealloc(Malloc_t where, MEM_SIZE size)
+safexrealloc(Malloc_t wh, MEM_SIZE size)
{
- register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
- return new + ALIGN;
+ char *where = (char*)wh;
+
+ if (!wh)
+ return safexmalloc(0,size);
+
+ {
+ MEM_SIZE old = sizeof_chunk(where - ALIGN);
+ int t = typeof_chunk(where - ALIGN);
+ register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
+
+ xycount[t][SIZE_TO_Y(old)]--;
+ xycount[t][SIZE_TO_Y(size)]++;
+ xcount[t] += size - old;
+ sizeof_chunk(new) = size;
+ return (Malloc_t)(new + ALIGN);
+ }
}
void
-safexfree(Malloc_t where)
+safexfree(Malloc_t wh)
{
I32 x;
-
+ char *where = (char*)wh;
+ MEM_SIZE size;
+
if (!where)
return;
where -= ALIGN;
+ size = sizeof_chunk(where);
x = where[0] + 100 * where[1];
- xcount[x]--;
+ xcount[x] -= size;
+ xycount[x][SIZE_TO_Y(size)]--;
safefree(where);
}
Malloc_t
safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
{
- register Malloc_t where;
-
- where = safexmalloc(x, size * count + ALIGN);
- xcount[x]++;
- memset((void*)where + ALIGN, 0, size * count);
- where[0] = x % 100;
- where[1] = x / 100;
- return where + ALIGN;
+ register char * where = (char*)safexmalloc(x, size * count + ALIGN);
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ memset((void*)(where + ALIGN), 0, size * count);
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
}
static void
-xstat(void)
+xstat(int flag)
{
- register I32 i;
+ register I32 i, j, total = 0;
+ I32 subtot[MAXYCOUNT];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] = 0;
+ }
+
+ PerlIO_printf(PerlIO_stderr(), " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
for (i = 0; i < MAXXCOUNT; i++) {
- if (xcount[i] > lastxcount[i]) {
- PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
+ total += xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] += xycount[i][j];
+ }
+ if (flag == 0
+ ? xcount[i] /* Have something */
+ : (flag == 2
+ ? xcount[i] != lastxcount[i] /* Changed */
+ : xcount[i] > lastxcount[i])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100,
+ flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
lastxcount[i] = xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if ( flag == 0
+ ? xycount[i][j] /* Have something */
+ : (flag == 2
+ ? xycount[i][j] != lastxycount[i][j] /* Changed */
+ : xycount[i][j] > lastxycount[i][j])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%3ld ",
+ flag == 2
+ ? xycount[i][j] - lastxycount[i][j]
+ : xycount[i][j]);
+ lastxycount[i][j] = xycount[i][j];
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ", xycount[i][j]);
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
}
}
+ if (flag != 2) {
+ PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total);
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if (subtot[j]) {
+ PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]);
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ");
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
+ }
}
#endif /* LEAKTEST */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
- char *lc_all = getenv("LC_ALL");
- char *lang = getenv("LANG");
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
{
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE,
- (!done && (lang || getenv("LC_CTYPE")))
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE,
- (!done && (lang || getenv("LC_COLLATE")))
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC,
- (!done && (lang || getenv("LC_NUMERIC")))
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
char *p;
bool locwarn = (printwarn > 1 ||
printwarn &&
- (!(p = getenv("PERL_BADLANG")) || atoi(p)));
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
if (locwarn) {
#ifdef LC_ALL
mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
{
char *xbuf;
- STRLEN xalloc, xin, xout;
+ STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
/* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
/* the +1 is for the terminating NUL. */
- xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
- New(171, xbuf, xalloc, char);
+ xAlloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
+ New(171, xbuf, xAlloc, char);
if (! xbuf)
goto bad;
SSize_t xused;
for (;;) {
- xused = strxfrm(xbuf + xout, s + xin, xalloc - xout);
+ xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
if (xused == -1)
goto bad;
- if (xused < xalloc - xout)
+ if (xused < xAlloc - xout)
break;
- xalloc = (2 * xalloc) + 1;
- Renew(xbuf, xalloc, char);
+ xAlloc = (2 * xAlloc) + 1;
+ Renew(xbuf, xAlloc, char);
if (! xbuf)
goto bad;
}
#endif /* USE_LOCALE_COLLATE */
void
-fbm_compile(SV *sv)
+fbm_compile(SV *sv, U32 flags /* not used yet */)
{
register unsigned char *s;
register unsigned char *table;
sv_upgrade(sv, SVt_PVBM);
if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */
return; /* can't have offsets that big */
- Sv_Grow(sv,len+258);
- table = (unsigned char*)(SvPVX(sv) + len + 1);
- s = table - 2;
- for (i = 0; i < 256; i++) {
- table[i] = len;
- }
- i = 0;
- while (s >= (unsigned char*)(SvPVX(sv)))
- {
- if (table[*s] == len)
- table[*s] = i;
- s--,i++;
+ if (len > 2) {
+ Sv_Grow(sv,len + 258);
+ table = (unsigned char*)(SvPVX(sv) + len + 1);
+ s = table - 2;
+ for (i = 0; i < 256; i++) {
+ table[i] = len;
+ }
+ i = 0;
+ while (s >= (unsigned char*)(SvPVX(sv)))
+ {
+ if (table[*s] == len)
+ table[*s] = i;
+ s--,i++;
+ }
}
sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
SvVALID_on(sv);
STRLEN len;
char *l = SvPV(littlestr,len);
if (!len) {
- if (SvTAIL(littlestr)) {
+ if (SvTAIL(littlestr)) { /* Can be only 0-len constant
+ substr => we can ignore SvVALID */
+ if (multiline) {
+ char *t = "\n";
+ if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend,
+ t, t + len))) {
+ return (char*)s;
+ }
+ }
if (bigend > big && bigend[-1] == '\n')
return (char *)(bigend - 1);
else
return Nullch;
little = (unsigned char*)SvPVX(littlestr);
s = bigend - littlelen;
- if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
+ if (s > big
+ && bigend[-1] == '\n'
+ && s[-1] == *little && memEQ((char*)s - 1,(char*)little,littlelen))
+ return (char*)s - 1; /* how sweet it is */
+ else if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
return (char*)s; /* how sweet it is */
- else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
- && s > big) {
- s--;
- if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
+ return Nullch;
+ }
+ if (littlelen <= 2) {
+ unsigned char c1 = (unsigned char)SvPVX(littlestr)[0];
+ unsigned char c2 = (unsigned char)SvPVX(littlestr)[1];
+ /* This may do extra comparisons if littlelen == 2, but this
+ should be hidden in the noise since we do less indirection. */
+
+ s = big;
+ bigend -= littlelen;
+ while (s <= bigend) {
+ if (s[0] == c1
+ && (littlelen == 1 || s[1] == c2)
+ && (!SvTAIL(littlestr)
+ || s == bigend
+ || s[littlelen] == '\n')) /* Automatically multiline */
+ {
return (char*)s;
+ }
+ s++;
}
return Nullch;
}
/* the SV for form() and mess() is not kept in an arena */
-static SV *
+STATIC SV *
mess_alloc(void)
{
SV *sv;
return sv;
}
-#ifdef I_STDARG
char *
form(const char* pat, ...)
-#else
-/*VARARGS0*/
-char *
-form(pat, va_alist)
- const char *pat;
- va_dcl
-#endif
{
va_list args;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
if (!mess_sv)
mess_sv = mess_alloc();
sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
return SvPVX(sv);
}
-#ifdef I_STDARG
OP *
die(const char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
- const char *pat;
- va_dcl
-#endif
{
dTHR;
va_list args;
"%p: die: curstack = %p, mainstack = %p\n",
thr, curstack, mainstack));
#endif /* USE_THREADS */
- /* We have to switch back to mainstack or die_where may try to pop
- * the eval block from the wrong stack if die is being called from a
- * signal handler. - dkindred@cs.cmu.edu */
- if (curstack != mainstack) {
- dSP;
- SWITCHSTACK(curstack, mainstack);
- }
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
+ message = pat ? mess(pat, &args) : Nullch;
va_end(args);
#ifdef USE_THREADS
SV *msg;
ENTER;
- msg = newSVpv(message, 0);
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
+ if(message) {
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+ }
+ else {
+ msg = ERRSV;
+ }
- PUSHMARK(sp);
+ PUSHSTACK(SI_DIEHOOK);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
-
+ POPSTACK();
LEAVE;
}
}
return restartop;
}
-#ifdef I_STDARG
void
croak(const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-croak(pat, va_alist)
- char *pat;
- va_dcl
-#endif
{
dTHR;
va_list args;
GV *gv;
CV *cv;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
message = mess(pat, &args);
va_end(args);
#ifdef USE_THREADS
SvREADONLY_on(msg);
SAVEFREESV(msg);
- PUSHMARK(sp);
+ PUSHSTACK(SI_DIEHOOK);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
-
+ POPSTACK();
LEAVE;
}
}
}
void
-#ifdef I_STDARG
warn(const char* pat,...)
-#else
-/*VARARGS0*/
-warn(pat,va_alist)
- const char *pat;
- va_dcl
-#endif
{
va_list args;
char *message;
GV *gv;
CV *cv;
-#ifdef I_STDARG
va_start(args, pat);
-#else
- va_start(args);
-#endif
message = mess(pat, &args);
va_end(args);
SvREADONLY_on(msg);
SAVEFREESV(msg);
- PUSHMARK(sp);
+ PUSHSTACK(SI_WARNHOOK);
+ PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
-
+ POPSTACK();
LEAVE;
return;
}
}
PerlIO_puts(PerlIO_stderr(),message);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(*message == '!'
+ ? (xstat(message[1]=='!'
+ ? (message[2]=='!' ? 2 : 1)
+ : 0)
+ , 0)
+ : 0);
#endif
(void)PerlIO_flush(PerlIO_stderr());
}
vallen = strlen(val);
New(904, envstr, namlen + vallen + 3, char);
(void)sprintf(envstr,"%s=%s",nam,val);
- (void)putenv(envstr);
+ (void)PerlEnv_putenv(envstr);
if (oldstr)
Safefree(oldstr);
#ifdef _MSC_VER
{
I32 i;
- for (i = 0; unlink(f) >= 0; i++) ;
+ for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
return i ? 0 : -1;
}
#endif
}
#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
-#if defined(I_STDARG) || defined(I_VARARGS)
#ifndef HAS_VPRINTF
#ifdef USE_CHAR_VSPRINTF
}
#endif /* HAS_VPRINTF */
-#endif /* I_VARARGS || I_STDARGS */
#ifdef MYSWAP
#if BYTEORDER != 0x4321
short
-#ifndef CAN_PROTOTYPE
-my_swap(s)
-short s;
-#else
my_swap(short s)
-#endif
{
#if (BYTEORDER & 1) == 0
short result;
}
long
-#ifndef CAN_PROTOTYPE
-my_htonl(l)
-register long l;
-#else
my_htonl(long l)
-#endif
{
union {
long result;
}
long
-#ifndef CAN_PROTOTYPE
-my_ntohl(l)
-register long l;
-#else
my_ntohl(long l)
-#endif
{
union {
long l;
return my_syspopen(cmd,mode);
}
#endif
- if (pipe(p) < 0)
- return Nullfp;
This = (*mode == 'w');
that = !This;
if (doexec && tainting) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
+ if (PerlProc_pipe(p) < 0)
+ return Nullfp;
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
- close(p[This]);
+ PerlLIO_close(p[This]);
if (!doexec)
croak("Can't fork");
return Nullfp;
if (pid == 0) {
GV* tmpgv;
+#undef THIS
+#undef THAT
#define THIS that
#define THAT This
- close(p[THAT]);
+ PerlLIO_close(p[THAT]);
if (p[THIS] != (*mode == 'r')) {
- dup2(p[THIS], *mode == 'r');
- close(p[THIS]);
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
}
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
#define NOFILE 20
#endif
for (fd = maxsysfd + 1; fd < NOFILE; fd++)
- close(fd);
+ PerlLIO_close(fd);
#endif
do_exec(cmd); /* may or may not use the shell */
- _exit(1);
+ PerlProc__exit(1);
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
#undef THAT
}
do_execfree(); /* free any memory malloced by child on vfork */
- close(p[that]);
+ PerlLIO_close(p[that]);
if (p[that] < p[This]) {
- dup2(p[This], p[that]);
- close(p[This]);
+ PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_close(p[This]);
p[This] = p[that];
}
sv = *av_fetch(fdpid,p[This],TRUE);
#endif /* !DOSISH */
#ifdef DUMP_FDS
-dump_fds(s)
-char *s;
+void
+dump_fds(char *s)
{
int fd;
struct stat tmpstatbuf;
PerlIO_printf(PerlIO_stderr(),"%s", s);
for (fd = 0; fd < 32; fd++) {
- if (Fstat(fd,&tmpstatbuf) >= 0)
+ if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
PerlIO_printf(PerlIO_stderr()," %d",fd);
}
PerlIO_printf(PerlIO_stderr(),"\n");
}
-#endif
+#endif /* DUMP_FDS */
#ifndef HAS_DUP2
int
#if defined(HAS_FCNTL) && defined(F_DUPFD)
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
#define DUP2_MAX_FDS 256
if (oldfd == newfd)
return oldfd;
- close(newfd);
+ PerlLIO_close(newfd);
/* good enough for low fd's... */
- while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
if (fdx >= DUP2_MAX_FDS) {
- close(fd);
+ PerlLIO_close(fd);
fd = -1;
break;
}
fdtmp[fdx++] = fd;
}
while (fdx > 0)
- close(fdtmp[--fdx]);
+ PerlLIO_close(fdtmp[--fdx]);
return fd;
#endif
}
Sighandler_t
rsignal(int signo, Sighandler_t handler)
{
- return signal(signo, handler);
+ return PerlProc_signal(signo, handler);
}
static int sig_trapped;
Sighandler_t oldsig;
sig_trapped = 0;
- oldsig = signal(signo, sig_trap);
- signal(signo, oldsig);
+ oldsig = PerlProc_signal(signo, sig_trap);
+ PerlProc_signal(signo, oldsig);
if (sig_trapped)
- kill(getpid(), signo);
+ PerlProc_kill(getpid(), signo);
return oldsig;
}
int
rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
{
- *save = signal(signo, handler);
+ *save = PerlProc_signal(signo, handler);
return (*save == SIG_ERR) ? -1 : 0;
}
int
rsignal_restore(int signo, Sigsave_t *save)
{
- return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
+ return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
I32
-my_pclose(FILE *ptr)
+my_pclose(PerlIO *ptr)
{
Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
int pid;
+ int pid2;
bool close_failed;
int saved_errno;
#ifdef VMS
int saved_vaxc_errno;
#endif
+#ifdef WIN32
+ int saved_win32_errno;
+#endif
svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
pid = (int)SvIVX(*svp);
#ifdef VMS
saved_vaxc_errno = vaxc$errno;
#endif
+#ifdef WIN32
+ saved_win32_errno = GetLastError();
+#endif
}
#ifdef UTS
- if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
+ if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
rsignal_save(SIGHUP, SIG_IGN, &hstat);
rsignal_save(SIGINT, SIG_IGN, &istat);
rsignal_save(SIGQUIT, SIG_IGN, &qstat);
do {
- pid = wait4pid(pid, &status, 0);
- } while (pid == -1 && errno == EINTR);
+ pid2 = wait4pid(pid, &status, 0);
+ } while (pid2 == -1 && errno == EINTR);
rsignal_restore(SIGHUP, &hstat);
rsignal_restore(SIGINT, &istat);
rsignal_restore(SIGQUIT, &qstat);
SETERRNO(saved_errno, saved_vaxc_errno);
return -1;
}
- return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
+ return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
}
#endif /* !DOSISH */
-#if !defined(DOSISH) || defined(OS2)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
I32
wait4pid(int pid, int *statusp, int flags)
{
if (!HAS_WAITPID_RUNTIME)
goto hard_way;
# endif
- return waitpid(pid,statusp,flags);
+ return PerlProc_waitpid(pid,statusp,flags);
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
if (flags)
croak("Can't do waitpid with flags");
else {
- while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
+ while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
pidgone(result,*statusp);
if (result < 0)
*statusp = -1;
}
#endif
}
-#endif /* !DOSISH */
+#endif /* !DOSISH || OS2 || WIN32 */
void
/*SUPPRESS 590*/
sv_setpv(tmpsv, ".");
else
sv_setpvn(tmpsv, a, fa - a);
- if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
sv_setpv(tmpsv, ".");
else
sv_setpvn(tmpsv, b, fb - b);
- if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
register char *s = start;
register UV retval = 0;
bool overflowed = FALSE;
- char *tmp;
+ char *tmp = s;
while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) {
register UV n = retval << 4;
retval = n | ((tmp - hexdigit) & 15);
s++;
}
+ if (dowarn && !tmp) {
+ warn("Illegal hex digit ignored");
+ }
*retlen = s - start;
return retval;
}
+char*
+find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
+{
+ dTHR;
+ char *xfound = Nullch;
+ char *xfailed = Nullch;
+ char tmpbuf[512];
+ register char *s;
+ I32 len;
+ int retval;
+#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
+# define SEARCH_EXTS ".bat", ".cmd", NULL
+# define MAX_EXT_LEN 4
+#endif
+#ifdef OS2
+# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
+# define MAX_EXT_LEN 4
+#endif
+#ifdef VMS
+# define SEARCH_EXTS ".pl", ".com", NULL
+# define MAX_EXT_LEN 4
+#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;
+ int extidx = 0, i = 0;
+ char *curext = Nullch;
+#else
+# define MAX_EXT_LEN 0
+#endif
+
+ /*
+ * If dosearch is true and if scriptname does not contain path
+ * delimiters, search the PATH for scriptname.
+ *
+ * If SEARCH_EXTS is also defined, will look for each
+ * scriptname{SEARCH_EXTS} whenever scriptname is not found
+ * while searching the PATH.
+ *
+ * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
+ * proceeds as follows:
+ * If DOSISH or VMSISH:
+ * + look for ./scriptname{,.foo,.bar}
+ * + search the PATH for scriptname{,.foo,.bar}
+ *
+ * If !DOSISH:
+ * + look *only* in the PATH for scriptname{,.foo,.bar} (note
+ * this will not look in '.' if it's not in the PATH)
+ */
+ tmpbuf[0] = '\0';
+
+#ifdef VMS
+# ifdef ALWAYS_DEFTYPES
+ len = strlen(scriptname);
+ if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+# else
+ if (dosearch) {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+# endif
+ /* The first time through, just add SEARCH_EXTS to whatever we
+ * already have, so we can check for default file types. */
+ while (deftypes ||
+ (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
+ {
+ if (deftypes) {
+ deftypes = 0;
+ *tmpbuf = '\0';
+ }
+ if ((strlen(tmpbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ strcat(tmpbuf, scriptname);
+#else /* !VMS */
+
+#ifdef DOSISH
+ if (strEQ(scriptname, "-"))
+ dosearch = 0;
+ if (dosearch) { /* Look in '.' first. */
+ char *cur = scriptname;
+#ifdef SEARCH_EXTS
+ if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
+ while (ext[i])
+ if (strEQ(ext[i++],curext)) {
+ extidx = -1; /* already has an ext */
+ break;
+ }
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log,
+ "Looking for %s\n",cur));
+ if (PerlLIO_stat(cur,&statbuf) >= 0) {
+ dosearch = 0;
+ scriptname = cur;
+#ifdef SEARCH_EXTS
+ break;
+#endif
+ }
+#ifdef SEARCH_EXTS
+ if (cur == scriptname) {
+ len = strlen(scriptname);
+ if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
+ break;
+ cur = strcpy(tmpbuf, scriptname);
+ }
+ } while (extidx >= 0 && ext[extidx] /* try an extension? */
+ && strcpy(tmpbuf+len, ext[extidx++]));
+#endif
+ }
+#endif
+
+ if (dosearch && !strchr(scriptname, '/')
+#ifdef DOSISH
+ && !strchr(scriptname, '\\')
+#endif
+ && (s = PerlEnv_getenv("PATH"))) {
+ bool seen_dot = 0;
+
+ bufend = s + strlen(s);
+ while (s < bufend) {
+#if defined(atarist) || defined(DOSISH)
+ for (len = 0; *s
+# ifdef atarist
+ && *s != ','
+# endif
+ && *s != ';'; len++, s++) {
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = *s;
+ }
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = '\0';
+#else /* ! (atarist || DOSISH) */
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+ ':',
+ &len);
+#endif /* ! (atarist || DOSISH) */
+ if (s < bufend)
+ s++;
+ if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ if (len
+#if defined(atarist) || defined(DOSISH)
+ && tmpbuf[len - 1] != '/'
+ && tmpbuf[len - 1] != '\\'
+#endif
+ )
+ tmpbuf[len++] = '/';
+ if (len == 2 && tmpbuf[0] == '.')
+ seen_dot = 1;
+ (void)strcpy(tmpbuf + len, scriptname);
+#endif /* !VMS */
+
+#ifdef SEARCH_EXTS
+ len = strlen(tmpbuf);
+ if (extidx > 0) /* reset after previous loop */
+ extidx = 0;
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
+ retval = PerlLIO_stat(tmpbuf,&statbuf);
+#ifdef SEARCH_EXTS
+ } while ( retval < 0 /* not there */
+ && extidx>=0 && ext[extidx] /* try an extension? */
+ && strcpy(tmpbuf+len, ext[extidx++])
+ );
+#endif
+ if (retval < 0)
+ continue;
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf)
+#ifndef DOSISH
+ && cando(S_IXUSR,TRUE,&statbuf)
+#endif
+ )
+ {
+ xfound = tmpbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savepv(tmpbuf);
+ }
+#ifndef DOSISH
+ if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
+#endif
+ seen_dot = 1; /* Disable message. */
+ if (!xfound)
+ scriptname = NULL;
+/* croak("Can't %s %s%s%s",
+ (xfailed ? "execute" : "find"),
+ (xfailed ? xfailed : scriptname),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */
+ if (xfailed)
+ Safefree(xfailed);
+ scriptname = xfound;
+ }
+ return scriptname;
+}
+
+
#ifdef USE_THREADS
#ifdef FAKE_THREADS
/* Very simplistic scheduler for now */
perl_cond_signal(cp)
perl_cond *cp;
{
- perl_thread t;
+ perl_os_thread t;
perl_cond cond = *cp;
if (!cond)
perl_cond_broadcast(cp)
perl_cond *cp;
{
- perl_thread t;
+ perl_os_thread t;
perl_cond cond, cond_next;
for (cond = *cp; cond; cond = cond_next) {
#endif /* FAKE_THREADS */
#ifdef OLD_PTHREADS_API
-struct thread *
+struct perl_thread *
getTHR _((void))
{
pthread_addr_t t;
if (pthread_getspecific(thr_key, &t))
croak("panic: pthread_getspecific");
- return (struct thread *) t;
+ return (struct perl_thread *) t;
}
#endif /* OLD_PTHREADS_API */
COND_INIT(&cp->owner_cond);
COND_INIT(&cp->cond);
cp->owner = 0;
- MUTEX_LOCK(&sv_mutex);
+ LOCK_SV_MUTEX;
mg = mg_find(sv, 'm');
if (mg) {
/* someone else beat us to initialising it */
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
MUTEX_DESTROY(&cp->mutex);
COND_DESTROY(&cp->owner_cond);
COND_DESTROY(&cp->cond);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
- MUTEX_UNLOCK(&sv_mutex);
+ UNLOCK_SV_MUTEX;
DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
"%p: condpair_magic %p\n", thr, sv));)
}
* called. The use by ext/Thread/Thread.xs in core perl (where t is the
* thread calling new_struct_thread) clearly satisfies this constraint.
*/
-struct thread *
-new_struct_thread(struct thread *t)
+struct perl_thread *
+new_struct_thread(struct perl_thread *t)
{
- struct thread *thr;
+ struct perl_thread *thr;
SV *sv;
SV **svp;
I32 i;
sv = newSVpv("", 0);
- SvGROW(sv, sizeof(struct thread) + 1);
- SvCUR_set(sv, sizeof(struct thread));
+ SvGROW(sv, sizeof(struct perl_thread) + 1);
+ SvCUR_set(sv, sizeof(struct perl_thread));
thr = (Thread) SvPVX(sv);
/* debug */
- memset(thr, 0xab, sizeof(struct thread));
+ memset(thr, 0xab, sizeof(struct perl_thread));
markstack = 0;
scopestack = 0;
savestack = 0;
/* Initialise all per-thread SVs that the template thread used */
svp = AvARRAY(t->threadsv);
- for (i = 0; i <= AvFILL(t->threadsv); i++, svp++) {
+ for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
if (*svp && *svp != &sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
"new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
}
}
+ thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&threads_mutex);
nthreads++;
}
#endif
+#ifdef PERL_GLOBAL_STRUCT
+struct perl_vars *
+Perl_GetVars(void)
+{
+ return &Perl_Vars;
+}
+#endif
+
+char **
+get_op_names(void)
+{
+ return op_name;
+}
+char **
+get_op_descs(void)
+{
+ return op_desc;
+}
+
+char *
+get_no_modify(void)
+{
+ return (char*)no_modify;
+}
+
+U32 *
+get_opargs(void)
+{
+ return opargs;
+}
+
+
+SV **
+get_specialsv_list(void)
+{
+ return specialsv_list;
+}
https://perl5.git.perl.org / perl5.git / blobdiff