X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/864dbfa3ca8032ef66f7aa86961933b19b962357..45e2aec9df9174aa335c0e92620b3df6d13f23e0:/util.c diff --git a/util.c b/util.c index 9c0df21..d613c8e 100644 --- a/util.c +++ b/util.c @@ -51,6 +51,10 @@ # include #endif +#ifdef I_LOCALE +# include +#endif + #define FLUSH #ifdef LEAKTEST @@ -62,6 +66,10 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; #endif +#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) +# define FD_CLOEXEC 1 /* NeXT needs this */ +#endif + /* paranoid version of system's malloc() */ /* NOTE: Do not call the next three routines directly. Use the macros @@ -71,31 +79,29 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; */ Malloc_t -Perl_safesysmalloc(pTHX_ 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 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; } @@ -105,8 +111,9 @@ Perl_safesysmalloc(pTHX_ MEM_SIZE size) /* paranoid version of system's realloc() */ Malloc_t -Perl_safesysrealloc(pTHX_ 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(); @@ -114,7 +121,7 @@ Perl_safesysrealloc(pTHX_ 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); } @@ -128,28 +135,19 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE 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 + 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 (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; } @@ -159,13 +157,10 @@ Perl_safesysrealloc(pTHX_ Malloc_t where,MEM_SIZE size) /* safe version of system's free() */ Free_t -Perl_safesysfree(pTHX_ 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 + dTHX; DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++)); -#endif if (where) { /*SUPPRESS 701*/ PerlMem_free(where); @@ -175,28 +170,25 @@ Perl_safesysfree(pTHX_ Malloc_t where) /* safe version of system's calloc() */ Malloc_t -Perl_safesyscalloc(pTHX_ 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 if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; @@ -204,7 +196,7 @@ Perl_safesyscalloc(pTHX_ 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; } @@ -235,7 +227,7 @@ struct mem_test_strut { : ((size) - 1)/4)) Malloc_t -Perl_safexmalloc(pTHX_ I32 x, MEM_SIZE size) +Perl_safexmalloc(I32 x, MEM_SIZE size) { register char* where = (char*)safemalloc(size + ALIGN); @@ -247,7 +239,7 @@ Perl_safexmalloc(pTHX_ I32 x, MEM_SIZE size) } Malloc_t -Perl_safexrealloc(pTHX_ Malloc_t wh, MEM_SIZE size) +Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) { char *where = (char*)wh; @@ -268,7 +260,7 @@ Perl_safexrealloc(pTHX_ Malloc_t wh, MEM_SIZE size) } void -Perl_safexfree(pTHX_ Malloc_t wh) +Perl_safexfree(Malloc_t wh) { I32 x; char *where = (char*)wh; @@ -285,7 +277,7 @@ Perl_safexfree(pTHX_ Malloc_t wh) } Malloc_t -Perl_safexcalloc(pTHX_ 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; @@ -297,7 +289,7 @@ Perl_safexcalloc(pTHX_ I32 x,MEM_SIZE count, MEM_SIZE size) } STATIC void -xstat(pTHX_ int flag) +S_xstat(pTHX_ int flag) { register I32 i, j, total = 0; I32 subtot[MAXYCOUNT]; @@ -306,7 +298,7 @@ xstat(pTHX_ 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++) { @@ -317,7 +309,7 @@ xstat(pTHX_ 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++) { @@ -326,28 +318,28 @@ xstat(pTHX_ 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"); } } @@ -527,7 +519,7 @@ Perl_new_collate(pTHX_ const 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; } @@ -536,6 +528,25 @@ Perl_new_collate(pTHX_ const 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. */ @@ -559,6 +570,7 @@ Perl_new_numeric(pTHX_ const 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 */ @@ -587,12 +599,12 @@ Perl_set_numeric_local(pTHX) setlocale(LC_NUMERIC, PL_numeric_name); PL_numeric_standard = FALSE; PL_numeric_local = TRUE; + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ } - /* * Initialize locale awareness. */ @@ -697,41 +709,41 @@ Perl_init_i18nl10n(pTHX_ 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"); #ifdef __GLIBC__ - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\tLANGUAGE = %c%s%c,\n", language ? '"' : '(', language ? language : "unset", language ? '"' : ')'); #endif - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', lc_all ? lc_all : "unset", @@ -743,18 +755,18 @@ Perl_init_i18nl10n(pTHX_ 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"); } @@ -762,13 +774,13 @@ Perl_init_i18nl10n(pTHX_ 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; } @@ -788,7 +800,7 @@ Perl_init_i18nl10n(pTHX_ 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; } @@ -898,7 +910,7 @@ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ void -Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) +Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { register U8 *s; register U8 *table; @@ -914,23 +926,23 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) if (len == 0) /* TAIL might be on on a zero-length string. */ return; if (len > 2) { - I32 mlen = len; + U8 mlen; unsigned char *sb; - if (mlen > 255) + if (len > 255) mlen = 255; - Sv_Grow(sv,len + 256 + FBM_TABLE_OFFSET); + 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 */ - for (i = 0; i < 256; i++) { - table[i] = mlen; - } - table[-1] = flags; /* Not used yet */ + s = table - 1 - FBM_TABLE_OFFSET; /* last char */ + memset((void*)table, mlen, 256); + table[-1] = (U8)flags; i = 0; - sb = s - mlen; + sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { if (table[*s] == mlen) - table[*s] = i; + table[*s] = (U8)i; s--, i++; } } @@ -949,7 +961,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */) 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))); + 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. */ @@ -1061,15 +1074,17 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; - if (s >= big - && bigend[-1] == '\n' - && *s == *little + 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)) + } + if (s[1] == *little + && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) + { return (char*)s + 1; /* how sweet it is */ + } return Nullch; } if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { @@ -1079,9 +1094,11 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit 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)) + if (*s == *little + && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) + { return (char*)s; + } return Nullch; } return b; @@ -1103,7 +1120,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit top2: /*SUPPRESS 560*/ - if (tmp = table[*s]) { + if ((tmp = table[*s])) { #ifdef POINTERRIGOR if (bigend - s > tmp) { s += tmp; @@ -1307,10 +1324,10 @@ Perl_savepvn(pTHX_ const 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(pTHX) +S_mess_alloc(pTHX) { dTHR; SV *sv; @@ -1332,19 +1349,66 @@ mess_alloc(pTHX) return sv; } +#if defined(PERL_IMPLICIT_CONTEXT) +char * +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 * Perl_form(pTHX_ const char* pat, ...) { - SV *sv = mess_alloc(); + 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 retval; +} + +char * +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_mess(pTHX_ const char *pat, va_list *args) +Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; @@ -1353,26 +1417,29 @@ Perl_mess(pTHX_ const char *pat, va_list *args) if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; if (PL_curcop->cop_line) - sv_catpvf(sv, " at %_ line %ld", - GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line); + Perl_sv_catpvf(aTHX_ sv, " at %_ line %"IVdf, + GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line); 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'); - sv_catpvf(sv, ", <%s> %s %ld", + Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", - (long)IoLINES(GvIOp(PL_last_in_gv))); + (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 sv; } OP * -Perl_die(pTHX_ 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; @@ -1381,25 +1448,29 @@ Perl_die(pTHX_ const char* pat, ...) 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); if (pat) { - msv = mess(pat, &args); - message = SvPV(msv,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); } else { message = Nullch; } - va_end(args); - 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); @@ -1424,14 +1495,18 @@ Perl_die(pTHX_ const char* pat, ...) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + /* 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(PerlIO_stderr(), + 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) @@ -1439,11 +1514,35 @@ Perl_die(pTHX_ 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 -Perl_croak(pTHX_ const char* pat, ...) +Perl_vcroak(pTHX_ const char* pat, va_list *args) { dTHR; - va_list args; char *message; HV *stash; GV *gv; @@ -1451,13 +1550,20 @@ Perl_croak(pTHX_ const char* pat, ...) SV *msv; STRLEN msglen; - va_start(args, pat); - msv = mess(pat, &args); - message = SvPV(msv,msglen); - va_end(args); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); + 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 croak() */ + /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; ENTER; SAVESPTR(PL_diehook); @@ -1491,8 +1597,10 @@ Perl_croak(pTHX_ const char* pat, ...) /* SFIO can really mess with your errno */ int e = errno; #endif - PerlIO_write(PerlIO_stderr(), message, msglen); - (void)PerlIO_flush(PerlIO_stderr()); + PerlIO *serr = Perl_error_log; + + PerlIO_write(serr, message, msglen); + (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; #endif @@ -1500,10 +1608,32 @@ Perl_croak(pTHX_ const char* pat, ...) my_failure_exit(); } +#if defined(PERL_IMPLICIT_CONTEXT) void -Perl_warn(pTHX_ 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; @@ -1511,13 +1641,11 @@ Perl_warn(pTHX_ const char* pat,...) SV *msv; STRLEN msglen; - va_start(args, pat); - msv = mess(pat, &args); + msv = vmess(pat, args); message = SvPV(msv, msglen); - va_end(args); if (PL_warnhook) { - /* sv_2cv might call warn() */ + /* sv_2cv might call Perl_warn() */ dTHR; SV *oldwarnhook = PL_warnhook; ENTER; @@ -1544,23 +1672,68 @@ Perl_warn(pTHX_ const char* pat,...) return; } } - PerlIO_write(PerlIO_stderr(), message, msglen); + { + 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 +Perl_warn_nocontext(const char *pat, ...) +{ + 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,...) { - dTHR; 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; @@ -1568,17 +1741,15 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) SV *msv; STRLEN msglen; - va_start(args, pat); - msv = mess(pat, &args); + msv = vmess(pat, args); message = SvPV(msv, msglen); - va_end(args); 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%lx %s", (unsigned long) 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); @@ -1606,14 +1777,17 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } - PerlIO_write(PerlIO_stderr(), message, msglen); - (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; @@ -1639,16 +1813,19 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) return; } } - PerlIO_write(PerlIO_stderr(), message, msglen); + { + 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 */ -#if !defined(WIN32) && !defined(CYGWIN32) +#if !defined(WIN32) && !defined(CYGWIN) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1687,32 +1864,52 @@ Perl_my_setenv(pTHX_ char *nam, char *val) safesysfree(environ[i]); environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char)); -#ifndef MSDOS (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ -#else - /* MS-DOS requires environment variable names to be in uppercase */ - /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but - * some utilities and applications may break because they only look - * for upper case strings. (Fixed strupr() bug here.)] - */ - strcpy(environ[i],nam); strupr(environ[i]); - (void)sprintf(environ[i] + strlen(nam),"=%s",val); -#endif /* MSDOS */ #else /* PERL_USE_SAFE_PUTENV */ char *new_env; new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char)); -#ifndef MSDOS (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */ -#else - strcpy(new_env,nam); strupr(new_env); - (void)sprintf(new_env + strlen(nam),"=%s",val); -#endif (void)putenv(new_env); #endif /* PERL_USE_SAFE_PUTENV */ } +#else /* WIN32 || CYGWIN */ +#if defined(CYGWIN) +/* + * Save environ of perl.exe, currently Cygwin links in separate environ's + * for each exe/dll. Probably should be a member of impure_ptr. + */ +static char ***Perl_main_environ; + +EXTERN_C void +Perl_my_setenv_init(char ***penviron) +{ + Perl_main_environ = penviron; +} + +void +my_setenv(char *nam, char *val) +{ + /* You can not directly manipulate the environ[] array because + * the routines do some additional work that syncs the Cygwin + * environment with the Windows environment. + */ + char *oldstr = environ[setenv_getix(nam)]; + + if (!val) { + if (!oldstr) + return; + unsetenv(nam); + Safefree(oldstr); + return; + } + setenv(nam, val, 1); + environ = *Perl_main_environ; /* environ realloc can occur in setenv */ + if(oldstr && environ[setenv_getix(nam)] != oldstr) + Safefree(oldstr); +} #else /* if WIN32 */ void @@ -1774,6 +1971,7 @@ Perl_my_setenv(pTHX_ char *nam,char *val) } #endif /* WIN32 */ +#endif I32 Perl_setenv_getix(pTHX_ char *nam) @@ -1925,7 +2123,7 @@ Perl_my_htonl(pTHX_ 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; @@ -1954,7 +2152,7 @@ Perl_my_ntohl(pTHX_ 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; @@ -2028,13 +2226,13 @@ 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) && !defined(__OPEN_VM) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) PerlIO * 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; @@ -2064,7 +2262,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(pp[1]); } if (!doexec) - croak("Can't fork"); + Perl_croak(aTHX_ "Can't fork"); return Nullfp; } sleep(5); @@ -2105,7 +2303,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #endif /* defined OS2 */ /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2137,10 +2335,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) break; n += n1; } + PerlLIO_close(pp[0]); + did_pipes = 0; if (n) { /* Error */ if (n != sizeof(int)) - croak("panic: kid popen errno read"); - PerlLIO_close(pp[0]); + Perl_croak(aTHX_ "panic: kid popen errno read"); errno = errkid; /* Propagate errno from kid */ return Nullfp; } @@ -2171,12 +2370,12 @@ 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 */ @@ -2319,15 +2518,15 @@ Perl_rsignal_restore(pTHX_ 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) I32 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 @@ -2338,7 +2537,7 @@ Perl_my_pclose(pTHX_ 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 @@ -2375,9 +2574,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) I32 -Perl_wait4pid(pTHX_ int pid, int *statusp, int flags) +Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; @@ -2422,7 +2621,7 @@ Perl_wait4pid(pTHX_ 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); @@ -2437,7 +2636,7 @@ Perl_wait4pid(pTHX_ int pid, int *statusp, int flags) void /*SUPPRESS 590*/ -Perl_pidgone(pTHX_ int pid, int status) +Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; char spid[TYPE_CHARS(int)]; @@ -2463,6 +2662,9 @@ Perl_my_pclose(pTHX_ 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; } @@ -2489,7 +2691,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi } U32 -Perl_cast_ulong(pTHX_ double f) +Perl_cast_ulong(pTHX_ NV f) { long along; @@ -2526,7 +2728,7 @@ Perl_cast_ulong(pTHX_ double f) #endif I32 -Perl_cast_i32(pTHX_ double f) +Perl_cast_i32(pTHX_ NV f) { if (f >= I32_MAX) return (I32) I32_MAX; @@ -2536,12 +2738,12 @@ Perl_cast_i32(pTHX_ double f) } IV -Perl_cast_iv(pTHX_ double f) +Perl_cast_iv(pTHX_ NV f) { if (f >= IV_MAX) { UV uv; - if (f >= (double)UV_MAX) + if (f >= (NV)UV_MAX) return (IV) UV_MAX; uv = (UV) f; return (IV)uv; @@ -2552,7 +2754,7 @@ Perl_cast_iv(pTHX_ double f) } UV -Perl_cast_uv(pTHX_ double f) +Perl_cast_uv(pTHX_ NV f) { if (f >= MY_UV_MAX) return (UV) MY_UV_MAX; @@ -2604,85 +2806,203 @@ Perl_same_dirent(pTHX_ char *a, char *b) } #endif /* !HAS_RENAME */ -UV +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 <= '1') { - register UV n = retval << 1; - if (!overflowed && (n >> 1) != retval) { - warn("Integer overflow in binary number"); - overflowed = TRUE; - } - retval = n | (*s++ - '0'); - len--; - } - if (len && (*s >= '2' && *s <= '9')) { - dTHR; - if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s); + 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'); + } + 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"); } *retlen = s - start; - return retval; + return rnv; } -UV + +NV Perl_scan_oct(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 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; - 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 >> 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'); } - 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 '%c' ignored", *s); + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Octal number > 037777777777 non-portable"); } *retlen = s - start; - return retval; + return rnv; } -UV +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 '%c' ignored", *s); + 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* @@ -2885,7 +3205,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f 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"), @@ -2963,7 +3283,7 @@ 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; @@ -2983,7 +3303,7 @@ 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 @@ -3019,7 +3339,7 @@ Perl_condpair_magic(pTHX_ SV *sv) mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ - DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } } @@ -3036,7 +3356,9 @@ Perl_condpair_magic(pTHX_ SV *sv) struct perl_thread * 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; @@ -3058,17 +3380,17 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) Zero(thr, 1, struct perl_thread); #endif - PL_protect = FUNC_NAME_TO_PTR(default_protect); + PL_protect = MEMBER_TO_FPTR(Perl_default_protect); 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 = newSVpvn("", 0); - thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); @@ -3089,9 +3411,13 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_restartop = 0; PL_statname = NEWSV(66,0); + PL_errors = newSVpvn("", 0); PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + 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; @@ -3099,6 +3425,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) 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); @@ -3129,7 +3456,7 @@ Perl_new_struct_thread(pTHX_ 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(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); } } @@ -3148,7 +3475,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) MUTEX_UNLOCK(&t->mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ return thr; } @@ -3160,7 +3487,7 @@ Perl_new_struct_thread(pTHX_ 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; @@ -3199,6 +3526,12 @@ 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) @@ -3356,3 +3689,24 @@ Perl_my_fflush_all(pTHX) 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 +}