Change 30661 could result in undefined variable

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 1ae9459..80e283b 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;

+#if defined(DEBUGGING) || defined(HAS_64K_LIMIT) || defined(PERL_TRACK_MEMPOOL)
+    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);
        }


@@ -478,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,8 +501,10 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     s = (U8*)SvPV_force_mutable(sv, len);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     s = (U8*)SvPV_force_mutable(sv, len);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;

-    SvUPGRADE(sv, SVt_PVBM);
+    SvUPGRADE(sv, SVt_PVGV);

     SvIOK_off(sv);
     SvIOK_off(sv);

+    SvNOK_off(sv);
+    SvVALID_on(sv);

     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;
     if (len > 2) {
        const unsigned char *sb;
        const U8 mlen = (len>255) ? 255 : (U8)len;


@@ -502,7 +515,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);

-       table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] = (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_set(sv, 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);
 


@@ -722,7 +736,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
        }
       check_end:
        if ( s == bigend
        }
       check_end:
        if ( s == bigend

-            && (table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] & FBMcf_TAIL)
+            && (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;


@@ -758,7 +772,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;
 

-    assert(SvTYPE(littlestr) == SVt_PVBM);
+    assert(SvTYPE(littlestr) == SVt_PVGV);
+    assert(SvVALID(littlestr));

 
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 
     if (*old_posp == -1
        ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0


@@ -949,6 +964,27 @@ 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);
+    assert(pv);
+    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


@@ -1129,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,


@@ -1267,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);
     }


@@ -1285,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);
 


@@ -1293,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;


@@ -2264,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
 }
 


@@ -2353,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());


@@ -4042,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.
 


@@ -4104,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 */
 


@@ -4283,7 +4337,7 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
        }
     }
 #endif

-    return upg_version(rv);
+    return upg_version(rv, FALSE);

 }
 
 /*
 }
 
 /*


@@ -4291,24 +4345,25 @@ 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];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");
        char tbuf[64];
 #ifdef USE_LOCALE_NUMERIC
        char *loc = setlocale(LC_NUMERIC, "C");


@@ -4328,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);


@@ -5118,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


@@ -5152,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); 


@@ -5164,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;
 }
 


@@ -5176,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 */


@@ -5505,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)
 {


@@ -5542,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


@@ -5577,6 +5729,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)
 {