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
rewrote deprecate test using File::Spec
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 3eb4f09..ea84cda 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
 /*    util.c
  *
- *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -9,8 +9,10 @@
  */
 
 /*
  */
 
 /*
- * "Very useful, no doubt, that was to Saruman; yet it seems that he was
- * not content."  --Gandalf
+ * '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"]
  */
 
 /* This file contains assorted utility routines.
  */
 
 /* This file contains assorted utility routines.
@@ -178,11 +180,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
 
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-
-    if (ptr != NULL) {
+    /* MUST do this fixup first, before doing ANYTHING else, as anything else
+       might allocate memory/free/move memory, and until we do the fixup, it
+       may well be chasing (and writing to) free memory.  */
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
+    if (ptr != NULL) {
        struct perl_memory_debug_header *const header
            = (struct perl_memory_debug_header *)ptr;
 
        struct perl_memory_debug_header *const header
            = (struct perl_memory_debug_header *)ptr;
 
@@ -198,7 +200,17 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
        header->prev->next = header;
 
         ptr = (Malloc_t)((char*)ptr+sTHX);
        header->prev->next = header;
 
         ptr = (Malloc_t)((char*)ptr+sTHX);
+    }
 #endif
 #endif
+
+    /* In particular, must do that fixup above before logging anything via
+     *printf(), as it can reallocate memory, which can cause SEGVs.  */
+
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+
+
+    if (ptr != NULL) {
        return ptr;
     }
     else if (PL_nomemok)
        return ptr;
     }
     else if (PL_nomemok)
@@ -258,11 +270,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
     dTHX;
     Malloc_t ptr;
 {
     dTHX;
     Malloc_t ptr;
+    MEM_SIZE total_size = 0;
 
 
+    /* Even though calloc() for zero bytes is strange, be robust. */
+    if (size && (count <= MEM_SIZE_MAX / size))
+       total_size = size * count;
+    else
+       Perl_croak_nocontext("%s", PL_memory_wrap);
+#ifdef PERL_TRACK_MEMPOOL
+    if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
+       total_size += sTHX;
+    else
+       Perl_croak_nocontext("%s", PL_memory_wrap);
+#endif
 #ifdef HAS_64K_LIMIT
 #ifdef HAS_64K_LIMIT
-    if (size * count > 0xffff) {
+    if (total_size > 0xffff) {
        PerlIO_printf(Perl_error_log,
        PerlIO_printf(Perl_error_log,
-                     "Allocation too large: %lx\n", size * count) FLUSH;
+                     "Allocation too large: %lx\n", total_size) FLUSH;
        my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
        my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
@@ -270,20 +294,28 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     if ((long)size < 0 || (long)count < 0)
        Perl_croak_nocontext("panic: calloc");
 #endif
     if ((long)size < 0 || (long)count < 0)
        Perl_croak_nocontext("panic: calloc");
 #endif
-    size *= count;
 #ifdef PERL_TRACK_MEMPOOL
 #ifdef PERL_TRACK_MEMPOOL
-    size += sTHX;
+    /* Have to use malloc() because we've added some space for our tracking
+       header.  */
+    /* malloc(0) is non-portable. */
+    ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
+#else
+    /* Use calloc() because it might save a memset() if the memory is fresh
+       and clean from the OS.  */
+    if (count && size)
+       ptr = (Malloc_t)PerlMem_calloc(count, size);
+    else /* calloc(0) is non-portable. */
+       ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 #endif
 #endif
-    ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
     PERL_ALLOC_CHECK(ptr);
-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
+    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
     if (ptr != NULL) {
     if (ptr != NULL) {
-       memset((void*)ptr, 0, size);
 #ifdef PERL_TRACK_MEMPOOL
        {
            struct perl_memory_debug_header *const header
                = (struct perl_memory_debug_header *)ptr;
 
 #ifdef PERL_TRACK_MEMPOOL
        {
            struct perl_memory_debug_header *const header
                = (struct perl_memory_debug_header *)ptr;
 
+           memset((void*)ptr, 0, total_size);
            header->interpreter = aTHX;
            /* Link us into the list.  */
            header->prev = &PL_memory_debug_header;
            header->interpreter = aTHX;
            /* Link us into the list.  */
            header->prev = &PL_memory_debug_header;
@@ -291,7 +323,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
            PL_memory_debug_header.next = header;
            header->next->prev = header;
 #  ifdef PERL_POISON
            PL_memory_debug_header.next = header;
            header->next->prev = header;
 #  ifdef PERL_POISON
-           header->size = size;
+           header->size = total_size;
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);
        }
 #  endif
            ptr = (Malloc_t)((char*)ptr+sTHX);
        }
@@ -342,6 +374,8 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
     register I32 tolen;
     PERL_UNUSED_CONTEXT;
 
     register I32 tolen;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_DELIMCPY;
+
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
            if (from[1] != delim) {
     for (tolen = 0; from < fromend; from++, tolen++) {
        if (*from == '\\') {
            if (from[1] != delim) {
@@ -371,6 +405,8 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
     register I32 first;
     PERL_UNUSED_CONTEXT;
 
     register I32 first;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_INSTR;
+
     if (!little)
        return (char*)big;
     first = *little++;
     if (!little)
        return (char*)big;
     first = *little++;
@@ -401,22 +437,23 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 char *
 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
 {
 char *
 Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
 {
+    PERL_ARGS_ASSERT_NINSTR;
     PERL_UNUSED_CONTEXT;
     if (little >= lend)
         return (char*)big;
     {
     PERL_UNUSED_CONTEXT;
     if (little >= lend)
         return (char*)big;
     {
-        char first = *little++;
+        const char first = *little;
         const char *s, *x;
         const char *s, *x;
-        bigend -= lend - little;
+        bigend -= lend - little++;
     OUTER:
         while (big <= bigend) {
     OUTER:
         while (big <= bigend) {
-            if (*big++ != first)
-                goto OUTER;
-            for (x=big,s=little; s < lend; x++,s++) {
-                if (*s != *x)
-                    goto OUTER;
+            if (*big++ == first) {
+                for (x=big,s=little; s < lend; x++,s++) {
+                    if (*s != *x)
+                        goto OUTER;
+                }
+                return (char*)(big-1);
             }
             }
-            return (char*)(big-1);
         }
     }
     return NULL;
         }
     }
     return NULL;
@@ -432,6 +469,8 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     register const char * const littleend = lend;
     PERL_UNUSED_CONTEXT;
 
     register const char * const littleend = lend;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_RNINSTR;
+
     if (little >= littleend)
        return (char*)bigend;
     bigbeg = big;
     if (little >= littleend)
        return (char*)bigend;
     bigbeg = big;
@@ -481,6 +520,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     U32 rarest = 0;
     U32 frequency = 256;
 
     U32 rarest = 0;
     U32 frequency = 256;
 
+    PERL_ARGS_ASSERT_FBM_COMPILE;
+
     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 (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() */
@@ -504,7 +545,6 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
        s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
            = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
        s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
-       BmFLAGS(sv) = (U8)flags;
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
        i = 0;
        sb = s - mlen + 1;                      /* first char (maybe) */
        while (s >= sb) {
@@ -524,6 +564,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            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 */
     BmRARE(sv) = s[rarest];
     BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
@@ -558,6 +599,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
+    PERL_ARGS_ASSERT_FBM_INSTR;
+
     if ((STRLEN)(bigend - big) < littlelen) {
        if ( SvTAIL(littlestr)
             && ((STRLEN)(bigend - big) == littlelen - 1)
     if ((STRLEN)(bigend - big) < littlelen) {
        if ( SvTAIL(littlestr)
             && ((STRLEN)(bigend - big) == littlelen - 1)
@@ -761,6 +804,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     register const unsigned char *littleend;
     I32 found = 0;
 
     register const unsigned char *littleend;
     I32 found = 0;
 
+    PERL_ARGS_ASSERT_SCREAMINSTR;
+
     assert(SvTYPE(littlestr) == SVt_PVGV);
     assert(SvVALID(littlestr));
 
     assert(SvTYPE(littlestr) == SVt_PVGV);
     assert(SvVALID(littlestr));
 
@@ -769,7 +814,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
        if ( BmRARE(littlestr) == '\n'
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
       cant_find:
        if ( BmRARE(littlestr) == '\n'
-            && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) {
+            && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
            little = (const unsigned char *)(SvPVX_const(littlestr));
            littleend = little + SvCUR(littlestr);
            first = *little++;
            little = (const unsigned char *)(SvPVX_const(littlestr));
            littleend = little + SvCUR(littlestr);
            first = *little++;
@@ -844,6 +889,8 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
     register const U8 *b = (const U8 *)s2;
     PERL_UNUSED_CONTEXT;
 
     register const U8 *b = (const U8 *)s2;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_IBCMP;
+
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
            return 1;
@@ -860,6 +907,8 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
     register const U8 *b = (const U8 *)s2;
     PERL_UNUSED_CONTEXT;
 
     register const U8 *b = (const U8 *)s2;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_IBCMP_LOCALE;
+
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
            return 1;
@@ -953,6 +1002,29 @@ Perl_savesharedpv(pTHX_ const char *pv)
 }
 
 /*
 }
 
 /*
+=for apidoc savesharedpvn
+
+A version of C<savepvn()> which allocates the duplicate string in memory
+which is shared between threads. (With the specific difference that a NULL
+pointer is not acceptable)
+
+=cut
+*/
+char *
+Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
+{
+    char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
+
+    PERL_ARGS_ASSERT_SAVESHAREDPVN;
+
+    if (!newaddr) {
+       return write_no_mem();
+    }
+    newaddr[len] = '\0';
+    return (char*)memcpy(newaddr, pv, len);
+}
+
+/*
 =for apidoc savesvpv
 
 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
 =for apidoc savesvpv
 
 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
@@ -968,6 +1040,8 @@ Perl_savesvpv(pTHX_ SV *sv)
     const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
     const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
+    PERL_ARGS_ASSERT_SAVESVPV;
+
     ++len;
     Newx(newaddr,len,char);
     return (char *) CopyD(pv,newaddr,len,char);
     ++len;
     Newx(newaddr,len,char);
     return (char *) CopyD(pv,newaddr,len,char);
@@ -984,7 +1058,7 @@ S_mess_alloc(pTHX)
     XPVMG *any;
 
     if (!PL_dirty)
     XPVMG *any;
 
     if (!PL_dirty)
-       return sv_2mortal(newSVpvs(""));
+       return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return PL_mess_sv;
 
     if (PL_mess_sv)
        return PL_mess_sv;
@@ -1007,6 +1081,7 @@ Perl_form_nocontext(const char* pat, ...)
     dTHX;
     char *retval;
     va_list args;
     dTHX;
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM_NOCONTEXT;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1039,6 +1114,7 @@ Perl_form(pTHX_ const char* pat, ...)
 {
     char *retval;
     va_list args;
 {
     char *retval;
     va_list args;
+    PERL_ARGS_ASSERT_FORM;
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vform(pat, &args);
     va_end(args);
@@ -1049,6 +1125,7 @@ char *
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
 Perl_vform(pTHX_ const char *pat, va_list *args)
 {
     SV * const sv = mess_alloc();
+    PERL_ARGS_ASSERT_VFORM;
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     return SvPVX(sv);
 }
@@ -1060,6 +1137,7 @@ Perl_mess_nocontext(const char *pat, ...)
     dTHX;
     SV *retval;
     va_list args;
     dTHX;
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS_NOCONTEXT;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1072,6 +1150,7 @@ Perl_mess(pTHX_ const char *pat, ...)
 {
     SV *retval;
     va_list args;
 {
     SV *retval;
     va_list args;
+    PERL_ARGS_ASSERT_MESS;
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
     va_start(args, pat);
     retval = vmess(pat, &args);
     va_end(args);
@@ -1084,6 +1163,8 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o)
     dVAR;
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
     dVAR;
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
+    PERL_ARGS_ASSERT_CLOSEST_COP;
+
     if (!o || o == PL_op)
        return cop;
 
     if (!o || o == PL_op)
        return cop;
 
@@ -1117,6 +1198,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     dVAR;
     SV * const sv = mess_alloc();
 
     dVAR;
     SV * const sv = mess_alloc();
 
+    PERL_ARGS_ASSERT_VMESS;
+
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        /*
@@ -1133,7 +1216,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
        if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
            OutCopFILE(cop), (IV)CopLINE(cop));
-       if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+       /* Seems that GvIO() can be untrustworthy during global destruction. */
+       if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
+               && IoLINES(GvIOp(PL_last_in_gv)))
+       {
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
            const bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
@@ -1155,9 +1241,11 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     IO *io;
     MAGIC *mg;
 
     IO *io;
     MAGIC *mg;
 
+    PERL_ARGS_ASSERT_WRITE_TO_STDERR;
+
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
-       && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 
+       && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     {
        dSP;
        ENTER;
     {
        dSP;
        ENTER;
@@ -1171,8 +1259,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
        PUSHMARK(SP);
        EXTEND(SP,2);
 
        PUSHMARK(SP);
        EXTEND(SP,2);
-       PUSHs(SvTIED_obj((SV*)io, mg));
-       PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+       PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+       mPUSHp(message, msglen);
        PUTBACK;
        call_method("PRINT", G_SCALAR);
 
        PUTBACK;
        call_method("PRINT", G_SCALAR);
 
@@ -1183,14 +1271,14 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
-       const int e = errno;
+       dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
 
        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
 #endif
        PerlIO * const serr = Perl_error_log;
 
        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
-       errno = e;
+       RESTORE_ERRNO;
 #endif
     }
 }
 #endif
     }
 }
@@ -1226,8 +1314,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
            *hook = NULL;
        }
        if (warn || message) {
            *hook = NULL;
        }
        if (warn || message) {
-           msg = newSVpvn(message, msglen);
-           SvFLAGS(msg) |= utf8;
+           msg = newSVpvn_flags(message, msglen, utf8);
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
        }
            SvREADONLY_on(msg);
            SAVEFREESV(msg);
        }
@@ -1239,7 +1326,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
        PUSHMARK(SP);
        XPUSHs(msg);
        PUTBACK;
-       call_sv((SV*)cv, G_DISCARD);
+       call_sv(MUTABLE_SV(cv), G_DISCARD);
        POPSTACK;
        LEAVE;
        return TRUE;
        POPSTACK;
        LEAVE;
        return TRUE;
@@ -1269,17 +1356,14 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
        message = NULL;
     }
 
        message = NULL;
     }
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
     if (PL_diehook) {
        S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
 
     if (PL_diehook) {
        S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     return message;
 }
 
-OP *
-Perl_vdie(pTHX_ const char* pat, va_list *args)
+static OP *
+S_vdie(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
     const char *message;
 {
     dVAR;
     const char *message;
@@ -1287,17 +1371,10 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
     STRLEN msglen;
     I32 utf8 = 0;
 
     STRLEN msglen;
     I32 utf8 = 0;
 
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die: curstack = %p, mainstack = %p\n",
-                         thr, PL_curstack, PL_mainstack));
-
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
     PL_restartop = die_where(message, msglen);
     SvFLAGS(ERRSV) |= utf8;
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-         "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
-         thr, PL_restartop, was_in_eval, PL_top_env));
     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
        JMPENV_JUMP(3);
     return PL_restartop;
     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
        JMPENV_JUMP(3);
     return PL_restartop;
@@ -1310,6 +1387,7 @@ Perl_die_nocontext(const char* pat, ...)
     dTHX;
     OP *o;
     va_list args;
     dTHX;
     OP *o;
     va_list args;
+    PERL_ARGS_ASSERT_DIE_NOCONTEXT;
     va_start(args, pat);
     o = vdie(pat, &args);
     va_end(args);
     va_start(args, pat);
     o = vdie(pat, &args);
     va_end(args);
@@ -1376,7 +1454,7 @@ sidestepping the normal C order of execution. See C<warn>.
 If you want to throw an exception object, assign the object to
 C<$@> and then pass C<NULL> to croak():
 
 If you want to throw an exception object, assign the object to
 C<$@> and then pass C<NULL> to croak():
 
-   errsv = get_sv("@", TRUE);
+   errsv = get_sv("@", GV_ADD);
    sv_setsv(errsv, exception_object);
    croak(NULL);
 
    sv_setsv(errsv, exception_object);
    croak(NULL);
 
@@ -1402,6 +1480,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     const I32 utf8 = SvUTF8(msv);
     const char * const message = SvPV_const(msv, msglen);
 
     const I32 utf8 = SvUTF8(msv);
     const char * const message = SvPV_const(msv, msglen);
 
+    PERL_ARGS_ASSERT_VWARN;
+
     if (PL_warnhook) {
        if (vdie_common(message, msglen, utf8, TRUE))
            return;
     if (PL_warnhook) {
        if (vdie_common(message, msglen, utf8, TRUE))
            return;
@@ -1416,6 +1496,7 @@ Perl_warn_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
 {
     dTHX;
     va_list args;
+    PERL_ARGS_ASSERT_WARN_NOCONTEXT;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1435,6 +1516,7 @@ void
 Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
 Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARN;
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarn(pat, &args);
     va_end(args);
@@ -1446,6 +1528,7 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 {
     dTHX; 
     va_list args;
 {
     dTHX; 
     va_list args;
+    PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1456,6 +1539,7 @@ void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_WARNER;
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
     va_start(args, pat);
     vwarner(err, pat, &args);
     va_end(args);
@@ -1465,6 +1549,7 @@ void
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
+    PERL_ARGS_ASSERT_VWARNER;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
        STRLEN msglen;
     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
        SV * const msv = vmess(pat, args);
        STRLEN msglen;
@@ -1546,6 +1631,7 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
                           STRLEN size) {
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
                           STRLEN size) {
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
 
     buffer = (STRLEN*)
        (specialWARN(buffer) ?
 
     buffer = (STRLEN*)
        (specialWARN(buffer) ?
@@ -1581,9 +1667,16 @@ 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=setenv_getix(nam);          /* where does it go? */
+    register I32 i;
+    register const I32 len = strlen(nam);
     int nlen, vlen;
 
     int nlen, vlen;
 
+    /* where does it go? */
+    for (i = 0; environ[i]; i++) {
+        if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+            break;
+    }
+
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
     if (environ == PL_origenviron) {   /* need we copy environment? */
        I32 j;
        I32 max;
@@ -1687,28 +1780,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 
 #endif /* WIN32 || NETWARE */
 
 
 #endif /* WIN32 || NETWARE */
 
-#ifndef PERL_MICRO
-I32
-Perl_setenv_getix(pTHX_ const char *nam)
-{
-    register I32 i;
-    register const I32 len = strlen(nam);
-    PERL_UNUSED_CONTEXT;
-
-    for (i = 0; environ[i]; i++) {
-       if (
-#ifdef WIN32
-           strnicmp(environ[i],nam,len) == 0
-#else
-           strnEQ(environ[i],nam,len)
-#endif
-           && environ[i][len] == '=')
-           break;                      /* strnEQ must come first to avoid */
-    }                                  /* potential SEGV's */
-    return i;
-}
-#endif /* !PERL_MICRO */
-
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
 #endif /* !VMS && !EPOC*/
 
 #ifdef UNLINK_ALL_VERSIONS
@@ -1717,6 +1788,8 @@ Perl_unlnk(pTHX_ const char *f)   /* unlink all versions of a file */
 {
     I32 retries = 0;
 
 {
     I32 retries = 0;
 
+    PERL_ARGS_ASSERT_UNLNK;
+
     while (PerlLIO_unlink(f) >= 0)
        retries++;
     return retries ? 0 : -1;
     while (PerlLIO_unlink(f) >= 0)
        retries++;
     return retries ? 0 : -1;
@@ -1730,6 +1803,8 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len)
 {
     char * const retval = to;
 
 {
     char * const retval = to;
 
+    PERL_ARGS_ASSERT_MY_BCOPY;
+
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
     if (from - to >= 0) {
        while (len--)
            *to++ = *from++;
@@ -1751,6 +1826,8 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len)
 {
     char * const retval = loc;
 
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_MEMSET;
+
     while (len--)
        *loc++ = ch;
     return retval;
     while (len--)
        *loc++ = ch;
     return retval;
@@ -1764,6 +1841,8 @@ Perl_my_bzero(register char *loc, register I32 len)
 {
     char * const retval = loc;
 
 {
     char * const retval = loc;
 
+    PERL_ARGS_ASSERT_MY_BZERO;
+
     while (len--)
        *loc++ = 0;
     return retval;
     while (len--)
        *loc++ = 0;
     return retval;
@@ -1779,6 +1858,8 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
     register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
     register const U8 *b = (const U8 *)s2;
     register I32 tmp;
 
+    PERL_ARGS_ASSERT_MY_MEMCMP;
+
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
     while (len--) {
         if ((tmp = *a++ - *b++))
            return tmp;
@@ -1788,24 +1869,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
 #ifndef HAS_VPRINTF
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
 #ifndef HAS_VPRINTF
+/* This vsprintf replacement should generally never get used, since
+   vsprintf was available in both System V and BSD 2.11.  (There may
+   be some cross-compilation or embedded set-ups where it is needed,
+   however.)
+
+   If you encounter a problem in this function, it's probably a symptom
+   that Configure failed to detect your system's vprintf() function.
+   See the section on "item vsprintf" in the INSTALL file.
+
+   This version may compile on systems with BSD-ish <stdio.h>,
+   but probably won't on others.
+*/
 
 #ifdef USE_CHAR_VSPRINTF
 char *
 #else
 int
 #endif
 
 #ifdef USE_CHAR_VSPRINTF
 char *
 #else
 int
 #endif
-vsprintf(char *dest, const char *pat, char *args)
+vsprintf(char *dest, const char *pat, void *args)
 {
     FILE fakebuf;
 
 {
     FILE fakebuf;
 
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+    FILE_ptr(&fakebuf) = (STDCHAR *) dest;
+    FILE_cnt(&fakebuf) = 32767;
+#else
+    /* These probably won't compile -- If you really need
+       this, you'll have to figure out some other method. */
     fakebuf._ptr = dest;
     fakebuf._cnt = 32767;
     fakebuf._ptr = dest;
     fakebuf._cnt = 32767;
+#endif
 #ifndef _IOSTRG
 #define _IOSTRG 0
 #endif
     fakebuf._flag = _IOWRT|_IOSTRG;
     _doprnt(pat, args, &fakebuf);      /* what a kludge */
 #ifndef _IOSTRG
 #define _IOSTRG 0
 #endif
     fakebuf._flag = _IOWRT|_IOSTRG;
     _doprnt(pat, args, &fakebuf);      /* what a kludge */
-    (void)putc('\0', &fakebuf);
+#if defined(STDIO_PTR_LVALUE)
+    *(FILE_ptr(&fakebuf)++) = '\0';
+#else
+    /* PerlIO has probably #defined away fputc, but we want it here. */
+#  ifdef fputc
+#    undef fputc  /* XXX Should really restore it later */
+#  endif
+    (void)fputc('\0', &fakebuf);
+#endif
 #ifdef USE_CHAR_VSPRINTF
     return(dest);
 #else
 #ifdef USE_CHAR_VSPRINTF
     return(dest);
 #else
@@ -1838,7 +1946,10 @@ Perl_my_htonl(pTHX_ long l)
        char c[sizeof(long)];
     } u;
 
        char c[sizeof(long)];
     } u;
 
-#if BYTEORDER == 0x1234
+#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[0] = (l >> 24) & 255;
     u.c[1] = (l >> 16) & 255;
     u.c[2] = (l >> 8) & 255;
@@ -2132,6 +2243,8 @@ Perl_my_swabn(void *ptr, int n)
     register char *e = s + (n-1);
     register char tc;
 
     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;
     for (n /= 2; n > 0; s++, e--, n--) {
       tc = *s;
       *s = *e;
@@ -2140,9 +2253,9 @@ Perl_my_swabn(void *ptr, int n)
 }
 
 PerlIO *
 }
 
 PerlIO *
-Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+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(MACOS_TRADITIONAL) && !defined(NETWARE)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
     dVAR;
     int p[2];
     register I32 This, that;
     dVAR;
     int p[2];
     register I32 This, that;
@@ -2151,6 +2264,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     I32 did_pipes = 0;
     int pp[2];
 
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN_LIST;
+
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
     PERL_FLUSHALL_FOR_CHILD;
     This = (*mode == 'w');
     that = !This;
@@ -2173,6 +2288,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
            }
            return NULL;
        }
            }
            return NULL;
        }
+       if (ckWARN(WARN_PIPE))
+           Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2269,7 +2386,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     return PerlIO_fdopen(p[This], mode);
 #else
 #  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
     return PerlIO_fdopen(p[This], mode);
 #else
 #  ifdef OS2   /* Same, without fork()ing and all extra overhead... */
-    return my_syspopen4(aTHX_ Nullch, mode, n, args);
+    return my_syspopen4(aTHX_ NULL, mode, n, args);
 #  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
 #  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
@@ -2278,7 +2395,7 @@ Perl_my_popen_list(pTHX_ 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(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
 PerlIO *
 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
@@ -2291,6 +2408,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
     I32 did_pipes = 0;
     int pp[2];
 
     I32 did_pipes = 0;
     int pp[2];
 
+    PERL_ARGS_ASSERT_MY_POPEN;
+
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
     PERL_FLUSHALL_FOR_CHILD;
 #ifdef OS2
     if (doexec) {
@@ -2316,9 +2435,11 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
                PerlLIO_close(pp[1]);
            }
            if (!doexec)
-               Perl_croak(aTHX_ "Can't fork");
+               Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
            return NULL;
        }
            return NULL;
        }
+       if (ckWARN(WARN_PIPE))
+           Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
        sleep(5);
     }
     if (pid == 0) {
        sleep(5);
     }
     if (pid == 0) {
@@ -2437,8 +2558,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
 #if defined(atarist) || defined(EPOC)
 FILE *popen();
 PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+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;
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
        used 0 for 2nd parameter to PerlIO_importFILE;
@@ -2450,7 +2572,7 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen((pTHX_ const char *cmd, const char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
 {
     PERL_FLUSHALL_FOR_CHILD;
     /* Call system's popen() to get a FILE *, then import it.
@@ -2459,6 +2581,14 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode)
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
     */
     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+PerlIO *
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
+{
+    return NULL;
+}
+#endif
 #endif
 #endif
 
 #endif
 #endif
 
@@ -2516,11 +2646,13 @@ Perl_my_fork(void)
 
 #ifdef DUMP_FDS
 void
 
 #ifdef DUMP_FDS
 void
-Perl_dump_fds(pTHX_ char *s)
+Perl_dump_fds(pTHX_ const char *const s)
 {
     int fd;
     Stat_t tmpstatbuf;
 
 {
     int fd;
     Stat_t tmpstatbuf;
 
+    PERL_ARGS_ASSERT_DUMP_FDS;
+
     PerlIO_printf(Perl_debug_log,"%s", s);
     for (fd = 0; fd < 32; fd++) {
        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
     PerlIO_printf(Perl_debug_log,"%s", s);
     for (fd = 0; fd < 32; fd++) {
        if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
@@ -2620,6 +2752,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
     dVAR;
     struct sigaction act;
 
     dVAR;
     struct sigaction act;
 
+    PERL_ARGS_ASSERT_RSIGNAL_SAVE;
+
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
 #ifdef USE_ITHREADS
     /* only "parent" interpreter can diddle signals */
     if (PL_curinterp != aTHX)
@@ -2721,7 +2855,7 @@ 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(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
 I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
@@ -2732,10 +2866,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
     Pid_t pid;
     Pid_t pid2;
     bool close_failed;
-    int saved_errno = 0;
-#ifdef WIN32
-    int saved_win32_errno;
-#endif
+    dSAVEDERRNO;
 
     LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
 
     LOCK_FDPID_MUTEX;
     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
@@ -2748,12 +2879,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
        return my_syspclose(ptr);
     }
 #endif
        return my_syspclose(ptr);
     }
 #endif
-    if ((close_failed = (PerlIO_close(ptr) == EOF))) {
-       saved_errno = errno;
-#ifdef WIN32
-       saved_win32_errno = GetLastError();
-#endif
-    }
+    close_failed = (PerlIO_close(ptr) == EOF);
+    SAVE_ERRNO;
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
 #ifdef UTS
     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
 #endif
@@ -2771,19 +2898,28 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
-       SETERRNO(saved_errno, 0);
+       RESTORE_ERRNO;
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
+#else
+#if defined(__LIBCATAMOUNT__)
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+    return -1;
+}
+#endif
 #endif /* !DOSISH */
 
 #endif /* !DOSISH */
 
-#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
+#if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     dVAR;
     I32 result = 0;
 I32
 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 {
     dVAR;
     I32 result = 0;
+    PERL_ARGS_ASSERT_WAIT4PID;
     if (!pid)
        return -1;
 #ifdef PERL_USES_PL_PIDSTATUS
     if (!pid)
        return -1;
 #ifdef PERL_USES_PL_PIDSTATUS
@@ -2856,6 +2992,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 #endif
     if (result < 0 && errno == EINTR) {
        PERL_ASYNC_CHECK();
 #endif
     if (result < 0 && errno == EINTR) {
        PERL_ASYNC_CHECK();
+       errno = EINTR; /* reset in case a signal handler changed $! */
     }
     return result;
 }
     }
     return result;
 }
@@ -2863,7 +3000,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
 #ifdef PERL_USES_PL_PIDSTATUS
 void
 
 #ifdef PERL_USES_PL_PIDSTATUS
 void
-Perl_pidgone(pTHX_ Pid_t pid, int status)
+S_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
 
 {
     register SV *sv;
 
@@ -2914,6 +3051,8 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi
     register const char * const frombase = from;
     PERL_UNUSED_CONTEXT;
 
     register const char * const frombase = from;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_REPEATCPY;
+
     if (len == 1) {
        register const char c = *from;
        while (count-- > 0)
     if (len == 1) {
        register const char c = *from;
        while (count-- > 0)
@@ -2938,6 +3077,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     Stat_t tmpstatbuf2;
     SV * const tmpsv = sv_newmortal();
 
     Stat_t tmpstatbuf2;
     SV * const tmpsv = sv_newmortal();
 
+    PERL_ARGS_ASSERT_SAME_DIRENT;
+
     if (fa)
        fa++;
     else
     if (fa)
        fa++;
     else
@@ -2949,13 +3090,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
-       sv_setpvn(tmpsv, ".", 1);
+       sv_setpvs(tmpsv, ".");
     else
        sv_setpvn(tmpsv, a, fa - a);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
     else
        sv_setpvn(tmpsv, a, fa - a);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
-       sv_setpvn(tmpsv, ".", 1);
+       sv_setpvs(tmpsv, ".");
     else
        sv_setpvn(tmpsv, b, fb - b);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
     else
        sv_setpvn(tmpsv, b, fb - b);
     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
@@ -2976,6 +3117,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     register char *s;
     I32 len = 0;
     int retval;
     register char *s;
     I32 len = 0;
     int retval;
+    char *bufend;
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
 #  define SEARCH_EXTS ".bat", ".cmd", NULL
 #  define MAX_EXT_LEN 4
@@ -2999,6 +3141,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #  define MAX_EXT_LEN 0
 #endif
 
 #  define MAX_EXT_LEN 0
 #endif
 
+    PERL_ARGS_ASSERT_FIND_SCRIPT;
+
     /*
      * If dosearch is true and if scriptname does not contain path
      * delimiters, search the PATH for scriptname.
     /*
      * If dosearch is true and if scriptname does not contain path
      * delimiters, search the PATH for scriptname.
@@ -3100,10 +3244,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
     {
        bool seen_dot = 0;
 
     {
        bool seen_dot = 0;
 
-       PL_bufend = s + strlen(s);
-       while (s < PL_bufend) {
+       bufend = s + strlen(s);
+       while (s < bufend) {
 #ifdef MACOS_TRADITIONAL
 #ifdef MACOS_TRADITIONAL
-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                        ',',
                        &len);
 #else
                        ',',
                        &len);
 #else
@@ -3119,12 +3263,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
            if (len < sizeof tmpbuf)
                tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
-           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+           s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
 #endif /* MACOS_TRADITIONAL */
                        ':',
                        &len);
 #endif /* ! (atarist || DOSISH) */
 #endif /* MACOS_TRADITIONAL */
-           if (s < PL_bufend)
+           if (s < bufend)
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
                s++;
            if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
@@ -3227,6 +3371,7 @@ void
 Perl_set_context(void *t)
 {
     dVAR;
 Perl_set_context(void *t)
 {
     dVAR;
+    PERL_ARGS_ASSERT_SET_CONTEXT;
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
@@ -3291,6 +3436,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
     PERL_UNUSED_CONTEXT;
 {
     char * const env_trans = PerlEnv_getenv(env_elem);
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_GETENV_LEN;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
@@ -3588,11 +3734,13 @@ Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
     const struct tm* my_tm;
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
     const struct tm* my_tm;
+    PERL_ARGS_ASSERT_INIT_TM;
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
 #else
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
 #else
+    PERL_ARGS_ASSERT_INIT_TM;
     PERL_UNUSED_ARG(ptm);
 #endif
 }
     PERL_UNUSED_ARG(ptm);
 #endif
 }
@@ -3610,6 +3758,8 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
     int odd_cent, odd_year;
     PERL_UNUSED_CONTEXT;
 
     int odd_cent, odd_year;
     PERL_UNUSED_CONTEXT;
 
+    PERL_ARGS_ASSERT_MINI_MKTIME;
+
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
 #define        DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
 #define        DAYS_PER_YEAR   365
 #define        DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
 #define        DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
@@ -3804,6 +3954,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   struct tm mytm;
   int len;
 
   struct tm mytm;
   int len;
 
+  PERL_ARGS_ASSERT_MY_STRFTIME;
+
   init_tm(&mytm);      /* XXX workaround - see init_tm() above */
   mytm.tm_sec = sec;
   mytm.tm_min = min;
   init_tm(&mytm);      /* XXX workaround - see init_tm() above */
   mytm.tm_sec = sec;
   mytm.tm_min = min;
@@ -3911,6 +4063,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
     SvTAINTED_on(sv);
 #endif
 
     SvTAINTED_on(sv);
 #endif
 
+    PERL_ARGS_ASSERT_GETCWD_SV;
+
 #ifdef HAS_GETCWD
     {
        char buf[MAXPATHLEN];
 #ifdef HAS_GETCWD
     {
        char buf[MAXPATHLEN];
@@ -4048,6 +4202,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
 #endif
 }
 
+#define VERSION_MAX 0x7FFFFFFF
 /*
 =for apidoc scan_version
 
 /*
 =for apidoc scan_version
 
@@ -4058,12 +4213,12 @@ an RV.
 Function must be called with an already existing SV like
 
     sv = newSV(0);
 Function must be called with an already existing SV like
 
     sv = newSV(0);
-    s = scan_version(s,SV *sv, bool qv);
+    s = scan_version(s, SV *sv, bool qv);
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
 
 Performs some preprocessing to the string to ensure that
 it has the correct characteristics of a version.  Flags the
 object if it contains an underscore (which denotes this
-is a alpha version).  The boolean qv denotes that the version
+is an alpha version).  The boolean qv denotes that the version
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
 should be interpreted as if it had multiple decimals, even if
 it doesn't.
 
@@ -4079,23 +4234,25 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
+    bool vinf = FALSE;
     AV * const av = newAV();
     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     AV * const av = newAV();
     SV * const 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
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
 
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
+    start = last = s;
+
     if (*s == 'v') {
        s++;  /* get past 'v' */
        qv = 1; /* force quoted version processing */
     }
 
     if (*s == 'v') {
        s++;  /* get past 'v' */
        qv = 1; /* force quoted version processing */
     }
 
-    start = last = pos = s;
+    pos = s;
 
     /* pre-scan the input string to check for decimals/underbars */
     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
 
     /* pre-scan the input string to check for decimals/underbars */
     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
@@ -4120,17 +4277,21 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( alpha && !saw_period )
        Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
 
     if ( alpha && !saw_period )
        Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
 
+    if ( alpha && saw_period && width == 0 )
+       Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
+
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
     if ( saw_period > 1 )
        qv = 1; /* force quoted version processing */
 
+    last = pos;
     pos = s;
 
     if ( qv )
     pos = s;
 
     if ( qv )
-       hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
     if ( alpha )
-       hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
     if ( !qv && width < 3 )
-       hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
     
     while (isDIGIT(*pos))
        pos++;
     
     while (isDIGIT(*pos))
        pos++;
@@ -4143,7 +4304,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                /* this is atoi() that delimits on underscores */
                const char *end = pos;
                I32 mult = 1;
                /* this is atoi() that delimits on underscores */
                const char *end = pos;
                I32 mult = 1;
-               I32 orev;
+               I32 orev;
 
                /* the following if() will only be true after the decimal
                 * point of a version originally created with a bare
 
                /* the following if() will only be true after the decimal
                 * point of a version originally created with a bare
@@ -4152,11 +4313,18 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                if ( !qv && s > start && saw_period == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
                if ( !qv && s > start && saw_period == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
-                       orev = rev;
+                       orev = rev;
                        rev += (*s - '0') * mult;
                        mult /= 10;
                        rev += (*s - '0') * mult;
                        mult /= 10;
-                       if ( PERL_ABS(orev) > PERL_ABS(rev) )
-                           Perl_croak(aTHX_ "Integer overflow in version");
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           if(ckWARN(WARN_OVERFLOW))
+                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                               "Integer overflow in version %d",VERSION_MAX);
+                           s = end - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
                        s++;
                        if ( *s == '_' )
                            s++;
                        s++;
                        if ( *s == '_' )
                            s++;
@@ -4164,18 +4332,29 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                }
                else {
                    while (--end >= s) {
                }
                else {
                    while (--end >= s) {
-                       orev = rev;
+                       orev = rev;
                        rev += (*end - '0') * mult;
                        mult *= 10;
                        rev += (*end - '0') * mult;
                        mult *= 10;
-                       if ( PERL_ABS(orev) > PERL_ABS(rev) )
-                           Perl_croak(aTHX_ "Integer overflow in version");
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           if(ckWARN(WARN_OVERFLOW))
+                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                               "Integer overflow in version");
+                           end = s - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
                    }
                } 
            }
 
            /* Append revision */
            av_push(av, newSViv(rev));
                    }
                } 
            }
 
            /* Append revision */
            av_push(av, newSViv(rev));
-           if ( *pos == '.' )
+           if ( vinf ) {
+               s = last;
+               break;
+           }
+           else if ( *pos == '.' )
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
                s = ++pos;
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
@@ -4206,23 +4385,40 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
           Compiler in question is:
           gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
           for ( len = 2 - len; len > 0; len-- )
           Compiler in question is:
           gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
           for ( len = 2 - len; len > 0; len-- )
-          av_push((AV *)sv, newSViv(0));
+          av_push(MUTABLE_AV(sv), newSViv(0));
        */
        len = 2 - len;
        while (len-- > 0)
            av_push(av, newSViv(0));
     }
 
        */
        len = 2 - len;
        while (len-- > 0)
            av_push(av, newSViv(0));
     }
 
-    if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
+    /* need to save off the current version string for later */
+    if ( vinf ) {
+       SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+       (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+    }
+    else if ( s > start ) {
+       SV * orig = newSVpvn(start,s-start);
+       if ( qv && saw_period == 1 && *start != 'v' ) {
+           /* need to insert a v to be consistent */
+           sv_insert(orig, 0, 0, "v", 1);
+       }
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+    }
+    else {
+       (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
        av_push(av, newSViv(0));
        av_push(av, newSViv(0));
+    }
+
+    /* And finally, store the AV in the hash */
+    (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 
     /* fix RT#19517 - special case 'undef' as string */
     if ( *s == 'u' && strEQ(s,"undef") ) {
        s += 5;
     }
 
 
     /* fix RT#19517 - special case 'undef' as string */
     if ( *s == 'u' && strEQ(s,"undef") ) {
        s += 5;
     }
 
-    /* And finally, store the AV in the hash */
-    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
     return s;
 }
 
     return s;
 }
 
@@ -4244,6 +4440,7 @@ Perl_new_version(pTHX_ SV *ver)
 {
     dVAR;
     SV * const rv = newSV(0);
 {
     dVAR;
     SV * const rv = newSV(0);
+    PERL_ARGS_ASSERT_NEW_VERSION;
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
        I32 key;
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
        I32 key;
@@ -4252,27 +4449,30 @@ Perl_new_version(pTHX_ SV *ver)
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
        /* This will get reblessed later if a derived class*/
        SV * const hv = newSVrv(rv, "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
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
 
        /* Begin copying all of the elements */
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
 
        /* Begin copying all of the elements */
-       if ( hv_exists((HV *)ver, "qv", 2) )
-           hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
+       if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+           (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
 
 
-       if ( hv_exists((HV *)ver, "alpha", 5) )
-           hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
+       if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+           (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
        
        
-       if ( hv_exists((HV*)ver, "width", 5 ) )
+       if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
+       {
+           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+       }
+
+       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
        {
        {
-           const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
-           hv_store((HV *)hv, "width", 5, newSViv(width), 0);
+           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
        }
 
        }
 
-       sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
+       sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
@@ -4280,7 +4480,7 @@ Perl_new_version(pTHX_ SV *ver)
            av_push(av, newSViv(rev));
        }
 
            av_push(av, newSViv(rev));
        }
 
-       hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+       (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
        return rv;
     }
 #ifdef SvVOK
        return rv;
     }
 #ifdef SvVOK
@@ -4290,6 +4490,9 @@ Perl_new_version(pTHX_ SV *ver)
            const STRLEN len = mg->mg_len;
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
            const STRLEN len = mg->mg_len;
            char * const version = savepvn( (const char*)mg->mg_ptr, len);
            sv_setpvn(rv,version,len);
+           /* this is for consistency with the pure Perl class */
+           if ( *version != 'v' ) 
+               sv_insert(rv, 0, 0, "v", 1);
            Safefree(version);
        }
        else {
            Safefree(version);
        }
        else {
@@ -4299,7 +4502,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4307,24 +4510,27 @@ Perl_new_version(pTHX_ SV *ver)
 
 In-place upgrade of the supplied SV to a version object.
 
 
 In-place upgrade of the supplied SV to a version object.
 
-    SV *sv = upg_version(SV *sv);
+    SV *sv = upg_version(SV *sv, bool qv);
 
 
-Returns a pointer to the upgraded SV.
+Returns a pointer to the upgraded SV.  Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
 
 =cut
 */
 
 SV *
 
 =cut
 */
 
 SV *
-Perl_upg_version(pTHX_ SV *ver)
+Perl_upg_version(pTHX_ SV *ver, bool qv)
 {
     const char *version, *s;
 {
     const char *version, *s;
-    bool qv = 0;
 #ifdef SvVOK
     const MAGIC *mg;
 #endif
 
 #ifdef SvVOK
     const MAGIC *mg;
 #endif
 
-    if ( SvNOK(ver) ) /* may get too much accuracy */ 
+    PERL_ARGS_ASSERT_UPG_VERSION;
+
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
     {
+       /* may get too much accuracy */ 
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
@@ -4334,6 +4540,7 @@ Perl_upg_version(pTHX_ SV *ver)
        setlocale(LC_NUMERIC, loc);
 #endif
        while (tbuf[len-1] == '0' && len > 0) len--;
        setlocale(LC_NUMERIC, loc);
 #endif
        while (tbuf[len-1] == '0' && len > 0) len--;
+       if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
        version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
@@ -4344,7 +4551,36 @@ Perl_upg_version(pTHX_ SV *ver)
 #endif
     else /* must be a string or something like a string */
     {
 #endif
     else /* must be a string or something like a string */
     {
-       version = savepv(SvPV_nolen(ver));
+       STRLEN len;
+       version = savepv(SvPV(ver,len));
+#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,"_") ) {
+           /* may be a v-string */
+           SV * const nsv = sv_newmortal();
+           const char *nver;
+           const char *pos;
+           int saw_period = 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_period++ ;
+               pos++;
+           }
+
+           /* is definitely a v-string */
+           if ( saw_period == 2 ) {    
+               Safefree(version);
+               version = nver;
+           }
+       }
+#  endif
+#endif
     }
 
     s = scan_version(version, ver, qv);
     }
 
     s = scan_version(version, ver, qv);
@@ -4384,13 +4620,16 @@ bool
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
+
+    PERL_ARGS_ASSERT_VVERIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
-        && hv_exists((HV*)vs, "version", 7)
-        && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
+        && hv_exists(MUTABLE_HV(vs), "version", 7)
+        && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
         && SvTYPE(sv) == SVt_PVAV )
        return TRUE;
     else
@@ -4419,6 +4658,9 @@ Perl_vnumify(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNUMIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
@@ -4426,16 +4668,16 @@ Perl_vnumify(pTHX_ SV *vs)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
        alpha = TRUE;
-    if ( hv_exists((HV*)vs, "width", 5 ) )
-       width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
+    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+       width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
     else
        width = 3;
 
 
     /* attempt to retrieve the version array */
     else
        width = 3;
 
 
     /* attempt to retrieve the version array */
-    if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
+    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
        sv_catpvs(sv,"0");
        return sv;
     }
        sv_catpvs(sv,"0");
        return sv;
     }
@@ -4497,15 +4739,18 @@ Perl_vnormal(pTHX_ SV *vs)
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
     bool alpha = FALSE;
     SV * const sv = newSV(0);
     AV *av;
+
+    PERL_ARGS_ASSERT_VNORMAL;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( SvROK(vs) )
        vs = SvRV(vs);
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV*)vs, "alpha", 5 ) )
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
        alpha = TRUE;
-    av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
+    av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 
     len = av_len(av);
     if ( len == -1 )
 
     len = av_len(av);
     if ( len == -1 )
@@ -4551,16 +4796,28 @@ the original version contained 1 or more dots, respectively
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
 SV *
 Perl_vstringify(pTHX_ SV *vs)
 {
+    PERL_ARGS_ASSERT_VSTRINGIFY;
+
     if ( SvROK(vs) )
        vs = SvRV(vs);
     if ( SvROK(vs) )
        vs = SvRV(vs);
-    
+
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( !vverify(vs) )
        Perl_croak(aTHX_ "Invalid version object");
 
-    if ( hv_exists((HV *)vs, "qv", 2) )
-       return vnormal(vs);
-    else
-       return vnumify(vs);
+    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
+       SV *pv;
+       pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+       if ( SvPOK(pv) )
+           return newSVsv(pv);
+       else
+           return &PL_sv_undef;
+    }
+    else {
+       if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+           return vnormal(vs);
+       else
+           return vnumify(vs);
+    }
 }
 
 /*
 }
 
 /*
@@ -4581,6 +4838,9 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     I32 left = 0;
     I32 right = 0;
     AV *lav, *rav;
     I32 left = 0;
     I32 right = 0;
     AV *lav, *rav;
+
+    PERL_ARGS_ASSERT_VCMP;
+
     if ( SvROK(lhv) )
        lhv = SvRV(lhv);
     if ( SvROK(rhv) )
     if ( SvROK(lhv) )
        lhv = SvRV(lhv);
     if ( SvROK(rhv) )
@@ -4593,13 +4853,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
-    lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
-    if ( hv_exists((HV*)lhv, "alpha", 5 ) )
+    lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
        lalpha = TRUE;
 
     /* and the right hand term */
        lalpha = TRUE;
 
     /* and the right hand term */
-    rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
-    if ( hv_exists((HV*)rhv, "alpha", 5 ) )
+    rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
        ralpha = TRUE;
 
     l = av_len(lav);
        ralpha = TRUE;
 
     l = av_len(lav);
@@ -4789,12 +5049,12 @@ S_socketpair_udp (int fd[2]) {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
     errno = ECONNABORTED;
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
        if (sockets[0] != -1)
            PerlLIO_close(sockets[0]);
        if (sockets[1] != -1)
            PerlLIO_close(sockets[1]);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -4893,14 +5153,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
 #endif
   tidy_up_and_fail:
     {
-       const int save_errno = errno;
+       dSAVE_ERRNO;
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
        if (listener != -1)
            PerlLIO_close(listener);
        if (connector != -1)
            PerlLIO_close(connector);
        if (acceptor != -1)
            PerlLIO_close(acceptor);
-       errno = save_errno;
+       RESTORE_ERRNO;
        return -1;
     }
 }
        return -1;
     }
 }
@@ -4936,12 +5196,34 @@ Perl_sv_nosharing(pTHX_ SV *sv)
     PERL_UNUSED_ARG(sv);
 }
 
     PERL_UNUSED_ARG(sv);
 }
 
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present.  It ignores its single SV argument, and returns
+'true'.  Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(sv);
+    return TRUE;
+}
+
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
   const char *p = *popt;
   U32 opt = 0;
 
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
   const char *p = *popt;
   U32 opt = 0;
 
+  PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
+
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
   if (*p) {
        if (isDIGIT(*p)) {
            opt = (U32) atoi(p);
@@ -5121,6 +5403,7 @@ 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;
     const char * const stashpv = CopSTASHPV(c);
     const char * const name = HvNAME_get(hv);
     PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
 
     if (stashpv == name)
        return TRUE;
 
     if (stashpv == name)
        return TRUE;
@@ -5134,13 +5417,14 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
 
 #ifdef PERL_GLOBAL_STRUCT
 
 
 #ifdef PERL_GLOBAL_STRUCT
 
+#define PERL_GLOBAL_STRUCT_INIT
+#include "opcode.h" /* the ppaddr and check */
+
 struct perl_vars *
 Perl_init_global_struct(pTHX)
 {
     struct perl_vars *plvarsp = NULL;
 struct perl_vars *
 Perl_init_global_struct(pTHX)
 {
     struct perl_vars *plvarsp = NULL;
-#ifdef PERL_GLOBAL_STRUCT
-#  define PERL_GLOBAL_STRUCT_INIT
-#  include "opcode.h" /* the ppaddr and check */
+# ifdef PERL_GLOBAL_STRUCT
     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
@@ -5168,10 +5452,14 @@ Perl_init_global_struct(pTHX)
 #  undef PERLVARIC
 #  undef PERLVARISC
 #  ifdef PERL_GLOBAL_STRUCT
 #  undef PERLVARIC
 #  undef PERLVARISC
 #  ifdef PERL_GLOBAL_STRUCT
-    plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
+    plvarsp->Gppaddr =
+       (Perl_ppaddr_t*)
+       PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
     if (!plvarsp->Gppaddr)
         exit(1);
     if (!plvarsp->Gppaddr)
         exit(1);
-    plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
+    plvarsp->Gcheck  =
+       (Perl_check_t*)
+       PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
     if (!plvarsp->Gcheck)
         exit(1);
     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
     if (!plvarsp->Gcheck)
         exit(1);
     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
@@ -5180,8 +5468,8 @@ Perl_init_global_struct(pTHX)
 #  ifdef PERL_SET_VARS
     PERL_SET_VARS(plvarsp);
 #  endif
 #  ifdef PERL_SET_VARS
     PERL_SET_VARS(plvarsp);
 #  endif
-#  undef PERL_GLOBAL_STRUCT_INIT
-#endif
+# undef PERL_GLOBAL_STRUCT_INIT
+# endif
     return plvarsp;
 }
 
     return plvarsp;
 }
 
@@ -5192,16 +5480,17 @@ Perl_init_global_struct(pTHX)
 void
 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 {
 void
 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 {
-#ifdef PERL_GLOBAL_STRUCT
+    PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
+# ifdef PERL_GLOBAL_STRUCT
 #  ifdef PERL_UNSET_VARS
     PERL_UNSET_VARS(plvarsp);
 #  endif
     free(plvarsp->Gppaddr);
     free(plvarsp->Gcheck);
 #  ifdef PERL_UNSET_VARS
     PERL_UNSET_VARS(plvarsp);
 #  endif
     free(plvarsp->Gppaddr);
     free(plvarsp->Gcheck);
-#    ifdef PERL_GLOBAL_STRUCT_PRIVATE
+#  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     free(plvarsp);
     free(plvarsp);
-#    endif
-#endif
+#  endif
+# endif
 }
 
 #endif /* PERL_GLOBAL_STRUCT */
 }
 
 #endif /* PERL_GLOBAL_STRUCT */
@@ -5212,9 +5501,15 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
  *
  * PERL_MEM_LOG_ENV: if defined, during run time the environment
  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
  *
  * PERL_MEM_LOG_ENV: if defined, during run time the environment
- * variable PERL_MEM_LOG will be consulted, and if the integer value
- * of that is true, the logging will happen.  (The default is to
- * always log if the PERL_MEM_LOG define was in effect.)
+ * variables PERL_MEM_LOG and PERL_SV_LOG will be consulted, and
+ * if the integer value of that is true, the logging will happen.
+ * (The default is to always log if the PERL_MEM_LOG define was
+ * in effect.)
+ *
+ * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged
+ * before every memory logging entry. This can be turned off at run
+ * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP
+ * to zero.
  */
 
 /*
  */
 
 /*
@@ -5233,15 +5528,27 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
 #endif
 
-Malloc_t
-Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
-{
 #ifdef PERL_MEM_LOG_STDERR
 #ifdef PERL_MEM_LOG_STDERR
+
+# ifdef DEBUG_LEAKING_SCALARS
+#   define SV_LOG_SERIAL_FMT       " [%lu]"
+#   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
+# else
+#   define SV_LOG_SERIAL_FMT
+#   define _SV_LOG_SERIAL_ARG(sv)
+# endif
+
+static void
+S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const char *type_name, const SV *sv, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
+    const char *s;
 # endif
 # endif
+
+    PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+
 # ifdef PERL_MEM_LOG_ENV
 # ifdef PERL_MEM_LOG_ENV
-    s = getenv("PERL_MEM_LOG");
+    s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG");
     if (s ? atoi(s) : 0)
 # endif
     {
     if (s ? atoi(s) : 0)
 # endif
     {
@@ -5249,83 +5556,90 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
         * so we'll use stdio and low-level IO instead. */
        char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
 # ifdef PERL_MEM_LOG_TIMESTAMP
         * so we'll use stdio and low-level IO instead. */
        char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
 # ifdef PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
 #   ifdef HAS_GETTIMEOFDAY
 #   ifdef HAS_GETTIMEOFDAY
+#     define MEM_LOG_TIME_FMT  "%10d.%06d: "
+#     define MEM_LOG_TIME_ARG  (int)tv.tv_sec, (int)tv.tv_usec
+       struct timeval tv;
        gettimeofday(&tv, 0);
        gettimeofday(&tv, 0);
+#   else
+#     define MEM_LOG_TIME_FMT  "%10d: "
+#     define MEM_LOG_TIME_ARG  (int)when
+        Time_t when;
+        (void)time(&when);
 #   endif
        /* If there are other OS specific ways of hires time than
 #   endif
        /* If there are other OS specific ways of hires time than
-        * gettimeofday() (see ext/Time/HiRes), the easiest way is
+        * gettimeofday() (see ext/Time-HiRes), the easiest way is
         * probably that they would be used to fill in the struct
         * timeval. */
 # endif
        {
         * probably that they would be used to fill in the struct
         * timeval. */
 # endif
        {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
+           int fd = PERL_MEM_LOG_FD;
+           STRLEN len;
+
+# ifdef PERL_MEM_LOG_ENV_FD
+           if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) {
+               fd = atoi(s);
+           }
 # endif
 # endif
-                           "alloc: %s:%d:%s: %"IVdf" %"UVuf
-                           " %s = %"IVdf": %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
+# ifdef PERL_MEM_LOG_TIMESTAMP
+           s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP");
+           if (!s || atoi(s)) {
+               len = my_snprintf(buf, sizeof(buf),
+                               MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+               PerlLIO_write(fd, buf, len);
+           }
 # endif
 # endif
-                           filename, linenumber, funcname, n, typesize,
-                           typename, n * typesize, PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-#endif
+           switch (mlt) {
+           case MLT_ALLOC:
+               len = my_snprintf(buf, sizeof(buf),
+                       "alloc: %s:%d:%s: %"IVdf" %"UVuf
+                       " %s = %"IVdf": %"UVxf"\n",
+                       filename, linenumber, funcname, n, typesize,
+                       type_name, n * typesize, PTR2UV(newalloc));
+               break;
+           case MLT_REALLOC:
+               len = my_snprintf(buf, sizeof(buf),
+                       "realloc: %s:%d:%s: %"IVdf" %"UVuf
+                       " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+                       filename, linenumber, funcname, n, typesize,
+                       type_name, n * typesize, PTR2UV(oldalloc),
+                       PTR2UV(newalloc));
+               break;
+           case MLT_FREE:
+               len = my_snprintf(buf, sizeof(buf),
+                       "free: %s:%d:%s: %"UVxf"\n",
+                       filename, linenumber, funcname,
+                       PTR2UV(oldalloc));
+               break;
+           case MLT_NEW_SV:
+           case MLT_DEL_SV:
+               len = my_snprintf(buf, sizeof(buf),
+                       "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
+                       mlt == MLT_NEW_SV ? "new" : "del",
+                       filename, linenumber, funcname,
+                       PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
+               break;
+           }
+           PerlLIO_write(fd, buf, len);
        }
     }
        }
     }
+}
+#endif
+
+Malloc_t
+Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+    mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname);
 #endif
     return newalloc;
 }
 
 Malloc_t
 #endif
     return newalloc;
 }
 
 Malloc_t
-Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
+Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
 {
 #ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-       /* We can't use SVs or PerlIO for obvious reasons,
-        * so we'll use stdio and low-level IO instead. */
-       char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
-       gettimeofday(&tv, 0);
-# endif
-       {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
-# endif
-                           "realloc: %s:%d:%s: %"IVdf" %"UVuf
-                           " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-                           filename, linenumber, funcname, n, typesize,
-                           typename, n * typesize, PTR2UV(oldalloc),
-                           PTR2UV(newalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-       }
-    }
+    mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname);
 #endif
     return newalloc;
 }
 #endif
     return newalloc;
 }
@@ -5334,46 +5648,27 @@ Malloc_t
 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
 {
 #ifdef PERL_MEM_LOG_STDERR
-# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
-    char *s;
-# endif
-# ifdef PERL_MEM_LOG_ENV
-    s = PerlEnv_getenv("PERL_MEM_LOG");
-    if (s ? atoi(s) : 0)
-# endif
-    {
-       /* We can't use SVs or PerlIO for obvious reasons,
-        * so we'll use stdio and low-level IO instead. */
-       char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-       struct timeval tv;
-       gettimeofday(&tv, 0);
-# endif
-       {
-           const STRLEN len =
-               my_snprintf(buf,
-                           sizeof(buf),
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           "%10d.%06d: "
-# endif
-                           "free: %s:%d:%s: %"UVxf"\n",
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-                           (int)tv.tv_sec, (int)tv.tv_usec,
-# endif
-                           filename, linenumber, funcname,
-                           PTR2UV(oldalloc));
-# ifdef PERL_MEM_LOG_ENV_FD
-           s = PerlEnv_getenv("PERL_MEM_LOG_FD");
-           PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
-# else
-           PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
-# endif
-       }
-    }
+    mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname);
 #endif
     return oldalloc;
 }
 
 #endif
     return oldalloc;
 }
 
+void
+Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+    mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
+#endif
+}
+
+void
+Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname)
+{
+#ifdef PERL_MEM_LOG_STDERR
+    mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname);
+#endif
+}
+
 #endif /* PERL_MEM_LOG */
 
 /*
 #endif /* PERL_MEM_LOG */
 
 /*
@@ -5390,6 +5685,7 @@ int
 Perl_my_sprintf(char *buffer, const char* pat, ...)
 {
     va_list args;
 Perl_my_sprintf(char *buffer, const char* pat, ...)
 {
     va_list args;
+    PERL_ARGS_ASSERT_MY_SPRINTF;
     va_start(args, pat);
     vsprintf(buffer, pat, args);
     va_end(args);
     va_start(args, pat);
     vsprintf(buffer, pat, args);
     va_end(args);
@@ -5415,6 +5711,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     dTHX;
     int retval;
     va_list ap;
     dTHX;
     int retval;
     va_list ap;
+    PERL_ARGS_ASSERT_MY_SNPRINTF;
     va_start(ap, format);
 #ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
     va_start(ap, format);
 #ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, ap);
@@ -5446,6 +5743,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
     int retval;
 #ifdef NEED_VA_COPY
     va_list apc;
+
+    PERL_ARGS_ASSERT_MY_VSNPRINTF;
+
     Perl_va_copy(ap, apc);
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
     Perl_va_copy(ap, apc);
 # ifdef HAS_VSNPRINTF
     retval = vsnprintf(buffer, len, format, apc);
@@ -5504,7 +5804,8 @@ Perl_my_clearenv(pTHX)
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
         bsiz = l + 1; /* + 1 for the \0. */
         buf = (char*)safesysmalloc(bufsiz);
       } 
-      my_strlcpy(buf, *environ, l + 1);
+      memcpy(buf, *environ, l);
+      buf[l] = '\0';
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5534,6 +5835,7 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
     dVAR;
     void *p;
 {
     dVAR;
     void *p;
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
        MUTEX_LOCK(&PL_my_ctx_mutex);
     if (*index == -1) {
        /* this module hasn't been allocated an index yet */
        MUTEX_LOCK(&PL_my_ctx_mutex);
@@ -5568,6 +5870,8 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
     dVAR;
     int index;
 
     dVAR;
     int index;
 
+    PERL_ARGS_ASSERT_MY_CXT_INDEX;
+
     for (index = 0; index < PL_my_cxt_index; index++) {
        const char *key = PL_my_cxt_keys[index];
        /* try direct pointer compare first - there are chances to success,
     for (index = 0; index < PL_my_cxt_index; index++) {
        const char *key = PL_my_cxt_keys[index];
        /* try direct pointer compare first - there are chances to success,
@@ -5586,6 +5890,8 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
     void *p;
     int index;
 
     void *p;
     int index;
 
+    PERL_ARGS_ASSERT_MY_CXT_INIT;
+
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */
     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
     if (index == -1) {
        /* this module hasn't been allocated an index yet */
@@ -5657,6 +5963,12 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size)
 }
 #endif
 
 }
 #endif
 
+#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
+/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
+long _ftol( double ); /* Defined by VC6 C libs. */
+long _ftol2( double dblSource ) { return _ftol( dblSource ); }
+#endif
+
 void
 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
 void
 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
@@ -5666,6 +5978,8 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
      * it's for informational purposes only.
      */
 
      * it's for informational purposes only.
      */
 
+    PERL_ARGS_ASSERT_GET_DB_SUB;
+
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
        GV * const gv = CvGV(cv);
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
        GV * const gv = CvGV(cv);
@@ -5673,10 +5987,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
-                !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
+                !( (SvTYPE(*svp) == SVt_PVGV)
+                   && (GvCV((const GV *)*svp) == cv) )))) {
            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
-           SV * const tmp = newRV((SV*)cv);
+           SV * const tmp = newRV(MUTABLE_SV(cv));
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
            sv_setsv(dbsv, tmp);
            SvREFCNT_dec(tmp);
        }
@@ -5693,6 +6008,41 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
     }
 }
 
     }
 }
 
+int
+Perl_my_dirfd(pTHX_ DIR * dir) {
+
+    /* Most dirfd implementations have problems when passed NULL. */
+    if(!dir)
+        return -1;
+#ifdef HAS_DIRFD
+    return dirfd(dir);
+#elif defined(HAS_DIR_DD_FD)
+    return dir->dd_fd;
+#else
+    Perl_die(aTHX_ PL_no_func, "dirfd");
+   /* NOT REACHED */
+    return 0;
+#endif 
+}
+
+REGEXP *
+Perl_get_re_arg(pTHX_ SV *sv) {
+    SV    *tmpsv;
+
+    if (sv) {
+        if (SvMAGICAL(sv))
+            mg_get(sv);
+        if (SvROK(sv) &&
+            (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
+            SvTYPE(tmpsv) == SVt_REGEXP)
+        {
+            return (REGEXP*) tmpsv;
+        }
+    }
+ 
+    return NULL;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.