X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=24af6622f8dcd3ee94d6eaefaf27c6345b2b67d0;hb=bf49b057b09bec860588a9b554c3a77683394722;hp=86e148d7209b9ad0441dd5fb04b5c5871fca1109;hpb=3fe6f2dcb97acb1a1bb0a27dc5753fbc0548c545;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 86e148d..24af662 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -13,6 +13,7 @@ */ #include "EXTERN.h" +#define PERL_IN_UTIL_C #include "perl.h" #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) @@ -50,19 +51,26 @@ # include #endif +#ifdef I_LOCALE +# include +#endif + #define FLUSH #ifdef LEAKTEST -static void xstat _((void)); -#endif -#ifdef USE_THREADS -static U32 threadnum = 0; -#endif /* USE_THREADS */ +long xcount[MAXXCOUNT]; +long lastxcount[MAXXCOUNT]; +long xycount[MAXXCOUNT][MAXYCOUNT]; +long lastxycount[MAXXCOUNT][MAXYCOUNT]; -#ifndef MYMALLOC +#endif + +#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) +# define FD_CLOEXEC 1 /* NeXT needs this */ +#endif -/* paranoid version of malloc */ +/* paranoid version of system's malloc() */ /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of @@ -71,203 +79,268 @@ static U32 threadnum = 0; */ Malloc_t -safemalloc(MEM_SIZE size) +Perl_safesysmalloc(MEM_SIZE size) { + dTHX; Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; - my_exit(1); + PerlIO_printf(Perl_error_log, + "Allocation too large: %lx\n", size) FLUSH; + my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0) - croak("panic: malloc"); -#endif - ptr = 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 - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + Perl_croak_nocontext("panic: malloc"); #endif + ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size)); if (ptr != Nullch) return ptr; - else if (nomemok) + else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; my_exit(1); return Nullch; } /*NOTREACHED*/ } -/* paranoid version of realloc */ +/* paranoid version of system's realloc() */ Malloc_t -saferealloc(Malloc_t where,MEM_SIZE size) +Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { + dTHX; 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 if (size > 0xffff) { - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ + if (!size) { + safesysfree(where); + return NULL; + } + if (!where) - croak("Null realloc"); + return safesysmalloc(size); #ifdef DEBUGGING if ((long)size < 0) - croak("panic: realloc"); + Perl_croak_nocontext("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); - } ) -#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); - } ) -#endif + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size)); if (ptr != Nullch) return ptr; - else if (nomemok) + else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; my_exit(1); return Nullch; } /*NOTREACHED*/ } -/* safe version of free */ +/* safe version of system's free() */ Free_t -safefree(Malloc_t where) +Perl_safesysfree(Malloc_t where) { -#if !(defined(I286) || defined(atarist)) - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,an++)); -#else - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,an++)); -#endif + dTHX; + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++)); if (where) { /*SUPPRESS 701*/ - free(where); + PerlMem_free(where); } } -/* safe version of calloc */ +/* safe version of system's calloc() */ Malloc_t -safecalloc(MEM_SIZE count, MEM_SIZE size) +Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { + dTHX; Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size * count > 0xffff) { - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0 || (long)count < 0) - croak("panic: calloc"); + Perl_croak_nocontext("panic: calloc"); #endif size *= count; - ptr = 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 - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); -#endif + ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size)); 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; + PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; my_exit(1); return Nullch; } /*NOTREACHED*/ } -#endif /* !MYMALLOC */ - #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) +Perl_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) +Perl_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) +Perl_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) +Perl_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) +STATIC void +S_xstat(pTHX_ 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(Perl_debug_log, " 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(Perl_debug_log,"%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(Perl_debug_log,"%3ld ", + flag == 2 + ? xycount[i][j] - lastxycount[i][j] + : xycount[i][j]); + lastxycount[i][j] = xycount[i][j]; + } else { + PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); + } + } + PerlIO_printf(Perl_debug_log, "\n"); } } + if (flag != 2) { + PerlIO_printf(Perl_debug_log, "Total %7ld ", total); + for (j = 0; j < MAXYCOUNT; j++) { + if (subtot[j]) { + PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); + } else { + PerlIO_printf(Perl_debug_log, " . "); + } + } + PerlIO_printf(Perl_debug_log, "\n"); + } } #endif /* LEAKTEST */ @@ -275,7 +348,7 @@ xstat(void) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -delimcpy(register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) { register I32 tolen; for (tolen = 0; from < fromend; from++, tolen++) { @@ -304,16 +377,16 @@ delimcpy(register char *to, register char *toend, register char *from, register /* This routine was donated by Corey Satten. */ char * -instr(register char *big, register char *little) +Perl_instr(pTHX_ register const char *big, register const char *little) { - register char *s, *x; + register const char *s, *x; register I32 first; if (!little) - return big; + return (char*)big; first = *little++; if (!first) - return big; + return (char*)big; while (*big) { if (*big++ != first) continue; @@ -326,7 +399,7 @@ instr(register char *big, register char *little) } } if (!*s) - return big-1; + return (char*)(big-1); } return Nullch; } @@ -334,14 +407,14 @@ instr(register char *big, register char *little) /* same as instr but allow embedded nulls */ char * -ninstr(register char *big, register char *bigend, char *little, char *lend) +Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) { - register char *s, *x; + register const char *s, *x; register I32 first = *little; - register char *littleend = lend; + register const char *littleend = lend; if (!first && little >= littleend) - return big; + return (char*)big; if (bigend - big < littleend - little) return Nullch; bigend -= littleend - little++; @@ -355,7 +428,7 @@ ninstr(register char *big, register char *bigend, char *little, char *lend) } } if (s >= littleend) - return big-1; + return (char*)(big-1); } return Nullch; } @@ -363,15 +436,15 @@ ninstr(register char *big, register char *bigend, char *little, char *lend) /* reverse of the above--find last substring */ char * -rninstr(register char *big, char *bigend, char *little, char *lend) +Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) { - register char *bigbeg; - register char *s, *x; + register const char *bigbeg; + register const char *s, *x; register I32 first = *little; - register char *littleend = lend; + register const char *littleend = lend; if (!first && little >= littleend) - return bigend; + return (char*)bigend; bigbeg = big; big = bigend - (littleend - little++); while (big >= bigbeg) { @@ -384,7 +457,7 @@ rninstr(register char *big, char *bigend, char *little, char *lend) } } if (s >= littleend) - return big+1; + return (char*)(big+1); } return Nullch; } @@ -393,7 +466,7 @@ rninstr(register char *big, char *bigend, char *little, char *lend) * Set up for a new ctype locale. */ void -perl_new_ctype(char *newctype) +Perl_new_ctype(pTHX_ const char *newctype) { #ifdef USE_LOCALE_CTYPE @@ -401,11 +474,11 @@ perl_new_ctype(char *newctype) for (i = 0; i < 256; i++) { if (isUPPER_LC(i)) - fold_locale[i] = toLOWER_LC(i); + PL_fold_locale[i] = toLOWER_LC(i); else if (isLOWER_LC(i)) - fold_locale[i] = toUPPER_LC(i); + PL_fold_locale[i] = toUPPER_LC(i); else - fold_locale[i] = i; + PL_fold_locale[i] = i; } #endif /* USE_LOCALE_CTYPE */ @@ -415,27 +488,27 @@ perl_new_ctype(char *newctype) * Set up for a new collation locale. */ void -perl_new_collate(char *newcoll) +Perl_new_collate(pTHX_ const 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'). */ @@ -446,77 +519,99 @@ perl_new_collate(char *newcoll) Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); SSize_t mult = fb - fa; if (mult < 1) - croak("strxfrm() gets absurd"); - collxfrm_base = (fa > mult) ? (fa - mult) : 0; - collxfrm_mult = mult; + Perl_croak(aTHX_ "strxfrm() gets absurd"); + PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; + PL_collxfrm_mult = mult; } } #endif /* USE_LOCALE_COLLATE */ } +void +Perl_set_numeric_radix(pTHX) +{ +#ifdef USE_LOCALE_NUMERIC +# ifdef HAS_LOCALECONV + struct lconv* lc; + + lc = localeconv(); + if (lc && lc->decimal_point) + /* We assume that decimal separator aka the radix + * character is always a single character. If it + * ever is a string, this needs to be rethunk. */ + PL_numeric_radix = *lc->decimal_point; + else + PL_numeric_radix = 0; +# endif /* HAS_LOCALECONV */ +#else + PL_numeric_radix = 0; +#endif /* USE_LOCALE_NUMERIC */ +} + /* * Set up for a new numeric locale. */ void -perl_new_numeric(char *newnum) +Perl_new_numeric(pTHX_ const 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; + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } void -perl_set_numeric_standard(void) +Perl_set_numeric_standard(pTHX) { #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 */ } void -perl_set_numeric_local(void) +Perl_set_numeric_local(pTHX) { #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; + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } - /* * Initialize locale awareness. */ int -perl_init_i18nl10n(int printwarn) +Perl_init_i18nl10n(pTHX_ int printwarn) { int ok = 1; /* returns @@ -536,8 +631,11 @@ 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"); +#ifdef __GLIBC__ + char *language = PerlEnv_getenv("LANGUAGE"); +#endif + char *lc_all = PerlEnv_getenv("LC_ALL"); + char *lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; #ifdef LOCALE_ENVIRON_REQUIRED @@ -556,102 +654,98 @@ perl_init_i18nl10n(int printwarn) else setlocale_failure = TRUE; } - if (!setlocale_failure) -#endif /* LC_ALL */ - { + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, - (!done && (lang || getenv("LC_CTYPE"))) + if (! (curctype = + setlocale(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"))) + if (! (curcoll = + setlocale(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"))) + if (! (curnum = + setlocale(LC_NUMERIC, + (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ } -#else /* !LOCALE_ENVIRON_REQUIRED */ +#endif /* LC_ALL */ -#ifdef LC_ALL +#endif /* !LOCALE_ENVIRON_REQUIRED */ +#ifdef LC_ALL if (! setlocale(LC_ALL, "")) setlocale_failure = TRUE; - else { -#ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); -#endif /* USE_LOCALE_NUMERIC */ - } - -#else /* !LC_ALL */ +#endif /* LC_ALL */ + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, ""))) - setlocale_failure = TRUE; + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, ""))) - setlocale_failure = TRUE; + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, ""))) - setlocale_failure = TRUE; + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ + } if (setlocale_failure) { 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 - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed.\n"); #else /* !LC_ALL */ - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed for the categories:\n\t"); #ifdef USE_LOCALE_CTYPE if (! curctype) - PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); + PerlIO_printf(Perl_error_log, "LC_CTYPE "); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! curcoll) - PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); + PerlIO_printf(Perl_error_log, "LC_COLLATE "); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! curnum) - PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); + PerlIO_printf(Perl_error_log, "LC_NUMERIC "); #endif /* USE_LOCALE_NUMERIC */ - PerlIO_printf(PerlIO_stderr(), "\n"); + PerlIO_printf(Perl_error_log, "\n"); #endif /* LC_ALL */ - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Please check that your locale settings:\n"); - PerlIO_printf(PerlIO_stderr(), +#ifdef __GLIBC__ + PerlIO_printf(Perl_error_log, + "\tLANGUAGE = %c%s%c,\n", + language ? '"' : '(', + language ? language : "unset", + language ? '"' : ')'); +#endif + + PerlIO_printf(Perl_error_log, "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', lc_all ? lc_all : "unset", @@ -663,18 +757,18 @@ perl_init_i18nl10n(int printwarn) if (strnEQ(*e, "LC_", 3) && strnNE(*e, "LC_ALL=", 7) && (p = strchr(*e, '='))) - PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", + PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n", (int)(p - *e), *e, p + 1); } } - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", lang ? '"' : '(', lang ? lang : "unset", lang ? '"' : ')'); - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, " are supported and installed on your system.\n"); } @@ -682,13 +776,13 @@ perl_init_i18nl10n(int printwarn) if (setlocale(LC_ALL, "C")) { if (locwarn) - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Falling back to the standard locale (\"C\").\n"); ok = 0; } else { if (locwarn) - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); ok = -1; } @@ -708,7 +802,7 @@ perl_init_i18nl10n(int printwarn) ) { if (locwarn) - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); ok = -1; } @@ -727,15 +821,15 @@ perl_init_i18nl10n(int printwarn) } #ifdef USE_LOCALE_CTYPE - perl_new_ctype(curctype); + new_ctype(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - perl_new_collate(curcoll); + new_collate(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - perl_new_numeric(curnum); + new_numeric(curnum); #endif /* USE_LOCALE_NUMERIC */ #endif /* USE_LOCALE */ @@ -745,9 +839,9 @@ perl_init_i18nl10n(int printwarn) /* Backwards compatibility. */ int -perl_init_i18nl14n(int printwarn) +Perl_init_i18nl14n(pTHX_ int printwarn) { - return perl_init_i18nl10n(printwarn); + return init_i18nl10n(printwarn); } #ifdef USE_LOCALE_COLLATE @@ -760,32 +854,32 @@ perl_init_i18nl14n(int printwarn) * Please see sv_collxfrm() to see how this is used. */ char * -mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) +Perl_mem_collxfrm(pTHX_ 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 +892,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: @@ -809,159 +903,262 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) #endif /* USE_LOCALE_COLLATE */ +#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ + +/* As a space optimization, we do not compile tables for strings of length + 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are + special-cased in fbm_instr(). + + If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ + void -fbm_compile(SV *sv) +Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - register unsigned char *s; - register unsigned char *table; + register U8 *s; + register U8 *table; register U32 i; - register U32 len = SvCUR(sv); + STRLEN len; I32 rarest = 0; U32 frequency = 256; - 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 */ + if (flags & FBMcf_TAIL) + sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ + s = (U8*)SvPV_force(sv, len); + (void)SvUPGRADE(sv, SVt_PVBM); + if (len == 0) /* TAIL might be on on a zero-length string. */ + return; 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; - } + U8 mlen; + unsigned char *sb; + + if (len > 255) + mlen = 255; + else + mlen = (U8)len; + Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); + table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); + s = table - 1 - FBM_TABLE_OFFSET; /* last char */ + memset((void*)table, mlen, 256); + table[-1] = (U8)flags; i = 0; - while (s >= (unsigned char*)(SvPVX(sv))) - { - if (table[*s] == len) - table[*s] = i; - s--,i++; - } + sb = s - mlen + 1; /* first char (maybe) */ + while (s >= sb) { + if (table[*s] == mlen) + table[*s] = (U8)i; + s--, i++; + } } sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ for (i = 0; i < len; i++) { - if (freq[s[i]] < frequency) { + if (PL_freq[s[i]] < frequency) { rarest = i; - frequency = freq[s[i]]; + frequency = PL_freq[s[i]]; } } BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); + BmUSEFUL(sv) = 100; /* Initial value */ + if (flags & FBMcf_TAIL) + SvTAIL_on(sv); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", + BmRARE(sv),BmPREVIOUS(sv))); } +/* If SvTAIL(littlestr), it has a fake '\n' at end. */ +/* If SvTAIL is actually due to \Z or \z, this gives false positives + if multiline */ + char * -fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) +Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) { register unsigned char *s; - register I32 tmp; - register I32 littlelen; - register unsigned char *little; - register unsigned char *table; - register unsigned char *olds; - register unsigned char *oldlittle; + STRLEN l; + register unsigned char *little = (unsigned char *)SvPV(littlestr,l); + register STRLEN littlelen = l; + register I32 multiline = flags & FBMrf_MULTILINE; + + if (bigend - big < littlelen) { + check_tail: + if ( SvTAIL(littlestr) + && (bigend - big == littlelen - 1) + && (littlelen == 1 + || *big == *little && memEQ(big, little, littlelen - 1))) + return (char*)big; + return Nullch; + } - if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { - STRLEN len; - char *l = SvPV(littlestr,len); - if (!len) { - 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 (littlelen <= 2) { /* Special-cased */ + register char c; + + if (littlelen == 1) { + if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ + /* Know that bigend != big. */ + if (bigend[-1] == '\n') + return (char *)(bigend - 1); + return (char *) bigend; + } + s = big; + while (s < bigend) { + if (*s == *little) + return (char *)s; + s++; + } + if (SvTAIL(littlestr)) + return (char *) bigend; + return Nullch; + } + if (!littlelen) + return (char*)big; /* Cannot be SvTAIL! */ + + /* littlelen is 2 */ + if (SvTAIL(littlestr) && !multiline) { + if (bigend[-1] == '\n' && bigend[-2] == *little) + return (char*)bigend - 2; + if (bigend[-1] == *little) + return (char*)bigend - 1; + return Nullch; + } + { + /* This should be better than FBM if c1 == c2, and almost + as good otherwise: maybe better since we do less indirection. + And we save a lot of memory by caching no table. */ + register unsigned char c1 = little[0]; + register unsigned char c2 = little[1]; + + s = big + 1; + bigend--; + if (c1 != c2) { + while (s <= bigend) { + if (s[0] == c2) { + if (s[-1] == c1) + return (char*)s - 1; + s += 2; + continue; } + next_chars: + if (s[0] == c1) { + if (s == bigend) + goto check_1char_anchor; + if (s[1] == c2) + return (char*)s; + else { + s++; + goto next_chars; + } + } + else + s += 2; + } + goto check_1char_anchor; + } + /* Now c1 == c2 */ + while (s <= bigend) { + if (s[0] == c1) { + if (s[-1] == c1) + return (char*)s - 1; + if (s == bigend) + goto check_1char_anchor; + if (s[1] == c1) + return (char*)s; + s += 3; } - if (bigend > big && bigend[-1] == '\n') - return (char *)(bigend - 1); else - return (char *) bigend; + s += 2; } - return (char*)big; } - return ninstr((char*)big,(char*)bigend, l, l + len); + check_1char_anchor: /* One char and anchor! */ + if (SvTAIL(littlestr) && (*bigend == *little)) + return (char *)bigend; /* bigend is already decremented. */ + return Nullch; } - - littlelen = SvCUR(littlestr); if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ - if (littlelen > bigend - big) - return Nullch; - little = (unsigned char*)SvPVX(littlestr); s = bigend - 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)) + if (s >= big && bigend[-1] == '\n' && *s == *little + /* Automatically of length > 2 */ + && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) + { return (char*)s; /* how sweet it is */ + } + if (s[1] == *little + && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) + { + return (char*)s + 1; /* how sweet it is */ + } 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 */ + if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { + char *b = ninstr((char*)big,(char*)bigend, + (char*)little, (char*)little + littlelen); + + if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ + /* Chop \n from littlestr: */ + s = bigend - littlelen + 1; + if (*s == *little + && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) { return (char*)s; } - s++; + return Nullch; } - return Nullch; + return b; } - table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); - if (--littlelen >= bigend - big) - return Nullch; - s = big + littlelen; - oldlittle = little = table - 2; - if (s < bigend) { - top2: - /*SUPPRESS 560*/ - if (tmp = table[*s]) { + + { /* Do actual FBM. */ + register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; + register unsigned char *oldlittle; + + if (littlelen > bigend - big) + return Nullch; + --littlelen; /* Last char found by table lookup */ + + s = big + littlelen; + little += littlelen; /* last char */ + oldlittle = little; + if (s < bigend) { + register I32 tmp; + + top2: + /*SUPPRESS 560*/ + if ((tmp = table[*s])) { #ifdef POINTERRIGOR - if (bigend - s > tmp) { + if (bigend - s > tmp) { + s += tmp; + goto top2; + } s += tmp; - goto top2; - } #else - if ((s += tmp) < bigend) - goto top2; -#endif - return Nullch; - } - else { - tmp = littlelen; /* less expensive than calling strncmp() */ - olds = s; - while (tmp--) { - if (*--s == *--little) - continue; - differ: - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ + if ((s += tmp) < bigend) goto top2; - return Nullch; +#endif + goto check_end; + } + else { /* less expensive than calling strncmp() */ + register unsigned char *olds = s; + + tmp = littlelen; + + while (tmp--) { + if (*--s == *--little) + continue; + differ: + s = olds + 1; /* here we pay the price for failure */ + little = oldlittle; + if (s < bigend) /* fake up continue to outer loop */ + goto top2; + goto check_end; + } + return (char *)s; } - if (SvTAIL(littlestr) /* automatically multiline */ - && olds + 1 != bigend - && olds[1] != '\n') - goto differ; - return (char *)s; } + check_end: + if ( s == bigend && (table[-1] & FBMcf_TAIL) + && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) ) + return (char*)bigend - littlelen; + return Nullch; } - return Nullch; } /* start_shift, end_shift are positive quantities which give offsets @@ -970,13 +1167,19 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) old_posp is the way of communication between consequent calls if the next call needs to find the . The initial *old_posp should be -1. - Note that we do not take into account SvTAIL, so it may give wrong - positives if _ALL flag is set. + + Note that we take into account SvTAIL, so one can get extra + optimizations if _ALL flag is set. */ +/* If SvTAIL is actually due to \Z or \z, this gives false positives + if PL_multiline. In fact if !PL_multiline the autoritative answer + is not supported yet. */ + char * -screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) +Perl_screaminstr(pTHX_ 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,9 +1191,19 @@ 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)) { + cant_find: + if ( BmRARE(littlestr) == '\n' + && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { + little = (unsigned char *)(SvPVX(littlestr)); + littleend = little + SvCUR(littlestr); + first = *little++; + goto check_tail; + } return Nullch; + } + little = (unsigned char *)(SvPVX(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; @@ -999,14 +1212,18 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ big = (unsigned char *)(SvPVX(bigstr)); /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); - if (previous + start_shift > stop_pos) return Nullch; + if (previous + start_shift > stop_pos) { + if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ + goto check_tail; + return Nullch; + } while (pos < previous + start_shift) { - if (!(pos += screamnext[pos])) - return Nullch; + if (!(pos += PL_screamnext[pos])) + goto cant_find; } #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 +1237,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,18 +1256,32 @@ 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] ); - return (last && found) ? (char *)(big+(*old_posp)) : Nullch; + } while ( pos += PL_screamnext[pos] ); + if (last && found) + return (char *)(big+(*old_posp)); #endif /* POINTERRIGOR */ + check_tail: + if (!SvTAIL(littlestr) || (end_shift > 0)) + return Nullch; + /* Ignore the trailing "\n". This code is not microoptimized */ + big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); + stop_pos = littleend - little; /* Actual littlestr len */ + if (stop_pos == 0) + return (char*)big; + big -= stop_pos; + if (*big == first + && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1))) + return (char*)big; + return Nullch; } I32 -ibcmp(char *s1, char *s2, register I32 len) +Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; while (len--) { - if (*a != *b && *a != fold[*b]) + if (*a != *b && *a != PL_fold[*b]) return 1; a++,b++; } @@ -1058,12 +1289,12 @@ ibcmp(char *s1, char *s2, register I32 len) } I32 -ibcmp_locale(char *s1, char *s2, register I32 len) +Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; while (len--) { - if (*a != *b && *a != fold_locale[*b]) + if (*a != *b && *a != PL_fold_locale[*b]) return 1; a++,b++; } @@ -1073,7 +1304,7 @@ ibcmp_locale(char *s1, char *s2, register I32 len) /* copy a string to a safe spot */ char * -savepv(char *sv) +Perl_savepv(pTHX_ const char *sv) { register char *newaddr; @@ -1085,7 +1316,7 @@ savepv(char *sv) /* same thing but with a known length */ char * -savepvn(char *sv, register I32 len) +Perl_savepvn(pTHX_ const char *sv, register I32 len) { register char *newaddr; @@ -1095,130 +1326,263 @@ savepvn(char *sv, register I32 len) return newaddr; } -/* the SV for form() and mess() is not kept in an arena */ +/* the SV for Perl_form() and mess() is not kept in an arena */ -static SV * -mess_alloc(void) +STATIC SV * +S_mess_alloc(pTHX) { + dTHR; SV *sv; XPVMG *any; + if (!PL_dirty) + return sv_2mortal(newSVpvn("",0)); + + if (PL_mess_sv) + return PL_mess_sv; + /* Create as PVMG now, to avoid any upgrading later */ New(905, sv, 1, SV); Newz(905, any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; SvREFCNT(sv) = 1 << 30; /* practically infinite */ + PL_mess_sv = sv; return sv; } -#ifdef I_STDARG +#if defined(PERL_IMPLICIT_CONTEXT) char * -form(const char* pat, ...) -#else -/*VARARGS0*/ +Perl_form_nocontext(const char* pat, ...) +{ + dTHX; + char *retval; + va_list args; + va_start(args, pat); + retval = vform(pat, &args); + va_end(args); + return retval; +} +#endif /* PERL_IMPLICIT_CONTEXT */ + char * -form(pat, va_alist) - const char *pat; - va_dcl -#endif +Perl_form(pTHX_ const char* pat, ...) { + char *retval; 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*)); + retval = vform(pat, &args); va_end(args); - return SvPVX(mess_sv); + return retval; } char * -mess(const char *pat, va_list *args) +Perl_vform(pTHX_ const char *pat, va_list *args) { - SV *sv; + SV *sv = mess_alloc(); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return SvPVX(sv); +} + +#if defined(PERL_IMPLICIT_CONTEXT) +SV * +Perl_mess_nocontext(const char *pat, ...) +{ + dTHX; + SV *retval; + va_list args; + va_start(args, pat); + retval = vmess(pat, &args); + va_end(args); + return retval; +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +SV * +Perl_mess(pTHX_ const char *pat, ...) +{ + SV *retval; + va_list args; + va_start(args, pat); + retval = vmess(pat, &args); + va_end(args); + return retval; +} + +SV * +Perl_vmess(pTHX_ const char *pat, va_list *args) +{ + SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; - if (!mess_sv) - mess_sv = mess_alloc(); - sv = mess_sv; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; - if (dirty) - sv_catpv(sv, dgd); - else { - if (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'); - sv_catpvf(sv, ", <%s> %s %ld", - last_in_gv == argvgv ? "" : GvNAME(last_in_gv), - line_mode ? "line" : "chunk", - (long)IoLINES(GvIOp(last_in_gv))); - } - sv_catpv(sv, ".\n"); +#ifdef IV_IS_QUAD + if (PL_curcop->cop_line) + Perl_sv_catpvf(aTHX_ sv, " at %_ line %" PERL_PRId64, + GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line); +#else + if (PL_curcop->cop_line) + Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld", + GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line); +#endif + if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { + bool line_mode = (RsSIMPLE(PL_rs) && + SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); +#ifdef IV_IS_QUAD + Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %" PERL_PRId64, + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + line_mode ? "line" : "chunk", + (IV)IoLINES(GvIOp(PL_last_in_gv))); +#else + Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld", + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + line_mode ? "line" : "chunk", + (long)IoLINES(GvIOp(PL_last_in_gv))); +#endif } +#ifdef USE_THREADS + if (thr->tid) + Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); +#endif + sv_catpv(sv, PL_dirty ? dgd : ".\n"); } - return SvPVX(sv); + return sv; } -#ifdef I_STDARG OP * -die(const char* pat, ...) -#else -/*VARARGS0*/ -OP * -die(pat, va_alist) - const char *pat; - va_dcl -#endif +Perl_vdie(pTHX_ const char* pat, va_list *args) { 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; + SV *msv; + STRLEN msglen; -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%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); + thr, PL_curstack, PL_mainstack)); + + if (pat) { + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); } + else { + message = Nullch; + } + + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: message = %s\ndiehook = %p\n", + thr, message, PL_diehook)); + if (PL_diehook) { + /* sv_2cv might call Perl_croak() */ + SV *olddiehook = PL_diehook; + ENTER; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; -#ifdef I_STDARG + ENTER; + if (message) { + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } + + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + /* HACK - REVISIT - avoid CATCH_SET(TRUE) in call_sv() + or we come back here due to a JMPENV_JMP() and do + a POPSTACK - but die_where() will have already done + one as it unwound - NI-S 1999/08/14 */ + call_sv((SV*)cv, G_DISCARD|G_NOCATCH); + POPSTACK; + LEAVE; + } + } + + PL_restartop = die_where(message, msglen); + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", + thr, PL_restartop, was_in_eval, PL_top_env)); + if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) + JMPENV_JUMP(3); + return PL_restartop; +} + +#if defined(PERL_IMPLICIT_CONTEXT) +OP * +Perl_die_nocontext(const char* pat, ...) +{ + dTHX; + OP *o; + va_list args; va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); + o = vdie(pat, &args); va_end(args); + return o; +} +#endif /* PERL_IMPLICIT_CONTEXT */ -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), - "%p: die: message = %s\ndiehook = %p\n", - thr, message, diehook)); -#endif /* USE_THREADS */ - if (diehook) { - /* sv_2cv might call croak() */ - SV *olddiehook = diehook; +OP * +Perl_die(pTHX_ const char* pat, ...) +{ + OP *o; + va_list args; + va_start(args, pat); + o = vdie(pat, &args); + va_end(args); + return o; +} + +void +Perl_vcroak(pTHX_ const char* pat, va_list *args) +{ + dTHR; + char *message; + HV *stash; + GV *gv; + CV *cv; + SV *msv; + STRLEN msglen; + + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); + + DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%lx %s", + (unsigned long) thr, message)); + + if (PL_diehook) { + /* sv_2cv might call Perl_croak() */ + 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,172 +1590,281 @@ die(pat, va_alist) SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHMARK(sp); + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - + call_sv((SV*)cv, G_DISCARD); + POPSTACK; LEAVE; } } - - 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)); -#endif /* USE_THREADS */ - if ((!restartop && was_in_eval) || top_env->je_prev) + if (PL_in_eval) { + PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); - return restartop; + } + { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO *serr = Perl_error_log; + + PerlIO_write(serr, message, msglen); + (void)PerlIO_flush(serr); +#ifdef USE_SFIO + errno = e; +#endif + } + my_failure_exit(); } -#ifdef I_STDARG +#if defined(PERL_IMPLICIT_CONTEXT) void -croak(const char* pat, ...) -#else -/*VARARGS0*/ +Perl_croak_nocontext(const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + vcroak(pat, &args); + /* NOTREACHED */ + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ + void -croak(pat, va_alist) - char *pat; - va_dcl -#endif +Perl_croak(pTHX_ const char *pat, ...) { - dTHR; va_list args; + va_start(args, pat); + vcroak(pat, &args); + /* NOTREACHED */ + va_end(args); +} + +void +Perl_vwarn(pTHX_ const char* pat, va_list *args) +{ char *message; HV *stash; GV *gv; CV *cv; + SV *msv; + STRLEN msglen; -#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) { - /* sv_2cv might call croak() */ - SV *olddiehook = diehook; + msv = vmess(pat, args); + message = SvPV(msv, msglen); + + if (PL_warnhook) { + /* sv_2cv might call Perl_warn() */ + dTHR; + SV *oldwarnhook = PL_warnhook; ENTER; - SAVESPTR(diehook); - diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHMARK(sp); + PUSHSTACKi(PERLSI_WARNHOOK); + PUSHMARK(SP); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - + call_sv((SV*)cv, G_DISCARD); + POPSTACK; LEAVE; + return; } } - if (in_eval) { - restartop = die_where(message); - JMPENV_JUMP(3); + { + PerlIO *serr = Perl_error_log; + + PerlIO_write(serr, message, msglen); +#ifdef LEAKTEST + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); +#endif + (void)PerlIO_flush(serr); } - PerlIO_puts(PerlIO_stderr(),message); - (void)PerlIO_flush(PerlIO_stderr()); - my_failure_exit(); } +#if defined(PERL_IMPLICIT_CONTEXT) void -#ifdef I_STDARG -warn(const char* pat,...) -#else -/*VARARGS0*/ -warn(pat,va_alist) - const char *pat; - va_dcl -#endif +Perl_warn_nocontext(const char *pat, ...) { + dTHX; va_list args; - char *message; - HV *stash; - GV *gv; - CV *cv; + va_start(args, pat); + vwarn(pat, &args); + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ -#ifdef I_STDARG +void +Perl_warn(pTHX_ const char *pat, ...) +{ + va_list args; va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); + vwarn(pat, &args); va_end(args); +} - if (warnhook) { - /* sv_2cv might call warn() */ - dTHR; - SV *oldwarnhook = warnhook; - ENTER; - SAVESPTR(warnhook); - warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; +#if defined(PERL_IMPLICIT_CONTEXT) +void +Perl_warner_nocontext(U32 err, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ - ENTER; - msg = newSVpv(message, 0); - SvREADONLY_on(msg); - SAVEFREESV(msg); +void +Perl_warner(pTHX_ U32 err, const char* pat,...) +{ + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); +} - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); +void +Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) +{ + dTHR; + char *message; + HV *stash; + GV *gv; + CV *cv; + SV *msv; + STRLEN msglen; - LEAVE; - return; + msv = vmess(pat, args); + message = SvPV(msv, msglen); + + if (ckDEAD(err)) { +#ifdef USE_THREADS + DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%lx %s", (unsigned long) thr, message)); +#endif /* USE_THREADS */ + if (PL_diehook) { + /* sv_2cv might call Perl_croak() */ + SV *olddiehook = PL_diehook; + ENTER; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); + + LEAVE; + } + } + if (PL_in_eval) { + PL_restartop = die_where(message, msglen); + JMPENV_JUMP(3); + } + { + PerlIO *serr = Perl_error_log; + PerlIO_write(serr, message, msglen); + (void)PerlIO_flush(serr); } + my_failure_exit(); + } - PerlIO_puts(PerlIO_stderr(),message); + else { + if (PL_warnhook) { + /* sv_2cv might call Perl_warn() */ + dTHR; + SV *oldwarnhook = PL_warnhook; + ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); + + LEAVE; + return; + } + } + { + PerlIO *serr = Perl_error_log; + PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(xstat()); #endif - (void)PerlIO_flush(PerlIO_stderr()); + (void)PerlIO_flush(serr); + } + } } #ifndef VMS /* VMS' my_setenv() is in VMS.c */ -#ifndef WIN32 +#if !defined(WIN32) && !defined(CYGWIN) void -my_setenv(char *nam, char *val) +Perl_my_setenv(pTHX_ char *nam, char *val) { +#ifndef PERL_USE_SAFE_PUTENV + /* most putenv()s leak, so we manipulate environ directly */ 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; /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; - New(901,tmpenv, max+2, char*); - for (j=0; j= 0; i++) ; + for (i = 0; PerlLIO_unlink(f) >= 0; i++) ; return i ? 0 : -1; } #endif #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char * -my_bcopy(register char *from,register char *to,register I32 len) +Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len) { char *retval = to; @@ -1539,10 +2041,7 @@ my_bcopy(register char *from,register char *to,register I32 len) #ifndef HAS_MEMSET void * -my_memset(loc,ch,len) -register char *loc; -register I32 ch; -register I32 len; +Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) { char *retval = loc; @@ -1554,9 +2053,7 @@ register I32 len; #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * -my_bzero(loc,len) -register char *loc; -register I32 len; +Perl_my_bzero(pTHX_ register char *loc, register I32 len) { char *retval = loc; @@ -1568,10 +2065,7 @@ register I32 len; #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 -my_memcmp(s1,s2,len) -char *s1; -char *s2; -register I32 len; +Perl_my_memcmp(pTHX_ const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; @@ -1585,7 +2079,6 @@ register I32 len; } #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ -#if defined(I_STDARG) || defined(I_VARARGS) #ifndef HAS_VPRINTF #ifdef USE_CHAR_VSPRINTF @@ -1593,10 +2086,7 @@ char * #else int #endif -vsprintf(dest, pat, args) -char *dest; -const char *pat; -char *args; +vsprintf(char *dest, const char *pat, char *args) { FILE fakebuf; @@ -1616,17 +2106,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 +Perl_my_swap(pTHX_ short s) { #if (BYTEORDER & 1) == 0 short result; @@ -1639,12 +2123,7 @@ my_swap(short s) } long -#ifndef CAN_PROTOTYPE -my_htonl(l) -register long l; -#else -my_htonl(long l) -#endif +Perl_my_htonl(pTHX_ long l) { union { long result; @@ -1659,7 +2138,7 @@ my_htonl(long l) return u.result; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) - croak("Unknown BYTEORDER\n"); + Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else register I32 o; register I32 s; @@ -1673,12 +2152,7 @@ my_htonl(long l) } long -#ifndef CAN_PROTOTYPE -my_ntohl(l) -register long l; -#else -my_ntohl(long l) -#endif +Perl_my_ntohl(pTHX_ long l) { union { long l; @@ -1693,7 +2167,7 @@ my_ntohl(long l) return u.l; #else #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) - croak("Unknown BYTEORDER\n"); + Perl_croak(aTHX_ "Unknown BYTEORDER\n"); #else register I32 o; register I32 s; @@ -1721,8 +2195,7 @@ my_ntohl(long l) #define HTOV(name,type) \ type \ - name (n) \ - register type n; \ + name (register type n) \ { \ union { \ type value; \ @@ -1738,8 +2211,7 @@ my_ntohl(long l) #define VTOH(name,type) \ type \ - name (n) \ - register type n; \ + name (register type n) \ { \ union { \ type value; \ @@ -1769,34 +2241,43 @@ VTOH(vtohl,long) #endif /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) PerlIO * -my_popen(char *cmd, char *mode) +Perl_my_popen(pTHX_ char *cmd, char *mode) { int p[2]; register I32 This, that; - register I32 pid; + register Pid_t pid; SV *sv; I32 doexec = strNE(cmd,"-"); + I32 did_pipes = 0; + int pp[2]; + PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { 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; + if (doexec && PerlProc_pipe(pp) >= 0) + did_pipes = 1; while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { - close(p[This]); + PerlLIO_close(p[This]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } if (!doexec) - croak("Can't fork"); + Perl_croak(aTHX_ "Can't fork"); return Nullfp; } sleep(5); @@ -1804,13 +2285,22 @@ 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 (did_pipes) { + PerlLIO_close(pp[0]); +#if defined(HAS_FCNTL) && defined(F_SETFD) + fcntl(pp[1], F_SETFD, FD_CLOEXEC); +#endif + } if (p[THIS] != (*mode == 'r')) { - dup2(p[THIS], *mode == 'r'); - close(p[THIS]); + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); } +#ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) int fd; @@ -1818,44 +2308,70 @@ 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++) + if (fd != pp[1]) + PerlLIO_close(fd); #endif - do_exec(cmd); /* may or may not use the shell */ - _exit(1); + do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ + PerlProc__exit(1); } +#endif /* defined OS2 */ /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); - forkprocess = 0; - hv_clear(pidstatus); /* we have no children */ + sv_setiv(GvSV(tmpgv), getpid()); + 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 (did_pipes) + PerlLIO_close(pp[1]); 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; + if (did_pipes && pid > 0) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + did_pipes = 0; + if (n) { /* Error */ + if (n != sizeof(int)) + Perl_croak(aTHX_ "panic: kid popen errno read"); + errno = errkid; /* Propagate errno from kid */ + return Nullfp; + } + } + if (did_pipes) + PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); } #else #if defined(atarist) || defined(DJGPP) FILE *popen(); PerlIO * -my_popen(cmd,mode) -char *cmd; -char *mode; +Perl_my_popen(pTHX_ char *cmd, char *mode) { /* Needs work for PerlIO ! */ /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + PERL_FLUSHALL_FOR_CHILD; return popen(PerlIO_exportFILE(cmd, 0), mode); } #endif @@ -1863,31 +2379,29 @@ char *mode; #endif /* !DOSISH */ #ifdef DUMP_FDS -dump_fds(s) -char *s; +void +Perl_dump_fds(pTHX_ char *s) { int fd; struct stat tmpstatbuf; - PerlIO_printf(PerlIO_stderr(),"%s", s); + PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { - if (Fstat(fd,&tmpstatbuf) >= 0) - PerlIO_printf(PerlIO_stderr()," %d",fd); + if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) + PerlIO_printf(Perl_debug_log," %d",fd); } - PerlIO_printf(PerlIO_stderr(),"\n"); + PerlIO_printf(Perl_debug_log,"\n"); } -#endif +#endif /* DUMP_FDS */ #ifndef HAS_DUP2 int -dup2(oldfd,newfd) -int oldfd; -int newfd; +dup2(int oldfd, 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 +2411,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 } @@ -1918,7 +2432,7 @@ int newfd; #ifdef HAS_SIGACTION Sighandler_t -rsignal(int signo, Sighandler_t handler) +Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { struct sigaction act, oact; @@ -1928,6 +2442,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 @@ -1935,7 +2453,7 @@ rsignal(int signo, Sighandler_t handler) } Sighandler_t -rsignal_state(int signo) +Perl_rsignal_state(pTHX_ int signo) { struct sigaction oact; @@ -1946,7 +2464,7 @@ rsignal_state(int signo) } int -rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save) +Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { struct sigaction act; @@ -1956,11 +2474,15 @@ 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); } int -rsignal_restore(int signo, Sigsave_t *save) +Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { return sigaction(signo, save, (struct sigaction *)NULL); } @@ -1968,9 +2490,9 @@ rsignal_restore(int signo, Sigsave_t *save) #else /* !HAS_SIGACTION */ Sighandler_t -rsignal(int signo, Sighandler_t handler) +Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { - return signal(signo, handler); + return PerlProc_signal(signo, handler); } static int sig_trapped; @@ -1983,52 +2505,56 @@ sig_trap(int signo) } Sighandler_t -rsignal_state(int signo) +Perl_rsignal_state(pTHX_ 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) +Perl_rsignal_save(pTHX_ 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) +Perl_rsignal_restore(pTHX_ 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) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) I32 -my_pclose(FILE *ptr) +Perl_my_pclose(pTHX_ PerlIO *ptr) { Sigsave_t hstat, istat, qstat; int status; SV **svp; - int pid; + Pid_t pid; + Pid_t 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); + svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); + pid = 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 +2565,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,13 +2585,13 @@ 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 */ -#if !defined(DOSISH) || defined(OS2) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) I32 -wait4pid(int pid, int *statusp, int flags) +Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; @@ -2072,23 +2601,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 +2626,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 *)); @@ -2107,9 +2636,9 @@ wait4pid(int pid, int *statusp, int flags) { I32 result; if (flags) - croak("Can't do waitpid with flags"); + Perl_croak(aTHX_ "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; @@ -2118,17 +2647,17 @@ wait4pid(int pid, int *statusp, int flags) } #endif } -#endif /* !DOSISH */ +#endif /* !DOSISH || OS2 || WIN32 */ void /*SUPPRESS 590*/ -pidgone(int pid, int status) +Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; 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; @@ -2139,31 +2668,33 @@ int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 in os2ish.h. */ -my_syspclose(ptr) +my_syspclose(PerlIO *ptr) #else I32 -my_pclose(ptr) +Perl_my_pclose(pTHX_ PerlIO *ptr) #endif -PerlIO *ptr; { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = pclose(f); +#if defined(DJGPP) + result = (result << 8) & 0xff00; +#endif PerlIO_releaseFILE(ptr,f); return result; } #endif void -repeatcpy(register char *to, register char *from, I32 len, register I32 count) +Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) { register I32 todo; - register char *frombase = from; + register const char *frombase = from; if (len == 1) { - todo = *from; + register const char c = *from; while (count-- > 0) - *to++ = todo; + *to++ = c; return; } while (count-- > 0) { @@ -2174,10 +2705,8 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) } } -#ifndef CASTNEGFLOAT U32 -cast_ulong(f) -double f; +Perl_cast_ulong(pTHX_ NV f) { long along; @@ -2192,9 +2721,6 @@ double f; return (unsigned long)along; } # undef BIGDOUBLE -#endif - -#ifndef CASTI32 /* Unfortunately, on some systems the cast_uv() function doesn't work with the system-supplied definition of ULONG_MAX. The @@ -2217,8 +2743,7 @@ double f; #endif I32 -cast_i32(f) -double f; +Perl_cast_i32(pTHX_ NV f) { if (f >= I32_MAX) return (I32) I32_MAX; @@ -2228,32 +2753,40 @@ double f; } IV -cast_iv(f) -double f; +Perl_cast_iv(pTHX_ NV f) { - if (f >= IV_MAX) - return (IV) IV_MAX; + if (f >= IV_MAX) { + UV uv; + + if (f >= (NV)UV_MAX) + return (IV) UV_MAX; + uv = (UV) f; + return (IV)uv; + } if (f <= IV_MIN) return (IV) IV_MIN; return (IV) f; } UV -cast_uv(f) -double f; +Perl_cast_uv(pTHX_ NV f) { if (f >= MY_UV_MAX) return (UV) MY_UV_MAX; + if (f < 0) { + IV iv; + + if (f < IV_MIN) + return (UV)IV_MIN; + iv = (IV) f; + return (UV) iv; + } return (UV) f; } -#endif - #ifndef HAS_RENAME I32 -same_dirent(a,b) -char *a; -char *b; +Perl_same_dirent(pTHX_ char *a, char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); @@ -2275,62 +2808,434 @@ 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; } #endif /* !HAS_RENAME */ -UV -scan_oct(char *start, I32 len, I32 *retlen) +NV +Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; - register UV retval = 0; - bool overflowed = FALSE; - - while (len && *s >= '0' && *s <= '7') { - register UV n = retval << 3; - if (!overflowed && (n >> 3) != retval) { - warn("Integer overflow in octal number"); - overflowed = TRUE; + register NV rnv = 0.0; + register UV ruv = 0; + register bool seenb = FALSE; + register bool overflowed = FALSE; + + for (; len-- && *s; s++) { + if (!(*s == '0' || *s == '1')) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + if (seenb == FALSE && *s == 'b' && ruv == 0) { + /* Disallow 0bbb0b0bbb... */ + seenb = TRUE; + continue; + } + else { + dTHR; + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal binary digit '%c' ignored", *s); + break; + } + } + if (!overflowed) { + register UV xuv = ruv << 1; + + if ((xuv >> 1) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in binary number"); + } else + ruv = xuv | (*s - '0'); } - retval = n | (*s++ - '0'); - len--; + if (overflowed) { + rnv *= 2; + /* If an NV has not enough bits in its mantissa to + * represent an UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply rnv by the + * right amount. */ + rnv += (*s - '0'); + } + } + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Binary number > 0b11111111111111111111111111111111 non-portable"); } - if (dowarn && len && (*s == '8' || *s == '9')) - warn("Illegal octal digit ignored"); *retlen = s - start; - return retval; + return rnv; } -UV -scan_hex(char *start, I32 len, I32 *retlen) +NV +Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; - register UV retval = 0; - bool overflowed = FALSE; - char *tmp; + register NV rnv = 0.0; + register UV ruv = 0; + register bool overflowed = FALSE; + + for (; len-- && *s; s++) { + if (!(*s >= '0' && *s <= '7')) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + else { + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (*s == '8' || *s == '9') { + dTHR; + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal octal digit '%c' ignored", *s); + } + break; + } + } + if (!overflowed) { + register UV xuv = ruv << 3; + + if ((xuv >> 3) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in octal number"); + } else + ruv = xuv | (*s - '0'); + } + if (overflowed) { + rnv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent an UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply rnv by the + * right amount of 8-tuples. */ + rnv += (NV)(*s - '0'); + } + } + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Octal number > 037777777777 non-portable"); + } + *retlen = s - start; + return rnv; +} - while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) { - register UV n = retval << 4; - if (!overflowed && (n >> 4) != retval) { - warn("Integer overflow in hex number"); - overflowed = TRUE; +NV +Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) +{ + register char *s = start; + register NV rnv = 0.0; + register UV ruv = 0; + register bool seenx = FALSE; + register bool overflowed = FALSE; + char *hexdigit; + + for (; len-- && *s; s++) { + hexdigit = strchr((char *) PL_hexdigit, *s); + if (!hexdigit) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + if (seenx == FALSE && *s == 'x' && ruv == 0) { + /* Disallow 0xxx0x0xxx... */ + seenx = TRUE; + continue; + } + else { + dTHR; + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal hexadecimal digit '%c' ignored", *s); + break; + } + } + if (!overflowed) { + register UV xuv = ruv << 4; + + if ((xuv >> 4) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in hexadecimal number"); + } else + ruv = xuv | ((hexdigit - PL_hexdigit) & 15); } - retval = n | ((tmp - hexdigit) & 15); - s++; + if (overflowed) { + rnv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent an UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply rnv by the + * right amount of 16-tuples. */ + rnv += (NV)((hexdigit - PL_hexdigit) & 15); + } + } + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Hexadecimal number > 0xffffffff non-portable"); } *retlen = s - start; - return retval; + return rnv; +} + +char* +Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) +{ + dTHR; + char *xfound = Nullch; + char *xfailed = Nullch; + char tmpbuf[MAXPATHLEN]; + 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 + && !S_ISDIR(PL_statbuf.st_mode)) { + 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(__MINT__) || 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); + if (S_ISDIR(PL_statbuf.st_mode)) { + retval = -1; + } +#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 + || S_ISDIR(PL_statbuf.st_mode))) +#endif + seen_dot = 1; /* Disable message. */ + if (!xfound) { + if (flags & 1) { /* do or die? */ + Perl_croak(aTHX_ "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 */ @@ -2341,15 +3246,13 @@ schedule(void) } void -perl_cond_init(cp) -perl_cond *cp; +Perl_cond_init(pTHX_ perl_cond *cp) { *cp = 0; } void -perl_cond_signal(cp) -perl_cond *cp; +Perl_cond_signal(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; @@ -2369,8 +3272,7 @@ perl_cond *cp; } void -perl_cond_broadcast(cp) -perl_cond *cp; +Perl_cond_broadcast(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond, cond_next; @@ -2391,13 +3293,12 @@ perl_cond *cp; } void -perl_cond_wait(cp) -perl_cond *cp; +Perl_cond_wait(pTHX_ perl_cond *cp) { perl_cond cond; if (thr->i.next_run == thr) - croak("panic: perl_cond_wait called by last runnable thread"); + Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); New(666, cond, 1, struct perl_wait_queue); cond->thread = thr; @@ -2410,20 +3311,20 @@ perl_cond *cp; } #endif /* FAKE_THREADS */ -#ifdef OLD_PTHREADS_API +#ifdef PTHREAD_GETSPECIFIC_INT struct perl_thread * -getTHR _((void)) +Perl_getTHR(pTHX) { pthread_addr_t t; - if (pthread_getspecific(thr_key, &t)) - croak("panic: pthread_getspecific"); + if (pthread_getspecific(PL_thr_key, &t)) + Perl_croak(aTHX_ "panic: pthread_getspecific"); return (struct perl_thread *) t; } -#endif /* OLD_PTHREADS_API */ +#endif MAGIC * -condpair_magic(SV *sv) +Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; @@ -2437,11 +3338,11 @@ condpair_magic(SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - MUTEX_LOCK(&sv_mutex); + MUTEX_LOCK(&PL_cred_mutex); /* XXX need separate mutex? */ mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - MUTEX_UNLOCK(&sv_mutex); + MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -2452,8 +3353,8 @@ condpair_magic(SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - MUTEX_UNLOCK(&sv_mutex); - DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } } @@ -2468,44 +3369,47 @@ condpair_magic(SV *sv) * thread calling new_struct_thread) clearly satisfies this constraint. */ struct perl_thread * -new_struct_thread(struct perl_thread *t) +Perl_new_struct_thread(pTHX_ struct perl_thread *t) { +#if !defined(PERL_IMPLICIT_CONTEXT) struct perl_thread *thr; +#endif SV *sv; SV **svp; I32 i; - sv = newSVpv("", 0); + sv = newSVpvn("", 0); SvGROW(sv, sizeof(struct perl_thread) + 1); SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); - /* debug */ +#ifdef DEBUGGING memset(thr, 0xab, sizeof(struct perl_thread)); - markstack = 0; - scopestack = 0; - savestack = 0; - retstack = 0; - dirty = 0; - localizing = 0; - /* end debug */ + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; + PL_dirty = 0; + PL_localizing = 0; + Zero(&PL_hv_fetch_ent_mh, 1, HE); +#else + Zero(thr, 1, struct perl_thread); +#endif + + PL_protect = MEMBER_TO_FPTR(Perl_default_protect); thr->oursv = sv; - init_stacks(ARGS); + init_stacks(); - curcop = &compiling; + PL_curcop = &PL_compiling; + thr->interp = t->interp; thr->cvcache = newHV(); thr->threadsv = newAV(); thr->specific = newAV(); - thr->errsv = newSVpv("", 0); + thr->errsv = newSVpvn("", 0); thr->errhv = newHV(); 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? */ - - /* top_env needs to be non-zero. It points to an area in which longjmp() stuff is stored, as C callstack info there at least is thread specific this has to @@ -2514,50 +3418,80 @@ 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 = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */ + PL_restartop = 0; + + PL_statname = NEWSV(66,0); + PL_errors = newSVpvn("", 0); + PL_maxscream = -1; + PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); + PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); + PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); + PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); + PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); + 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; + PL_reg_poscache = Nullch; + + /* parent thread's data needs to be locked while we make copy */ + MUTEX_LOCK(&t->mutex); + + PL_protect = t->Tprotect; + + 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? */ + + 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); + /* 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); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); + DEBUG_S(PerlIO_printf(Perl_debug_log, "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); + + /* done copying parent's state */ + MUTEX_UNLOCK(&t->mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ return thr; } @@ -2569,7 +3503,7 @@ new_struct_thread(struct perl_thread *t) * So it is in perl for (say) POSIX to use. * Needed for SunOS with Sun's 'acc' for example. */ -double +NV Perl_huge(void) { return HUGE_VAL; @@ -2578,20 +3512,217 @@ Perl_huge(void) #ifdef PERL_GLOBAL_STRUCT struct perl_vars * -Perl_GetVars(void) +Perl_GetVars(pTHX) { - return &Perl_Vars; + return &PL_Vars; } #endif char ** -get_op_names(void) +Perl_get_op_names(pTHX) { - return op_name; + return PL_op_name; } char ** -get_op_descs(void) +Perl_get_op_descs(pTHX) +{ + return PL_op_desc; +} + +char * +Perl_get_no_modify(pTHX) +{ + return (char*)PL_no_modify; +} + +U32 * +Perl_get_opargs(pTHX) +{ + return PL_opargs; +} + +PPADDR_t* +Perl_get_ppaddr(pTHX) +{ + return &PL_ppaddr; +} + +#ifndef HAS_GETENV_LEN +char * +Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len) +{ + char *env_trans = PerlEnv_getenv(env_elem); + if (env_trans) + *len = strlen(env_trans); + return env_trans; +} +#endif + + +MGVTBL* +Perl_get_vtbl(pTHX_ int vtbl_id) +{ + MGVTBL* result = Null(MGVTBL*); + + switch(vtbl_id) { + case want_vtbl_sv: + result = &PL_vtbl_sv; + break; + case want_vtbl_env: + result = &PL_vtbl_env; + break; + case want_vtbl_envelem: + result = &PL_vtbl_envelem; + break; + case want_vtbl_sig: + result = &PL_vtbl_sig; + break; + case want_vtbl_sigelem: + result = &PL_vtbl_sigelem; + break; + case want_vtbl_pack: + result = &PL_vtbl_pack; + break; + case want_vtbl_packelem: + result = &PL_vtbl_packelem; + break; + case want_vtbl_dbline: + result = &PL_vtbl_dbline; + break; + case want_vtbl_isa: + result = &PL_vtbl_isa; + break; + case want_vtbl_isaelem: + result = &PL_vtbl_isaelem; + break; + case want_vtbl_arylen: + result = &PL_vtbl_arylen; + break; + case want_vtbl_glob: + result = &PL_vtbl_glob; + break; + case want_vtbl_mglob: + result = &PL_vtbl_mglob; + break; + case want_vtbl_nkeys: + result = &PL_vtbl_nkeys; + break; + case want_vtbl_taint: + result = &PL_vtbl_taint; + break; + case want_vtbl_substr: + result = &PL_vtbl_substr; + break; + case want_vtbl_vec: + result = &PL_vtbl_vec; + break; + case want_vtbl_pos: + result = &PL_vtbl_pos; + break; + case want_vtbl_bm: + result = &PL_vtbl_bm; + break; + case want_vtbl_fm: + result = &PL_vtbl_fm; + break; + case want_vtbl_uvar: + result = &PL_vtbl_uvar; + break; +#ifdef USE_THREADS + case want_vtbl_mutex: + result = &PL_vtbl_mutex; + break; +#endif + case want_vtbl_defelem: + result = &PL_vtbl_defelem; + break; + case want_vtbl_regexp: + result = &PL_vtbl_regexp; + break; + case want_vtbl_regdata: + result = &PL_vtbl_regdata; + break; + case want_vtbl_regdatum: + result = &PL_vtbl_regdatum; + break; +#ifdef USE_LOCALE_COLLATE + case want_vtbl_collxfrm: + result = &PL_vtbl_collxfrm; + break; +#endif + case want_vtbl_amagic: + result = &PL_vtbl_amagic; + break; + case want_vtbl_amagicelem: + result = &PL_vtbl_amagicelem; + break; + case want_vtbl_backref: + result = &PL_vtbl_backref; + break; + } + return result; +} + +I32 +Perl_my_fflush_all(pTHX) { - return op_desc; +#ifdef FFLUSH_NULL + return PerlIO_flush(NULL); +#else + long open_max = -1; +# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) +# ifdef PERL_FFLUSH_ALL_FOPEN_MAX + open_max = PERL_FFLUSH_ALL_FOPEN_MAX; +# else +# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) + open_max = sysconf(_SC_OPEN_MAX); +# else +# ifdef FOPEN_MAX + open_max = FOPEN_MAX; +# else +# ifdef OPEN_MAX + open_max = OPEN_MAX; +# else +# ifdef _NFILE + open_max = _NFILE; +# endif +# endif +# endif +# endif +# endif + if (open_max > 0) { + long i; + for (i = 0; i < open_max; i++) + if (STDIO_STREAM_ARRAY[i]._file >= 0 && + STDIO_STREAM_ARRAY[i]._file < open_max && + STDIO_STREAM_ARRAY[i]._flag) + PerlIO_flush(&STDIO_STREAM_ARRAY[i]); + return 0; + } +# endif + SETERRNO(EBADF,RMS$_IFI); + return EOF; +#endif +} + +NV +Perl_my_atof(pTHX_ const char* s) { +#ifdef USE_LOCALE_NUMERIC + if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { + NV x, y; + + x = Perl_atof(s); + SET_NUMERIC_STANDARD(); + y = Perl_atof(s); + SET_NUMERIC_LOCAL(); + if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) + return y; + return x; + } + else + return Perl_atof(s); +#else + return Perl_atof(s); +#endif }