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
Add some PERL_MEM* defines to the -V output that were missing.
[perl5.git] / util.c
diff --git a/util.c b/util.c
index 6e291d3..edd51b5 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,7 +1,7 @@
 /*    util.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 /*    util.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.
@@ -258,11 +258,18 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
     dTHX;
     Malloc_t ptr;
 {
     dTHX;
     Malloc_t ptr;
+#ifdef DEBUGGING
+    const MEM_SIZE total_size = size * count
+#ifdef   PERL_TRACK_MEMPOOL
+       + sTHX
+#endif
+       ;
+#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 +277,24 @@ 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.  */
+    ptr = (Malloc_t)PerlMem_malloc(total_size);
+#else
+    /* Use calloc() because it might save a memset() if the memory is fresh
+       and clean from the OS.  */
+    ptr = (Malloc_t)PerlMem_calloc(count, size);
 #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 +302,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);
        }
@@ -454,8 +465,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     return NULL;
 }
 
     return NULL;
 }
 
-#define FBM_TABLE_OFFSET 2     /* Number of bytes between EOS and table*/
-
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
 /* As a space optimization, we do not compile tables for strings of length
    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
    special-cased in fbm_instr().
@@ -480,7 +489,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     register const U8 *s;
     register U32 i;
     STRLEN len;
     register const U8 *s;
     register U32 i;
     STRLEN len;
-    I32 rarest = 0;
+    U32 rarest = 0;
     U32 frequency = 256;
 
     if (flags & FBMcf_TAIL) {
     U32 frequency = 256;
 
     if (flags & FBMcf_TAIL) {
@@ -490,19 +499,22 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
            mg->mg_len++;
     }
     s = (U8*)SvPV_force_mutable(sv, len);
-    SvUPGRADE(sv, SVt_PVBM);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
+    SvUPGRADE(sv, SVt_PVGV);
+    SvIOK_off(sv);
+    SvNOK_off(sv);
+    SvVALID_on(sv);
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
        register U8 *table;
 
-       Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
-       table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
-       s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
+       Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
+       table
+           = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
+       s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
        memset((void*)table, mlen, 256);
        memset((void*)table, mlen, 256);
-       table[-1] = (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) {
@@ -510,9 +522,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
                table[*s] = (U8)i;
            s--, i++;
        }
                table[*s] = (U8)i;
            s--, i++;
        }
+    } else {
+       Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
     }
     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0);        /* deep magic */
-    SvVALID_on(sv);
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
 
     s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
@@ -521,13 +534,14 @@ 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];
     BmRARE(sv) = s[rarest];
-    BmPREVIOUS(sv) = (U16)rarest;
+    BmPREVIOUS(sv) = rarest;
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
     BmUSEFUL(sv) = 100;                        /* Initial value */
     if (flags & FBMcf_TAIL)
        SvTAIL_on(sv);
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
-                         BmRARE(sv),BmPREVIOUS(sv)));
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+                         BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 }
 
 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
@@ -663,7 +677,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
        return NULL;
     }
        }
        return NULL;
     }
-    if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+    if (!SvVALID(littlestr)) {
        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 
        char * const b = ninstr((char*)big,(char*)bigend,
                         (char*)little, (char*)little + littlelen);
 
@@ -680,12 +694,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        return b;
     }
 
        return b;
     }
 
-    {  /* Do actual FBM.  */
-       register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+    /* Do actual FBM.  */
+    if (littlelen > (STRLEN)(bigend - big))
+       return NULL;
+
+    {
+       register const unsigned char * const table
+           = little + littlelen + PERL_FBM_TABLE_OFFSET;
        register const unsigned char *oldlittle;
 
        register const unsigned char *oldlittle;
 
-       if (littlelen > (STRLEN)(bigend - big))
-           return NULL;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
        --littlelen;                    /* Last char found by table lookup */
 
        s = big + littlelen;
@@ -718,7 +735,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            }
        }
       check_end:
            }
        }
       check_end:
-       if ( s == bigend && (table[-1] & FBMcf_TAIL)
+       if ( s == bigend
+            && (BmFLAGS(littlestr) & FBMcf_TAIL)
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
             && memEQ((char *)(bigend - littlelen),
                      (char *)(oldlittle - littlelen), littlelen) )
            return (char*)bigend - littlelen;
@@ -754,6 +772,9 @@ 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;
 
+    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvVALID(littlestr));
+
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
        : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
@@ -882,8 +903,8 @@ Perl_savepv(pTHX_ const char *pv)
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
     else {
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
-       Newx(newaddr,pvlen,char);
-       return memcpy(newaddr,pv,pvlen);
+       Newx(newaddr, pvlen, char);
+       return (char*)memcpy(newaddr, pv, pvlen);
     }
 }
 
     }
 }
 
@@ -939,7 +960,28 @@ Perl_savesharedpv(pTHX_ const char *pv)
     if (!newaddr) {
        return write_no_mem();
     }
     if (!newaddr) {
        return write_no_mem();
     }
-    return memcpy(newaddr,pv,pvlen);
+    return (char*)memcpy(newaddr, pv, pvlen);
+}
+
+/*
+=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);
+    assert(pv);
+    if (!newaddr) {
+       return write_no_mem();
+    }
+    newaddr[len] = '\0';
+    return (char*)memcpy(newaddr, pv, len);
 }
 
 /*
 }
 
 /*
@@ -1123,7 +1165,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,
@@ -1261,7 +1306,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die/croak: message = %s\ndiehook = %p\n",
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
+                         (void*)thr, message, (void*)PL_diehook));
     if (PL_diehook) {
        S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
     if (PL_diehook) {
        S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
     }
@@ -1279,7 +1324,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die: curstack = %p, mainstack = %p\n",
 
     DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: die: curstack = %p, mainstack = %p\n",
-                         thr, PL_curstack, PL_mainstack));
+                         (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
 
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
 
     message = vdie_croak_common(pat, args, &msglen, &utf8);
 
@@ -1287,7 +1332,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args)
     SvFLAGS(ERRSV) |= utf8;
     DEBUG_S(PerlIO_printf(Perl_debug_log,
          "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
     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));
+         (void*)thr, (void*)PL_restartop, was_in_eval, (void*)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;
@@ -1537,8 +1582,10 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
 
     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
     PERL_UNUSED_CONTEXT;
 
-    buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
-       : PerlMemShared_realloc(buffer, len_wanted);
+    buffer = (STRLEN*)
+       (specialWARN(buffer) ?
+        PerlMemShared_malloc(len_wanted) :
+        PerlMemShared_realloc(buffer, len_wanted));
     buffer[0] = size;
     Copy(bits, (buffer + 1), size, char);
     return buffer;
     buffer[0] = size;
     Copy(bits, (buffer + 1), size, char);
     return buffer;
@@ -1569,46 +1616,46 @@ 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=setenv_getix(nam);          /* where does it go? */
     int nlen, vlen;
 
     int nlen, vlen;
 
-    if (environ == PL_origenviron) {   /* need we copy environment? */
-       I32 j;
-       I32 max;
-       char **tmpenv;
-
-       max = i;
-       while (environ[max])
-           max++;
-       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
-       for (j=0; j<max; j++) {         /* copy environment */
-           const int len = strlen(environ[j]);
-           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
-           Copy(environ[j], tmpenv[j], len+1, char);
-       }
-       tmpenv[max] = NULL;
-       environ = tmpenv;               /* tell exec where it is now */
+    if (environ == PL_origenviron) {   /* need we copy environment? */
+       I32 j;
+       I32 max;
+       char **tmpenv;
+
+       max = i;
+       while (environ[max])
+           max++;
+       tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+       for (j=0; j<max; j++) {         /* copy environment */
+           const int len = strlen(environ[j]);
+           tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+           Copy(environ[j], tmpenv[j], len+1, char);
+       }
+       tmpenv[max] = NULL;
+       environ = tmpenv;               /* tell exec where it is now */
     }
     if (!val) {
     }
     if (!val) {
-       safesysfree(environ[i]);
-       while (environ[i]) {
-           environ[i] = environ[i+1];
-           i++;
+       safesysfree(environ[i]);
+       while (environ[i]) {
+           environ[i] = environ[i+1];
+           i++;
        }
        }
-       return;
+       return;
     }
     }
-    if (!environ[i]) {                 /* does not exist yet */
-       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
-       environ[i+1] = NULL;    /* make sure it's null terminated */
+    if (!environ[i]) {                 /* does not exist yet */
+       environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+       environ[i+1] = NULL;    /* make sure it's null terminated */
     }
     else
     }
     else
-       safesysfree(environ[i]);
-       nlen = strlen(nam);
-       vlen = strlen(val);
+       safesysfree(environ[i]);
+       nlen = strlen(nam);
+       vlen = strlen(val);
 
 
-       environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
-       /* all that work just for this */
-       my_setenv_format(environ[i], nam, nlen, val, vlen);
+       environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+       /* all that work just for this */
+       my_setenv_format(environ[i], nam, nlen, val, vlen);
     } else {
 # endif
 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
     } else {
 # endif
 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
@@ -1664,7 +1711,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     int vlen;
 
     if (!val) {
     int vlen;
 
     if (!val) {
-       val = "";
+       val = "";
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
     }
     vlen = strlen(val);
     Newx(envstr, nlen+vlen+2, char);
@@ -2256,8 +2303,12 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
         PerlLIO_close(pp[0]);
     return PerlIO_fdopen(p[This], mode);
 #else
         PerlLIO_close(pp[0]);
     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);
+#  else
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
     Perl_croak(aTHX_ "List form of piped open not implemented");
     return (PerlIO *) NULL;
+#  endif
 #endif
 }
 
 #endif
 }
 
@@ -2345,6 +2396,14 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
+
+#ifdef PERLIO_USING_CRLF
+   /* Since we circumvent IO layers when we manipulate low-level
+      filedescriptors directly, need to manually switch to the
+      default, binary, low-level mode; see PerlIOBuf_open(). */
+   PerlLIO_setmode((*mode == 'r'), O_BINARY);
+#endif 
+
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
        if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
@@ -2413,7 +2472,7 @@ 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_ char *cmd, 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.
@@ -2426,7 +2485,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
 #if defined(DJGPP)
 FILE *djgpp_popen();
 PerlIO *
-Perl_my_popen(pTHX_ char *cmd, 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.
@@ -3022,7 +3081,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
            if ((strlen(tmpbuf) + strlen(scriptname)
                 + MAX_EXT_LEN) >= sizeof tmpbuf)
                continue;       /* don't search dir with too-long name */
-           strcat(tmpbuf, scriptname);
+           my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
 #else  /* !VMS */
 
 #ifdef DOSISH
 #else  /* !VMS */
 
 #ifdef DOSISH
@@ -3054,11 +3113,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
-               /* FIXME? Convert to memcpy  */
-               cur = strcpy(tmpbuf, scriptname);
+               my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
+               cur = tmpbuf;
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
-                && strcpy(tmpbuf+len, ext[extidx++]));
+                && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
 #endif
     }
 #endif
 #endif
     }
 #endif
@@ -3118,13 +3177,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
 #endif
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
 #endif
-#ifdef HAS_STRLCAT
-           (void)strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
-#else
-           /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
-            */
-           (void)strcpy(tmpbuf + len, scriptname);
-#endif /* #ifdef HAS_STRLCAT */
+           (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
@@ -3141,7 +3194,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
 #ifdef SEARCH_EXTS
            } while (  retval < 0               /* not there */
                    && extidx>=0 && ext[extidx] /* try an extension? */
-                   && strcpy(tmpbuf+len, ext[extidx++])
+                   && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
                );
 #endif
            if (retval < 0)
                );
 #endif
            if (retval < 0)
@@ -3440,7 +3493,8 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {
-           const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+           const char * const direction =
+               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
            if (name && *name)
                Perl_warner(aTHX_ packWARN(WARN_IO),
                            "Filehandle %s opened only for %sput",
@@ -3464,15 +3518,19 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
        }
 
        if (ckWARN(warn_type)) {
        }
 
        if (ckWARN(warn_type)) {
-           const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+           const char * const pars =
+               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
            const char * const func =
            const char * const func =
-               op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
-               op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
-               op < 0              ? "" :              /* handle phoney cases */
-               PL_op_desc[op];
-           const char * const type = OP_IS_SOCKET(op)
-                   || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
-                       ?  "socket" : "filehandle";
+               (const char *)
+               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
+                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
+                op < 0              ? "" :              /* handle phoney cases */
+                PL_op_desc[op]);
+           const char * const type =
+               (const char *)
+               (OP_IS_SOCKET(op) ||
+                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                "socket" : "filehandle");
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
            if (name && *name) {
                Perl_warner(aTHX_ packWARN(warn_type),
                            "%s%s on %s %s %s", func, pars, vile, type, name);
@@ -3828,7 +3886,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
   else {
     /* Possibly buf overflowed - try again with a bigger buf */
     const int fmtlen = strlen(fmt);
-    const int bufsize = fmtlen + buflen;
+    int bufsize = fmtlen + buflen;
 
     Newx(buf, bufsize, char);
     while (buf) {
 
     Newx(buf, bufsize, char);
     while (buf) {
@@ -3841,7 +3899,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
        buf = NULL;
        break;
       }
        buf = NULL;
        break;
       }
-      Renew(buf, bufsize*2, char);
+      bufsize *= 2;
+      Renew(buf, bufsize, char);
     }
     return buf;
   }
     }
     return buf;
   }
@@ -4034,12 +4093,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.
 
@@ -4096,6 +4155,9 @@ 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 */
 
@@ -4275,7 +4337,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif
-    return upg_version(rv);
+    return upg_version(rv, FALSE);
 }
 
 /*
 }
 
 /*
@@ -4283,26 +4345,33 @@ 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 */ 
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
     {
     {
+       /* may get too much accuracy */ 
        char tbuf[64];
        char tbuf[64];
+#ifdef USE_LOCALE_NUMERIC
+       char *loc = setlocale(LC_NUMERIC, "C");
+#endif
        STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
        STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+       setlocale(LC_NUMERIC, loc);
+#endif
        while (tbuf[len-1] == '0' && len > 0) len--;
        version = savepvn(tbuf, len);
     }
        while (tbuf[len-1] == '0' && len > 0) len--;
        version = savepvn(tbuf, len);
     }
@@ -4314,7 +4383,35 @@ 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,"%vd",ver);
+           pos = nver = savepv(SvPV_nolen(nsv));
+
+           /* scan the resulting formatted string */
+           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);
@@ -5104,13 +5201,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
@@ -5138,10 +5236,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); 
@@ -5150,8 +5252,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;
 }
 
@@ -5162,16 +5264,16 @@ 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
+# 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 */
@@ -5231,7 +5333,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
        {
            const STRLEN len =
                my_snprintf(buf,
        {
            const STRLEN len =
                my_snprintf(buf,
-                           PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+                           sizeof(buf),
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
@@ -5276,7 +5378,7 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc
        {
            const STRLEN len =
                my_snprintf(buf,
        {
            const STRLEN len =
                my_snprintf(buf,
-                           PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+                           sizeof(buf),
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
@@ -5322,7 +5424,7 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber,
        {
            const STRLEN len =
                my_snprintf(buf,
        {
            const STRLEN len =
                my_snprintf(buf,
-                           PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+                           sizeof(buf),
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                            "%10d.%06d: "
 # endif
@@ -5464,17 +5566,17 @@ Perl_my_clearenv(pTHX)
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
     (void)clearenv();
 #        elif defined(HAS_UNSETENV)
     int bsiz = 80; /* Most envvar names will be shorter than this. */
-    char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+    int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
+    char *buf = (char*)safesysmalloc(bufsiz);
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
     while (*environ != NULL) {
       char *e = strchr(*environ, '=');
-      int l = e ? e - *environ : strlen(*environ);
+      int l = e ? e - *environ : (int)strlen(*environ);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
       if (bsiz < l + 1) {
         (void)safesysfree(buf);
-        bsiz = l + 1;
-        buf = (char*)safesysmalloc(bsiz * sizeof(char));
+        bsiz = l + 1; /* + 1 for the \0. */
+        buf = (char*)safesysmalloc(bufsiz);
       } 
       } 
-      strncpy(buf, *environ, l);
-      *(buf + l) = '\0';
+      my_strlcpy(buf, *environ, l + 1);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
       (void)unsetenv(buf);
     }
     (void)safesysfree(buf);
@@ -5491,13 +5593,14 @@ Perl_my_clearenv(pTHX)
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
 
 #ifdef PERL_IMPLICIT_CONTEXT
 
-/* implements the MY_CXT_INIT macro. The first time a module is loaded,
+/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
 the global PL_my_cxt_index is incremented, and that value is assigned to
 that module's static my_cxt_index (who's address is passed as an arg).
 Then, for each interpreter this function is called for, it makes sure a
 void* slot is available to hang the static data off, by allocating or
 extending the interpreter's PL_my_cxt_list array */
 
+#ifndef PERL_GLOBAL_STRUCT_PRIVATE
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
 void *
 Perl_my_cxt_init(pTHX_ int *index, size_t size)
 {
@@ -5528,7 +5631,70 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size)
     Zero(p, size, char);
     return p;
 }
     Zero(p, size, char);
     return p;
 }
-#endif
+
+#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
+int
+Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
+{
+    dVAR;
+    int 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,
+        * and it's much faster.
+        */
+       if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
+           return index;
+    }
+    return -1;
+}
+
+void *
+Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
+{
+    dVAR;
+    void *p;
+    int index;
+
+    index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+    if (index == -1) {
+       /* this module hasn't been allocated an index yet */
+       MUTEX_LOCK(&PL_my_ctx_mutex);
+       index = PL_my_cxt_index++;
+       MUTEX_UNLOCK(&PL_my_ctx_mutex);
+    }
+
+    /* make sure the array is big enough */
+    if (PL_my_cxt_size <= index) {
+       int old_size = PL_my_cxt_size;
+       int i;
+       if (PL_my_cxt_size) {
+           while (PL_my_cxt_size <= index)
+               PL_my_cxt_size *= 2;
+           Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       else {
+           PL_my_cxt_size = 16;
+           Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+           Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
+       }
+       for (i = old_size; i < PL_my_cxt_size; i++) {
+           PL_my_cxt_keys[i] = 0;
+           PL_my_cxt_list[i] = 0;
+       }
+    }
+    PL_my_cxt_keys[index] = my_cxt_key;
+    /* newSV() allocates one more than needed */
+    p = (void*)SvPVX(newSV(size-1));
+    PL_my_cxt_list[index] = p;
+    Zero(p, size, char);
+    return p;
+}
+#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+#endif /* PERL_IMPLICIT_CONTEXT */
 
 #ifndef HAS_STRLCAT
 Size_t
 
 #ifndef HAS_STRLCAT
 Size_t
@@ -5563,6 +5729,48 @@ 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)
+{
+    dVAR;
+    SV * const dbsv = GvSVn(PL_DBsub);
+    /* We do not care about using sv to call CV;
+     * it's for informational purposes only.
+     */
+
+    save_item(dbsv);
+    if (!PERLDB_SUB_NN) {
+       GV * const gv = CvGV(cv);
+
+       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) )))) {
+           /* Use GV from the stack as a fallback. */
+           /* GV is potentially non-unique, or contain different CV. */
+           SV * const tmp = newRV((SV*)cv);
+           sv_setsv(dbsv, tmp);
+           SvREFCNT_dec(tmp);
+       }
+       else {
+           gv_efullname3(dbsv, gv, NULL);
+       }
+    }
+    else {
+       const int type = SvTYPE(dbsv);
+       if (type < SVt_PVIV && type != SVt_IV)
+           sv_upgrade(dbsv, SVt_PVIV);
+       (void)SvIOK_on(dbsv);
+       SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
+    }
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
 /*
  * Local variables:
  * c-indentation-style: bsd
Unnamed repository; edit this file 'description' to name the repository.