X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fperlhost.h;h=61f87659df46c3f674e2da9d13bc61bb1e54f44c;hb=e5973ed5ed7077edf70f4112414ae22c6300aec8;hp=3be76ed817e990e65d0765a336ffc422870d576d;hpb=d2ee51b61413d0946f6558ae280350393bbe9b35;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/win32/perlhost.h b/win32/perlhost.h
index 3be76ed..61f8765 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -7,20 +7,30 @@
  *    License or the Artistic License, as specified in the README file.
  */
 
+#ifndef UNDER_CE
+#define CHECK_HOST_INTERP
+#endif
+
 #ifndef ___PerlHost_H___
 #define ___PerlHost_H___
 
+#ifndef UNDER_CE
 #include <signal.h>
+#endif
 #include "iperlsys.h"
 #include "vmem.h"
 #include "vdir.h"
 
+#ifndef WC_NO_BEST_FIT_CHARS
+#  define WC_NO_BEST_FIT_CHARS 0x00000400
+#endif
+
 START_EXTERN_C
-extern char *		g_win32_get_privlib(const char *pl);
-extern char *		g_win32_get_sitelib(const char *pl);
-extern char *		g_win32_get_vendorlib(const char *pl);
+extern char *		g_win32_get_privlib(const char *pl, STRLEN *const len);
+extern char *		g_win32_get_sitelib(const char *pl, STRLEN *const len);
+extern char *		g_win32_get_vendorlib(const char *pl,
+					      STRLEN *const len);
 extern char *		g_getlogin(void);
-extern int		do_spawn2(char *cmd, int exectype);
 END_EXTERN_C
 
 class CPerlHost
@@ -214,26 +224,38 @@ protected:
     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)
@@ -496,21 +518,22 @@ PerlEnvOsId(struct IPerlEnv* piPerl)
 }
 
 char*
-PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
 {
-    return g_win32_get_privlib(pl);
+    return g_win32_get_privlib(pl, len);
 }
 
 char*
-PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
 {
-    return g_win32_get_sitelib(pl);
+    return g_win32_get_sitelib(pl, len);
 }
 
 char*
-PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl)
+PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl,
+		     STRLEN *const len)
 {
-    return g_win32_get_vendorlib(pl);
+    return g_win32_get_vendorlib(pl, len);
 }
 
 void
@@ -595,14 +618,14 @@ PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
     return win32_getc(pf);
 }
 
-char*
+STDCHAR*
 PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef FILE_base
     FILE *f = pf;
     return FILE_base(f);
 #else
-    return Nullch;
+    return NULL;
 #endif
 }
 
@@ -628,14 +651,14 @@ PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
 #endif
 }
 
-char*
+STDCHAR*
 PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
 {
 #ifdef USE_STDIO_PTR
     FILE *f = pf;
     return FILE_ptr(f);
 #else
-    return Nullch;
+    return NULL;
 #endif
 }
 
@@ -721,7 +744,7 @@ PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
 }
 
 void
-PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
 {
 #ifdef STDIO_PTR_LVALUE
     FILE *f = pf;
@@ -749,14 +772,14 @@ PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_lis
     return win32_vfprintf(pf, format, arglist);
 }
 
-long
+Off_t
 PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
 {
     return win32_ftell(pf);
 }
 
 int
-PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, off_t offset, int origin)
+PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin)
 {
     return win32_fseek(pf, offset, origin);
 }
@@ -796,12 +819,12 @@ PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
 }
 
 int
-PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, long osfhandle, int flags)
+PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags)
 {
     return win32_open_osfhandle(osfhandle, flags);
 }
 
-int
+intptr_t
 PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
 {
     return win32_get_osfhandle(filenum);
@@ -810,6 +833,7 @@ PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
 FILE*
 PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
 {
+#ifndef UNDER_CE
     FILE* pfdup;
     fpos_t pos;
     char mode[3];
@@ -857,6 +881,9 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
 	fsetpos(pfdup, &pos);
     }
     return pfdup;
+#else
+    return 0;
+#endif
 }
 
 struct IPerlStdIO perlStdIO =
@@ -926,9 +953,9 @@ PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t g
 }
 
 int
-PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size)
+PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size)
 {
-    return chsize(handle, size);
+    return win32_chsize(handle, size);
 }
 
 int
@@ -956,7 +983,7 @@ PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
 }
 
 int
-PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
+PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer)
 {
     return win32_fstat(handle, buffer);
 }
@@ -964,7 +991,14 @@ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
 int
 PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
 {
-    return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
+    u_long u_long_arg;
+    int retval;
+
+    /* mauke says using memcpy avoids alignment issues */
+    memcpy(&u_long_arg, data, sizeof u_long_arg); 
+    retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg);
+    memcpy(data, &u_long_arg, sizeof u_long_arg);
+    return retval;
 }
 
 int
@@ -979,14 +1013,14 @@ PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
     return win32_link(oldname, newname);
 }
 
-long
-PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin)
+Off_t
+PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
 {
     return win32_lseek(handle, offset, origin);
 }
 
 int
-PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
 {
     return win32_stat(path, buffer);
 }
@@ -1028,7 +1062,7 @@ PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
 }
 
 int
-PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
+PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
 {
     return win32_stat(path, buffer);
 }
@@ -1052,7 +1086,7 @@ PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
 }
 
 int
-PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times)
+PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
 {
     return win32_utime(filename, times);
 }
@@ -1123,7 +1157,7 @@ PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
 }
 
 DIR*
-PerlDirOpen(struct IPerlDir* piPerl, char *filename)
+PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
 {
     return win32_opendir(filename);
 }
@@ -1586,9 +1620,7 @@ PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
 int
 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
 {
-    dTHX;
-    Perl_croak(aTHX_ "killpg not implemented!\n");
-    return 0;
+    return win32_kill(pid, -sig);
 }
 
 int
@@ -1664,7 +1696,13 @@ 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);
+}
+
+int
+PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
+{
+    return win32_gettimeofday(t, z);
 }
 
 #ifdef USE_ITHREADS
@@ -1674,6 +1712,7 @@ win32_start_child(LPVOID arg)
     PerlInterpreter *my_perl = (PerlInterpreter*)arg;
     GV *tmpgv;
     int status;
+    HWND parent_message_hwnd;
 #ifdef PERL_SYNC_FORK
     static long sync_fork_id = 0;
     long id = ++sync_fork_id;
@@ -1681,6 +1720,7 @@ win32_start_child(LPVOID arg)
 
 
     PERL_SET_THX(my_perl);
+    win32_checkTLS(my_perl);
 
     /* set $$ to pseudo id */
 #ifdef PERL_SYNC_FORK
@@ -1699,7 +1739,15 @@ win32_start_child(LPVOID arg)
 	sv_setiv(sv, -(IV)w32_pseudo_id);
 	SvREADONLY_on(sv);
     }
+#ifdef PERL_USES_PL_PIDSTATUS    
     hv_clear(PL_pidstatus);
+#endif    
+
+    /* create message window and tell parent about it */
+    parent_message_hwnd = w32_message_hwnd;
+    w32_message_hwnd = win32_create_message_window();
+    if (parent_message_hwnd != NULL)
+        PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd);
 
     /* push a zero on the stack (we are the child) */
     {
@@ -1714,7 +1762,7 @@ win32_start_child(LPVOID arg)
 
     {
 	dJMPENV;
-	volatile int oldscope = PL_scopestack_ix;
+	volatile int oldscope = 1; /* We are responsible for all scopes */
 
 restart:
 	JMPENV_PUSH(status);
@@ -1730,13 +1778,13 @@ restart:
 	    PL_curstash = PL_defstash;
 	    if (PL_endav && !PL_minus_c)
 		call_list(oldscope, PL_endav);
-	    status = STATUS_NATIVE_EXPORT;
+	    status = STATUS_EXIT;
 	    break;
 	case 3:
 	    if (PL_restartop) {
 		POPSTACK_TO(PL_mainstack);
 		PL_op = PL_restartop;
-		PL_restartop = Nullop;
+		PL_restartop = (OP*)NULL;
 		goto restart;
 	    }
 	    PerlIO_printf(Perl_error_log, "panic: restartop\n");
@@ -1747,18 +1795,22 @@ restart:
 	JMPENV_POP;
 
 	/* XXX hack to avoid perl_destruct() freeing optree */
-	PL_main_root = Nullop;
+        win32_checkTLS(my_perl);
+	PL_main_root = (OP*)NULL;
     }
 
+    win32_checkTLS(my_perl);
     /* close the std handles to avoid fd leaks */
     {
-	do_close(gv_fetchpv("STDIN", TRUE, SVt_PVIO), FALSE);
-	do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE);
-	do_close(gv_fetchpv("STDERR", TRUE, SVt_PVIO), FALSE);
+	do_close(PL_stdingv, FALSE);
+	do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
+	do_close(PL_stderrgv, FALSE);
     }
 
     /* 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
@@ -1783,7 +1835,8 @@ PerlProcFork(struct IPerlProc* piPerl)
 	return -1;
     }
     h = new CPerlHost(*(CPerlHost*)w32_internal_host);
-    PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
+    PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
+						 CLONEf_COPY_STACKS,
 						 h->m_pHostperlMem,
 						 h->m_pHostperlMemShared,
 						 h->m_pHostperlMemParse,
@@ -1795,10 +1848,16 @@ 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);
 #  else
+    if (w32_message_hwnd == INVALID_HANDLE_VALUE)
+        w32_message_hwnd = win32_create_message_window();
+    new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
+    w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
+        (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
 #    ifdef USE_RTL_THREAD_API
     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
 				    (void*)new_perl, 0, (unsigned*)&id);
@@ -1845,19 +1904,6 @@ PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
     win32_str_os_error(sv, dwErr);
 }
 
-BOOL
-PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
-{
-    do_spawn2(cmd, EXECF_EXEC);
-    return FALSE;
-}
-
-int
-PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
-{
-    return do_spawn2(cmds, EXECF_SPAWN);
-}
-
 int
 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
 {
@@ -1865,12 +1911,6 @@ PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const c
 }
 
 int
-PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp)
-{
-    return do_aspawn(vreally, vmark, vsp);
-}
-
-int
 PerlProcLastHost(struct IPerlProc* piPerl)
 {
  dTHX;
@@ -1909,12 +1949,10 @@ struct IPerlProc perlProc =
     PerlProcGetpid,
     PerlProcDynaLoader,
     PerlProcGetOSError,
-    PerlProcDoCmd,
-    PerlProcSpawn,
     PerlProcSpawnvp,
-    PerlProcASpawn,
     PerlProcLastHost,
-    PerlProcPopenList
+    PerlProcPopenList,
+    PerlProcGetTimeOfDay
 };
 
 
@@ -2053,7 +2091,7 @@ CPerlHost::CPerlHost(CPerlHost& host)
 
 CPerlHost::~CPerlHost(void)
 {
-//  Reset();
+    Reset();
     InterlockedDecrement(&num_hosts);
     delete m_pvDir;
     m_pVMemParse->Release();
@@ -2114,6 +2152,12 @@ lookup(const void *arg1, const void *arg2)
 LPSTR*
 CPerlHost::Lookup(LPCSTR lpStr)
 {
+#ifdef UNDER_CE
+    if (!m_lppEnvList || !m_dwEnvCount)
+	return NULL;
+#endif
+    if (!lpStr)
+	return NULL;
     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
 }
 
@@ -2142,7 +2186,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
 	    }
 	}
@@ -2165,20 +2209,24 @@ CPerlHost::Add(LPCSTR lpStr)
 
     // replacing ?
     lpPtr = Lookup(szBuffer);
-    if(lpPtr != NULL) {
-	Renew(*lpPtr, length, char);
+    if (lpPtr != NULL) {
+	// must allocate things via host memory allocation functions 
+	// rather than perl's Renew() et al, as the perl interpreter
+	// may either not be initialized enough when we allocate these,
+	// or may already be dead when we go to free these
+	*lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
 	strcpy(*lpPtr, lpStr);
     }
     else {
-	++m_dwEnvCount;
-	Renew(m_lppEnvList, m_dwEnvCount, LPSTR);
-	New(1, m_lppEnvList[m_dwEnvCount-1], length, char);
-	if(m_lppEnvList[m_dwEnvCount-1] != NULL) {
-	    strcpy(m_lppEnvList[m_dwEnvCount-1], lpStr);
-	    qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
+	m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
+	if (m_lppEnvList) {
+	    m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
+	    if (m_lppEnvList[m_dwEnvCount] != NULL) {
+		strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
+		++m_dwEnvCount;
+		qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
+	    }
 	}
-	else
-	    --m_dwEnvCount;
     }
 }
 
@@ -2204,16 +2252,15 @@ char*
 CPerlHost::GetChildDir(void)
 {
     dTHX;
-    int length;
     char* ptr;
-    New(0, ptr, MAX_PATH+1, char);
-    if(ptr) {
-	m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
-	length = strlen(ptr);
-	if (length > 3) {
-	    if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
-		ptr[length-1] = 0;
-	}
+    size_t length;
+
+    Newx(ptr, MAX_PATH+1, char);
+    m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
+    length = strlen(ptr);
+    if (length > 3) {
+        if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
+            ptr[length-1] = 0;
     }
     return ptr;
 }
@@ -2253,7 +2300,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
     // add the additional space used by changes made to the environment
     dwSize += CalculateEnvironmentSpace();
 
-    New(1, lpStr, dwSize, char);
+    Newx(lpStr, dwSize, char);
     lpPtr = lpStr;
     if(lpStr != NULL) {
 	// build the local environment
@@ -2270,7 +2317,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
 		lpStr += nLength;
 		lpEnvPtr += nLength;
 	    }
-	    else {	
+	    else {
 		// determine which string to copy next
 		compVal = compare(&lpEnvPtr, &lpLocalEnv);
 		if(compVal < 0) {
@@ -2321,11 +2368,13 @@ CPerlHost::Reset(void)
     dTHX;
     if(m_lppEnvList != NULL) {
 	for(DWORD index = 0; index < m_dwEnvCount; ++index) {
-	    Safefree(m_lppEnvList[index]);
+	    Free(m_lppEnvList[index]);
 	    m_lppEnvList[index] = NULL;
 	}
     }
     m_dwEnvCount = 0;
+    Free(m_lppEnvList);
+    m_lppEnvList = NULL;
 }
 
 void
@@ -2400,13 +2449,7 @@ CPerlHost::Chdir(const char *dirname)
 	errno = ENOENT;
 	return -1;
     }
-    if (USING_WIDE()) {
-	WCHAR wBuffer[MAX_PATH];
-	A2WHELPER(dirname, wBuffer, sizeof(wBuffer));
-	ret = m_pvDir->SetCurrentDirectoryW(wBuffer);
-    }
-    else
-	ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
+    ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
     if(ret < 0) {
 	errno = ENOENT;
     }