#include "EXTERN.h"
#include "perl.h"
-#include "perlmem.h"
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
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 = PerlMem_realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+ ptr = PerlMem_realloc(where,size);
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
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;
}
}
char *
-fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr)
+fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
{
register unsigned char *s;
register I32 tmp;
}
#ifdef POINTERRIGOR
do {
- if (pos >= stop_pos) return Nullch;
+ if (pos >= stop_pos) break;
if (big[pos-previous] != first)
continue;
for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
#else /* !POINTERRIGOR */
big -= previous;
do {
- if (pos >= stop_pos) return Nullch;
+ if (pos >= stop_pos) break;
if (big[pos] != first)
continue;
for (x=big+pos+1,s=little; s < littleend; /**/ ) {
/* 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;
thr, curstack, mainstack));
#endif /* USE_THREADS */
-#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;
+ }
- PUSHSTACK(SI_DIEHOOK);
+ PUSHSTACKi(PERLSI_DIEHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- POPSTACK();
+ 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);
- PUSHSTACK(SI_DIEHOOK);
+ PUSHSTACKi(PERLSI_DIEHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- POPSTACK();
+ 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);
- PUSHSTACK(SI_WARNHOOK);
+ PUSHSTACKi(PERLSI_WARNHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
- POPSTACK();
+ POPSTACK;
LEAVE;
return;
}
}
#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
if (pid == 0) {
GV* tmpgv;
+#undef THIS
+#undef THAT
#define THIS that
#define THAT This
PerlLIO_close(p[THAT]);
#endif /* !DOSISH */
#ifdef DUMP_FDS
-dump_fds(s)
-char *s;
+void
+dump_fds(char *s)
{
int fd;
struct stat tmpstatbuf;
}
PerlIO_printf(PerlIO_stderr(),"\n");
}
-#endif
+#endif /* DUMP_FDS */
#ifndef HAS_DUP2
int
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;
dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
+ char tmpbuf[512];
register char *s;
I32 len;
int retval;
* + 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
/* 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",tokenbuf,idx++)) )
+ (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
{
if (deftypes) {
deftypes = 0;
- *tokenbuf = '\0';
+ *tmpbuf = '\0';
}
- if ((strlen(tokenbuf) + strlen(scriptname)
- + MAX_EXT_LEN) >= sizeof tokenbuf)
+ if ((strlen(tmpbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
- strcat(tokenbuf, scriptname);
+ strcat(tmpbuf, scriptname);
#else /* !VMS */
#ifdef DOSISH
#ifdef SEARCH_EXTS
if (cur == scriptname) {
len = strlen(scriptname);
- if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
+ if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
break;
- cur = strcpy(tokenbuf, scriptname);
+ cur = strcpy(tmpbuf, scriptname);
}
} while (extidx >= 0 && ext[extidx] /* try an extension? */
- && strcpy(tokenbuf+len, ext[extidx++]));
+ && strcpy(tmpbuf+len, ext[extidx++]));
#endif
}
#endif
&& *s != ','
# endif
&& *s != ';'; len++, s++) {
- if (len < sizeof tokenbuf)
- tokenbuf[len] = *s;
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = *s;
}
- if (len < sizeof tokenbuf)
- tokenbuf[len] = '\0';
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
- s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+ 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 tokenbuf)
+ 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)
- && tokenbuf[len - 1] != '/'
- && tokenbuf[len - 1] != '\\'
+ && tmpbuf[len - 1] != '/'
+ && tmpbuf[len - 1] != '\\'
#endif
)
- tokenbuf[len++] = '/';
- if (len == 2 && tokenbuf[0] == '.')
+ tmpbuf[len++] = '/';
+ if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
- (void)strcpy(tokenbuf + len, scriptname);
+ (void)strcpy(tmpbuf + len, scriptname);
#endif /* !VMS */
#ifdef SEARCH_EXTS
- len = strlen(tokenbuf);
+ 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",tokenbuf));
- retval = PerlLIO_stat(tokenbuf,&statbuf);
+ 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(tokenbuf+len, ext[extidx++])
+ && strcpy(tmpbuf+len, ext[extidx++])
);
#endif
if (retval < 0)
#endif
)
{
- xfound = tokenbuf; /* bingo! */
+ xfound = tmpbuf; /* bingo! */
break;
}
if (!xfailed)
- xfailed = savepv(tokenbuf);
+ 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 (!xfound) {
+ if (flags & 1) { /* do or die? */
+ croak("Can't %s %s%s%s",
+ (xfailed ? "execute" : "find"),
+ (xfailed ? xfailed : scriptname),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH");
+ }
+ scriptname = Nullch;
+ }
if (xfailed)
Safefree(xfailed);
scriptname = xfound;
}
- return scriptname;
+ return (scriptname ? savepv(scriptname) : Nullch);
}
{
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;
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff