X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2d7a92375815264badaef23c612657cbd4799f31..6b88bc9c1f6d4b32c70e7ef68f8c65266e431623:/util.c diff --git a/util.c b/util.c index 53ee31c..b91601d 100644 --- a/util.c +++ b/util.c @@ -53,12 +53,14 @@ #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 @@ -84,15 +86,15 @@ safemalloc(MEM_SIZE size) 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)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size)); #else - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size)); #endif if (ptr != Nullch) return ptr; - else if (nomemok) + else if (PL_nomemok) return Nullch; else { PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; @@ -109,7 +111,7 @@ saferealloc(Malloc_t where,MEM_SIZE size) { 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 @@ -119,29 +121,34 @@ 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 = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ + ptr = PerlMem_realloc(where,size); #if !(defined(I286) || defined(atarist)) DEBUG_m( { - PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); - PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size); } ) #else DEBUG_m( { - PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); - PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size); } ) #endif if (ptr != Nullch) return ptr; - else if (nomemok) + else if (PL_nomemok) return Nullch; else { PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; @@ -157,13 +164,13 @@ Free_t safefree(Malloc_t where) { #if !(defined(I286) || defined(atarist)) - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++)); #else - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++)); #endif if (where) { /*SUPPRESS 701*/ - free(where); + PerlMem_free(where); } } @@ -186,17 +193,17 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) 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)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size)); #else - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size)); #endif if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; } - else if (nomemok) + else if (PL_nomemok) return Nullch; else { PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; @@ -210,63 +217,141 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) #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"); } } @@ -420,22 +505,22 @@ perl_new_collate(char *newcoll) #ifdef USE_LOCALE_COLLATE if (! newcoll) { - if (collation_name) { - ++collation_ix; - Safefree(collation_name); - collation_name = NULL; - collation_standard = TRUE; - collxfrm_base = 0; - collxfrm_mult = 2; + if (PL_collation_name) { + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = NULL; + PL_collation_standard = TRUE; + PL_collxfrm_base = 0; + PL_collxfrm_mult = 2; } return; } - if (! collation_name || strNE(collation_name, newcoll)) { - ++collation_ix; - Safefree(collation_name); - collation_name = savepv(newcoll); - collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); + if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = savepv(newcoll); + PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); { /* 2: at most so many chars ('a', 'b'). */ @@ -447,8 +532,8 @@ perl_new_collate(char *newcoll) SSize_t mult = fb - fa; if (mult < 1) croak("strxfrm() gets absurd"); - collxfrm_base = (fa > mult) ? (fa - mult) : 0; - collxfrm_mult = mult; + PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; + PL_collxfrm_mult = mult; } } @@ -464,20 +549,20 @@ perl_new_numeric(char *newnum) #ifdef USE_LOCALE_NUMERIC if (! newnum) { - if (numeric_name) { - Safefree(numeric_name); - numeric_name = NULL; - numeric_standard = TRUE; - numeric_local = TRUE; + if (PL_numeric_name) { + Safefree(PL_numeric_name); + PL_numeric_name = NULL; + PL_numeric_standard = TRUE; + PL_numeric_local = TRUE; } return; } - if (! numeric_name || strNE(numeric_name, newnum)) { - Safefree(numeric_name); - numeric_name = savepv(newnum); - numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); - numeric_local = TRUE; + if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { + Safefree(PL_numeric_name); + PL_numeric_name = savepv(newnum); + PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); + PL_numeric_local = TRUE; } #endif /* USE_LOCALE_NUMERIC */ @@ -488,10 +573,10 @@ perl_set_numeric_standard(void) { #ifdef USE_LOCALE_NUMERIC - if (! numeric_standard) { + if (! PL_numeric_standard) { setlocale(LC_NUMERIC, "C"); - numeric_standard = TRUE; - numeric_local = FALSE; + PL_numeric_standard = TRUE; + PL_numeric_local = FALSE; } #endif /* USE_LOCALE_NUMERIC */ @@ -502,10 +587,10 @@ perl_set_numeric_local(void) { #ifdef USE_LOCALE_NUMERIC - if (! numeric_local) { - setlocale(LC_NUMERIC, numeric_name); - numeric_standard = FALSE; - numeric_local = TRUE; + if (! PL_numeric_local) { + setlocale(LC_NUMERIC, PL_numeric_name); + PL_numeric_standard = FALSE; + PL_numeric_local = TRUE; } #endif /* USE_LOCALE_NUMERIC */ @@ -536,8 +621,8 @@ perl_init_i18nl10n(int printwarn) #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 @@ -561,19 +646,19 @@ perl_init_i18nl10n(int printwarn) { #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 */ @@ -620,7 +705,7 @@ perl_init_i18nl10n(int printwarn) 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 @@ -763,29 +848,29 @@ char * 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(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; + New(171, xbuf, xAlloc, char); if (! xbuf) goto bad; - *(U32*)xbuf = collation_ix; - xout = sizeof(collation_ix); + *(U32*)xbuf = PL_collation_ix; + xout = sizeof(PL_collation_ix); for (xin = 0; xin < len; ) { 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; } @@ -798,7 +883,7 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) } xbuf[xout] = '\0'; - *xlen = xout - sizeof(collation_ix); + *xlen = xout - sizeof(PL_collation_ix); return xbuf; bad: @@ -810,7 +895,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; @@ -853,7 +938,7 @@ fbm_compile(SV *sv) } 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; @@ -869,7 +954,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) if (!len) { if (SvTAIL(littlestr)) { /* Can be only 0-len constant substr => we can ignore SvVALID */ - if (multiline) { + if (PL_multiline) { char *t = "\n"; if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend, t, t + len))) { @@ -887,7 +972,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) } littlelen = SvCUR(littlestr); - if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ + if (SvTAIL(littlestr) && !PL_multiline) { /* tail anchored? */ if (littlelen > bigend - big) return Nullch; little = (unsigned char*)SvPVX(littlestr); @@ -977,6 +1062,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) char * screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { + dTHR; register unsigned char *s, *x; register unsigned char *big; register I32 pos; @@ -988,8 +1074,8 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ I32 found = 0; if (*old_posp == -1 - ? (pos = screamfirst[BmRARE(littlestr)]) < 0 - : (((pos = *old_posp), pos += screamnext[pos]) == 0)) + ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 + : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) return Nullch; little = (unsigned char *)(SvPVX(littlestr)); littleend = little + SvCUR(littlestr); @@ -1001,12 +1087,12 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) return Nullch; while (pos < previous + start_shift) { - if (!(pos += screamnext[pos])) + if (!(pos += PL_screamnext[pos])) return Nullch; } #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; /**/ ) { @@ -1020,12 +1106,12 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ if (!last) return (char *)(big+pos-previous); found = 1; } - } while ( pos += screamnext[pos] ); + } while ( pos += PL_screamnext[pos] ); return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; #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; /**/ ) { @@ -1039,7 +1125,7 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ if (!last) return (char *)(big+pos); found = 1; } - } while ( pos += screamnext[pos] ); + } while ( pos += PL_screamnext[pos] ); return (last && found) ? (char *)(big+(*old_posp)) : Nullch; #endif /* POINTERRIGOR */ } @@ -1097,7 +1183,7 @@ savepvn(char *sv, register I32 len) /* the SV for form() and mess() is not kept in an arena */ -static SV * +STATIC SV * mess_alloc(void) { SV *sv; @@ -1112,28 +1198,16 @@ 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*)); + if (!PL_mess_sv) + PL_mess_sv = mess_alloc(); + sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); - return SvPVX(mess_sv); + return SvPVX(PL_mess_sv); } char * @@ -1142,25 +1216,25 @@ mess(const char *pat, va_list *args) SV *sv; static char dgd[] = " during global destruction.\n"; - if (!mess_sv) - mess_sv = mess_alloc(); - sv = mess_sv; + if (!PL_mess_sv) + PL_mess_sv = mess_alloc(); + sv = PL_mess_sv; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; - if (dirty) + if (PL_dirty) sv_catpv(sv, dgd); else { - if (curcop->cop_line) + if (PL_curcop->cop_line) sv_catpvf(sv, " at %_ line %ld", - GvSV(curcop->cop_filegv), (long)curcop->cop_line); - if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { - bool line_mode = (RsSIMPLE(rs) && - SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); + GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line); + if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { + bool line_mode = (RsSIMPLE(PL_rs) && + SvLEN(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); sv_catpvf(sv, ", <%s> %s %ld", - last_in_gv == argvgv ? "" : GvNAME(last_in_gv), + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", - (long)IoLINES(GvIOp(last_in_gv))); + (long)IoLINES(GvIOp(PL_last_in_gv))); } sv_catpv(sv, ".\n"); } @@ -1168,21 +1242,13 @@ 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; char *message; - int was_in_eval = in_eval; + int was_in_eval = PL_in_eval; HV *stash; GV *gv; CV *cv; @@ -1190,35 +1256,24 @@ die(pat, va_alist) #ifdef USE_THREADS DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: die: curstack = %p, mainstack = %p\n", - thr, curstack, mainstack)); + thr, PL_curstack, PL_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 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: die: message = %s\ndiehook = %p\n", - thr, message, diehook)); + thr, message, PL_diehook)); #endif /* USE_THREADS */ - if (diehook) { + if (PL_diehook) { /* sv_2cv might call croak() */ - SV *olddiehook = diehook; + SV *olddiehook = PL_diehook; ENTER; - SAVESPTR(diehook); - diehook = Nullsv; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; cv = sv_2cv(olddiehook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { @@ -1226,40 +1281,38 @@ 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); + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; } } - restartop = die_where(message); + PL_restartop = die_where(message); #ifdef USE_THREADS DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", - thr, restartop, was_in_eval, top_env)); + thr, PL_restartop, was_in_eval, PL_top_env)); #endif /* USE_THREADS */ - if ((!restartop && was_in_eval) || top_env->je_prev) + if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); - return restartop; + return PL_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; @@ -1268,22 +1321,18 @@ 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 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); #endif /* USE_THREADS */ - if (diehook) { + if (PL_diehook) { /* sv_2cv might call croak() */ - SV *olddiehook = diehook; + SV *olddiehook = PL_diehook; ENTER; - SAVESPTR(diehook); - diehook = Nullsv; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; cv = sv_2cv(olddiehook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { @@ -1295,16 +1344,17 @@ croak(pat, va_alist) SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHMARK(sp); + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; } } - if (in_eval) { - restartop = die_where(message); + if (PL_in_eval) { + PL_restartop = die_where(message); JMPENV_JUMP(3); } PerlIO_puts(PerlIO_stderr(),message); @@ -1313,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; @@ -1328,21 +1371,17 @@ 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); - if (warnhook) { + if (PL_warnhook) { /* sv_2cv might call warn() */ dTHR; - SV *oldwarnhook = warnhook; + SV *oldwarnhook = PL_warnhook; ENTER; - SAVESPTR(warnhook); - warnhook = Nullsv; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; cv = sv_2cv(oldwarnhook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { @@ -1354,18 +1393,24 @@ warn(pat,va_alist) SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHMARK(sp); + PUSHSTACKi(PERLSI_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()); } @@ -1377,7 +1422,7 @@ my_setenv(char *nam, char *val) { register I32 i=setenv_getix(nam); /* where does it go? */ - if (environ == origenviron) { /* need we copy environment? */ + if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; I32 max; char **tmpenv; @@ -1455,7 +1500,7 @@ my_setenv(char *nam,char *val) 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 @@ -1512,7 +1557,7 @@ char *f; { I32 i; - for (i = 0; unlink(f) >= 0; i++) ; + for (i = 0; PerlLIO_unlink(f) >= 0; i++) ; return i ? 0 : -1; } #endif @@ -1585,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 @@ -1616,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; @@ -1639,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; @@ -1673,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; @@ -1784,17 +1812,17 @@ my_popen(char *cmd, char *mode) return my_syspopen(cmd,mode); } #endif - if (pipe(p) < 0) - return Nullfp; This = (*mode == 'w'); that = !This; - if (doexec && tainting) { + if (doexec && PL_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; @@ -1804,12 +1832,14 @@ my_popen(char *cmd, char *mode) 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) @@ -1818,32 +1848,32 @@ my_popen(char *cmd, char *mode) #ifndef NOFILE #define NOFILE 20 #endif - for (fd = maxsysfd + 1; fd < NOFILE; fd++) - close(fd); + for (fd = PL_maxsysfd + 1; fd < NOFILE; 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)) sv_setiv(GvSV(tmpgv), (IV)getpid()); - forkprocess = 0; - hv_clear(pidstatus); /* we have no children */ + PL_forkprocess = 0; + hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; #undef THIS #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); + sv = *av_fetch(PL_fdpid,p[This],TRUE); (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; - forkprocess = pid; + PL_forkprocess = pid; return PerlIO_fdopen(p[This], mode); } #else @@ -1863,20 +1893,20 @@ char *mode; #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 @@ -1887,7 +1917,7 @@ int newfd; #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 @@ -1897,18 +1927,18 @@ int newfd; 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 } @@ -1928,6 +1958,10 @@ rsignal(int signo, Sighandler_t handler) #ifdef SA_RESTART act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#ifdef SA_NOCLDWAIT + if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + act.sa_flags |= SA_NOCLDWAIT; +#endif if (sigaction(signo, &act, &oact) == -1) return SIG_ERR; else @@ -1956,6 +1990,10 @@ rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save) #ifdef SA_RESTART act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#ifdef SA_NOCLDWAIT + if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + act.sa_flags |= SA_NOCLDWAIT; +#endif return sigaction(signo, &act, save); } @@ -1970,7 +2008,7 @@ rsignal_restore(int signo, Sigsave_t *save) Sighandler_t rsignal(int signo, Sighandler_t handler) { - return signal(signo, handler); + return PerlProc_signal(signo, handler); } static int sig_trapped; @@ -1988,24 +2026,24 @@ rsignal_state(int signo) 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 */ @@ -2013,22 +2051,26 @@ rsignal_restore(int signo, Sigsave_t *save) /* 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); + svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); - *svp = &sv_undef; + *svp = &PL_sv_undef; #ifdef OS2 if (pid == -1) { /* Opened by popen. */ return my_syspclose(ptr); @@ -2039,16 +2081,19 @@ my_pclose(FILE *ptr) #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); @@ -2056,7 +2101,7 @@ my_pclose(FILE *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 */ @@ -2072,23 +2117,23 @@ wait4pid(int pid, int *statusp, int flags) return -1; if (pid > 0) { sprintf(spid, "%d", pid); - svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); - if (svp && *svp != &sv_undef) { + svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); + if (svp && *svp != &PL_sv_undef) { *statusp = SvIVX(*svp); - (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); + (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } else { HE *entry; - hv_iterinit(pidstatus); - if (entry = hv_iternext(pidstatus)) { + hv_iterinit(PL_pidstatus); + if (entry = hv_iternext(PL_pidstatus)) { pid = atoi(hv_iterkey(entry,(I32*)statusp)); - sv = hv_iterval(pidstatus,entry); + sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); sprintf(spid, "%d", pid); - (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); + (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } @@ -2097,7 +2142,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 *)); @@ -2109,7 +2154,7 @@ wait4pid(int pid, int *statusp, int flags) 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; @@ -2128,7 +2173,7 @@ pidgone(int pid, int status) char spid[TYPE_CHARS(int)]; sprintf(spid, "%d", pid); - sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); + sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = status; return; @@ -2275,13 +2320,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; @@ -2304,7 +2349,7 @@ scan_oct(char *start, I32 len, I32 *retlen) retval = n | (*s++ - '0'); len--; } - if (dowarn && len && (*s == '8' || *s == '9')) + if (PL_dowarn && len && (*s == '8' || *s == '9')) warn("Illegal octal digit ignored"); *retlen = s - start; return retval; @@ -2316,21 +2361,234 @@ 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))) { + while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) { register UV n = retval << 4; if (!overflowed && (n >> 4) != retval) { warn("Integer overflow in hex number"); overflowed = TRUE; } - retval = n | ((tmp - hexdigit) & 15); + retval = n | ((tmp - PL_hexdigit) & 15); s++; } + if (PL_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,":[= 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,&PL_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; + + PL_bufend = s + strlen(s); + while (s < PL_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, PL_bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ + if (s < PL_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,&PL_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(PL_statbuf.st_mode) + && cando(S_IRUSR,TRUE,&PL_statbuf) +#ifndef DOSISH + && cando(S_IXUSR,TRUE,&PL_statbuf) +#endif + ) + { + xfound = tmpbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tmpbuf); + } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_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 */ @@ -2416,7 +2674,7 @@ getTHR _((void)) { pthread_addr_t t; - if (pthread_getspecific(thr_key, &t)) + if (pthread_getspecific(PL_thr_key, &t)) croak("panic: pthread_getspecific"); return (struct perl_thread *) t; } @@ -2437,11 +2695,11 @@ condpair_magic(SV *sv) 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); @@ -2452,7 +2710,7 @@ condpair_magic(SV *sv) 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));) } @@ -2481,18 +2739,18 @@ new_struct_thread(struct perl_thread *t) thr = (Thread) SvPVX(sv); /* debug */ memset(thr, 0xab, sizeof(struct perl_thread)); - markstack = 0; - scopestack = 0; - savestack = 0; - retstack = 0; - dirty = 0; - localizing = 0; + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; + PL_dirty = 0; + PL_localizing = 0; /* end debug */ thr->oursv = sv; init_stacks(ARGS); - curcop = &compiling; + PL_curcop = &PL_compiling; thr->cvcache = newHV(); thr->threadsv = newAV(); thr->specific = newAV(); @@ -2501,9 +2759,9 @@ new_struct_thread(struct perl_thread *t) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - curcop = t->Tcurcop; /* XXX As good a guess as any? */ - defstash = t->Tdefstash; /* XXX maybe these should */ - curstash = t->Tcurstash; /* always be set to main? */ + PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ + PL_defstash = t->Tdefstash; /* XXX maybe these should */ + PL_curstash = t->Tcurstash; /* always be set to main? */ /* top_env needs to be non-zero. It points to an area @@ -2514,47 +2772,60 @@ new_struct_thread(struct perl_thread *t) See comments in scope.h Initialize top entry (as in perl.c for main thread) */ - start_env.je_prev = NULL; - start_env.je_ret = -1; - start_env.je_mustcatch = TRUE; - top_env = &start_env; - - in_eval = FALSE; - restartop = 0; - - tainted = t->Ttainted; - curpm = t->Tcurpm; /* XXX No PMOP ref count */ - nrs = newSVsv(t->Tnrs); - rs = newSVsv(t->Trs); - last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv); - ofslen = t->Tofslen; - ofs = savepvn(t->Tofs, ofslen); - defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); - chopset = t->Tchopset; - formtarget = newSVsv(t->Tformtarget); - bodytarget = newSVsv(t->Tbodytarget); - toptarget = newSVsv(t->Ttoptarget); + PL_start_env.je_prev = NULL; + PL_start_env.je_ret = -1; + PL_start_env.je_mustcatch = TRUE; + PL_top_env = &PL_start_env; + + PL_in_eval = FALSE; + PL_restartop = 0; + + PL_tainted = t->Ttainted; + PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ + PL_nrs = newSVsv(t->Tnrs); + PL_rs = SvREFCNT_inc(PL_nrs); + PL_last_in_gv = Nullgv; + PL_ofslen = t->Tofslen; + PL_ofs = savepvn(t->Tofs, PL_ofslen); + PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); + PL_chopset = t->Tchopset; + PL_formtarget = newSVsv(t->Tformtarget); + PL_bodytarget = newSVsv(t->Tbodytarget); + PL_toptarget = newSVsv(t->Ttoptarget); + + PL_statname = NEWSV(66,0); + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_lastscream = Nullsv; + PL_screamfirst = 0; + PL_screamnext = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); - for (i = 0; i <= AvFILL(t->threadsv); i++, svp++) { - if (*svp && *svp != &sv_undef) { + for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { + if (*svp && *svp != &PL_sv_undef) { SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, 0, &threadsv_names[i], 1); + sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); DEBUG_L(PerlIO_printf(PerlIO_stderr(), "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); } } + thr->threadsvp = AvARRAY(thr->threadsv); - MUTEX_LOCK(&threads_mutex); - nthreads++; - thr->tid = ++threadnum; + MUTEX_LOCK(&PL_threads_mutex); + PL_nthreads++; + thr->tid = ++PL_threadnum; thr->next = t->next; thr->prev = t; t->next = thr; thr->next->prev = thr; - MUTEX_UNLOCK(&threads_mutex); + MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); @@ -2580,7 +2851,7 @@ Perl_huge(void) struct perl_vars * Perl_GetVars(void) { - return &Perl_Vars; + return &PL_Vars; } #endif @@ -2595,3 +2866,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 PL_specialsv_list; +}