X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e1dfb34bfc42ff65ed44f37b855c1f4b6cc2109e..146174a91a192:/util.c diff --git a/util.c b/util.c index 58532a0..2ecb73a 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,9 +13,9 @@ */ #include "EXTERN.h" +#define PERL_IN_UTIL_C #include "perl.h" -/* XXX Configure test needed */ #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif @@ -51,11 +51,14 @@ # include #endif +#ifdef I_LOCALE +# include +#endif + #define FLUSH #ifdef LEAKTEST -static void xstat _((int)); long xcount[MAXXCOUNT]; long lastxcount[MAXXCOUNT]; long xycount[MAXXCOUNT][MAXYCOUNT]; @@ -63,9 +66,11 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; #endif -#ifndef MYMALLOC +#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 @@ -74,42 +79,42 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; */ 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"); + Perl_croak_nocontext("panic: malloc"); #endif ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ -#if !(defined(I286) || defined(atarist)) - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size)); -#else - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size)); -#endif + PERL_ALLOC_CHECK(ptr); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) return ptr; else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),PL_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 PerlMem_realloc(); @@ -117,89 +122,76 @@ saferealloc(Malloc_t where,MEM_SIZE size) #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) { - safefree(where); + safesysfree(where); return NULL; } if (!where) - return safemalloc(size); + return safesysmalloc(size); #ifdef DEBUGGING if ((long)size < 0) - croak("panic: realloc"); + Perl_croak_nocontext("panic: realloc"); #endif ptr = PerlMem_realloc(where,size); - -#if !(defined(I286) || defined(atarist)) - DEBUG_m( { - PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++); - PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size); - } ) -#else - DEBUG_m( { - PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++); - PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size); - } ) -#endif + PERL_ALLOC_CHECK(ptr); + + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) return ptr; else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),PL_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,PL_an++)); -#else - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++)); -#endif + dTHX; + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { /*SUPPRESS 701*/ 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 = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ -#if !(defined(I286) || defined(atarist)) - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size)); -#else - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size)); -#endif + PERL_ALLOC_CHECK(ptr); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; @@ -207,15 +199,13 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; + PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; my_exit(1); return Nullch; } /*NOTREACHED*/ } -#endif /* !MYMALLOC */ - #ifdef LEAKTEST struct mem_test_strut { @@ -240,7 +230,7 @@ struct mem_test_strut { : ((size) - 1)/4)) Malloc_t -safexmalloc(I32 x, MEM_SIZE size) +Perl_safexmalloc(I32 x, MEM_SIZE size) { register char* where = (char*)safemalloc(size + ALIGN); @@ -252,7 +242,7 @@ safexmalloc(I32 x, MEM_SIZE size) } Malloc_t -safexrealloc(Malloc_t wh, MEM_SIZE size) +Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) { char *where = (char*)wh; @@ -273,7 +263,7 @@ safexrealloc(Malloc_t wh, MEM_SIZE size) } void -safexfree(Malloc_t wh) +Perl_safexfree(Malloc_t wh) { I32 x; char *where = (char*)wh; @@ -290,7 +280,7 @@ safexfree(Malloc_t wh) } Malloc_t -safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) +Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) { register char * where = (char*)safexmalloc(x, size * count + ALIGN); xcount[x] += size; @@ -301,8 +291,8 @@ safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) return (Malloc_t)(where + ALIGN); } -static void -xstat(int flag) +STATIC void +S_xstat(pTHX_ int flag) { register I32 i, j, total = 0; I32 subtot[MAXYCOUNT]; @@ -311,7 +301,7 @@ xstat(int flag) subtot[j] = 0; } - PerlIO_printf(PerlIO_stderr(), " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); + 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++) { total += xcount[i]; for (j = 0; j < MAXYCOUNT; j++) { @@ -322,7 +312,7 @@ xstat(int flag) : (flag == 2 ? xcount[i] != lastxcount[i] /* Changed */ : xcount[i] > lastxcount[i])) { /* Growed */ - PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100, + 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++) { @@ -331,28 +321,28 @@ xstat(int flag) : (flag == 2 ? xycount[i][j] != lastxycount[i][j] /* Changed */ : xycount[i][j] > lastxycount[i][j])) { /* Growed */ - PerlIO_printf(PerlIO_stderr(),"%3ld ", + 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(PerlIO_stderr(), " . ", xycount[i][j]); + PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); } } - PerlIO_printf(PerlIO_stderr(), "\n"); + PerlIO_printf(Perl_debug_log, "\n"); } } if (flag != 2) { - PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total); + PerlIO_printf(Perl_debug_log, "Total %7ld ", total); for (j = 0; j < MAXYCOUNT; j++) { if (subtot[j]) { - PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]); + PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); } else { - PerlIO_printf(PerlIO_stderr(), " . "); + PerlIO_printf(Perl_debug_log, " . "); } } - PerlIO_printf(PerlIO_stderr(), "\n"); + PerlIO_printf(Perl_debug_log, "\n"); } } @@ -361,7 +351,7 @@ xstat(int flag) /* 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++) { @@ -390,16 +380,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; @@ -412,7 +402,7 @@ instr(register char *big, register char *little) } } if (!*s) - return big-1; + return (char*)(big-1); } return Nullch; } @@ -420,14 +410,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++; @@ -441,7 +431,7 @@ ninstr(register char *big, register char *bigend, char *little, char *lend) } } if (s >= littleend) - return big-1; + return (char*)(big-1); } return Nullch; } @@ -449,15 +439,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) { @@ -470,7 +460,7 @@ rninstr(register char *big, char *bigend, char *little, char *lend) } } if (s >= littleend) - return big+1; + return (char*)(big+1); } return Nullch; } @@ -479,7 +469,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 @@ -501,7 +491,7 @@ 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 @@ -532,7 +522,7 @@ perl_new_collate(char *newcoll) Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); SSize_t mult = fb - fa; if (mult < 1) - croak("strxfrm() gets absurd"); + Perl_croak(aTHX_ "strxfrm() gets absurd"); PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; PL_collxfrm_mult = mult; } @@ -541,11 +531,30 @@ perl_new_collate(char *newcoll) #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 */ +#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 @@ -564,13 +573,14 @@ perl_new_numeric(char *newnum) 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 @@ -584,7 +594,7 @@ perl_set_numeric_standard(void) } void -perl_set_numeric_local(void) +Perl_set_numeric_local(pTHX) { #ifdef USE_LOCALE_NUMERIC @@ -592,17 +602,17 @@ perl_set_numeric_local(void) 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 @@ -622,6 +632,9 @@ perl_init_i18nl10n(int printwarn) #ifdef USE_LOCALE_NUMERIC char *curnum = NULL; #endif /* USE_LOCALE_NUMERIC */ +#ifdef __GLIBC__ + char *language = PerlEnv_getenv("LANGUAGE"); +#endif char *lc_all = PerlEnv_getenv("LC_ALL"); char *lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; @@ -699,33 +712,41 @@ perl_init_i18nl10n(int printwarn) 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", @@ -737,18 +758,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"); } @@ -756,13 +777,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; } @@ -782,7 +803,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; } @@ -801,15 +822,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 */ @@ -819,9 +840,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 @@ -834,7 +855,7 @@ 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; /* xalloc is a reserved word in VC */ @@ -883,8 +904,16 @@ 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, U32 flags /* not used yet */) +Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { register U8 *s; register U8 *table; @@ -893,24 +922,32 @@ fbm_compile(SV *sv, U32 flags /* not used yet */) I32 rarest = 0; U32 frequency = 256; + 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 > 255 || len == 0) /* TAIL might be on on a zero-length string. */ - return; /* can't have offsets that big */ + 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); @@ -924,119 +961,205 @@ fbm_compile(SV *sv, U32 flags /* not used yet */) } 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, U32 flags) +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 (PL_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) && !PL_multiline) { /* tail anchored? */ - if (littlelen > bigend - big) - return Nullch; - little = (unsigned char*)SvPVX(littlestr); + if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 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 @@ -1045,12 +1168,17 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 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; @@ -1065,8 +1193,18 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ if (*old_posp == -1 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 - : (((pos = *old_posp), pos += PL_screamnext[pos]) == 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++; @@ -1075,10 +1213,14 @@ 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 += PL_screamnext[pos])) - return Nullch; + goto cant_find; } #ifdef POINTERRIGOR do { @@ -1116,12 +1258,26 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ found = 1; } } while ( pos += PL_screamnext[pos] ); - return (last && found) ? (char *)(big+(*old_posp)) : Nullch; + 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; @@ -1134,7 +1290,7 @@ 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; @@ -1149,7 +1305,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; @@ -1161,7 +1317,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; @@ -1171,10 +1327,10 @@ 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) +S_mess_alloc(pTHX) { dTHR; SV *sv; @@ -1196,19 +1352,66 @@ mess_alloc(void) return sv; } +#if defined(PERL_IMPLICIT_CONTEXT) char * -form(const char* pat, ...) +Perl_form_nocontext(const char* pat, ...) { - SV *sv = mess_alloc(); + dTHX; + char *retval; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + retval = vform(pat, &args); va_end(args); - return SvPVX(sv); + return retval; +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +char * +Perl_form(pTHX_ const char* pat, ...) +{ + char *retval; + va_list args; + va_start(args, pat); + retval = vform(pat, &args); + va_end(args); + return retval; } char * -mess(const char *pat, va_list *args) +Perl_vform(pTHX_ const char *pat, va_list *args) +{ + 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"; @@ -1216,50 +1419,61 @@ mess(const char *pat, va_list *args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; - if (PL_dirty) - sv_catpv(sv, dgd); - else { - if (PL_curcop->cop_line) - sv_catpvf(sv, " at %_ line %ld", - GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line); - if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { - bool line_mode = (RsSIMPLE(PL_rs) && - SvLEN(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); - sv_catpvf(sv, ", <%s> %s %ld", - PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), - line_mode ? "line" : "chunk", - (long)IoLINES(GvIOp(PL_last_in_gv))); - } - sv_catpv(sv, ".\n"); + if (CopLINE(PL_curcop)) + Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + 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'); + Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + line_mode ? "line" : "chunk", + (IV)IoLINES(GvIOp(PL_last_in_gv))); } +#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; } OP * -die(const char* pat, ...) +Perl_vdie(pTHX_ const char* pat, va_list *args) { dTHR; - va_list args; char *message; int was_in_eval = PL_in_eval; HV *stash; GV *gv; CV *cv; + SV *msv; + STRLEN msglen; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); - va_start(args, pat); - message = pat ? mess(pat, &args) : Nullch; - va_end(args); + 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(PerlIO_stderr(), + 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 croak() */ + /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; ENTER; SAVESPTR(PL_diehook); @@ -1271,8 +1485,8 @@ die(const char* pat, ...) SV *msg; ENTER; - if(message) { - msg = newSVpv(message, 0); + if (message) { + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1284,14 +1498,14 @@ die(const char* pat, ...) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; } } - PL_restartop = die_where(message); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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) @@ -1299,22 +1513,56 @@ die(const char* pat, ...) 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); + o = vdie(pat, &args); + va_end(args); + return o; +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +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 -croak(const char* pat, ...) +Perl_vcroak(pTHX_ const char* pat, va_list *args) { dTHR; - va_list args; 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%"UVxf" %s", + PTR2UV(thr), message)); - va_start(args, pat); - message = mess(pat, &args); - va_end(args); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); if (PL_diehook) { - /* sv_2cv might call croak() */ + /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; ENTER; SAVESPTR(PL_diehook); @@ -1326,7 +1574,7 @@ croak(const char* pat, ...) SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1334,35 +1582,69 @@ croak(const char* pat, ...) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; } } if (PL_in_eval) { - PL_restartop = die_where(message); + PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } - PerlIO_puts(PerlIO_stderr(),message); - (void)PerlIO_flush(PerlIO_stderr()); + { +#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(); } +#if defined(PERL_IMPLICIT_CONTEXT) void -warn(const char* pat,...) +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 +Perl_croak(pTHX_ const char *pat, ...) +{ + 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; - va_start(args, pat); - message = mess(pat, &args); - va_end(args); + msv = vmess(pat, args); + message = SvPV(msv, msglen); if (PL_warnhook) { - /* sv_2cv might call warn() */ + /* sv_2cv might call Perl_warn() */ dTHR; SV *oldwarnhook = PL_warnhook; ENTER; @@ -1375,7 +1657,7 @@ warn(const char* pat,...) SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1383,44 +1665,90 @@ warn(const char* pat,...) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; return; } } - PerlIO_puts(PerlIO_stderr(),message); + { + 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); + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); #endif - (void)PerlIO_flush(PerlIO_stderr()); + (void)PerlIO_flush(serr); + } } +#if defined(PERL_IMPLICIT_CONTEXT) void -warner(U32 err, const char* pat,...) +Perl_warn_nocontext(const char *pat, ...) { - dTHR; + dTHX; + va_list args; + va_start(args, pat); + vwarn(pat, &args); + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ + +void +Perl_warn(pTHX_ const char *pat, ...) +{ + va_list args; + va_start(args, pat); + vwarn(pat, &args); + va_end(args); +} + +#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 */ + +void +Perl_warner(pTHX_ U32 err, const char* pat,...) +{ + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); +} + +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; - va_start(args, pat); - message = mess(pat, &args); - va_end(args); + msv = vmess(pat, args); + message = SvPV(msv, msglen); if (ckDEAD(err)) { #ifdef USE_THREADS - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); #endif /* USE_THREADS */ if (PL_diehook) { - /* sv_2cv might call croak() */ + /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; ENTER; SAVESPTR(PL_diehook); @@ -1432,30 +1760,33 @@ warner(U32 err, const char* pat,...) SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); PUSHMARK(sp); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); LEAVE; } } if (PL_in_eval) { - PL_restartop = die_where(message); + PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } - PerlIO_puts(PerlIO_stderr(),message); - (void)PerlIO_flush(PerlIO_stderr()); + { + PerlIO *serr = Perl_error_log; + PerlIO_write(serr, message, msglen); + (void)PerlIO_flush(serr); + } my_failure_exit(); } else { if (PL_warnhook) { - /* sv_2cv might call warn() */ + /* sv_2cv might call Perl_warn() */ dTHR; SV *oldwarnhook = PL_warnhook; ENTER; @@ -1468,32 +1799,37 @@ warner(U32 err, const char* pat,...) SV *msg; ENTER; - msg = newSVpv(message, 0); + msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); PUSHMARK(sp); XPUSHs(msg); PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD); LEAVE; return; } } - PerlIO_puts(PerlIO_stderr(),message); + { + 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 == PL_origenviron) { /* need we copy environment? */ @@ -1503,14 +1839,16 @@ my_setenv(char *nam, char *val) /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; - New(901,tmpenv, max+2, char*); - for (j=0; j= 0) + did_pipes = 1; while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { 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); @@ -1911,10 +2278,17 @@ my_popen(char *cmd, char *mode) #define THIS that #define THAT This 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')) { PerlLIO_dup2(p[THIS], *mode == 'r'); PerlLIO_close(p[THIS]); } +#ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) int fd; @@ -1923,14 +2297,16 @@ my_popen(char *cmd, char *mode) #define NOFILE 20 #endif for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - PerlLIO_close(fd); + if (fd != pp[1]) + PerlLIO_close(fd); #endif - do_exec(cmd); /* may or may not use the shell */ + 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()); + sv_setiv(GvSV(tmpgv), PerlProc_getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -1939,6 +2315,8 @@ my_popen(char *cmd, char *mode) } do_execfree(); /* free any memory malloced by child on vfork */ PerlLIO_close(p[that]); + if (did_pipes) + PerlLIO_close(pp[1]); if (p[that] < p[This]) { PerlLIO_dup2(p[This], p[that]); PerlLIO_close(p[This]); @@ -1948,18 +2326,40 @@ my_popen(char *cmd, char *mode) (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = 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 @@ -1968,25 +2368,23 @@ char *mode; #ifdef DUMP_FDS void -dump_fds(char *s) +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 (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) - PerlIO_printf(PerlIO_stderr()," %d",fd); + PerlIO_printf(Perl_debug_log," %d",fd); } - PerlIO_printf(PerlIO_stderr(),"\n"); + PerlIO_printf(Perl_debug_log,"\n"); } #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) @@ -2022,7 +2420,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; @@ -2043,7 +2441,7 @@ rsignal(int signo, Sighandler_t handler) } Sighandler_t -rsignal_state(int signo) +Perl_rsignal_state(pTHX_ int signo) { struct sigaction oact; @@ -2054,7 +2452,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; @@ -2072,7 +2470,7 @@ rsignal_save(int signo, Sighandler_t handler, Sigsave_t *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); } @@ -2080,7 +2478,7 @@ 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 PerlProc_signal(signo, handler); } @@ -2095,7 +2493,7 @@ sig_trap(int signo) } Sighandler_t -rsignal_state(int signo) +Perl_rsignal_state(pTHX_ int signo) { Sighandler_t oldsig; @@ -2103,19 +2501,19 @@ rsignal_state(int signo) oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (sig_trapped) - PerlProc_kill(getpid(), signo); + PerlProc_kill(PerlProc_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 = 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 (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; } @@ -2123,15 +2521,15 @@ rsignal_restore(int signo, Sigsave_t *save) #endif /* !HAS_SIGACTION */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) I32 -my_pclose(PerlIO *ptr) +Perl_my_pclose(pTHX_ PerlIO *ptr) { Sigsave_t hstat, istat, qstat; int status; SV **svp; - int pid; - int pid2; + Pid_t pid; + Pid_t pid2; bool close_failed; int saved_errno; #ifdef VMS @@ -2142,7 +2540,7 @@ my_pclose(PerlIO *ptr) #endif svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - pid = (int)SvIVX(*svp); + pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; #ifdef OS2 @@ -2179,9 +2577,9 @@ my_pclose(PerlIO *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) I32 -wait4pid(int pid, int *statusp, int flags) +Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; @@ -2190,7 +2588,7 @@ wait4pid(int pid, int *statusp, int flags) if (!pid) return -1; if (pid > 0) { - sprintf(spid, "%d", pid); + sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); if (svp && *svp != &PL_sv_undef) { *statusp = SvIVX(*svp); @@ -2206,7 +2604,7 @@ wait4pid(int pid, int *statusp, int flags) pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); - sprintf(spid, "%d", pid); + sprintf(spid, "%"IVdf, (IV)pid); (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } @@ -2226,7 +2624,7 @@ 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 = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) pidgone(result,*statusp); @@ -2241,12 +2639,12 @@ wait4pid(int pid, int *statusp, int flags) 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); + sprintf(spid, "%"IVdf, (IV)pid); sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = status; @@ -2258,31 +2656,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) { @@ -2294,7 +2694,7 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) } U32 -cast_ulong(double f) +Perl_cast_ulong(pTHX_ NV f) { long along; @@ -2331,7 +2731,7 @@ cast_ulong(double f) #endif I32 -cast_i32(double f) +Perl_cast_i32(pTHX_ NV f) { if (f >= I32_MAX) return (I32) I32_MAX; @@ -2341,26 +2741,40 @@ cast_i32(double f) } IV -cast_iv(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(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; } #ifndef HAS_RENAME I32 -same_dirent(char *a, char *b) +Perl_same_dirent(pTHX_ char *a, char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); @@ -2395,71 +2809,212 @@ same_dirent(char *a, char *b) } #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; + 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; - while (len && *s >= '0' && *s <= '7') { - register UV n = retval << 3; - if (!overflowed && (n >> 3) != retval) { - warn("Integer overflow in octal number"); - overflowed = TRUE; + 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'); + } + 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'); } - retval = n | (*s++ - '0'); - len--; } - if (len && (*s == '8' || *s == '9')) { + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { dTHR; - if (ckWARN(WARN_OCTAL)) - warner(WARN_OCTAL, "Illegal octal digit ignored"); + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Binary number > 0b11111111111111111111111111111111 non-portable"); } *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 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; +} + +NV +Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; - register UV retval = 0; - bool overflowed = FALSE; - char *tmp = s; - register UV n; - - while (len-- && *s) { - tmp = strchr((char *) PL_hexdigit, *s++); - if (!tmp) { - if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) + 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; - --s; - if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE,"Illegal hex digit ignored"); + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal hexadecimal digit '%c' ignored", *s); break; } } - n = retval << 4; - if (!overflowed && (n >> 4) != retval) { - warn("Integer overflow in hex number"); - overflowed = TRUE; + 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); + } + 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); } - retval = n | ((tmp - 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* -find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) +Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) { dTHR; char *xfound = Nullch; char *xfailed = Nullch; - char tmpbuf[512]; + char tmpbuf[MAXPATHLEN]; register char *s; I32 len; int retval; @@ -2572,15 +3127,26 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) } #endif +#ifdef MACOS_TRADITIONAL + if (dosearch && !strchr(scriptname, ':') && + (s = PerlEnv_getenv("Commands"))) +#else if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH && !strchr(scriptname, '\\') #endif - && (s = PerlEnv_getenv("PATH"))) { + && (s = PerlEnv_getenv("PATH"))) +#endif + { bool seen_dot = 0; PL_bufend = s + strlen(s); while (s < PL_bufend) { +#ifdef MACOS_TRADITIONAL + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + ',', + &len); +#else #if defined(atarist) || defined(DOSISH) for (len = 0; *s # ifdef atarist @@ -2597,12 +3163,17 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) ':', &len); #endif /* ! (atarist || DOSISH) */ +#endif /* MACOS_TRADITIONAL */ if (s < PL_bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ +#ifdef MACOS_TRADITIONAL + if (len && tmpbuf[len - 1] != ':') + tmpbuf[len++] = ':'; +#else if (len -#if defined(atarist) || defined(DOSISH) +#if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' #endif @@ -2610,6 +3181,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; +#endif (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ @@ -2634,7 +3206,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) continue; if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) -#ifndef DOSISH +#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) @@ -2653,7 +3225,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ - croak("Can't %s %s%s%s", + Perl_croak(aTHX_ "Can't %s %s%s%s", (xfailed ? "execute" : "find"), (xfailed ? xfailed : scriptname), (xfailed ? "" : " on PATH"), @@ -2679,13 +3251,13 @@ schedule(void) } void -perl_cond_init(perl_cond *cp) +Perl_cond_init(pTHX_ perl_cond *cp) { *cp = 0; } void -perl_cond_signal(perl_cond *cp) +Perl_cond_signal(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; @@ -2705,7 +3277,7 @@ perl_cond_signal(perl_cond *cp) } void -perl_cond_broadcast(perl_cond *cp) +Perl_cond_broadcast(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond, cond_next; @@ -2726,12 +3298,12 @@ perl_cond_broadcast(perl_cond *cp) } void -perl_cond_wait(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; @@ -2746,18 +3318,18 @@ perl_cond_wait(perl_cond *cp) #ifdef PTHREAD_GETSPECIFIC_INT struct perl_thread * -getTHR _((void)) +Perl_getTHR(pTHX) { pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) - croak("panic: pthread_getspecific"); + Perl_croak(aTHX_ "panic: pthread_getspecific"); return (struct perl_thread *) t; } #endif MAGIC * -condpair_magic(SV *sv) +Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; @@ -2771,11 +3343,11 @@ condpair_magic(SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - LOCK_SV_MUTEX; + LOCK_CRED_MUTEX; /* XXX need separate mutex? */ mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - UNLOCK_SV_MUTEX; + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -2786,8 +3358,8 @@ condpair_magic(SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - UNLOCK_SV_MUTEX; - DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ + DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } } @@ -2802,14 +3374,16 @@ 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); @@ -2827,37 +3401,47 @@ new_struct_thread(struct perl_thread *t) #endif thr->oursv = sv; - init_stacks(ARGS); + init_stacks(); PL_curcop = &PL_compiling; + thr->interp = t->interp; thr->cvcache = newHV(); thr->threadsv = newAV(); thr->specific = newAV(); - thr->errsv = newSVpv("", 0); - thr->errhv = newHV(); + thr->errsv = newSVpvn("", 0); thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - 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? */ + JMPENV_BOOTSTRAP; + PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */ + PL_restartop = 0; - /* 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 - be per-thread. Otherwise a 'die' in a thread gives - that thread the C stack of last thread to do an eval {}! - See comments in scope.h - Initialize top entry (as in perl.c for main thread) - */ - 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_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; - PL_in_eval = FALSE; - PL_restartop = 0; + /* 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 */ @@ -2868,22 +3452,13 @@ new_struct_thread(struct perl_thread *t) 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); + if (t->Tformtarget == t->Ttoptarget) + PL_formtarget = PL_toptarget; + else + PL_formtarget = PL_bodytarget; - PL_statname = NEWSV(66,0); - PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { @@ -2891,8 +3466,9 @@ new_struct_thread(struct perl_thread *t) SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), - "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); + DEBUG_S(PerlIO_printf(Perl_debug_log, + "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", + (IV)i, t, thr)); } } thr->threadsvp = AvARRAY(thr->threadsv); @@ -2906,8 +3482,11 @@ new_struct_thread(struct perl_thread *t) thr->next->prev = thr; 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; } @@ -2919,7 +3498,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; @@ -2928,45 +3507,56 @@ Perl_huge(void) #ifdef PERL_GLOBAL_STRUCT struct perl_vars * -Perl_GetVars(void) +Perl_GetVars(pTHX) { return &PL_Vars; } #endif char ** -get_op_names(void) +Perl_get_op_names(pTHX) { return PL_op_name; } char ** -get_op_descs(void) +Perl_get_op_descs(pTHX) { return PL_op_desc; } char * -get_no_modify(void) +Perl_get_no_modify(pTHX) { return (char*)PL_no_modify; } U32 * -get_opargs(void) +Perl_get_opargs(pTHX) { return PL_opargs; } -SV ** -get_specialsv_list(void) +PPADDR_t* +Perl_get_ppaddr(pTHX) { - return PL_specialsv_list; + 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* -get_vtbl(int vtbl_id) +Perl_get_vtbl(pTHX_ int vtbl_id) { MGVTBL* result = Null(MGVTBL*); @@ -3051,16 +3641,83 @@ get_vtbl(int vtbl_id) 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) +{ +#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 +}