This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Describe the changes to ExtUtils::{Embed,Miniperl} in perldelta.
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 6fdc653..2904500 100644 (file)
--- a/util.c
+++ b/util.c
@@ -12,7 +12,7 @@
  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  *  not content.'                                    --Gandalf to Pippin
  *
  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  *  not content.'                                    --Gandalf to Pippin
  *
- *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
+ *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  */
 
 /* This file contains assorted utility routines.
  */
 
 /* This file contains assorted utility routines.
@@ -24,6 +24,11 @@
 #include "EXTERN.h"
 #define PERL_IN_UTIL_C
 #include "perl.h"
 #include "EXTERN.h"
 #define PERL_IN_UTIL_C
 #include "perl.h"
+#include "reentr.h"
+
+#ifdef USE_PERLIO
+#include "perliol.h" /* For PerlIOUnix_refcnt */
+#endif
 
 #ifndef PERL_MICRO
 #include <signal.h>
 
 #ifndef PERL_MICRO
 #include <signal.h>
@@ -37,10 +42,6 @@
 int putenv(char *);
 #endif
 
 int putenv(char *);
 #endif
 
-#ifdef I_SYS_WAIT
-#  include <sys/wait.h>
-#endif
-
 #ifdef HAS_SELECT
 # ifdef I_SYS_SELECT
 #  include <sys/select.h>
 #ifdef HAS_SELECT
 # ifdef I_SYS_SELECT
 #  include <sys/select.h>
@@ -59,17 +60,6 @@ int putenv(char *);
  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  */
 
  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  */
 
-static char *
-S_write_no_mem(pTHX)
-{
-    dVAR;
-    /* Can't use PerlIO to write as it allocates memory */
-    PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                 PL_no_mem, strlen(PL_no_mem));
-    my_exit(1);
-    NORETURN_FUNCTION_END;
-}
-
 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
 #  define ALWAYS_NEED_THX
 #endif
 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
 #  define ALWAYS_NEED_THX
 #endif
@@ -94,12 +84,11 @@ Perl_safesysmalloc(MEM_SIZE size)
     size += sTHX;
 #endif
 #ifdef DEBUGGING
     size += sTHX;
 #endif
 #ifdef DEBUGGING
-    if ((long)size < 0)
-       Perl_croak_nocontext("panic: malloc");
+    if ((SSize_t)size < 0)
+       Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     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 != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
@@ -122,6 +111,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
        return ptr;
 }
     else {
        return ptr;
 }
     else {
@@ -131,7 +121,7 @@ Perl_safesysmalloc(MEM_SIZE size)
        if (PL_nomemok)
            return NULL;
        else {
        if (PL_nomemok)
            return NULL;
        else {
-           return write_no_mem();
+           croak_no_mem();
        }
     }
     /*NOTREACHED*/
        }
     }
     /*NOTREACHED*/
@@ -172,7 +162,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
            = (struct perl_memory_debug_header *)where;
 
        if (header->interpreter != aTHX) {
            = (struct perl_memory_debug_header *)where;
 
        if (header->interpreter != aTHX) {
-           Perl_croak_nocontext("panic: realloc from wrong pool");
+           Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+                                header->interpreter, aTHX);
        }
        assert(header->next->prev == header);
        assert(header->prev->next == header);
        }
        assert(header->next->prev == header);
        assert(header->prev->next == header);
@@ -187,8 +178,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     }
 #endif
 #ifdef DEBUGGING
     }
 #endif
 #ifdef DEBUGGING
-    if ((long)size < 0)
-       Perl_croak_nocontext("panic: realloc");
+    if ((SSize_t)size < 0)
+       Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
@@ -233,7 +224,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        if (PL_nomemok)
            return NULL;
        else {
        if (PL_nomemok)
            return NULL;
        else {
-           return write_no_mem();
+           croak_no_mem();
        }
     }
     /*NOTREACHED*/
        }
     }
     /*NOTREACHED*/
@@ -258,14 +249,19 @@ Perl_safesysfree(Malloc_t where)
                = (struct perl_memory_debug_header *)where;
 
            if (header->interpreter != aTHX) {
                = (struct perl_memory_debug_header *)where;
 
            if (header->interpreter != aTHX) {
-               Perl_croak_nocontext("panic: free from wrong pool");
+               Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+                                    header->interpreter, aTHX);
            }
            if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }
            }
            if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }
-           if (!(header->next) || header->next->prev != header
-               || header->prev->next != header) {
-               Perl_croak_nocontext("panic: bad free");
+           if (!(header->next))
+               Perl_croak_nocontext("panic: bad free, header->next==NULL");
+           if (header->next->prev != header || header->prev->next != header) {
+               Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+                                    "header=%p, ->prev->next=%p",
+                                    header->next->prev, header,
+                                    header->prev->next);
            }
            /* Unlink us from the chain.  */
            header->next->prev = header->prev;
            }
            /* Unlink us from the chain.  */
            header->next->prev = header->prev;
@@ -290,18 +286,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     dTHX;
 #endif
     Malloc_t ptr;
     dTHX;
 #endif
     Malloc_t ptr;
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
     MEM_SIZE total_size = 0;
     MEM_SIZE total_size = 0;
+#endif
 
     /* Even though calloc() for zero bytes is strange, be robust. */
 
     /* Even though calloc() for zero bytes is strange, be robust. */
-    if (size && (count <= MEM_SIZE_MAX / size))
+    if (size && (count <= MEM_SIZE_MAX / size)) {
+#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
        total_size = size * count;
        total_size = size * count;
+#endif
+    }
     else
     else
-       Perl_croak_nocontext("%s", PL_memory_wrap);
+       Perl_croak_memory_wrap();
 #ifdef PERL_TRACK_MEMPOOL
     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
        total_size += sTHX;
     else
 #ifdef PERL_TRACK_MEMPOOL
     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
        total_size += sTHX;
     else
-       Perl_croak_nocontext("%s", PL_memory_wrap);
+       Perl_croak_memory_wrap();
 #endif
 #ifdef HAS_64K_LIMIT
     if (total_size > 0xffff) {
 #endif
 #ifdef HAS_64K_LIMIT
     if (total_size > 0xffff) {
@@ -311,8 +312,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     }
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
     }
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
-    if ((long)size < 0 || (long)count < 0)
-       Perl_croak_nocontext("panic: calloc");
+    if ((SSize_t)size < 0 || (SSize_t)count < 0)
+       Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+                            (UV)size, (UV)count);
 #endif
 #ifdef PERL_TRACK_MEMPOOL
     /* Have to use malloc() because we've added some space for our tracking
 #endif
 #ifdef PERL_TRACK_MEMPOOL
     /* Have to use malloc() because we've added some space for our tracking
@@ -356,7 +358,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
        if (PL_nomemok)
            return NULL;
 #endif
        if (PL_nomemok)
            return NULL;
-       return write_no_mem();
+       croak_no_mem();
     }
 }
 
     }
 }
 
@@ -394,9 +396,9 @@ Free_t   Perl_mfree (Malloc_t where)
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
-Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
 {
 {
-    register I32 tolen;
+    I32 tolen;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
@@ -424,38 +426,19 @@ Perl_delimcpy(register char *to, register const char *toend, register const char
 /* This routine was donated by Corey Satten. */
 
 char *
 /* This routine was donated by Corey Satten. */
 
 char *
-Perl_instr(register const char *big, register const char *little)
+Perl_instr(const char *big, const char *little)
 {
 {
-    register I32 first;
 
     PERL_ARGS_ASSERT_INSTR;
 
 
     PERL_ARGS_ASSERT_INSTR;
 
+    /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
     if (!little)
        return (char*)big;
     if (!little)
        return (char*)big;
-    first = *little++;
-    if (!first)
-       return (char*)big;
-    while (*big) {
-       register const char *s, *x;
-       if (*big++ != first)
-           continue;
-       for (x=big,s=little; *s; /**/ ) {
-           if (!*x)
-               return NULL;
-           if (*s != *x)
-               break;
-           else {
-               s++;
-               x++;
-           }
-       }
-       if (!*s)
-           return (char*)(big-1);
-    }
-    return NULL;
+    return strstr((char*)big, (char*)little);
 }
 
 }
 
-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
+ * the final character desired to be checked */
 
 char *
 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 
 char *
 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
@@ -484,11 +467,11 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char
 /* reverse of the above--find last substring */
 
 char *
 /* reverse of the above--find last substring */
 
 char *
-Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
+Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
 {
 {
-    register const char *bigbeg;
-    register const I32 first = *little;
-    register const char * const littleend = lend;
+    const char *bigbeg;
+    const I32 first = *little;
+    const char * const littleend = lend;
 
     PERL_ARGS_ASSERT_RNINSTR;
 
 
     PERL_ARGS_ASSERT_RNINSTR;
 
@@ -497,7 +480,7 @@ Perl_rninstr(register const char *big, const char *bigend, const char *little, c
     bigbeg = big;
     big = bigend - (littleend - little++);
     while (big >= bigbeg) {
     bigbeg = big;
     big = bigend - (littleend - little++);
     while (big >= bigbeg) {
-       register const char *s, *x;
+       const char *s, *x;
        if (*big-- != first)
            continue;
        for (x=big+2,s=little; s < littleend; /**/ ) {
        if (*big-- != first)
            continue;
        for (x=big+2,s=little; s < littleend; /**/ ) {
@@ -535,64 +518,88 @@ void
 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
     dVAR;
 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
     dVAR;
-    register const U8 *s;
-    register U32 i;
+    const U8 *s;
+    STRLEN i;
     STRLEN len;
     STRLEN len;
-    U32 rarest = 0;
     U32 frequency = 256;
     U32 frequency = 256;
+    MAGIC *mg;
+    PERL_DEB( STRLEN rarest = 0 );
 
     PERL_ARGS_ASSERT_FBM_COMPILE;
 
 
     PERL_ARGS_ASSERT_FBM_COMPILE;
 
+    if (isGV_with_GP(sv) || SvROK(sv))
+       return;
+
+    if (SvVALID(sv))
+       return;
+
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
        if (mg && mg->mg_len >= 0)
            mg->mg_len++;
     }
     if (flags & FBMcf_TAIL) {
        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
        sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
        if (mg && mg->mg_len >= 0)
            mg->mg_len++;
     }
-    s = (U8*)SvPV_force_mutable(sv, len);
+    if (!SvPOK(sv) || SvNIOKp(sv) || SvIsCOW(sv))
+       s = (U8*)SvPV_force_mutable(sv, len);
+    else s = (U8 *)SvPV_mutable(sv, len);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
-    SvUPGRADE(sv, SVt_PVGV);
+    SvUPGRADE(sv, SVt_PVMG);
     SvIOK_off(sv);
     SvNOK_off(sv);
     SvVALID_on(sv);
     SvIOK_off(sv);
     SvNOK_off(sv);
     SvVALID_on(sv);
+
+    /* "deep magic", the comment used to add. The use of MAGIC itself isn't
+       really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
+       to call SvVALID_off() if the scalar was assigned to.
+
+       The comment itself (and "deeper magic" below) date back to
+       378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
+       str->str_pok |= 2;
+       where the magic (presumably) was that the scalar had a BM table hidden
+       inside itself.
+
+       As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
+       the table instead of the previous (somewhat hacky) approach of co-opting
+       the string buffer and storing it after the string.  */
+
+    assert(!mg_find(sv, PERL_MAGIC_bm));
+    mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
+    assert(mg);
+
     if (len > 2) {
     if (len > 2) {
-       const unsigned char *sb;
+       /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+          the BM table.  */
        const U8 mlen = (len>255) ? 255 : (U8)len;
        const U8 mlen = (len>255) ? 255 : (U8)len;
-       register U8 *table;
+       const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
+       U8 *table;
 
 
-       Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
-       table
-           = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
-       s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
+       Newx(table, 256, U8);
        memset((void*)table, mlen, 256);
        memset((void*)table, mlen, 256);
+       mg->mg_ptr = (char *)table;
+       mg->mg_len = 256;
+
+       s += len - 1; /* last char */
        i = 0;
        i = 0;
-       sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
            if (table[*s] == mlen)
                table[*s] = (U8)i;
            s--, i++;
        }
        while (s >= sb) {
            if (table[*s] == mlen)
                table[*s] = (U8)i;
            s--, i++;
        }
-    } else {
-       Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
     }
     }
-    sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
        if (PL_freq[s[i]] < frequency) {
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
        if (PL_freq[s[i]] < frequency) {
-           rarest = i;
+           PERL_DEB( rarest = i );
            frequency = PL_freq[s[i]];
        }
     }
            frequency = PL_freq[s[i]];
        }
     }
-    BmFLAGS(sv) = (U8)flags;
-    BmRARE(sv) = s[rarest];
-    BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
-                         BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+                         s[rarest], rarest));
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
@@ -602,8 +609,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 /*
 =for apidoc fbm_instr
 
 /*
 =for apidoc fbm_instr
 
-Returns the location of the SV in the string delimited by C<str> and
-C<strend>.  It returns C<NULL> if the string can't be found.  The C<sv>
+Returns the location of the SV in the string delimited by C<big> and
+C<bigend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 does not have to be fbm_compiled, but the search will not be as fast
 then.
 
 does not have to be fbm_compiled, but the search will not be as fast
 then.
 
@@ -611,14 +618,13 @@ then.
 */
 
 char *
 */
 
 char *
-Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
+Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 {
 {
-    register unsigned char *s;
+    unsigned char *s;
     STRLEN l;
     STRLEN l;
-    register const unsigned char *little
-       = (const unsigned char *)SvPV_const(littlestr,l);
-    register STRLEN littlelen = l;
-    register const I32 multiline = flags & FBMrf_MULTILINE;
+    const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
+    STRLEN littlelen = l;
+    const I32 multiline = flags & FBMrf_MULTILINE;
 
     PERL_ARGS_ASSERT_FBM_INSTR;
 
 
     PERL_ARGS_ASSERT_FBM_INSTR;
 
@@ -632,9 +638,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return NULL;
     }
 
        return NULL;
     }
 
-    if (littlelen <= 2) {              /* Special-cased */
-
-       if (littlelen == 1) {
+    switch (littlelen) { /* Special cases for 0, 1 and 2  */
+    case 0:
+       return (char*)big;              /* Cannot be SvTAIL! */
+    case 1:
            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
                /* Know that bigend != big.  */
                if (bigend[-1] == '\n')
            if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
                /* Know that bigend != big.  */
                if (bigend[-1] == '\n')
@@ -650,11 +657,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            if (SvTAIL(littlestr))
                return (char *) bigend;
            return NULL;
            if (SvTAIL(littlestr))
                return (char *) bigend;
            return NULL;
-       }
-       if (!littlelen)
-           return (char*)big;          /* Cannot be SvTAIL! */
-
-       /* littlelen is 2 */
+    case 2:
        if (SvTAIL(littlestr) && !multiline) {
            if (bigend[-1] == '\n' && bigend[-2] == *little)
                return (char*)bigend - 2;
        if (SvTAIL(littlestr) && !multiline) {
            if (bigend[-1] == '\n' && bigend[-2] == *little)
                return (char*)bigend - 2;
@@ -714,7 +717,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
        return NULL;
        if (SvTAIL(littlestr) && (*bigend == *little))
            return (char *)bigend;      /* bigend is already decremented. */
        return NULL;
+    default:
+       break; /* Only lengths 0 1 and 2 have special-case code.  */
     }
     }
+
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little
     if (SvTAIL(littlestr) && !multiline) {     /* tail anchored? */
        s = bigend - littlelen;
        if (s >= big && bigend[-1] == '\n' && *s == *little
@@ -752,9 +758,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return NULL;
 
     {
        return NULL;
 
     {
-       register const unsigned char * const table
-           = little + littlelen + PERL_FBM_TABLE_OFFSET;
-       register const unsigned char *oldlittle;
+       const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+       const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+       const unsigned char *oldlittle;
 
        --littlelen;                    /* Last char found by table lookup */
 
 
        --littlelen;                    /* Last char found by table lookup */
 
@@ -762,7 +768,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        little += littlelen;            /* last char */
        oldlittle = little;
        if (s < bigend) {
        little += littlelen;            /* last char */
        oldlittle = little;
        if (s < bigend) {
-           register I32 tmp;
+           I32 tmp;
 
          top2:
            if ((tmp = table[*s])) {
 
          top2:
            if ((tmp = table[*s])) {
@@ -771,7 +777,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
                goto check_end;
            }
            else {              /* less expensive than calling strncmp() */
                goto check_end;
            }
            else {              /* less expensive than calling strncmp() */
-               register unsigned char * const olds = s;
+               unsigned char * const olds = s;
 
                tmp = littlelen;
 
 
                tmp = littlelen;
 
@@ -789,7 +795,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
       check_end:
        if ( s == bigend
        }
       check_end:
        if ( s == bigend
-            && (BmFLAGS(littlestr) & FBMcf_TAIL)
+            && SvTAIL(littlestr)
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
@@ -797,109 +803,21 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     }
 }
 
     }
 }
 
-/* start_shift, end_shift are positive quantities which give offsets
-   of ends of some substring of bigstr.
-   If "last" we want the last occurrence.
-   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 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 authoritative answer
-   is not supported yet. */
-
 char *
 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 {
     dVAR;
 char *
 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 {
     dVAR;
-    register const unsigned char *big;
-    register I32 pos;
-    register I32 previous;
-    register I32 first;
-    register const unsigned char *little;
-    register I32 stop_pos;
-    register const unsigned char *littleend;
-    I32 found = 0;
-
     PERL_ARGS_ASSERT_SCREAMINSTR;
     PERL_ARGS_ASSERT_SCREAMINSTR;
-
-    assert(SvTYPE(littlestr) == SVt_PVGV);
-    assert(SvVALID(littlestr));
-
-    if (*old_posp == -1
-       ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
-       : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
-      cant_find:
-       if ( BmRARE(littlestr) == '\n'
-            && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
-           little = (const unsigned char *)(SvPVX_const(littlestr));
-           littleend = little + SvCUR(littlestr);
-           first = *little++;
-           goto check_tail;
-       }
-       return NULL;
-    }
-
-    little = (const unsigned char *)(SvPVX_const(littlestr));
-    littleend = little + SvCUR(littlestr);
-    first = *little++;
-    /* The value of pos we can start at: */
-    previous = BmPREVIOUS(littlestr);
-    big = (const unsigned char *)(SvPVX_const(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) {
-/*
-  stop_pos does not include SvTAIL in the count, so this check is incorrect
-  (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
-*/
-#if 0
-       if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
-           goto check_tail;
-#endif
-       return NULL;
-    }
-    while (pos < previous + start_shift) {
-       if (!(pos += PL_screamnext[pos]))
-           goto cant_find;
-    }
-    big -= previous;
-    do {
-       register const unsigned char *s, *x;
-       if (pos >= stop_pos) break;
-       if (big[pos] != first)
-           continue;
-       for (x=big+pos+1,s=little; s < littleend; /**/ ) {
-           if (*s++ != *x++) {
-               s--;
-               break;
-           }
-       }
-       if (s == littleend) {
-           *old_posp = pos;
-           if (!last) return (char *)(big+pos);
-           found = 1;
-       }
-    } while ( pos += PL_screamnext[pos] );
-    if (last && found)
-       return (char *)(big+(*old_posp));
-  check_tail:
-    if (!SvTAIL(littlestr) || (end_shift > 0))
-       return NULL;
-    /* Ignore the trailing "\n".  This code is not microoptimized */
-    big = (const unsigned char *)(SvPVX_const(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((char *)(big + 1), (char *)little, stop_pos - 1)))
-       return (char*)big;
+    PERL_UNUSED_ARG(bigstr);
+    PERL_UNUSED_ARG(littlestr);
+    PERL_UNUSED_ARG(start_shift);
+    PERL_UNUSED_ARG(end_shift);
+    PERL_UNUSED_ARG(old_posp);
+    PERL_UNUSED_ARG(last);
+
+    /* This function must only ever be called on a scalar with study magic,
+       but those do not happen any more. */
+    Perl_croak(aTHX_ "panic: screaminstr");
     return NULL;
 }
 
     return NULL;
 }
 
@@ -916,13 +834,15 @@ range bytes match only themselves.
 
 
 I32
 
 
 I32
-Perl_foldEQ(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, I32 len)
 {
 {
-    register const U8 *a = (const U8 *)s1;
-    register const U8 *b = (const U8 *)s2;
+    const U8 *a = (const U8 *)s1;
+    const U8 *b = (const U8 *)s2;
 
     PERL_ARGS_ASSERT_FOLDEQ;
 
 
     PERL_ARGS_ASSERT_FOLDEQ;
 
+    assert(len >= 0);
+
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 0;
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 0;
@@ -930,6 +850,29 @@ Perl_foldEQ(const char *s1, const char *s2, register I32 len)
     }
     return 1;
 }
     }
     return 1;
 }
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
+{
+    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
+     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
+     * does it check that the strings each have at least 'len' characters */
+
+    const U8 *a = (const U8 *)s1;
+    const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+    assert(len >= 0);
+
+    while (len--) {
+       if (*a != *b && *a != PL_fold_latin1[*b]) {
+           return 0;
+       }
+       a++, b++;
+    }
+    return 1;
+}
 
 /*
 =for apidoc foldEQ_locale
 
 /*
 =for apidoc foldEQ_locale
@@ -941,14 +884,16 @@ case-insensitively in the current locale; false otherwise.
 */
 
 I32
 */
 
 I32
-Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
 {
     dVAR;
 {
     dVAR;
-    register const U8 *a = (const U8 *)s1;
-    register const U8 *b = (const U8 *)s2;
+    const U8 *a = (const U8 *)s1;
+    const U8 *b = (const U8 *)s2;
 
     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 
 
     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 
+    assert(len >= 0);
+
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 0;
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 0;
@@ -1000,11 +945,13 @@ the new string can be freed with the C<Safefree()> function.
 */
 
 char *
 */
 
 char *
-Perl_savepvn(pTHX_ const char *pv, register I32 len)
+Perl_savepvn(pTHX_ const char *pv, I32 len)
 {
 {
-    register char *newaddr;
+    char *newaddr;
     PERL_UNUSED_CONTEXT;
 
     PERL_UNUSED_CONTEXT;
 
+    assert(len >= 0);
+
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
     if (pv) {
     Newx(newaddr,len+1,char);
     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
     if (pv) {
@@ -1028,7 +975,7 @@ which is shared between threads.
 char *
 Perl_savesharedpv(pTHX_ const char *pv)
 {
 char *
 Perl_savesharedpv(pTHX_ const char *pv)
 {
-    register char *newaddr;
+    char *newaddr;
     STRLEN pvlen;
     if (!pv)
        return NULL;
     STRLEN pvlen;
     if (!pv)
        return NULL;
@@ -1036,7 +983,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-       return write_no_mem();
+       croak_no_mem();
     }
     return (char*)memcpy(newaddr, pv, pvlen);
 }
     }
     return (char*)memcpy(newaddr, pv, pvlen);
 }
@@ -1055,10 +1002,10 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
 {
     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
 
 {
     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
 
-    PERL_ARGS_ASSERT_SAVESHAREDPVN;
+    /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
 
     if (!newaddr) {
 
     if (!newaddr) {
-       return write_no_mem();
+       croak_no_mem();
     }
     newaddr[len] = '\0';
     return (char*)memcpy(newaddr, pv, len);
     }
     newaddr[len] = '\0';
     return (char*)memcpy(newaddr, pv, len);
@@ -1078,7 +1025,7 @@ Perl_savesvpv(pTHX_ SV *sv)
 {
     STRLEN len;
     const char * const pv = SvPV_const(sv, len);
 {
     STRLEN len;
     const char * const pv = SvPV_const(sv, len);
-    register char *newaddr;
+    char *newaddr;
 
     PERL_ARGS_ASSERT_SAVESVPV;
 
 
     PERL_ARGS_ASSERT_SAVESVPV;
 
@@ -1087,6 +1034,25 @@ Perl_savesvpv(pTHX_ SV *sv)
     return (char *) CopyD(pv,newaddr,len,char);
 }
 
     return (char *) CopyD(pv,newaddr,len,char);
 }
 
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char * const pv = SvPV_const(sv, len);
+
+    PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+    return savesharedpvn(pv, len);
+}
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
@@ -1097,7 +1063,7 @@ S_mess_alloc(pTHX)
     SV *sv;
     XPVMG *any;
 
     SV *sv;
     XPVMG *any;
 
-    if (!PL_dirty)
+    if (PL_phase != PERL_PHASE_DESTRUCT)
        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
@@ -1317,14 +1283,17 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
        if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
                && IoLINES(GvIOp(PL_last_in_gv)))
        {
        if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
                && IoLINES(GvIOp(PL_last_in_gv)))
        {
+           STRLEN l;
            const bool line_mode = (RsSIMPLE(PL_rs) &&
            const bool line_mode = (RsSIMPLE(PL_rs) &&
-                             SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
-           Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
-                          PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
+                                  *SvPV_const(PL_rs,l) == '\n' && l == 1);
+           Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
+                          SVfARG(PL_last_in_gv == PL_argvgv
+                                 ? &PL_sv_no
+                                 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
-       if (PL_dirty)
+       if (PL_phase == PERL_PHASE_DESTRUCT)
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
@@ -1371,38 +1340,16 @@ Perl_write_to_stderr(pTHX_ SV* msv)
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
-    {
-       dSP;
-       ENTER;
-       SAVETMPS;
-
-       save_re_context();
-       SAVESPTR(PL_stderrgv);
-       PL_stderrgv = NULL;
-
-       PUSHSTACKi(PERLSI_MAGIC);
-
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-       PUSHs(msv);
-       PUTBACK;
-       call_method("PRINT", G_SCALAR);
-
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
-    }
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
+                           G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
-       STRLEN msglen;
-       const char* message = SvPVx_const(msv, msglen);
 
 
-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+       do_print(msv, serr);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;
@@ -1488,7 +1435,7 @@ Perl_die_sv(pTHX_ SV *baseex)
 {
     PERL_ARGS_ASSERT_DIE_SV;
     croak_sv(baseex);
 {
     PERL_ARGS_ASSERT_DIE_SV;
     croak_sv(baseex);
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
     return NULL;
 }
 
     return NULL;
 }
 
@@ -1510,7 +1457,7 @@ Perl_die_nocontext(const char* pat, ...)
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
     va_end(args);
     return NULL;
 }
     va_end(args);
     return NULL;
 }
@@ -1522,7 +1469,7 @@ Perl_die(pTHX_ const char* pat, ...)
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
     va_end(args);
     return NULL;
 }
     va_end(args);
     return NULL;
 }
@@ -1622,7 +1569,7 @@ Perl_croak_nocontext(const char *pat, ...)
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
     va_end(args);
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
     va_end(args);
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
@@ -1633,7 +1580,7 @@ Perl_croak(pTHX_ const char *pat, ...)
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
     va_list args;
     va_start(args, pat);
     vcroak(pat, &args);
-    /* NOTREACHED */
+    assert(0); /* NOTREACHED */
     va_end(args);
 }
 
     va_end(args);
 }
 
@@ -1648,9 +1595,40 @@ paths reduces CPU cache pressure.
 */
 
 void
 */
 
 void
-Perl_croak_no_modify(pTHX)
+Perl_croak_no_modify()
+{
+    Perl_croak_nocontext( "%s", PL_no_modify);
+}
+
+/* does not return, used in util.c perlio.c and win32.c
+   This is typically called when malloc returns NULL.
+*/
+void
+Perl_croak_no_mem()
+{
+    dTHX;
+
+    /* Can't use PerlIO to write as it allocates memory */
+    PerlLIO_write(PerlIO_fileno(Perl_error_log),
+                 PL_no_mem, sizeof(PL_no_mem)-1);
+    my_exit(1);
+}
+
+/* saves machine code for a common noreturn idiom typically used in Newx*() */
+void
+Perl_croak_memory_wrap(void)
+{
+    Perl_croak_nocontext("%s",PL_memory_wrap);
+}
+
+
+/* does not return, used only in POPSTACK */
+void
+Perl_croak_popstack(void)
 {
 {
-    Perl_croak(aTHX_ "%s", PL_no_modify);
+    dTHX;
+    PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
+    my_exit(1);
 }
 
 /*
 }
 
 /*
@@ -1876,7 +1854,8 @@ S_ckwarn_common(pTHX_ U32 w)
 STRLEN *
 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
                           STRLEN size) {
 STRLEN *
 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
                           STRLEN size) {
-    const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+    const MEM_SIZE len_wanted =
+       sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
     PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
     PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
@@ -1886,6 +1865,8 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
         PerlMemShared_realloc(buffer, len_wanted));
     buffer[0] = size;
     Copy(bits, (buffer + 1), size, char);
         PerlMemShared_realloc(buffer, len_wanted));
     buffer[0] = size;
     Copy(bits, (buffer + 1), size, char);
+    if (size < WARNsize)
+       Zero((char *)(buffer + 1) + size, WARNsize - size, char);
     return buffer;
 }
 
     return buffer;
 }
 
@@ -1914,8 +1895,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
 #ifndef PERL_USE_SAFE_PUTENV
     if (!PL_use_safe_putenv) {
     /* most putenv()s leak, so we manipulate environ directly */
-    register I32 i;
-    register const I32 len = strlen(nam);
+    I32 i;
+    const I32 len = strlen(nam);
     int nlen, vlen;
 
     /* where does it go? */
     int nlen, vlen;
 
     /* where does it go? */
@@ -1963,7 +1944,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
        my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
        my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
-#   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
+#   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
             (void)unsetenv(nam);
@@ -1976,7 +1957,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 #   else
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
 #   else
 #       if defined(HAS_UNSETENV)
         if (val == NULL) {
-            (void)unsetenv(nam);
+            if (environ) /* old glibc can crash with null environ */
+                (void)unsetenv(nam);
         } else {
            const int nlen = strlen(nam);
            const int vlen = strlen(val);
         } else {
            const int nlen = strlen(nam);
            const int vlen = strlen(val);
@@ -2011,7 +1993,7 @@ void
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
     dVAR;
 Perl_my_setenv(pTHX_ const char *nam, const char *val)
 {
     dVAR;
-    register char *envstr;
+    char *envstr;
     const int nlen = strlen(nam);
     int vlen;
 
     const int nlen = strlen(nam);
     int vlen;
 
@@ -2027,7 +2009,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 
 #endif /* WIN32 || NETWARE */
 
 
 #endif /* WIN32 || NETWARE */
 
-#endif /* !VMS && !EPOC*/
+#endif /* !VMS */
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
 
 #ifdef UNLINK_ALL_VERSIONS
 I32
@@ -2046,12 +2028,14 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
 /* this is a drop-in replacement for bcopy() */
 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
 char *
 /* this is a drop-in replacement for bcopy() */
 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
 char *
-Perl_my_bcopy(register const char *from,register char *to,register I32 len)
+Perl_my_bcopy(const char *from, char *to, I32 len)
 {
     char * const retval = to;
 
     PERL_ARGS_ASSERT_MY_BCOPY;
 
 {
     char * const retval = to;
 
     PERL_ARGS_ASSERT_MY_BCOPY;
 
+    assert(len >= 0);
+
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
@@ -2069,12 +2053,14 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 /* this is a drop-in replacement for memset() */
 #ifndef HAS_MEMSET
 void *
 /* this is a drop-in replacement for memset() */
 #ifndef HAS_MEMSET
 void *
-Perl_my_memset(register char *loc, register I32 ch, register I32 len)
+Perl_my_memset(char *loc, I32 ch, I32 len)
 {
     char * const retval = loc;
 
     PERL_ARGS_ASSERT_MY_MEMSET;
 
 {
     char * const retval = loc;
 
     PERL_ARGS_ASSERT_MY_MEMSET;
 
+    assert(len >= 0);
+
     while (len--)
        *loc++ = ch;
     return retval;
     while (len--)
        *loc++ = ch;
     return retval;
@@ -2084,12 +2070,14 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 /* this is a drop-in replacement for bzero() */
 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
 char *
 /* this is a drop-in replacement for bzero() */
 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
 char *
-Perl_my_bzero(register char *loc, register I32 len)
+Perl_my_bzero(char *loc, I32 len)
 {
     char * const retval = loc;
 
     PERL_ARGS_ASSERT_MY_BZERO;
 
 {
     char * const retval = loc;
 
     PERL_ARGS_ASSERT_MY_BZERO;
 
+    assert(len >= 0);
+
     while (len--)
        *loc++ = 0;
     return retval;
     while (len--)
        *loc++ = 0;
     return retval;
@@ -2099,14 +2087,16 @@ Perl_my_bzero(register char *loc, register I32 len)
 /* this is a drop-in replacement for memcmp() */
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 I32
 /* this is a drop-in replacement for memcmp() */
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 I32
-Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
+Perl_my_memcmp(const char *s1, const char *s2, I32 len)
 {
 {
-    register const U8 *a = (const U8 *)s1;
-    register const U8 *b = (const U8 *)s2;
-    register I32 tmp;
+    const U8 *a = (const U8 *)s1;
+    const U8 *b = (const U8 *)s2;
+    I32 tmp;
 
     PERL_ARGS_ASSERT_MY_MEMCMP;
 
 
     PERL_ARGS_ASSERT_MY_MEMCMP;
 
+    assert(len >= 0);
+
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
@@ -2170,343 +2160,14 @@ vsprintf(char *dest, const char *pat, void *args)
 
 #endif /* HAS_VPRINTF */
 
 
 #endif /* HAS_VPRINTF */
 
-#ifdef MYSWAP
-#if BYTEORDER != 0x4321
-short
-Perl_my_swap(pTHX_ short s)
-{
-#if (BYTEORDER & 1) == 0
-    short result;
-
-    result = ((s & 255) << 8) + ((s >> 8) & 255);
-    return result;
-#else
-    return s;
-#endif
-}
-
-long
-Perl_my_htonl(pTHX_ long l)
-{
-    union {
-       long result;
-       char c[sizeof(long)];
-    } u;
-
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#if BYTEORDER == 0x12345678
-    u.result = 0; 
-#endif 
-    u.c[0] = (l >> 24) & 255;
-    u.c[1] = (l >> 16) & 255;
-    u.c[2] = (l >> 8) & 255;
-    u.c[3] = l & 255;
-    return u.result;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
-    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
-    register I32 o;
-    register I32 s;
-
-    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
-       u.c[o & 0xf] = (l >> s) & 255;
-    }
-    return u.result;
-#endif
-#endif
-}
-
-long
-Perl_my_ntohl(pTHX_ long l)
-{
-    union {
-       long l;
-       char c[sizeof(long)];
-    } u;
-
-#if BYTEORDER == 0x1234
-    u.c[0] = (l >> 24) & 255;
-    u.c[1] = (l >> 16) & 255;
-    u.c[2] = (l >> 8) & 255;
-    u.c[3] = l & 255;
-    return u.l;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
-    Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
-    register I32 o;
-    register I32 s;
-
-    u.l = l;
-    l = 0;
-    for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
-       l |= (u.c[o & 0xf] & 255) << s;
-    }
-    return l;
-#endif
-#endif
-}
-
-#endif /* BYTEORDER != 0x4321 */
-#endif /* MYSWAP */
-
-/*
- * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
- * If these functions are defined,
- * the BYTEORDER is neither 0x1234 nor 0x4321.
- * However, this is not assumed.
- * -DWS
- */
-
-#define HTOLE(name,type)                                       \
-       type                                                    \
-       name (register type n)                                  \
-       {                                                       \
-           union {                                             \
-               type value;                                     \
-               char c[sizeof(type)];                           \
-           } u;                                                \
-           register U32 i;                                     \
-           register U32 s = 0;                                 \
-           for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
-               u.c[i] = (n >> s) & 0xFF;                       \
-           }                                                   \
-           return u.value;                                     \
-       }
-
-#define LETOH(name,type)                                       \
-       type                                                    \
-       name (register type n)                                  \
-       {                                                       \
-           union {                                             \
-               type value;                                     \
-               char c[sizeof(type)];                           \
-           } u;                                                \
-           register U32 i;                                     \
-           register U32 s = 0;                                 \
-           u.value = n;                                        \
-           n = 0;                                              \
-           for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
-               n |= ((type)(u.c[i] & 0xFF)) << s;              \
-           }                                                   \
-           return n;                                           \
-       }
-
-/*
- * Big-endian byte order functions.
- */
-
-#define HTOBE(name,type)                                       \
-       type                                                    \
-       name (register type n)                                  \
-       {                                                       \
-           union {                                             \
-               type value;                                     \
-               char c[sizeof(type)];                           \
-           } u;                                                \
-           register U32 i;                                     \
-           register U32 s = 8*(sizeof(u.c)-1);                 \
-           for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
-               u.c[i] = (n >> s) & 0xFF;                       \
-           }                                                   \
-           return u.value;                                     \
-       }
-
-#define BETOH(name,type)                                       \
-       type                                                    \
-       name (register type n)                                  \
-       {                                                       \
-           union {                                             \
-               type value;                                     \
-               char c[sizeof(type)];                           \
-           } u;                                                \
-           register U32 i;                                     \
-           register U32 s = 8*(sizeof(u.c)-1);                 \
-           u.value = n;                                        \
-           n = 0;                                              \
-           for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
-               n |= ((type)(u.c[i] & 0xFF)) << s;              \
-           }                                                   \
-           return n;                                           \
-       }
-
-/*
- * If we just can't do it...
- */
-
-#define NOT_AVAIL(name,type)                                    \
-        type                                                    \
-        name (register type n)                                  \
-        {                                                       \
-            Perl_croak_nocontext(#name "() not available");     \
-            return n; /* not reached */                         \
-        }
-
-
-#if defined(HAS_HTOVS) && !defined(htovs)
-HTOLE(htovs,short)
-#endif
-#if defined(HAS_HTOVL) && !defined(htovl)
-HTOLE(htovl,long)
-#endif
-#if defined(HAS_VTOHS) && !defined(vtohs)
-LETOH(vtohs,short)
-#endif
-#if defined(HAS_VTOHL) && !defined(vtohl)
-LETOH(vtohl,long)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE16
-# if U16SIZE == 2
-HTOLE(Perl_my_htole16,U16)
-# else
-NOT_AVAIL(Perl_my_htole16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH16
-# if U16SIZE == 2
-LETOH(Perl_my_letoh16,U16)
-# else
-NOT_AVAIL(Perl_my_letoh16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE16
-# if U16SIZE == 2
-HTOBE(Perl_my_htobe16,U16)
-# else
-NOT_AVAIL(Perl_my_htobe16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH16
-# if U16SIZE == 2
-BETOH(Perl_my_betoh16,U16)
-# else
-NOT_AVAIL(Perl_my_betoh16,U16)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE32
-# if U32SIZE == 4
-HTOLE(Perl_my_htole32,U32)
-# else
-NOT_AVAIL(Perl_my_htole32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH32
-# if U32SIZE == 4
-LETOH(Perl_my_letoh32,U32)
-# else
-NOT_AVAIL(Perl_my_letoh32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE32
-# if U32SIZE == 4
-HTOBE(Perl_my_htobe32,U32)
-# else
-NOT_AVAIL(Perl_my_htobe32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH32
-# if U32SIZE == 4
-BETOH(Perl_my_betoh32,U32)
-# else
-NOT_AVAIL(Perl_my_betoh32,U32)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE64
-# if U64SIZE == 8
-HTOLE(Perl_my_htole64,U64)
-# else
-NOT_AVAIL(Perl_my_htole64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH64
-# if U64SIZE == 8
-LETOH(Perl_my_letoh64,U64)
-# else
-NOT_AVAIL(Perl_my_letoh64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE64
-# if U64SIZE == 8
-HTOBE(Perl_my_htobe64,U64)
-# else
-NOT_AVAIL(Perl_my_htobe64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH64
-# if U64SIZE == 8
-BETOH(Perl_my_betoh64,U64)
-# else
-NOT_AVAIL(Perl_my_betoh64,U64)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLES
-HTOLE(Perl_my_htoles,short)
-#endif
-#ifdef PERL_NEED_MY_LETOHS
-LETOH(Perl_my_letohs,short)
-#endif
-#ifdef PERL_NEED_MY_HTOBES
-HTOBE(Perl_my_htobes,short)
-#endif
-#ifdef PERL_NEED_MY_BETOHS
-BETOH(Perl_my_betohs,short)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEI
-HTOLE(Perl_my_htolei,int)
-#endif
-#ifdef PERL_NEED_MY_LETOHI
-LETOH(Perl_my_letohi,int)
-#endif
-#ifdef PERL_NEED_MY_HTOBEI
-HTOBE(Perl_my_htobei,int)
-#endif
-#ifdef PERL_NEED_MY_BETOHI
-BETOH(Perl_my_betohi,int)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEL
-HTOLE(Perl_my_htolel,long)
-#endif
-#ifdef PERL_NEED_MY_LETOHL
-LETOH(Perl_my_letohl,long)
-#endif
-#ifdef PERL_NEED_MY_HTOBEL
-HTOBE(Perl_my_htobel,long)
-#endif
-#ifdef PERL_NEED_MY_BETOHL
-BETOH(Perl_my_betohl,long)
-#endif
-
-void
-Perl_my_swabn(void *ptr, int n)
-{
-    register char *s = (char *)ptr;
-    register char *e = s + (n-1);
-    register char tc;
-
-    PERL_ARGS_ASSERT_MY_SWABN;
-
-    for (n /= 2; n > 0; s++, e--, n--) {
-      tc = *s;
-      *s = *e;
-      *e = tc;
-    }
-}
-
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
 PerlIO *
 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 {
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
     dVAR;
     int p[2];
     dVAR;
     int p[2];
-    register I32 This, that;
-    register Pid_t pid;
+    I32 This, that;
+    Pid_t pid;
     SV *sv;
     I32 did_pipes = 0;
     int pp[2];
     SV *sv;
     I32 did_pipes = 0;
     int pp[2];
@@ -2516,7 +2177,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
-    if (PL_tainting) {
+    if (TAINTING_get) {
        taint_env();
        taint_proper("Insecure %s%s", "EXEC");
     }
        taint_env();
        taint_proper("Insecure %s%s", "EXEC");
     }
@@ -2617,7 +2278,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
@@ -2639,14 +2300,14 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 }
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     dVAR;
     int p[2];
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     dVAR;
     int p[2];
-    register I32 This, that;
-    register Pid_t pid;
+    I32 This, that;
+    Pid_t pid;
     SV *sv;
     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
     I32 did_pipes = 0;
     SV *sv;
     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
     I32 did_pipes = 0;
@@ -2662,7 +2323,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #endif
     This = (*mode == 'w');
     that = !This;
 #endif
     This = (*mode == 'w');
     that = !This;
-    if (doexec && PL_tainting) {
+    if (doexec && TAINTING_get) {
        taint_env();
        taint_proper("Insecure %s%s", "EXEC");
     }
        taint_env();
        taint_proper("Insecure %s%s", "EXEC");
     }
@@ -2686,7 +2347,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
-       GV* tmpgv;
 
 #undef THIS
 #undef THAT
 
 #undef THIS
 #undef THAT
@@ -2732,15 +2392,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
       default, binary, low-level mode; see PerlIOBuf_open(). */
    PerlLIO_setmode((*mode == 'r'), O_BINARY);
 #endif 
       default, binary, low-level mode; see PerlIOBuf_open(). */
    PerlLIO_setmode((*mode == 'r'), O_BINARY);
 #endif 
-
-       if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
-           SvREADONLY_off(GvSV(tmpgv));
-           sv_setiv(GvSV(tmpgv), PerlProc_getpid());
-           SvREADONLY_on(GvSV(tmpgv));
-       }
-#ifdef THREADS_HAVE_PIDS
-       PL_ppid = (IV)getppid();
-#endif
        PL_forkprocess = 0;
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* we have no children */
        PL_forkprocess = 0;
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* we have no children */
@@ -2783,7 +2434,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
@@ -2796,20 +2447,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     return PerlIO_fdopen(p[This], mode);
 }
 #else
     return PerlIO_fdopen(p[This], mode);
 }
 #else
-#if defined(atarist) || defined(EPOC)
-FILE *popen();
-PerlIO *
-Perl_my_popen(pTHX_ const char *cmd, const char *mode)
-{
-    PERL_ARGS_ASSERT_MY_POPEN;
-    PERL_FLUSHALL_FOR_CHILD;
-    /* Call system's popen() to get a FILE *, then import it.
-       used 0 for 2nd parameter to PerlIO_importFILE;
-       apparently not used
-    */
-    return PerlIO_importFILE(popen(cmd, mode), 0);
-}
-#else
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
@@ -2831,7 +2468,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 }
 #endif
 #endif
 }
 #endif
 #endif
-#endif
 
 #endif /* !DOSISH */
 
 
 #endif /* !DOSISH */
 
@@ -2842,6 +2478,9 @@ Perl_atfork_lock(void)
    dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be held in locking order (if any) */
    dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be held in locking order (if any) */
+#  ifdef USE_PERLIO
+    MUTEX_LOCK(&PL_perlio_mutex);
+#  endif
 #  ifdef MYMALLOC
     MUTEX_LOCK(&PL_malloc_mutex);
 #  endif
 #  ifdef MYMALLOC
     MUTEX_LOCK(&PL_malloc_mutex);
 #  endif
@@ -2856,6 +2495,9 @@ Perl_atfork_unlock(void)
     dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be released in same order as in atfork_lock() */
     dVAR;
 #if defined(USE_ITHREADS)
     /* locks must be released in same order as in atfork_lock() */
+#  ifdef USE_PERLIO
+    MUTEX_UNLOCK(&PL_perlio_mutex);
+#  endif
 #  ifdef MYMALLOC
     MUTEX_UNLOCK(&PL_malloc_mutex);
 #  endif
 #  ifdef MYMALLOC
     MUTEX_UNLOCK(&PL_malloc_mutex);
 #  endif
@@ -3091,20 +2733,28 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
 #endif /* !PERL_MICRO */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
     dVAR;
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
     dVAR;
-    Sigsave_t hstat, istat, qstat;
     int status;
     SV **svp;
     Pid_t pid;
     int status;
     SV **svp;
     Pid_t pid;
-    Pid_t pid2;
+    Pid_t pid2 = 0;
     bool close_failed;
     dSAVEDERRNO;
     bool close_failed;
     dSAVEDERRNO;
+    const int fd = PerlIO_fileno(ptr);
 
 
-    svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+#ifdef USE_PERLIO
+    /* Find out whether the refcount is low enough for us to wait for the
+       child proc without blocking. */
+    const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+#else
+    const bool should_wait = 1;
+#endif
+
+    svp = av_fetch(PL_fdpid,fd,TRUE);
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
     SvREFCNT_dec(*svp);
     *svp = &PL_sv_undef;
@@ -3115,27 +2765,18 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 #endif
     close_failed = (PerlIO_close(ptr) == EOF);
     SAVE_ERRNO;
 #endif
     close_failed = (PerlIO_close(ptr) == EOF);
     SAVE_ERRNO;
-#ifdef UTS
-    if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
-#endif
-#ifndef PERL_MICRO
-    rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
-    rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
-    rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
-#endif
-    do {
+    if (should_wait) do {
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
        pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
-#ifndef PERL_MICRO
-    rsignal_restore(SIGHUP, &hstat);
-    rsignal_restore(SIGINT, &istat);
-    rsignal_restore(SIGQUIT, &qstat);
-#endif
     if (close_failed) {
        RESTORE_ERRNO;
        return -1;
     }
     if (close_failed) {
        RESTORE_ERRNO;
        return -1;
     }
-    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+    return(
+      should_wait
+       ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
+       : 0
+    );
 }
 #else
 #if defined(__LIBCATAMOUNT__)
 }
 #else
 #if defined(__LIBCATAMOUNT__)
@@ -3236,7 +2877,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 void
 S_pidgone(pTHX_ Pid_t pid, int status)
 {
 void
 S_pidgone(pTHX_ Pid_t pid, int status)
 {
-    register SV *sv;
+    SV *sv;
 
     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
     SvUPGRADE(sv,SVt_IV);
 
     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
     SvUPGRADE(sv,SVt_IV);
@@ -3245,7 +2886,7 @@ S_pidgone(pTHX_ Pid_t pid, int status)
 }
 #endif
 
 }
 #endif
 
-#if defined(atarist) || defined(OS2) || defined(EPOC)
+#if defined(OS2)
 int pclose();
 #ifdef HAS_FORK
 int                                    /* Cannot prototype with I32
 int pclose();
 #ifdef HAS_FORK
 int                                    /* Cannot prototype with I32
@@ -3280,27 +2921,32 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 
 #define PERL_REPEATCPY_LINEAR 4
 void
 
 #define PERL_REPEATCPY_LINEAR 4
 void
-Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
+Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
 {
     PERL_ARGS_ASSERT_REPEATCPY;
 
 {
     PERL_ARGS_ASSERT_REPEATCPY;
 
+    assert(len >= 0);
+
+    if (count < 0)
+       Perl_croak_memory_wrap();
+
     if (len == 1)
        memset(to, *from, count);
     else if (count) {
     if (len == 1)
        memset(to, *from, count);
     else if (count) {
-       register char *p = to;
-       I32 items, linear, half;
+       char *p = to;
+       IV items, linear, half;
 
        linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
        for (items = 0; items < linear; ++items) {
 
        linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
        for (items = 0; items < linear; ++items) {
-           register const char *q = from;
-           I32 todo;
+           const char *q = from;
+           IV todo;
            for (todo = len; todo > 0; todo--)
                *p++ = *q++;
         }
 
        half = count / 2;
        while (items <= half) {
            for (todo = len; todo > 0; todo--)
                *p++ = *q++;
         }
 
        half = count / 2;
        while (items <= half) {
-           I32 size = items * len;
+           IV size = items * len;
            memcpy(p, to, size);
            p     += size;
            items *= 2;
            memcpy(p, to, size);
            p     += size;
            items *= 2;
@@ -3358,11 +3004,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     const char *xfound = NULL;
     char *xfailed = NULL;
     char tmpbuf[MAXPATHLEN];
     const char *xfound = NULL;
     char *xfailed = NULL;
     char tmpbuf[MAXPATHLEN];
-    register char *s;
+    char *s;
     I32 len = 0;
     int retval;
     char *bufend;
     I32 len = 0;
     int retval;
     char *bufend;
-#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
+#if defined(DOSISH) && !defined(OS2)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
 #endif
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
 #endif
@@ -3485,28 +3131,25 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 
        bufend = s + strlen(s);
        while (s < bufend) {
 
        bufend = s + strlen(s);
        while (s < bufend) {
-#if defined(atarist) || defined(DOSISH)
+#  ifdef DOSISH
            for (len = 0; *s
            for (len = 0; *s
-#  ifdef atarist
-                   && *s != ','
-#  endif
                    && *s != ';'; len++, s++) {
                if (len < sizeof tmpbuf)
                    tmpbuf[len] = *s;
            }
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
                    && *s != ';'; len++, s++) {
                if (len < sizeof tmpbuf)
                    tmpbuf[len] = *s;
            }
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
-#else  /* ! (atarist || DOSISH) */
+#  else
            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                        ':',
                        &len);
            s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                        ':',
                        &len);
-#endif /* ! (atarist || DOSISH) */
+#  endif
            if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if (len
            if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if (len
-#  if defined(atarist) || defined(DOSISH)
+#  ifdef DOSISH
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
 #  endif
@@ -3557,6 +3200,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            seen_dot = 1;                       /* Disable message. */
        if (!xfound) {
            if (flags & 1) {                    /* do or die? */
            seen_dot = 1;                       /* Disable message. */
        if (!xfound) {
            if (flags & 1) {                    /* do or die? */
+               /* diag_listed_as: Can't execute %s */
                Perl_croak(aTHX_ "Can't %s %s%s%s",
                      (xfailed ? "execute" : "find"),
                      (xfailed ? xfailed : scriptname),
                Perl_croak(aTHX_ "Can't %s %s%s%s",
                      (xfailed ? "execute" : "find"),
                      (xfailed ? xfailed : scriptname),
@@ -3580,8 +3224,9 @@ Perl_get_context(void)
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
-    if (pthread_getspecific(PL_thr_key, &t))
-       Perl_croak_nocontext("panic: pthread_getspecific");
+    int error = pthread_getspecific(PL_thr_key, &t)
+    if (error)
+       Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
     return (void*)t;
 #  else
 #    ifdef I_MACH_CTHREADS
     return (void*)t;
 #  else
 #    ifdef I_MACH_CTHREADS
@@ -3604,8 +3249,11 @@ Perl_set_context(void *t)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else
-    if (pthread_setspecific(PL_thr_key, t))
-       Perl_croak_nocontext("panic: pthread_setspecific");
+    {
+       const int error = pthread_setspecific(PL_thr_key, t);
+       if (error)
+           Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+    }
 #  endif
 #else
     PERL_UNUSED_ARG(t);
 #  endif
 #else
     PERL_UNUSED_ARG(t);
@@ -3675,104 +3323,10 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
-    const MGVTBL* result;
     PERL_UNUSED_CONTEXT;
 
     PERL_UNUSED_CONTEXT;
 
-    switch(vtbl_id) {
-    case want_vtbl_sv:
-       result = &PL_vtbl_sv;
-       break;
-    case want_vtbl_env:
-       result = &PL_vtbl_env;
-       break;
-    case want_vtbl_envelem:
-       result = &PL_vtbl_envelem;
-       break;
-    case want_vtbl_sig:
-       result = &PL_vtbl_sig;
-       break;
-    case want_vtbl_sigelem:
-       result = &PL_vtbl_sigelem;
-       break;
-    case want_vtbl_pack:
-       result = &PL_vtbl_pack;
-       break;
-    case want_vtbl_packelem:
-       result = &PL_vtbl_packelem;
-       break;
-    case want_vtbl_dbline:
-       result = &PL_vtbl_dbline;
-       break;
-    case want_vtbl_isa:
-       result = &PL_vtbl_isa;
-       break;
-    case want_vtbl_isaelem:
-       result = &PL_vtbl_isaelem;
-       break;
-    case want_vtbl_arylen:
-       result = &PL_vtbl_arylen;
-       break;
-    case want_vtbl_mglob:
-       result = &PL_vtbl_mglob;
-       break;
-    case want_vtbl_nkeys:
-       result = &PL_vtbl_nkeys;
-       break;
-    case want_vtbl_taint:
-       result = &PL_vtbl_taint;
-       break;
-    case want_vtbl_substr:
-       result = &PL_vtbl_substr;
-       break;
-    case want_vtbl_vec:
-       result = &PL_vtbl_vec;
-       break;
-    case want_vtbl_pos:
-       result = &PL_vtbl_pos;
-       break;
-    case want_vtbl_bm:
-       result = &PL_vtbl_bm;
-       break;
-    case want_vtbl_fm:
-       result = &PL_vtbl_fm;
-       break;
-    case want_vtbl_uvar:
-       result = &PL_vtbl_uvar;
-       break;
-    case want_vtbl_defelem:
-       result = &PL_vtbl_defelem;
-       break;
-    case want_vtbl_regexp:
-       result = &PL_vtbl_regexp;
-       break;
-    case want_vtbl_regdata:
-       result = &PL_vtbl_regdata;
-       break;
-    case want_vtbl_regdatum:
-       result = &PL_vtbl_regdatum;
-       break;
-#ifdef USE_LOCALE_COLLATE
-    case want_vtbl_collxfrm:
-       result = &PL_vtbl_collxfrm;
-       break;
-#endif
-    case want_vtbl_amagic:
-       result = &PL_vtbl_amagic;
-       break;
-    case want_vtbl_amagicelem:
-       result = &PL_vtbl_amagicelem;
-       break;
-    case want_vtbl_backref:
-       result = &PL_vtbl_backref;
-       break;
-    case want_vtbl_utf8:
-       result = &PL_vtbl_utf8;
-       break;
-    default:
-       result = NULL;
-       break;
-    }
-    return (MGVTBL*)result;
+    return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+       ? NULL : PL_magic_vtables + vtbl_id;
 }
 
 I32
 }
 
 I32
@@ -3826,179 +3380,70 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
 }
 
 void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
-    const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
-
-    if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
-       if (ckWARN(WARN_IO)) {
-           const char * const direction =
-               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
-           if (name && *name)
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle %s opened only for %sput",
-                           name, direction);
-           else
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle opened only for %sput", direction);
-       }
-    }
-    else {
-        const char *vile;
-       I32   warn_type;
-
-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
-       }
-       else {
-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
-       }
-
-       if (ckWARN(warn_type)) {
-           const char * const pars =
-               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
-           const char * const func =
-               (const char *)
-               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
-                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
-                op < 0              ? "" :              /* handle phoney cases */
-                PL_op_desc[op]);
-           const char * const type =
-               (const char *)
-               (OP_IS_SOCKET(op) ||
-                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
-                "socket" : "filehandle");
-           if (name && *name) {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s %s", func, pars, vile, type, name);
-               if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name
-                   );
-           }
-           else {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s", func, pars, vile, type);
-               if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars
-                   );
-           }
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
+{
+    if (ckWARN(WARN_IO)) {
+        HEK * const name
+           = gv && (isGV_with_GP(gv))
+                ? GvENAME_HEK((gv))
+                : NULL;
+       const char * const direction = have == '>' ? "out" : "in";
+
+       if (name && HEK_LEN(name))
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle %"HEKf" opened only for %sput",
+                       name, direction);
+       else
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle opened only for %sput", direction);
     }
 }
 
     }
 }
 
-/* XXX Add documentation after final interface and behavior is decided */
-/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
-    U8 source = *current;
-
-    May want to add eg, WARN_REGEX
-*/
-
-char
-Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
 {
 {
+    const IO *io = gv ? GvIO(gv) : NULL;
+    const PERL_BITFIELD16 op = PL_op->op_type;
+    const char *vile;
+    I32 warn_type;
 
 
-    U8 result;
-
-    if (! isASCII(source)) {
-       Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
-    }
-
-    result = toCTRL(source);
-    if (! isCNTRL(result)) {
-       if (source == '{') {
-           Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
-       }
-       else if (output_warning) {
-           U8 clearer[3];
-           U8 i = 0;
-           if (! isALNUM(result)) {
-               clearer[i++] = '\\';
-           }
-           clearer[i++] = result;
-           clearer[i++] = '\0';
-
-           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-                           "\"\\c%c\" more clearly written simply as \"%s\"",
-                           source,
-                           clearer);
-       }
-    }
-
-    return result;
-}
-
-char *
-Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_warning)
-{
-
-/*  Documentation to be supplied when interface nailed down finally
- *  This returns NULL on success, otherwise a pointer to an internal constant
- *  error message.  On input:
- *     s   points to a string that begins with o, and the previous character was
- *         a backslash.
- *     uv  points to a UV that will hold the output value
- *     len will point to the next character in the string past the end of this
- *         construct
- *     output_warning says whether to output any warning messages, or suppress
- *         them
- */
-    char* e;
-    STRLEN numbers_len;
-    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
-               | PERL_SCAN_DISALLOW_PREFIX
-               /* XXX Until the message is improved in grok_oct, handle errors
-                * ourselves */
-               | PERL_SCAN_SILENT_ILLDIGIT;
-
-    PERL_ARGS_ASSERT_GROK_BSLASH_O;
-
-
-    assert(*s == 'o');
-    s++;
-
-    if (*s != '{') {
-       *len = 1;       /* Move past the o */
-       return "Missing braces on \\o{}";
-    }
-
-    e = strchr(s, '}');
-    if (!e) {
-       *len = 2;       /* Move past the o{ */
-       return "Missing right brace on \\o{";
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;
     }
     }
-
-    /* Return past the '}' no matter what is inside the braces */
-    *len = e - s + 2;  /* 2 = 1 for the o + 1 for the '}' */
-
-    s++;    /* Point to first digit */
-
-    numbers_len = e - s;
-    if (numbers_len == 0) {
-       return "Number with no digits";
-    }
-
-    *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
-    /* Note that if has non-octal, will ignore everything starting with that up
-     * to the '}' */
-
-    if (output_warning && numbers_len != (STRLEN) (e - s)) {
-       Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
-       /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
-                      "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
-                      *(s + numbers_len),
-                      (int) numbers_len,
-                      s);
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+        SV * const name
+            = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
+                                     sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       const bool have_name = name && SvCUR(name);
+       Perl_warner(aTHX_ packWARN(warn_type),
+                  "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+                   have_name ? " " : "",
+                   SVfARG(have_name ? name : &PL_sv_no));
+       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                       "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+                       func, pars, have_name ? " " : "",
+                       SVfARG(have_name ? name : &PL_sv_no)
+                           );
     }
     }
-
-    return NULL;
 }
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
 }
 
 /* To workaround core dumps from the uninitialised tm_zone we get the
@@ -4121,7 +3566,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
@@ -4132,15 +3577,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     year = 1900 + ptm->tm_year;
     month = ptm->tm_mon;
     mday = ptm->tm_mday;
     year = 1900 + ptm->tm_year;
     month = ptm->tm_mon;
     mday = ptm->tm_mday;
-    /* allow given yday with no month & mday to dominate the result */
-    if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
-       month = 0;
-       mday = 0;
-       jday = 1 + ptm->tm_yday;
-    }
-    else {
-       jday = 0;
-    }
+    jday = 0;
     if (month >= 2)
        month+=2;
     else
     if (month >= 2)
        month+=2;
     else
@@ -4235,9 +3672,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
     yearday += 14*MONTH_TO_DAYS + 1;
     ptm->tm_yday = jday - yearday;
     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
     yearday += 14*MONTH_TO_DAYS + 1;
     ptm->tm_yday = jday - yearday;
-    /* fix tm_wday if not overridden by caller */
-    if ((unsigned)ptm->tm_wday > 6)
-       ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
+    ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
 }
 
 char *
 }
 
 char *
@@ -4350,7 +3785,7 @@ Fill the sv with current working directory
  *     back into. */
 
 int
  *     back into. */
 
 int
-Perl_getcwd_sv(pTHX_ register SV *sv)
+Perl_getcwd_sv(pTHX_ SV *sv)
 {
 #ifndef PERL_MICRO
     dVAR;
 {
 #ifndef PERL_MICRO
     dVAR;
@@ -4503,6 +3938,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 /*
 =for apidoc prescan_version
 
 /*
 =for apidoc prescan_version
 
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
 =cut
 */
 const char *
 =cut
 */
 const char *
@@ -4598,6 +4038,7 @@ dotted_decimal_version:
     }                                  /* end if dotted-decimal */
     else
     {                                  /* decimal versions */
     }                                  /* end if dotted-decimal */
     else
     {                                  /* decimal versions */
+       int j = 0;                      /* may need this later */
        /* special strict case for leading '.' or '0' */
        if (strict) {
            if (*d == '.') {
        /* special strict case for leading '.' or '0' */
        if (strict) {
            if (*d == '.') {
@@ -4608,6 +4049,11 @@ dotted_decimal_version:
            }
        }
 
            }
        }
 
+       /* and we never support negative versions */
+       if ( *d == '-') {
+           BADVERSION(s,errstr,"Invalid version format (negative version number)");
+       }
+
        /* consume all of the integer part */
        while (isDIGIT(*d))
            d++;
        /* consume all of the integer part */
        while (isDIGIT(*d))
            d++;
@@ -4655,7 +4101,7 @@ dotted_decimal_version:
        }
 
        while (isDIGIT(*d)) {
        }
 
        while (isDIGIT(*d)) {
-           d++;
+           d++; j++;
            if (*d == '.' && isDIGIT(d[-1])) {
                if (alpha) {
                    BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
            if (*d == '.' && isDIGIT(d[-1])) {
                if (alpha) {
                    BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
@@ -4677,6 +4123,7 @@ dotted_decimal_version:
                if ( ! isDIGIT(d[1]) ) {
                    BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
                }
                if ( ! isDIGIT(d[1]) ) {
                    BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
                }
+               width = j;
                d++;
                alpha = TRUE;
            }
                d++;
                alpha = TRUE;
            }
@@ -4728,7 +4175,7 @@ it doesn't.
 const char *
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
 const char *
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
-    const char *start;
+    const char *start = s;
     const char *pos;
     const char *last;
     const char *errstr = NULL;
     const char *pos;
     const char *last;
     const char *errstr = NULL;
@@ -4736,17 +4183,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int width = 3;
     bool alpha = FALSE;
     bool vinf = FALSE;
     int width = 3;
     bool alpha = FALSE;
     bool vinf = FALSE;
-    AV * const av = newAV();
-    SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    AV * av;
+    SV * hv;
 
     PERL_ARGS_ASSERT_SCAN_VERSION;
 
 
     PERL_ARGS_ASSERT_SCAN_VERSION;
 
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
-
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
@@ -4754,6 +4195,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if (errstr) {
        /* "undef" is a special case and not an error */
        if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
     if (errstr) {
        /* "undef" is a special case and not an error */
        if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+           Safefree(start);
            Perl_croak(aTHX_ "%s", errstr);
        }
     }
            Perl_croak(aTHX_ "%s", errstr);
        }
     }
@@ -4763,13 +4205,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        s++;
     pos = s;
 
        s++;
     pos = s;
 
+    /* Now that we are through the prescan, start creating the object */
+    av = newAV();
+    hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
     if ( qv )
        (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
        (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
        (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
     if ( qv )
        (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
        (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
        (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-    
+
     while (isDIGIT(*pos))
        pos++;
     if (!isALPHA(*pos)) {
     while (isDIGIT(*pos))
        pos++;
     if (!isALPHA(*pos)) {
@@ -4918,7 +4369,8 @@ Perl_new_version(pTHX_ SV *ver)
     dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
     dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
-    if ( sv_derived_from(ver,"version") ) /* can just copy directly */
+    if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+        /* can just copy directly */
     {
        I32 key;
        AV * const av = newAV();
     {
        I32 key;
        AV * const av = newAV();
@@ -4939,7 +4391,7 @@ Perl_new_version(pTHX_ SV *ver)
 
        if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
            (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
 
        if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
            (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-       
+
        if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
        {
            const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
        if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
        {
            const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
@@ -5010,18 +4462,37 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
 
     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
+       STRLEN len;
+
        /* may get too much accuracy */ 
        char tbuf[64];
        /* may get too much accuracy */ 
        char tbuf[64];
+       SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
+       char *buf;
 #ifdef USE_LOCALE_NUMERIC
 #ifdef USE_LOCALE_NUMERIC
-       char *loc = setlocale(LC_NUMERIC, "C");
+       char *loc = NULL;
+        if (! PL_numeric_standard) {
+            loc = savepv(setlocale(LC_NUMERIC, NULL));
+            setlocale(LC_NUMERIC, "C");
+        }
 #endif
 #endif
-       STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+       if (sv) {
+           Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+           buf = SvPV(sv, len);
+       }
+       else {
+           len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+           buf = tbuf;
+       }
 #ifdef USE_LOCALE_NUMERIC
 #ifdef USE_LOCALE_NUMERIC
-       setlocale(LC_NUMERIC, loc);
+        if (loc) {
+            setlocale(LC_NUMERIC, loc);
+            Safefree(loc);
+        }
 #endif
 #endif
-       while (tbuf[len-1] == '0' && len > 0) len--;
-       if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
-       version = savepvn(tbuf, len);
+       while (buf[len-1] == '0' && len > 0) len--;
+       if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+       version = savepvn(buf, len);
+       SvREFCNT_dec(sv);
     }
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
     }
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
@@ -5036,29 +4507,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
-       if ( len >= 3 && !instr(version,".") && !instr(version,"_")
-           && !(*version == 'u' && strEQ(version, "undef"))
-           && (*version < '0' || *version > '9') ) {
+       if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
            /* may be a v-string */
            /* may be a v-string */
-           SV * const nsv = sv_newmortal();
-           const char *nver;
-           const char *pos;
-           int saw_decimal = 0;
-           sv_setpvf(nsv,"v%vd",ver);
-           pos = nver = savepv(SvPV_nolen(nsv));
-
-           /* scan the resulting formatted string */
-           pos++; /* skip the leading 'v' */
-           while ( *pos == '.' || isDIGIT(*pos) ) {
-               if ( *pos == '.' )
-                   saw_decimal++ ;
-               pos++;
-           }
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   SV * const nsv = sv_newmortal();
+                   const char *nver;
+                   const char *pos;
+                   int saw_decimal = 0;
+                   sv_setpvf(nsv,"v%vd",ver);
+                   pos = nver = savepv(SvPV_nolen(nsv));
+
+                   /* scan the resulting formatted string */
+                   pos++; /* skip the leading 'v' */
+                   while ( *pos == '.' || isDIGIT(*pos) ) {
+                       if ( *pos == '.' )
+                           saw_decimal++ ;
+                       pos++;
+                   }
 
 
-           /* is definitely a v-string */
-           if ( saw_decimal >= 2 ) {
-               Safefree(version);
-               version = nver;
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }
            }
        }
 #  endif
            }
        }
 #  endif
@@ -5077,27 +4554,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 /*
 =for apidoc vverify
 
 /*
 =for apidoc vverify
 
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.
 
 
-    bool vverify(SV *vobj);
+    SV *hv = vverify(sv);
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
 
 Note that it only confirms the bare minimum structure (so as not to get
 confused by derived classes which may contain additional hash entries):
 
 =over 4
 
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
 
 =item * The hash contains a "version" key
 
 
 =item * The hash contains a "version" key
 
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
 
 =back
 
 =cut
 */
 
 
 =back
 
 =cut
 */
 
-bool
+SV *
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
@@ -5112,9 +4592,9 @@ Perl_vverify(pTHX_ SV *vs)
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
-       return TRUE;
+       return vs;
     else
     else
-       return FALSE;
+       return NULL;
 }
 
 /*
 }
 
 /*
@@ -5128,6 +4608,8 @@ point representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
 =cut
 */
 
@@ -5142,10 +4624,9 @@ Perl_vnumify(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
@@ -5208,6 +4689,8 @@ representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
+The SV returned has a refcount of 1.
+
 =cut
 */
 
 =cut
 */
 
@@ -5221,10 +4704,9 @@ Perl_vnormal(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNORMAL;
 
 
     PERL_ARGS_ASSERT_VNORMAL;
 
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
@@ -5266,7 +4748,9 @@ Perl_vnormal(pTHX_ SV *vs)
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
 
 =cut
 */
 
 =cut
 */
@@ -5276,10 +4760,9 @@ Perl_vstringify(pTHX_ SV *vs)
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
@@ -5319,15 +4802,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 
     PERL_ARGS_ASSERT_VCMP;
 
 
     PERL_ARGS_ASSERT_VCMP;
 
-    if ( SvROK(lhv) )
-       lhv = SvRV(lhv);
-    if ( SvROK(rhv) )
-       rhv = SvRV(rhv);
-
-    if ( !vverify(lhv) )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    if ( !vverify(rhv) )
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && rhv ) )
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
@@ -5543,7 +5021,7 @@ int
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
     /* Stevens says that family must be AF_LOCAL, protocol 0.
        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
     /* Stevens says that family must be AF_LOCAL, protocol 0.
        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
-    dTHX;
+    dTHXa(NULL);
     int listener = -1;
     int connector = -1;
     int acceptor = -1;
     int listener = -1;
     int connector = -1;
     int acceptor = -1;
@@ -5569,6 +5047,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
        return S_socketpair_udp(fd);
 #endif
 
        return S_socketpair_udp(fd);
 #endif
 
+    aTHXa(PERL_GET_THX);
     listener = PerlSock_socket(AF_INET, type, 0);
     if (listener == -1)
        return -1;
     listener = PerlSock_socket(AF_INET, type, 0);
     if (listener == -1)
        return -1;
@@ -5644,7 +5123,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 }
 #else
 /* In any case have a stub so that there's code corresponding
 }
 #else
 /* In any case have a stub so that there's code corresponding
- * to the my_socketpair in global.sym. */
+ * to the my_socketpair in embed.fnc. */
 int
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #ifdef HAS_SOCKETPAIR
 int
 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #ifdef HAS_SOCKETPAIR
@@ -5707,8 +5186,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;
-           if (*p && *p != '\n' && *p != '\r')
+           if (*p && *p != '\n' && *p != '\r') {
+            if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+            else
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+           }
        }
        else {
            for (; *p; p++) {
        }
        else {
            for (; *p; p++) {
@@ -5734,9 +5216,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
-                     if (*p != '\n' && *p != '\r')
+                     if (*p != '\n' && *p != '\r') {
+                       if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+                       else
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
+                     }
                 }
            }
        }
                 }
            }
        }
@@ -5744,6 +5229,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
+  the_end_of_the_opts_parser:
+
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
@@ -5753,6 +5240,10 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   return opt;
 }
 
   return opt;
 }
 
+#ifdef VMS
+#  include <starlet.h>
+#endif
+
 U32
 Perl_seed(pTHX)
 {
 U32
 Perl_seed(pTHX)
 {
@@ -5784,7 +5275,6 @@ Perl_seed(pTHX)
 #endif
     U32 u;
 #ifdef VMS
 #endif
     U32 u;
 #ifdef VMS
-#  include <starlet.h>
     /* when[] = (low 32 bits, high 32 bits) of time since epoch
      * in 100-ns units, typically incremented ever 10 ms.        */
     unsigned int when[2];
     /* when[] = (low 32 bits, high 32 bits) of time since epoch
      * in 100-ns units, typically incremented ever 10 ms.        */
     unsigned int when[2];
@@ -5835,63 +5325,86 @@ Perl_seed(pTHX)
     return u;
 }
 
     return u;
 }
 
-UV
-Perl_get_hash_seed(pTHX)
+void
+Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
 {
     dVAR;
 {
     dVAR;
-     const char *s = PerlEnv_getenv("PERL_HASH_SEED");
-     UV myseed = 0;
-
-     if (s)
-       while (isSPACE(*s))
-           s++;
-     if (s && isDIGIT(*s))
-         myseed = (UV)Atoul(s);
-     else
-#ifdef USE_HASH_SEED_EXPLICIT
-     if (s)
-#endif
-     {
-         /* Compute a random seed */
-         (void)seedDrand01((Rand_seed_t)seed());
-         myseed = (UV)(Drand01() * (NV)UV_MAX);
-#if RANDBITS < (UVSIZE * 8)
-         /* Since there are not enough randbits to to reach all
-          * the bits of a UV, the low bits might need extra
-          * help.  Sum in another random number that will
-          * fill in the low bits. */
-         myseed +=
-              (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
-#endif /* RANDBITS < (UVSIZE * 8) */
-         if (myseed == 0) { /* Superparanoia. */
-             myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
-             if (myseed == 0)
-                 Perl_croak(aTHX_ "Your random numbers are not that random");
-         }
-     }
-     PL_rehash_seed_set = TRUE;
-
-     return myseed;
-}
+    const char *env_pv;
+    unsigned long i;
 
 
-#ifdef USE_ITHREADS
-bool
-Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
-{
-    const char * const stashpv = CopSTASHPV(c);
-    const char * const name = HvNAME_get(hv);
-    PERL_UNUSED_CONTEXT;
-    PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
+    PERL_ARGS_ASSERT_GET_HASH_SEED;
 
 
-    if (stashpv == name)
-       return TRUE;
-    if (stashpv && name)
-       if (strEQ(stashpv, name))
-           return TRUE;
-    return FALSE;
-}
+    env_pv= PerlEnv_getenv("PERL_HASH_SEED");
+
+    if ( env_pv )
+#ifndef USE_HASH_SEED_EXPLICIT
+    {
+        /* ignore leading spaces */
+        while (isSPACE(*env_pv))
+            env_pv++;
+#ifdef USE_PERL_PERTURB_KEYS
+        /* if they set it to "0" we disable key traversal randomization completely */
+        if (strEQ(env_pv,"0")) {
+            PL_hash_rand_bits_enabled= 0;
+        } else {
+            /* otherwise switch to deterministic mode */
+            PL_hash_rand_bits_enabled= 2;
+        }
 #endif
 #endif
+        /* ignore a leading 0x... if it is there */
+        if (env_pv[0] == '0' && env_pv[1] == 'x')
+            env_pv += 2;
+
+        for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
+            seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
+            if ( isXDIGIT(*env_pv)) {
+                seed_buffer[i] |= READ_XDIGIT(env_pv);
+            }
+        }
+        while (isSPACE(*env_pv))
+            env_pv++;
 
 
+        if (*env_pv && !isXDIGIT(*env_pv)) {
+            Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
+        }
+        /* should we check for unparsed crap? */
+        /* should we warn about unused hex? */
+        /* should we warn about insufficient hex? */
+    }
+    else
+#endif
+    {
+        (void)seedDrand01((Rand_seed_t)seed());
+
+        for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
+            seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
+        }
+    }
+#ifdef USE_PERL_PERTURB_KEYS
+    {   /* initialize PL_hash_rand_bits from the hash seed.
+         * This value is highly volatile, it is updated every
+         * hash insert, and is used as part of hash bucket chain
+         * randomization and hash iterator randomization. */
+        PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
+        for( i = 0; i < sizeof(UV) ; i++ ) {
+            PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
+            PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
+        }
+    }
+    env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
+    if (env_pv) {
+        if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
+            PL_hash_rand_bits_enabled= 0;
+        } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
+            PL_hash_rand_bits_enabled= 1;
+        } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
+            PL_hash_rand_bits_enabled= 2;
+        } else {
+            Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
+        }
+    }
+#endif
+}
 
 #ifdef PERL_GLOBAL_STRUCT
 
 
 #ifdef PERL_GLOBAL_STRUCT
 
@@ -5917,18 +5430,15 @@ Perl_init_global_struct(pTHX)
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
-#  undef PERLVARISC
-#  define PERLVAR(var,type) /**/
-#  define PERLVARA(var,n,type) /**/
-#  define PERLVARI(var,type,init) plvarsp->var = init;
-#  define PERLVARIC(var,type,init) plvarsp->var = init;
-#  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
+#  define PERLVAR(prefix,var,type) /**/
+#  define PERLVARA(prefix,var,n,type) /**/
+#  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
+#  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
 #  include "perlvars.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
 #  include "perlvars.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
 #  undef PERLVARIC
-#  undef PERLVARISC
 #  ifdef PERL_GLOBAL_STRUCT
     plvarsp->Gppaddr =
        (Perl_ppaddr_t*)
 #  ifdef PERL_GLOBAL_STRUCT
     plvarsp->Gppaddr =
        (Perl_ppaddr_t*)
@@ -6104,7 +5614,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their
-   own implemenation, but is getting these functions anyway, and they
+   own implementation, but is getting these functions anyway, and they
    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
@@ -6202,7 +5712,6 @@ getting C<vsnprintf>.
 int
 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
 {
 int
 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
 {
-    dTHX;
     int retval;
     va_list ap;
     PERL_ARGS_ASSERT_MY_SNPRINTF;
     int retval;
     va_list ap;
     PERL_ARGS_ASSERT_MY_SNPRINTF;
@@ -6213,9 +5722,15 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
-       Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
+       Perl_croak_nocontext("panic: my_snprintf buffer overflow");
     return retval;
 }
 
     return retval;
 }
 
@@ -6233,7 +5748,6 @@ C<sv_vcatpvf> instead, or getting C<vsnprintf>.
 int
 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
 {
 int
 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
 {
-    dTHX;
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
@@ -6253,9 +5767,15 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
-       Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )
+       Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
     return retval;
 }
 
     return retval;
 }
 
@@ -6288,15 +5808,14 @@ Perl_my_clearenv(pTHX)
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
-    int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
-    char *buf = (char*)safesysmalloc(bufsiz);
+    char *buf = (char*)safesysmalloc(bsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
       int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
         bsiz = l + 1; /* + 1 for the \0. */
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
       int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
         bsiz = l + 1; /* + 1 for the \0. */
-        buf = (char*)safesysmalloc(bufsiz);
+        buf = (char*)safesysmalloc(bsiz);
       } 
       memcpy(buf, *environ, l);
       buf[l] = '\0';
       } 
       memcpy(buf, *environ, l);
       buf[l] = '\0';
@@ -6432,6 +5951,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+                         STRLEN xs_len)
+{
+    SV *sv;
+    const char *vn = NULL;
+    SV *const module = PL_stack_base[ax];
+
+    PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+    if (items >= 2)     /* version supplied as bootstrap arg */
+       sv = PL_stack_base[ax + 1];
+    else {
+       /* XXX GV_ADDWARN */
+       vn = "XS_VERSION";
+       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       if (!sv || !SvOK(sv)) {
+           vn = "VERSION";
+           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       }
+    }
+    if (sv) {
+       SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+       SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
+           ? sv : sv_2mortal(new_version(sv));
+       xssv = upg_version(xssv, 0);
+       if ( vcmp(pmsv,xssv) ) {
+           SV *string = vstringify(xssv);
+           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+                                   " does not match ", module, string);
+
+           SvREFCNT_dec(string);
+           string = vstringify(pmsv);
+
+           if (vn) {
+               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+                              string);
+           } else {
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+           }
+           SvREFCNT_dec(string);
+
+           Perl_sv_2mortal(aTHX_ xpt);
+           Perl_croak_sv(aTHX_ xpt);
+       }
+    }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+                            STRLEN api_len)
+{
+    SV *xpt = NULL;
+    SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+    SV *runver;
+
+    PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+    /* This might croak  */
+    compver = upg_version(compver, 0);
+    /* This should never croak */
+    runver = new_version(PL_apiversion);
+    if (vcmp(compver, runver)) {
+       SV *compver_string = vstringify(compver);
+       SV *runver_string = vstringify(runver);
+       xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+                           " of %"SVf" does not match %"SVf,
+                           compver_string, module, runver_string);
+       Perl_sv_2mortal(aTHX_ xpt);
+
+       SvREFCNT_dec(compver_string);
+       SvREFCNT_dec(runver_string);
+    }
+    SvREFCNT_dec(runver);
+    if (xpt)
+       Perl_croak_sv(aTHX_ xpt);
+}
+
 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)
 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)
@@ -6471,34 +6068,65 @@ long _ftol( double ); /* Defined by VC6 C libs. */
 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
 #endif
 
 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
 #endif
 
+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+    GV **gvp;
+    return GvSTASH(gv)
+       && HvENAME(GvSTASH(gv))
+       && (gvp = (GV **)hv_fetch(
+                       GvSTASH(gv), GvNAME(gv),
+                       GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+          ))
+       && *gvp == gv;
+}
+
 void
 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
 void
 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
-    /* We do not care about using sv to call CV;
+    const bool save_taint = TAINT_get;
+
+    /* When we are called from pp_goto (svp is null),
+     * we do not care about using dbsv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
+    TAINT_set(FALSE);
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
-       GV * const gv = CvGV(cv);
+       GV *gv = CvGV(cv);
 
 
-       if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+       if (!svp) {
+           gv_efullname3(dbsv, gv, NULL);
+       }
+       else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || strEQ(GvNAME(gv), "END")
-            || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+            || ( /* Could be imported, and old sub redefined. */
+                (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+                &&
                 !( (SvTYPE(*svp) == SVt_PVGV)
                 !( (SvTYPE(*svp) == SVt_PVGV)
-                   && (GvCV((const GV *)*svp) == cv) )))) {
-           /* Use GV from the stack as a fallback. */
+                   && (GvCV((const GV *)*svp) == cv)
+                   /* Use GV from the stack as a fallback. */
+                   && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 
+                 )
+               )
+       ) {
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
        else {
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
        else {
-           gv_efullname3(dbsv, gv, NULL);
+           sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+           sv_catpvs(dbsv, "::");
+           sv_catpvn_flags(
+             dbsv, GvNAME(gv), GvNAMELEN(gv),
+             GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+           );
        }
     }
     else {
        }
     }
     else {
@@ -6508,6 +6136,10 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }
+    TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+    PERL_UNUSED_VAR(save_taint);
+#endif
 }
 
 int
 }
 
 int
@@ -6522,7 +6154,7 @@ Perl_my_dirfd(pTHX_ DIR * dir) {
     return dir->dd_fd;
 #else
     Perl_die(aTHX_ PL_no_func, "dirfd");
     return dir->dd_fd;
 #else
     Perl_die(aTHX_ PL_no_func, "dirfd");
-   /* NOT REACHED */
+    assert(0); /* NOT REACHED */
     return 0;
 #endif 
 }
     return 0;
 #endif 
 }
@@ -6546,8 +6178,8 @@ Perl_get_re_arg(pTHX_ SV *sv) {
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */
  */
Unnamed repository; edit this file 'description' to name the repository.