X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fperlhost.h;h=c0b53d6919e284a1b77a10ab8bcadbe77bdd878a;hb=b27299349ad81150118bac89c15f9a07eb50cb15;hp=3e22dba992ecb9e5e6e8f5a4b6c31a20f1a76db2;hpb=1784c7b8860f001488d9f9431a9519a239e537e3;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/win32/perlhost.h b/win32/perlhost.h
index 3e22dba..c0b53d6 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1,12 +1,14 @@
 /* perlhost.h
  *
- * (c) 1999 Microsoft Corporation. All rights reserved. 
+ * (c) 1999 Microsoft Corporation. All rights reserved.
  * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  */
 
+#define CHECK_HOST_INTERP
+
 #ifndef ___PerlHost_H___
 #define ___PerlHost_H___
 
@@ -52,6 +54,7 @@ public:
     void PerlDestroy(void);
 
 /* IPerlMem */
+    /* Locks provided but should be unnecessary as this is private pool */
     inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); };
     inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); };
     inline void Free(void* ptr) { m_pVMem->Free(ptr); };
@@ -68,12 +71,32 @@ public:
     inline int IsLocked(void) { return m_pVMem->IsLocked(); };
 
 /* IPerlMemShared */
+    /* Locks used to serialize access to the pool */
+    inline void GetLockShared(void) { m_pVMemShared->GetLock(); };
+    inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); };
+    inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); };
     inline void* MallocShared(size_t size)
     {
-	return m_pVMemShared->Malloc(size);
+	void *result;
+	GetLockShared();
+	result = m_pVMemShared->Malloc(size);
+	FreeLockShared();
+	return result;
+    };
+    inline void* ReallocShared(void* ptr, size_t size)
+    {
+	void *result;
+	GetLockShared();
+	result = m_pVMemShared->Realloc(ptr, size);
+	FreeLockShared();
+	return result;
+    };
+    inline void FreeShared(void* ptr)
+    {
+	GetLockShared();
+	m_pVMemShared->Free(ptr);
+	FreeLockShared();
     };
-    inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); };
-    inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); };
     inline void* CallocShared(size_t num, size_t size)
     {
 	size_t count = num*size;
@@ -82,11 +105,14 @@ public:
 	    ZeroMemory(lpVoid, count);
 	return lpVoid;
     };
-    inline void GetLockShared(void) { m_pVMem->GetLock(); };
-    inline void FreeLockShared(void) { m_pVMem->FreeLock(); };
-    inline int IsLockedShared(void) { return m_pVMem->IsLocked(); };
 
 /* IPerlMemParse */
+    /* Assume something else is using locks to mangaging serialize
+       on a batch basis
+     */
+    inline void GetLockParse(void) { m_pVMemParse->GetLock(); };
+    inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); };
+    inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); };
     inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); };
     inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); };
     inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); };
@@ -98,9 +124,6 @@ public:
 	    ZeroMemory(lpVoid, count);
 	return lpVoid;
     };
-    inline void GetLockParse(void) { m_pVMem->GetLock(); };
-    inline void FreeLockParse(void) { m_pVMem->FreeLock(); };
-    inline int IsLockedParse(void) { return m_pVMem->IsLocked(); };
 
 /* IPerlEnv */
     char *Getenv(const char *varname);
@@ -189,29 +212,42 @@ protected:
 
     DWORD   m_dwEnvCount;
     LPSTR*  m_lppEnvList;
+    BOOL    m_bTopLevel;	// is this a toplevel host?
     static long num_hosts;
 public:
     inline  int LastHost(void) { return num_hosts == 1L; };
+    struct interpreter *host_perl;
 };
 
 long CPerlHost::num_hosts = 0L;
 
+extern "C" void win32_checkTLS(struct interpreter *host_perl);
 
-#define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+#define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
+#ifdef CHECK_HOST_INTERP
+inline CPerlHost* CheckInterp(CPerlHost *host)
+{
+ win32_checkTLS(host->host_perl);
+ return host;
+}
+#define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y))
+#else
+#define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y)
+#endif
 
 inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
 {
-    return STRUCT2PTR(piPerl, m_hostperlMem);
+    return STRUCT2RAWPTR(piPerl, m_hostperlMem);
 }
 
 inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
 {
-    return STRUCT2PTR(piPerl, m_hostperlMemShared);
+    return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
 }
 
 inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
 {
-    return STRUCT2PTR(piPerl, m_hostperlMemParse);
+    return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
 }
 
 inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
@@ -497,7 +533,7 @@ PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr)
     win32_get_child_IO(ptr);
 }
 
-struct IPerlEnv perlEnv = 
+struct IPerlEnv perlEnv =
 {
     PerlEnvGetenv,
     PerlEnvPutenv,
@@ -824,7 +860,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
     }
 #endif
 
-    /* it appears that the binmode is attached to the 
+    /* it appears that the binmode is attached to the
      * file descriptor so binmode files will be handled
      * correctly
      */
@@ -837,7 +873,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
     return pfdup;
 }
 
-struct IPerlStdIO perlStdIO = 
+struct IPerlStdIO perlStdIO =
 {
     PerlStdIOStdin,
     PerlStdIOStdout,
@@ -1414,9 +1450,7 @@ PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
 int
 PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
 {
-    dTHX;
-    Perl_croak(aTHX_ "socketpair not implemented!\n");
-    return 0;
+    return Perl_my_socketpair(domain, type, protocol, fds);
 }
 
 int
@@ -1644,7 +1678,7 @@ PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
 Sighandler_t
 PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
 {
-    return signal(sig, subcode);
+    return win32_signal(sig, subcode);
 }
 
 #ifdef USE_ITHREADS
@@ -1661,6 +1695,7 @@ win32_start_child(LPVOID arg)
 
 
     PERL_SET_THX(my_perl);
+    win32_checkTLS(my_perl);
 
     /* set $$ to pseudo id */
 #ifdef PERL_SYNC_FORK
@@ -1673,8 +1708,12 @@ win32_start_child(LPVOID arg)
 	    w32_pseudo_id = -pid;
     }
 #endif
-    if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
-	sv_setiv(GvSV(tmpgv), -(IV)w32_pseudo_id);
+    if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
+	SV *sv = GvSV(tmpgv);
+	SvREADONLY_off(sv);
+	sv_setiv(sv, -(IV)w32_pseudo_id);
+	SvREADONLY_on(sv);
+    }
     hv_clear(PL_pidstatus);
 
     /* push a zero on the stack (we are the child) */
@@ -1723,9 +1762,11 @@ restart:
 	JMPENV_POP;
 
 	/* XXX hack to avoid perl_destruct() freeing optree */
+        win32_checkTLS(my_perl);
 	PL_main_root = Nullop;
     }
 
+    win32_checkTLS(my_perl);
     /* close the std handles to avoid fd leaks */
     {
 	do_close(gv_fetchpv("STDIN", TRUE, SVt_PVIO), FALSE);
@@ -1734,7 +1775,9 @@ restart:
     }
 
     /* destroy everything (waits for any pseudo-forked children) */
+    win32_checkTLS(my_perl);
     perl_destruct(my_perl);
+    win32_checkTLS(my_perl);
     perl_free(my_perl);
 
 #ifdef PERL_SYNC_FORK
@@ -1771,6 +1814,7 @@ PerlProcFork(struct IPerlProc* piPerl)
 						 h->m_pHostperlProc
 						 );
     new_perl->Isys_intern.internal_host = h;
+    h->host_perl = new_perl;
 #  ifdef PERL_SYNC_FORK
     id = win32_start_child((LPVOID)new_perl);
     PERL_SET_THX(aTHX);
@@ -1911,6 +1955,7 @@ CPerlHost::CPerlHost(void)
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = TRUE;
 
     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
@@ -1960,6 +2005,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = FALSE;
 
     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
@@ -2016,6 +2062,7 @@ CPerlHost::CPerlHost(CPerlHost& host)
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = FALSE;
 
     /* duplicate environment info */
     LPSTR lpPtr;
@@ -2115,7 +2162,7 @@ compare(const void *arg1, const void *arg2)
 	    if(c1 != c2) {
 		if(c1 < c2)
 		    return -1; // string 1 < string 2
-	    
+
 		return 1; // string 1 > string 2
 	    }
 	}
@@ -2243,7 +2290,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
 		lpStr += nLength;
 		lpEnvPtr += nLength;
 	    }
-	    else {	
+	    else {
 		// determine which string to copy next
 		compVal = compare(&lpEnvPtr, &lpLocalEnv);
 		if(compVal < 0) {
@@ -2330,7 +2377,7 @@ CPerlHost::Clearenv(void)
 	    ch = *++lpPtr;
 	    *lpPtr = 0;
 	    Add(lpStr);
-	    if (!w32_pseudo_id)
+	    if (m_bTopLevel)
 		(void)win32_putenv(lpStr);
 	    *lpPtr = ch;
 	}
@@ -2345,7 +2392,7 @@ char*
 CPerlHost::Getenv(const char *varname)
 {
     dTHX;
-    if (w32_pseudo_id) {
+    if (!m_bTopLevel) {
 	char *pEnv = Find(varname);
 	if (pEnv && *pEnv)
 	    return pEnv;
@@ -2358,7 +2405,7 @@ CPerlHost::Putenv(const char *envstring)
 {
     dTHX;
     Add(envstring);
-    if (!w32_pseudo_id)
+    if (m_bTopLevel)
 	return win32_putenv(envstring);
 
     return 0;