X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=d32f897c4e6314e7998d70c8f0bed01f53b3512f;hb=d790c045735c0bdbf37ccd2827e8fc572aaeae88;hp=4ef55f207aef7d7bdf999072ac1cddb901000a89;hpb=9e24b6e2f422a9f67d0605cdea60de0c597868f3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 4ef55f2..d32f897 100644 --- a/util.c +++ b/util.c @@ -81,12 +81,13 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; Malloc_t 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; - WITH_THX(my_exit(1)); + my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING @@ -94,18 +95,14 @@ Perl_safesysmalloc(MEM_SIZE size) 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; - WITH_THX(my_exit(1)); + my_exit(1); return Nullch; } /*NOTREACHED*/ @@ -116,6 +113,7 @@ Perl_safesysmalloc(MEM_SIZE size) Malloc_t Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { + dTHX; Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) Malloc_t PerlMem_realloc(); @@ -125,7 +123,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; - WITH_THX(my_exit(1)); + my_exit(1); } #endif /* HAS_64K_LIMIT */ if (!size) { @@ -141,17 +139,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #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; @@ -159,7 +148,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) return Nullch; else { PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; - WITH_THX(my_exit(1)); + my_exit(1); return Nullch; } /*NOTREACHED*/ @@ -170,11 +159,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t 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); @@ -186,13 +172,14 @@ Perl_safesysfree(Malloc_t where) Malloc_t Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { + dTHX; Malloc_t ptr; #ifdef HAS_64K_LIMIT if (size * count > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; - WITH_THX(my_exit(1)); + my_exit(1); } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING @@ -201,11 +188,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #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; @@ -214,7 +197,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) return Nullch; else { PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; - WITH_THX(my_exit(1)); + my_exit(1); return Nullch; } /*NOTREACHED*/ @@ -929,7 +912,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; @@ -945,23 +928,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++; } } @@ -980,7 +963,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. */ @@ -1092,15 +1076,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)) { @@ -1110,9 +1096,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; @@ -1134,7 +1122,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; @@ -1396,8 +1384,33 @@ Perl_vform(pTHX_ const char *pat, va_list *args) 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, va_list *args) +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"; @@ -1406,15 +1419,15 @@ Perl_mess(pTHX_ const char *pat, va_list *args) if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; if (PL_curcop->cop_line) - Perl_sv_catpvf(aTHX_ 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'); - Perl_sv_catpvf(aTHX_ 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) @@ -1442,8 +1455,14 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) thr, PL_curstack, PL_mainstack)); 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; @@ -1478,7 +1497,11 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) 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; } @@ -1529,9 +1552,18 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = mess(pat, args); - message = SvPV(msv,msglen); - 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(PerlIO_stderr(), "croak: 0x%lx %s", + (unsigned long) thr, message)); + if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1609,7 +1641,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = mess(pat, args); + msv = vmess(pat, args); message = SvPV(msv, msglen); if (PL_warnhook) { @@ -1705,7 +1737,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SV *msv; STRLEN msglen; - msv = mess(pat, args); + msv = vmess(pat, args); message = SvPV(msv, msglen); if (ckDEAD(err)) { @@ -1783,7 +1815,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } #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) { @@ -1822,34 +1854,19 @@ 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 || CYGWIN32 */ -#if defined(CYGWIN32) +#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. @@ -2205,7 +2222,7 @@ 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; @@ -2276,7 +2293,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; @@ -2498,8 +2515,8 @@ 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 @@ -2510,7 +2527,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 @@ -2547,9 +2564,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; @@ -2609,7 +2626,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)]; @@ -2635,6 +2652,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; } @@ -2784,27 +2804,23 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) register UV ruv = 0; register bool seenb = FALSE; register bool overflowed = FALSE; - char *nonzero = NULL; 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' && nonzero == NULL) { + if (seenb == FALSE && *s == 'b' && ruv == 0) { /* Disallow 0bbb0b0bbb... */ seenb = TRUE; continue; } else { dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, "Illegal binary digit '%c' ignored", *s); break; } - } else { - if (nonzero == NULL && *s != '0') - nonzero = s; } if (!overflowed) { register UV xuv = ruv << 1; @@ -2813,8 +2829,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) dTHR; overflowed = TRUE; rnv = (NV) ruv; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in binary number"); } else ruv = xuv | (*s - '0'); @@ -2826,16 +2842,20 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) * 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. */ + * right amount. */ rnv += (*s - '0'); } } if (!overflowed) rnv = (NV) ruv; - if (sizeof(UV) > 4 && nonzero && (s - nonzero) > 32) { + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, "Binary number > 0b11111111111111111111111111111111 non-portable"); } *retlen = s - start; @@ -2849,7 +2869,6 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) register NV rnv = 0.0; register UV ruv = 0; register bool overflowed = FALSE; - char *nonzero = NULL; for (; len-- && *s; s++) { if (!(*s >= '0' && *s <= '7')) { @@ -2861,26 +2880,22 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) * someone seems to want to use the digits eight and nine). */ if (*s == '8' || *s == '9') { dTHR; - if (ckWARN(WARN_OCTAL)) - Perl_warner(aTHX_ WARN_OCTAL, + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, "Illegal octal digit '%c' ignored", *s); } break; } } - else { - if (nonzero == NULL && *s != '0') - nonzero = s; - } if (!overflowed) { - register xuv = ruv << 3; + register UV xuv = ruv << 3; if ((xuv >> 3) != ruv) { dTHR; overflowed = TRUE; rnv = (NV) ruv; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in octal number"); } else ruv = xuv | (*s - '0'); @@ -2898,12 +2913,14 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) } if (!overflowed) rnv = (NV) ruv; - if (sizeof(UV) > 4 && - overflowed ? rnv > 4294967295.0 : - (nonzero && (s - nonzero) > 10 && (ruv >> 30) > 3)) { + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, "Octal number > 037777777777 non-portable"); } *retlen = s - start; @@ -2918,7 +2935,6 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) register UV ruv = 0; register bool seenx = FALSE; register bool overflowed = FALSE; - char *nonzero = NULL; char *hexdigit; for (; len-- && *s; s++) { @@ -2926,23 +2942,19 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) if (!hexdigit) { if (*s == '_') continue; /* Note: does not check for __ and the like. */ - if (seenx == FALSE && *s == 'x' && nonzero == NULL) { + if (seenx == FALSE && *s == 'x' && ruv == 0) { /* Disallow 0xxx0x0xxx... */ seenx = TRUE; continue; } else { dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, "Illegal hexadecimal digit '%c' ignored", *s); break; } } - else { - if (nonzero == NULL && *s != '0') - nonzero = s; - } if (!overflowed) { register UV xuv = ruv << 4; @@ -2950,8 +2962,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) dTHR; overflowed = TRUE; rnv = (NV) ruv; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in hexadecimal number"); } else ruv = xuv | ((hexdigit - PL_hexdigit) & 15); @@ -2969,11 +2981,14 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) } if (!overflowed) rnv = (NV) ruv; - if (sizeof(UV) > 4 && - nonzero && (s - nonzero) > 8) { + if ( ( overflowed && rnv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, "Hexadecimal number > 0xffffffff non-portable"); } *retlen = s - start; @@ -3387,6 +3402,7 @@ 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 = MEMBER_TO_FPTR(Perl_pregcomp); PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); @@ -3400,6 +3416,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);