Re: [ID 19991001.005] [_61] [PATCH] tarball fine on win32, zip isn't

[p5sagit/p5-mst-13.2.git] / win32 / perllib.c

diff --git a/win32/perllib.c b/win32/perllib.c
index 8682f77..10b252a 100644 (file)
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -91,6 +91,49 @@ PerlEnvUname(struct IPerlEnv*, struct utsname *name)
     return win32_uname(name);
 }
 
+void
+PerlEnvClearenv(struct IPerlEnv*)
+{
+    dTHXo;
+    char *envv = GetEnvironmentStrings();
+    char *cur = envv;
+    STRLEN len;
+    while (*cur) {
+       char *end = strchr(cur,'=');
+       if (end && end != cur) {
+           *end = '\0';
+           my_setenv(cur,Nullch);
+           *end = '=';
+           cur = end + strlen(end+1)+2;
+       }
+       else if ((len = strlen(cur)))
+           cur += len+1;
+    }
+    FreeEnvironmentStrings(envv);
+}
+
+void*
+PerlEnvGetChildEnv(struct IPerlEnv*)
+{
+    return NULL;
+}
+
+void
+PerlEnvFreeChildEnv(struct IPerlEnv*, void* env)
+{
+}
+
+char*
+PerlEnvGetChildDir(struct IPerlEnv*)
+{
+    return NULL;
+}
+
+void
+PerlEnvFreeChildDir(struct IPerlEnv*, char* dir)
+{
+}
+
 unsigned long
 PerlEnvOsId(struct IPerlEnv*)
 {
@@ -115,7 +158,11 @@ struct IPerlEnv perlEnv =
     PerlEnvPutenv,
     PerlEnvGetenv_len,
     PerlEnvUname,
-    NULL,
+    PerlEnvClearenv,
+    PerlEnvGetChildEnv,
+    PerlEnvFreeChildEnv,
+    PerlEnvGetChildDir,
+    PerlEnvFreeChildDir,
     PerlEnvOsId,
     PerlEnvLibPath,
     PerlEnvSiteLibPath,
@@ -375,6 +422,8 @@ PerlStdIOInit(struct IPerlStdIO*)
 void
 PerlStdIOInitOSExtras(struct IPerlStdIO*)
 {
+    dTHXo;
+    xs_init(pPerl);
     Perl_init_os_extras();
 }
 
@@ -771,7 +820,7 @@ PerlSockGethostbyname(struct IPerlSock*, const char* name)
 struct hostent*
 PerlSockGethostent(struct IPerlSock*)
 {
-    dPERLOBJ;
+    dTHXo;
     croak("gethostent not implemented!\n");
     return NULL;
 }
@@ -946,7 +995,7 @@ PerlSockSocket(struct IPerlSock*, int af, int type, int protocol)
 int
 PerlSockSocketpair(struct IPerlSock*, int domain, int type, int protocol, int* fds)
 {
-    dPERLOBJ;
+    dTHXo;
     croak("socketpair not implemented!\n");
     return 0;
 }
@@ -1102,7 +1151,7 @@ PerlProcKill(struct IPerlProc*, int pid, int sig)
 int
 PerlProcKillpg(struct IPerlProc*, int pid, int sig)
 {
-    dPERLOBJ;
+    dTHXo;
     croak("killpg not implemented!\n");
     return 0;
 }
@@ -1249,24 +1298,6 @@ struct IPerlProc perlProc =
 
 //#include "perlhost.h"
 
-static DWORD g_TlsAllocIndex;
-BOOL SetPerlInterpreter(CPerlObj* pPerl)
-{
-    return TlsSetValue(g_TlsAllocIndex, pPerl);
-}
-
-EXTERN_C CPerlObj* GetPerlInterpreter(PerlInterpreter* sv_interp)
-{
-    if(GetCurrentThreadId() == (DWORD)sv_interp)
-       return (CPerlObj*)TlsGetValue(g_TlsAllocIndex);
-    return NULL;
-}
-
-CPerlObj* GetPerlInter(void)
-{
-    return (CPerlObj*)TlsGetValue(g_TlsAllocIndex);
-}
-
 
 EXTERN_C void perl_get_host_info(IPerlMemInfo* perlMemInfo,
                        IPerlEnvInfo* perlEnvInfo, IPerlStdIOInfo* perlStdIOInfo,
@@ -1321,7 +1352,7 @@ EXTERN_C PerlInterpreter* perl_alloc_using(IPerlMem* pMem,
     if(pPerl)
     {
        SetPerlInterpreter(pPerl);
-       return (PerlInterpreter*)GetCurrentThreadId();
+       return (PerlInterpreter*)pPerl;
     }
     SetPerlInterpreter(NULL);
     return NULL;
@@ -1349,7 +1380,7 @@ EXTERN_C PerlInterpreter* perl_alloc(void)
     if(pPerl)
     {
        SetPerlInterpreter(pPerl);
-       return (PerlInterpreter*)GetCurrentThreadId();
+       return (PerlInterpreter*)pPerl;
     }
     SetPerlInterpreter(NULL);
     return NULL;
@@ -1357,7 +1388,7 @@ EXTERN_C PerlInterpreter* perl_alloc(void)
 
 EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
 {
-    CPerlObj* pPerl = GetPerlInterpreter(sv_interp);
+    CPerlObj* pPerl = (CPerlObj*)sv_interp;
     try
     {
        pPerl->perl_construct();
@@ -1373,7 +1404,7 @@ EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
 
 EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
 {
-    CPerlObj* pPerl = GetPerlInterpreter(sv_interp);
+    CPerlObj* pPerl = (CPerlObj*)sv_interp;
     try
     {
        pPerl->perl_destruct();
@@ -1385,7 +1416,7 @@ EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
 
 EXTERN_C void perl_free(PerlInterpreter* sv_interp)
 {
-    CPerlObj* pPerl = GetPerlInterpreter(sv_interp);
+    CPerlObj* pPerl = (CPerlObj*)sv_interp;
     try
     {
        pPerl->perl_free();
@@ -1398,7 +1429,7 @@ EXTERN_C void perl_free(PerlInterpreter* sv_interp)
 
 EXTERN_C int perl_run(PerlInterpreter* sv_interp)
 {
-    CPerlObj* pPerl = GetPerlInterpreter(sv_interp);
+    CPerlObj* pPerl = (CPerlObj*)sv_interp;
     int retVal;
     try
     {
@@ -1422,10 +1453,10 @@ EXTERN_C int perl_run(PerlInterpreter* sv_interp)
 EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
 {
     int retVal;
-    CPerlObj* pPerl = GetPerlInterpreter(sv_interp);
+    CPerlObj* pPerl = (CPerlObj*)sv_interp;
     try
     {
-       retVal = pPerl->perl_parse(xs_init, argc, argv, env);
+       retVal = pPerl->perl_parse(xsinit, argc, argv, env);
     }
 /*
     catch(int x)
@@ -1445,14 +1476,24 @@ EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), i
 
 #undef PL_perl_destruct_level
 #define PL_perl_destruct_level int dummy
-#undef w32_perldll_handle
-#define w32_perldll_handle g_w32_perldll_handle
-HANDLE g_w32_perldll_handle;
-#else
-extern HANDLE w32_perldll_handle;
 #endif /* PERL_OBJECT */
 
-DllExport int
+extern HANDLE w32_perldll_handle;
+static DWORD g_TlsAllocIndex;
+
+EXTERN_C DllExport bool
+SetPerlInterpreter(void *interp)
+{
+    return TlsSetValue(g_TlsAllocIndex, interp);
+}
+
+EXTERN_C DllExport void*
+GetPerlInterpreter(void)
+{
+    return TlsGetValue(g_TlsAllocIndex);
+}
+
+EXTERN_C DllExport int
 RunPerl(int argc, char **argv, char **env)
 {
     int exitstatus;
@@ -1490,7 +1531,12 @@ RunPerl(int argc, char **argv, char **env)
     perl_construct( my_perl );
     PL_perl_destruct_level = 0;
 
+#ifdef PERL_OBJECT
+    /* PERL_OBJECT build sets Dynaloader in PerlStdIOInitOSExtras */
+    exitstatus = perl_parse(my_perl, NULL, argc, argv, env);
+#else
     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
+#endif
     if (!exitstatus) {
        exitstatus = perl_run( my_perl );
     }
@@ -1520,21 +1566,16 @@ DllMain(HANDLE hModule,         /* DLL module handle */
        setmode( fileno( stderr ), O_BINARY );
        _fmode = O_BINARY;
 #endif
-#ifdef PERL_OBJECT
        g_TlsAllocIndex = TlsAlloc();
        DisableThreadLibraryCalls(hModule);
-#else
        w32_perldll_handle = hModule;
-#endif
        break;
 
        /* The DLL is detaching from a process due to
         * process termination or call to FreeLibrary.
         */
     case DLL_PROCESS_DETACH:
-#ifdef PERL_OBJECT
        TlsFree(g_TlsAllocIndex);
-#endif
        break;
 
        /* The attached process creates a new thread. */