X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=2fa77408a988ec5973bd68cf0ec2a4d14a7b9ac0;hb=6224f72bf639f0ca7f774fe2738f2408b3e430ac;hp=f8adc8f5d0c62665629c5f02a7bcb3afe7d972f3;hpb=837485b6cd4b757519a4ac6f03f3857c2fcf4844;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index f8adc8f..2fa7740 100644 --- a/util.c +++ b/util.c @@ -122,13 +122,18 @@ saferealloc(Malloc_t where,MEM_SIZE size) 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( { @@ -891,7 +896,7 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) #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; @@ -1193,23 +1198,11 @@ mess_alloc(void) 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*)); @@ -1249,16 +1242,8 @@ mess(const char *pat, va_list *args) 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; @@ -1273,20 +1258,9 @@ die(pat, va_alist) "%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 @@ -1307,15 +1281,21 @@ die(pat, va_alist) 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; } } @@ -1331,16 +1311,8 @@ die(pat, va_alist) 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; @@ -1349,11 +1321,7 @@ croak(pat, va_alist) 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 @@ -1376,11 +1344,12 @@ croak(pat, va_alist) SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHMARK(sp); + PUSHSTACK(SI_DIEHOOK); + PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - + POPSTACK(); LEAVE; } } @@ -1394,14 +1363,7 @@ croak(pat, va_alist) } 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; @@ -1409,11 +1371,7 @@ warn(pat,va_alist) GV *gv; CV *cv; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif message = mess(pat, &args); va_end(args); @@ -1435,11 +1393,12 @@ warn(pat,va_alist) 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; } @@ -1671,7 +1630,6 @@ register I32 len; } #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ -#if defined(I_STDARG) || defined(I_VARARGS) #ifndef HAS_VPRINTF #ifdef USE_CHAR_VSPRINTF @@ -1702,17 +1660,11 @@ char *args; } #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; @@ -1725,12 +1677,7 @@ my_swap(short s) } long -#ifndef CAN_PROTOTYPE -my_htonl(l) -register long l; -#else my_htonl(long l) -#endif { union { long result; @@ -1759,12 +1706,7 @@ my_htonl(long l) } long -#ifndef CAN_PROTOTYPE -my_ntohl(l) -register long l; -#else my_ntohl(long l) -#endif { union { long l; @@ -1870,14 +1812,14 @@ my_popen(char *cmd, char *mode) return my_syspopen(cmd,mode); } #endif - if (PerlProc_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) { PerlLIO_close(p[This]); @@ -1890,6 +1832,8 @@ my_popen(char *cmd, char *mode) if (pid == 0) { GV* tmpgv; +#undef THIS +#undef THAT #define THIS that #define THAT This PerlLIO_close(p[THAT]); @@ -1949,8 +1893,8 @@ char *mode; #endif /* !DOSISH */ #ifdef DUMP_FDS -dump_fds(s) -char *s; +void +dump_fds(char *s) { int fd; struct stat tmpstatbuf; @@ -1962,7 +1906,7 @@ char *s; } PerlIO_printf(PerlIO_stderr(),"\n"); } -#endif +#endif /* DUMP_FDS */ #ifndef HAS_DUP2 int @@ -2105,6 +2049,7 @@ my_pclose(PerlIO *ptr) int status; SV **svp; int pid; + int pid2; bool close_failed; int saved_errno; #ifdef VMS @@ -2139,8 +2084,8 @@ my_pclose(PerlIO *ptr) 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); @@ -2148,7 +2093,7 @@ my_pclose(PerlIO *ptr) 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 */ @@ -2189,7 +2134,7 @@ 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 *)); @@ -2367,13 +2312,13 @@ char *b; 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; @@ -2408,7 +2353,7 @@ scan_hex(char *start, I32 len, I32 *retlen) 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; @@ -2419,10 +2364,218 @@ scan_hex(char *start, I32 len, I32 *retlen) 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; + 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) + */ + +#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,":[= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + strcat(tokenbuf, 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(tokenbuf)) + break; + cur = strcpy(tokenbuf, scriptname); + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+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 tokenbuf) + tokenbuf[len] = *s; + } + if (len < sizeof tokenbuf) + tokenbuf[len] = '\0'; +#else /* ! (atarist || DOSISH) */ + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ + if (s < bufend) + s++; + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + if (len +#if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' + && tokenbuf[len - 1] != '\\' +#endif + ) + tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; + (void)strcpy(tokenbuf + len, scriptname); +#endif /* !VMS */ + +#ifdef SEARCH_EXTS + len = strlen(tokenbuf); + 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); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+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 = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tokenbuf); + } +#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 */ @@ -2688,3 +2841,22 @@ 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; +}