#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;
"%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;
+ }
+ PUSHSTACKi(PERLSI_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);
+ PUSHSTACKi(PERLSI_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);
+ PUSHSTACKi(PERLSI_WARNHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
-
+ 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
int status;
SV **svp;
int pid;
+ int pid2;
bool close_failed;
int saved_errno;
#ifdef VMS
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 (!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;
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) {
+ 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 ? savepv(scriptname) : Nullch);
+}
+
+
#ifdef USE_THREADS
#ifdef FAKE_THREADS
/* Very simplistic scheduler for now */
{
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