integrate cfgperl contents into mainline; resolve h2xs.PL conflict
[p5sagit/p5-mst-13.2.git] / util.c
diff --git a/util.c b/util.c
index 87ebb55..97401ab 100644 (file)
--- 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(pTHX_ const char *pat, va_list *args)
+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";
@@ -1405,16 +1418,29 @@ Perl_mess(pTHX_ 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;
+#ifdef IV_IS_QUAD
+       if (PL_curcop->cop_line)
+           Perl_sv_catpvf(aTHX_ sv, " at %_ line %" PERL_PRId64,
+                     GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
+#else
        if (PL_curcop->cop_line)
            Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld",
                      GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+#endif
        if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
            bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
+#ifdef IV_IS_QUAD
+           Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %" PERL_PRId64,
+                     PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
+                     line_mode ? "line" : "chunk", 
+                     (IV)IoLINES(GvIOp(PL_last_in_gv)));
+#else
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld",
                      PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
                      line_mode ? "line" : "chunk", 
                      (long)IoLINES(GvIOp(PL_last_in_gv)));
+#endif
        }
 #ifdef USE_THREADS
        if (thr->tid)
@@ -1442,8 +1468,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 +1510,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 +1565,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 +1654,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 +1750,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)) {
@@ -1822,28 +1867,13 @@ 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 */
 }
@@ -2205,7 +2235,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 +2306,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 +2528,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 +2540,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 +2577,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 }
 #endif /* !DOSISH */
 
-#if  !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN)
+#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 +2639,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 +2665,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;
 }
@@ -2776,139 +2809,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;
-    register UV n;
-    register I32 d = 0;
+    register NV rnv = 0.0;
+    register UV ruv = 0;
     register bool seenb = FALSE;
-    register bool overflow = FALSE;
+    register bool overflowed = FALSE;
 
     for (; len-- && *s; s++) {
        if (!(*s == '0' || *s == '1')) {
            if (*s == '_')
-               continue;
-           if (seenb == FALSE && *s == 'b' && retval == 0) {
+               continue; /* Note: does not check for __ and the like. */
+           if (seenb == FALSE && *s == 'b' && ruv == 0) {
                /* Disallow 0bbb0b0bbb... */
                seenb = TRUE;
-               d = 0; /* Forget any leading zeros before the 'b'. */
                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;
            }
        }
-       n = retval << 1;
-       overflow |= (n >> 1) != retval;
-       retval = n | (*s - '0');
-       d++;
+       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 (sizeof(UV) > 4 && d > 32) {
+    if (!overflowed)
+       rnv = (NV) ruv;
+    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");
     }
-    if (overflow)
-       Perl_croak(aTHX_ "Integer overflow in binary number");
     *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;
-    register UV n;
-    register I32 d = 0;
-    register bool overflow = 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;
+               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_OCTAL))
-                       Perl_warner(aTHX_ WARN_OCTAL,
+                   if (ckWARN(WARN_DIGIT))
+                       Perl_warner(aTHX_ WARN_DIGIT,
                                    "Illegal octal digit '%c' ignored", *s);
                }
                break;
            }
        }
-       n = retval << 3;
-       overflow |= (n >> 3) != retval;
-       retval = n | (*s - '0');
-       d++;
+       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 (sizeof(UV) > 4 && d > 10 && (retval >> 30) > 3) {
+    if (!overflowed)
+       rnv = (NV) ruv;
+    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");
     }
-    if (overflow)
-       Perl_croak(aTHX_ "Integer overflow in octal number");
     *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;
-    char *tmp = s;
-    register UV n;
-    register I32 d = 0;
+    register NV rnv = 0.0;
+    register UV ruv = 0;
     register bool seenx = FALSE;
-    register bool overflow = FALSE;
+    register bool overflowed = FALSE;
+    char *hexdigit;
 
-    while (len-- && *s) {
-       tmp = strchr((char *) PL_hexdigit, *s++);
-       if (!tmp) {
-           if (*(s-1) == '_')
-               continue;
-           if (seenx == FALSE && *(s-1) == 'x' && retval == 0) {
+    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;
-               d = 0; /* Forget any leading zeros before the 'x'. */
                continue;
            }
            else {
                dTHR;
-               --s;
-               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;
            }
        }
-       d++;
-       n = retval << 4;
-       overflow |= (n >> 4) != retval;
-       retval = n | ((tmp - PL_hexdigit) & 15);
+       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);
+       }
     }
-    if (sizeof(UV) > 4 && d > 8) {
+    if (!overflowed)
+       rnv = (NV) ruv;
+    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");
     }
-    if (overflow)
-       Perl_croak(aTHX_ "Integer overflow in hexadecimal number");
     *retlen = s - start;
-    return retval;
+    return rnv;
 }
 
 char*
@@ -3318,6 +3415,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);
@@ -3331,6 +3429,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);