summaryrefslogtreecommitdiff
path: root/wince
diff options
context:
space:
mode:
authorVadim Konovalov <vkonovalov@lucent.com>2003-07-06 22:46:09 +0400
committerJarkko Hietaniemi <jhi@iki.fi>2003-07-06 16:16:08 +0000
commit216db7eec92546173ac6bab178225bf585542186 (patch)
treec2161974d273973711d0329fa189f5f96d8e5f5a /wince
parent16073f159843070bc8b173d94704d3759febc9f1 (diff)
downloadperl-216db7eec92546173ac6bab178225bf585542186.tar.gz
[PATCH] improve WinCE port
Date: Sun, 6 Jul 2003 18:46:09 +0400 Message-ID: <001401c343cd$8069cd40$ce5ec3d9@vad> Subject: [PATCH] improve WinCE port -- addition From: "Vadim Konovalov" <vkonovalov@peterstar.ru> Date: Sun, 6 Jul 2003 19:50:47 +0400 Message-ID: <000b01c343d6$7ff96920$5b5dc3d9@vad> p4raw-id: //depot/perl@20031
Diffstat (limited to 'wince')
-rw-r--r--wince/Makefile.ce26
-rw-r--r--wince/config.ce2
-rw-r--r--wince/perlhost.h2440
-rw-r--r--wince/perllib.c68
-rw-r--r--wince/vdir.h691
-rw-r--r--wince/vmem.h1248
-rw-r--r--wince/win32.h85
-rw-r--r--wince/win32io.c3
-rw-r--r--wince/win32iop.h7
-rw-r--r--wince/win32thread.c2
-rw-r--r--wince/win32thread.h13
-rw-r--r--wince/wince.c808
-rw-r--r--wince/wince.h26
13 files changed, 5350 insertions, 69 deletions
diff --git a/wince/Makefile.ce b/wince/Makefile.ce
index f6ea3f2c7c..5d452203f6 100644
--- a/wince/Makefile.ce
+++ b/wince/Makefile.ce
@@ -289,7 +289,9 @@ MCFLAGS = -D MIPS -D mips -D _MIPS_ -D _mips_ -DPROCESSOR_MIPS \
MACH = -machine:mips
SUBSYS = -subsystem:windowsce,3.00
CELIBPATH = $(CELIBDLLDIR)\$(MACHINE)-release
+#STDLIBPATH = $(WCEROOT)\$(OSVERSION)\$(PLATFORM)\lib\$(CPU)
LDLIBPATH = -libpath:$(CELIBPATH)
+#"-libpath:$(STDLIBPATH)"
STARTOBJS = $(CECONSOLEDIR)/$(MACHINE)/wmain.obj \
$(CECONSOLEDIR)/$(MACHINE)/w32console.obj
!endif
@@ -457,7 +459,7 @@ RSC = rc
INCLUDES = -I.\include -I. -I..
DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) $(CECFLAGS)
LOCDEFS = -DPERLDLL -DPERL_CORE
-CXX_FLAG = -TP -GX
+CXX_FLAG = -TP
PERLEXE_RES = perl.res
PERLDLL_RES =
@@ -827,12 +829,28 @@ XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\malloc.obj
!IF "$(CRYPT_SRC)" != ""
XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\fcrypt.obj
!ENDIF
+!IF "$(CRYPT_SRC)" != ""
+XDLLOBJS = $(XDLLOBJS) $(DLLDIR)\fcrypt.obj
+!ENDIF
{$(SRCDIR)}.c{$(DLLDIR)}.obj:
- $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+
+# compiler explains that it will optimize toke.c if we'll give it an
+# option -QMOb<num> with num>=4178
+$(DLLDIR)\toke.obj:
+ $(CC) -c $(CFLAGS_O) -QMOb9000 -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ ..\toke.c
{$(SRCDIR)/wince}.c{$(DLLDIR)}.obj:
- $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ $<
+
+# -DPERL_IMPLICIT_SYS needs C++ for perllib.c
+# This is the only file that depends on perlhost.h, vmem.h, and vdir.h
+!IF "$(USE_IMP_SYS)" == "define"
+$(DLLDIR)\perllib$(o) : perllib.c ..\win32\perlhost.h .\vdir.h .\vmem.h
+ $(CC) -c -I. $(CFLAGS_O) $(CXX_FLAG) $(OBJOUT_FLAG)$@ perllib.c
+ rem (frustrated) mv perllib.obj $(DLLDIR)
+!ENDIF
perldll.def : $(HPERL) $(CONFIGPM) ..\global.sym ..\pp.sym ..\makedef.pl
$(HPERL) -w ..\makedef.pl PLATFORM=wince $(OPTIMIZE) $(DEFINES) $(BUILDOPT) \
@@ -848,7 +866,7 @@ $(DLLDIR) :
if not exist "$(DLLDIR)" mkdir "$(DLLDIR)"
$(DLLDIR)\DynaLoader.obj: $(EXTDIR)\DynaLoader\DynaLoader.c
- $(CC) -c $(CFLAGS) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ \
+ $(CC) -c $(CFLAGS_O) -DPERL_EXTERNAL_GLOB -Fo$(DLLDIR)\ \
$(EXTDIR)\DynaLoader\DynaLoader.c
XPERLEXEOBJS = \
diff --git a/wince/config.ce b/wince/config.ce
index 11ce7006ee..c108de4928 100644
--- a/wince/config.ce
+++ b/wince/config.ce
@@ -787,7 +787,7 @@ sig_name='ZERO NUM01 INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PI
sig_name_init='"ZERO", "NUM01", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0'
sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20 0'
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0'
-sig_size='0'
+sig_size='27'
signal_t='void'
sitearch='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
sitearchexp='~INST_TOP~\site~INST_VER~\lib~INST_ARCH~'
diff --git a/wince/perlhost.h b/wince/perlhost.h
new file mode 100644
index 0000000000..9e93b571e2
--- /dev/null
+++ b/wince/perlhost.h
@@ -0,0 +1,2440 @@
+/* perlhost.h
+ *
+ * (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.
+ */
+
+#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"
+
+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_getlogin(void);
+END_EXTERN_C
+
+class CPerlHost
+{
+public:
+ /* Constructors */
+ CPerlHost(void);
+ CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc);
+ CPerlHost(CPerlHost& host);
+ ~CPerlHost(void);
+
+ static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl);
+ static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl);
+ static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl);
+ static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl);
+ static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl);
+ static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl);
+ static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl);
+
+ BOOL PerlCreate(void);
+ int PerlParse(int argc, char** argv, char** env);
+ int PerlRun(void);
+ 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); };
+ inline void* Calloc(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = Malloc(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+ inline void GetLock(void) { m_pVMem->GetLock(); };
+ inline void FreeLock(void) { m_pVMem->FreeLock(); };
+ 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)
+ {
+ 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* CallocShared(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocShared(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+
+/* 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); };
+ inline void* CallocParse(size_t num, size_t size)
+ {
+ size_t count = num*size;
+ void* lpVoid = MallocParse(count);
+ if (lpVoid)
+ ZeroMemory(lpVoid, count);
+ return lpVoid;
+ };
+
+/* IPerlEnv */
+ char *Getenv(const char *varname);
+ int Putenv(const char *envstring);
+ inline char *Getenv(const char *varname, unsigned long *len)
+ {
+ *len = 0;
+ char *e = Getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+ }
+ void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); };
+ void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); };
+ char* GetChildDir(void);
+ void FreeChildDir(char* pStr);
+ void Reset(void);
+ void Clearenv(void);
+
+ inline LPSTR GetIndex(DWORD &dwIndex)
+ {
+ if(dwIndex < m_dwEnvCount)
+ {
+ ++dwIndex;
+ return m_lppEnvList[dwIndex-1];
+ }
+ return NULL;
+ };
+
+protected:
+ LPSTR Find(LPCSTR lpStr);
+ void Add(LPCSTR lpStr);
+
+ LPSTR CreateLocalEnvironmentStrings(VDir &vDir);
+ void FreeLocalEnvironmentStrings(LPSTR lpStr);
+ LPSTR* Lookup(LPCSTR lpStr);
+ DWORD CalculateEnvironmentSpace(void);
+
+public:
+
+/* IPerlDIR */
+ virtual int Chdir(const char *dirname);
+
+/* IPerllProc */
+ void Abort(void);
+ void Exit(int status);
+ void _Exit(int status);
+ int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
+ int Execv(const char *cmdname, const char *const *argv);
+ int Execvp(const char *cmdname, const char *const *argv);
+
+ inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; };
+ inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; };
+ inline VDir* GetDir(void) { return m_pvDir; };
+
+public:
+
+ struct IPerlMem m_hostperlMem;
+ struct IPerlMem m_hostperlMemShared;
+ struct IPerlMem m_hostperlMemParse;
+ struct IPerlEnv m_hostperlEnv;
+ struct IPerlStdIO m_hostperlStdIO;
+ struct IPerlLIO m_hostperlLIO;
+ struct IPerlDir m_hostperlDir;
+ struct IPerlSock m_hostperlSock;
+ struct IPerlProc m_hostperlProc;
+
+ struct IPerlMem* m_pHostperlMem;
+ struct IPerlMem* m_pHostperlMemShared;
+ struct IPerlMem* m_pHostperlMemParse;
+ struct IPerlEnv* m_pHostperlEnv;
+ struct IPerlStdIO* m_pHostperlStdIO;
+ struct IPerlLIO* m_pHostperlLIO;
+ struct IPerlDir* m_pHostperlDir;
+ struct IPerlSock* m_pHostperlSock;
+ struct IPerlProc* m_pHostperlProc;
+
+ inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); };
+ inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); };
+protected:
+
+ VDir* m_pvDir;
+ VMem* m_pVMem;
+ VMem* m_pVMemShared;
+ VMem* m_pVMemParse;
+
+ 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 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 STRUCT2RAWPTR(piPerl, m_hostperlMem);
+}
+
+inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
+}
+
+inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
+{
+ return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
+}
+
+inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlEnv);
+}
+
+inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlStdIO);
+}
+
+inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlLIO);
+}
+
+inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlDir);
+}
+
+inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlSock);
+}
+
+inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl)
+{
+ return STRUCT2PTR(piPerl, m_hostperlProc);
+}
+
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMem2Host(x)
+
+/* IPerlMem */
+void*
+PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->Malloc(size);
+}
+void*
+PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->Realloc(ptr, size);
+}
+void
+PerlMemFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->Free(ptr);
+}
+void*
+PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->Calloc(num, size);
+}
+
+void
+PerlMemGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLock();
+}
+
+void
+PerlMemFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLock();
+}
+
+int
+PerlMemIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLocked();
+}
+
+struct IPerlMem perlMem =
+{
+ PerlMemMalloc,
+ PerlMemRealloc,
+ PerlMemFree,
+ PerlMemCalloc,
+ PerlMemGetLock,
+ PerlMemFreeLock,
+ PerlMemIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemShared2Host(x)
+
+/* IPerlMemShared */
+void*
+PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocShared(size);
+}
+void*
+PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocShared(ptr, size);
+}
+void
+PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeShared(ptr);
+}
+void*
+PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocShared(num, size);
+}
+
+void
+PerlMemSharedGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockShared();
+}
+
+void
+PerlMemSharedFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockShared();
+}
+
+int
+PerlMemSharedIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedShared();
+}
+
+struct IPerlMem perlMemShared =
+{
+ PerlMemSharedMalloc,
+ PerlMemSharedRealloc,
+ PerlMemSharedFree,
+ PerlMemSharedCalloc,
+ PerlMemSharedGetLock,
+ PerlMemSharedFreeLock,
+ PerlMemSharedIsLocked,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlMemParse2Host(x)
+
+/* IPerlMemParse */
+void*
+PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size)
+{
+ return IPERL2HOST(piPerl)->MallocParse(size);
+}
+void*
+PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
+{
+ return IPERL2HOST(piPerl)->ReallocParse(ptr, size);
+}
+void
+PerlMemParseFree(struct IPerlMem* piPerl, void* ptr)
+{
+ IPERL2HOST(piPerl)->FreeParse(ptr);
+}
+void*
+PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
+{
+ return IPERL2HOST(piPerl)->CallocParse(num, size);
+}
+
+void
+PerlMemParseGetLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->GetLockParse();
+}
+
+void
+PerlMemParseFreeLock(struct IPerlMem* piPerl)
+{
+ IPERL2HOST(piPerl)->FreeLockParse();
+}
+
+int
+PerlMemParseIsLocked(struct IPerlMem* piPerl)
+{
+ return IPERL2HOST(piPerl)->IsLockedParse();
+}
+
+struct IPerlMem perlMemParse =
+{
+ PerlMemParseMalloc,
+ PerlMemParseRealloc,
+ PerlMemParseFree,
+ PerlMemParseCalloc,
+ PerlMemParseGetLock,
+ PerlMemParseFreeLock,
+ PerlMemParseIsLocked,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlEnv2Host(x)
+
+/* IPerlEnv */
+char*
+PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname);
+};
+
+int
+PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
+{
+ return IPERL2HOST(piPerl)->Putenv(envstring);
+};
+
+char*
+PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
+{
+ return IPERL2HOST(piPerl)->Getenv(varname, len);
+}
+
+int
+PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
+{
+ return win32_uname(name);
+}
+
+void
+PerlEnvClearenv(struct IPerlEnv* piPerl)
+{
+ IPERL2HOST(piPerl)->Clearenv();
+}
+
+void*
+PerlEnvGetChildenv(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->CreateChildEnv();
+}
+
+void
+PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv)
+{
+ IPERL2HOST(piPerl)->FreeChildEnv(childEnv);
+}
+
+char*
+PerlEnvGetChilddir(struct IPerlEnv* piPerl)
+{
+ return IPERL2HOST(piPerl)->GetChildDir();
+}
+
+void
+PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir)
+{
+ IPERL2HOST(piPerl)->FreeChildDir(childDir);
+}
+
+unsigned long
+PerlEnvOsId(struct IPerlEnv* piPerl)
+{
+ return win32_os_id();
+}
+
+char*
+PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_privlib(pl);
+}
+
+char*
+PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_sitelib(pl);
+}
+
+char*
+PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl)
+{
+ return g_win32_get_vendorlib(pl);
+}
+
+void
+PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr)
+{
+ win32_get_child_IO(ptr);
+}
+
+struct IPerlEnv perlEnv =
+{
+ PerlEnvGetenv,
+ PerlEnvPutenv,
+ PerlEnvGetenv_len,
+ PerlEnvUname,
+ PerlEnvClearenv,
+ PerlEnvGetChildenv,
+ PerlEnvFreeChildenv,
+ PerlEnvGetChilddir,
+ PerlEnvFreeChilddir,
+ PerlEnvOsId,
+ PerlEnvLibPath,
+ PerlEnvSiteLibPath,
+ PerlEnvVendorLibPath,
+ PerlEnvGetChildIO,
+};
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlStdIO2Host(x)
+
+/* PerlStdIO */
+FILE*
+PerlStdIOStdin(struct IPerlStdIO* piPerl)
+{
+ return win32_stdin();
+}
+
+FILE*
+PerlStdIOStdout(struct IPerlStdIO* piPerl)
+{
+ return win32_stdout();
+}
+
+FILE*
+PerlStdIOStderr(struct IPerlStdIO* piPerl)
+{
+ return win32_stderr();
+}
+
+FILE*
+PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
+{
+ return win32_fopen(path, mode);
+}
+
+int
+PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fclose((pf));
+}
+
+int
+PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_feof(pf);
+}
+
+int
+PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_ferror(pf);
+}
+
+void
+PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_clearerr(pf);
+}
+
+int
+PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_getc(pf);
+}
+
+char*
+PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef FILE_base
+ FILE *f = pf;
+ return FILE_base(f);
+#else
+ return Nullch;
+#endif
+}
+
+int
+PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef FILE_bufsiz
+ FILE *f = pf;
+ return FILE_bufsiz(f);
+#else
+ return (-1);
+#endif
+}
+
+int
+PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_cnt(f);
+#else
+ return (-1);
+#endif
+}
+
+char*
+PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = pf;
+ return FILE_ptr(f);
+#else
+ return Nullch;
+#endif
+}
+
+char*
+PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
+{
+ return win32_fgets(s, n, pf);
+}
+
+int
+PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
+{
+ return win32_fputc(c, pf);
+}
+
+int
+PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
+{
+ return win32_fputs(s, pf);
+}
+
+int
+PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fflush(pf);
+}
+
+int
+PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf)
+{
+ return win32_ungetc(c, pf);
+}
+
+int
+PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_fileno(pf);
+}
+
+FILE*
+PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
+{
+ return win32_fdopen(fd, mode);
+}
+
+FILE*
+PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
+{
+ return win32_freopen(path, mode, (FILE*)pf);
+}
+
+SSize_t
+PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
+{
+ return win32_fread(buffer, size, count, pf);
+}
+
+SSize_t
+PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
+{
+ return win32_fwrite(buffer, size, count, pf);
+}
+
+void
+PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
+{
+ win32_setbuf(pf, buffer);
+}
+
+int
+PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
+{
+ return win32_setvbuf(pf, buffer, type, size);
+}
+
+void
+PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
+{
+#ifdef STDIO_CNT_LVALUE
+ FILE *f = pf;
+ FILE_cnt(f) = n;
+#endif
+}
+
+void
+PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, char * ptr)
+{
+#ifdef STDIO_PTR_LVALUE
+ FILE *f = pf;
+ FILE_ptr(f) = ptr;
+#endif
+}
+
+void
+PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_setvbuf(pf, NULL, _IOLBF, 0);
+}
+
+int
+PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
+{
+ va_list(arglist);
+ va_start(arglist, format);
+ return win32_vfprintf(pf, format, arglist);
+}
+
+int
+PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
+{
+ return win32_vfprintf(pf, format, arglist);
+}
+
+Off_t
+PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ return win32_ftell(pf);
+}
+
+int
+PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin)
+{
+ return win32_fseek(pf, offset, origin);
+}
+
+void
+PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
+{
+ win32_rewind(pf);
+}
+
+FILE*
+PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
+{
+ return win32_tmpfile();
+}
+
+int
+PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
+{
+ return win32_fgetpos(pf, p);
+}
+
+int
+PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
+{
+ return win32_fsetpos(pf, p);
+}
+void
+PerlStdIOInit(struct IPerlStdIO* piPerl)
+{
+}
+
+void
+PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
+{
+ Perl_init_os_extras();
+}
+
+int
+PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags)
+{
+ return win32_open_osfhandle(osfhandle, flags);
+}
+
+intptr_t
+PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
+{
+ return win32_get_osfhandle(filenum);
+}
+
+FILE*
+PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
+{
+#ifndef UNDER_CE
+ FILE* pfdup;
+ fpos_t pos;
+ char mode[3];
+ int fileno = win32_dup(win32_fileno(pf));
+
+ /* open the file in the same mode */
+#ifdef __BORLANDC__
+ if((pf)->flags & _F_READ) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if((pf)->flags & _F_WRIT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if((pf)->flags & _F_RDWR) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+#else
+ if((pf)->_flag & _IOREAD) {
+ mode[0] = 'r';
+ mode[1] = 0;
+ }
+ else if((pf)->_flag & _IOWRT) {
+ mode[0] = 'a';
+ mode[1] = 0;
+ }
+ else if((pf)->_flag & _IORW) {
+ mode[0] = 'r';
+ mode[1] = '+';
+ mode[2] = 0;
+ }
+#endif
+
+ /* it appears that the binmode is attached to the
+ * file descriptor so binmode files will be handled
+ * correctly
+ */
+ pfdup = win32_fdopen(fileno, mode);
+
+ /* move the file pointer to the same position */
+ if (!fgetpos(pf, &pos)) {
+ fsetpos(pfdup, &pos);
+ }
+ return pfdup;
+#else
+ return 0;
+#endif
+}
+
+struct IPerlStdIO perlStdIO =
+{
+ PerlStdIOStdin,
+ PerlStdIOStdout,
+ PerlStdIOStderr,
+ PerlStdIOOpen,
+ PerlStdIOClose,
+ PerlStdIOEof,
+ PerlStdIOError,
+ PerlStdIOClearerr,
+ PerlStdIOGetc,
+ PerlStdIOGetBase,
+ PerlStdIOGetBufsiz,
+ PerlStdIOGetCnt,
+ PerlStdIOGetPtr,
+ PerlStdIOGets,
+ PerlStdIOPutc,
+ PerlStdIOPuts,
+ PerlStdIOFlush,
+ PerlStdIOUngetc,
+ PerlStdIOFileno,
+ PerlStdIOFdopen,
+ PerlStdIOReopen,
+ PerlStdIORead,
+ PerlStdIOWrite,
+ PerlStdIOSetBuf,
+ PerlStdIOSetVBuf,
+ PerlStdIOSetCnt,
+ PerlStdIOSetPtr,
+ PerlStdIOSetlinebuf,
+ PerlStdIOPrintf,
+ PerlStdIOVprintf,
+ PerlStdIOTell,
+ PerlStdIOSeek,
+ PerlStdIORewind,
+ PerlStdIOTmpfile,
+ PerlStdIOGetpos,
+ PerlStdIOSetpos,
+ PerlStdIOInit,
+ PerlStdIOInitOSExtras,
+ PerlStdIOFdupopen,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlLIO2Host(x)
+
+/* IPerlLIO */
+int
+PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
+{
+ return win32_access(path, mode);
+}
+
+int
+PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
+{
+ return win32_chmod(filename, pmode);
+}
+
+int
+PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
+{
+ return chown(filename, owner, group);
+}
+
+int
+PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size)
+{
+ return win32_chsize(handle, size);
+}
+
+int
+PerlLIOClose(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_close(handle);
+}
+
+int
+PerlLIODup(struct IPerlLIO* piPerl, int handle)
+{
+ return win32_dup(handle);
+}
+
+int
+PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
+{
+ return win32_dup2(handle1, handle2);
+}
+
+int
+PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
+{
+ return win32_flock(fd, oper);
+}
+
+int
+PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer)
+{
+ return win32_fstat(handle, buffer);
+}
+
+int
+PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
+{
+ return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
+}
+
+int
+PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
+{
+ return isatty(fd);
+}
+
+int
+PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
+{
+ return win32_link(oldname, newname);
+}
+
+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, Stat_t *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
+{
+ return mktemp(Template);
+}
+
+int
+PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
+{
+ return win32_open(filename, oflag);
+}
+
+int
+PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
+{
+ return win32_open(filename, oflag, pmode);
+}
+
+int
+PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
+{
+ return win32_read(handle, buffer, count);
+}
+
+int
+PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
+{
+ return win32_rename(OldFileName, newname);
+}
+
+int
+PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
+{
+ return win32_setmode(handle, mode);
+}
+
+int
+PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
+{
+ return win32_stat(path, buffer);
+}
+
+char*
+PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
+{
+ return tmpnam(string);
+}
+
+int
+PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
+{
+ return umask(pmode);
+}
+
+int
+PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
+{
+ return win32_unlink(filename);
+}
+
+int
+PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times)
+{
+ return win32_utime(filename, times);
+}
+
+int
+PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
+{
+ return win32_write(handle, buffer, count);
+}
+
+struct IPerlLIO perlLIO =
+{
+ PerlLIOAccess,
+ PerlLIOChmod,
+ PerlLIOChown,
+ PerlLIOChsize,
+ PerlLIOClose,
+ PerlLIODup,
+ PerlLIODup2,
+ PerlLIOFlock,
+ PerlLIOFileStat,
+ PerlLIOIOCtl,
+ PerlLIOIsatty,
+ PerlLIOLink,
+ PerlLIOLseek,
+ PerlLIOLstat,
+ PerlLIOMktemp,
+ PerlLIOOpen,
+ PerlLIOOpen3,
+ PerlLIORead,
+ PerlLIORename,
+ PerlLIOSetmode,
+ PerlLIONameStat,
+ PerlLIOTmpnam,
+ PerlLIOUmask,
+ PerlLIOUnlink,
+ PerlLIOUtime,
+ PerlLIOWrite,
+};
+
+
+#undef IPERL2HOST
+#define IPERL2HOST(x) IPerlDir2Host(x)
+
+/* IPerlDIR */
+int
+PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
+{
+ return win32_mkdir(dirname, mode);
+}
+
+int
+PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return IPERL2HOST(piPerl)->Chdir(dirname);
+}
+
+int
+PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
+{
+ return win32_rmdir(dirname);
+}
+
+int
+PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_closedir(dirp);
+}
+
+DIR*
+PerlDirOpen(struct IPerlDir* piPerl, char *filename)
+{
+ return win32_opendir(filename);
+}
+
+struct direct *
+PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_readdir(dirp);
+}
+
+void
+PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
+{
+ win32_rewinddir(dirp);
+}
+
+void
+PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
+{
+ win32_seekdir(dirp, loc);
+}
+
+long
+PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
+{
+ return win32_telldir(dirp);
+}
+
+char*
+PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
+{
+ return IPERL2HOST(piPerl)->MapPathA(path);
+}
+
+WCHAR*
+PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
+{
+ return IPERL2HOST(piPerl)->MapPathW(path);
+}
+
+struct IPerlDir perlDir =
+{
+ PerlDirMakedir,
+ PerlDirChdir,
+ PerlDirRmdir,
+ PerlDirClose,
+ PerlDirOpen,
+ PerlDirRead,
+ PerlDirRewind,
+ PerlDirSeek,
+ PerlDirTell,
+ PerlDirMapPathA,
+ PerlDirMapPathW,
+};
+
+
+/* IPerlSock */
+u_long
+PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
+{
+ return win32_htonl(hostlong);
+}
+
+u_short
+PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
+{
+ return win32_htons(hostshort);
+}
+
+u_long
+PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
+{
+ return win32_ntohl(netlong);
+}
+
+u_short
+PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
+{
+ return win32_ntohs(netshort);
+}
+
+SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
+{
+ return win32_accept(s, addr, addrlen);
+}
+
+int
+PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_bind(s, name, namelen);
+}
+
+int
+PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_connect(s, name, namelen);
+}
+
+void
+PerlSockEndhostent(struct IPerlSock* piPerl)
+{
+ win32_endhostent();
+}
+
+void
+PerlSockEndnetent(struct IPerlSock* piPerl)
+{
+ win32_endnetent();
+}
+
+void
+PerlSockEndprotoent(struct IPerlSock* piPerl)
+{
+ win32_endprotoent();
+}
+
+void
+PerlSockEndservent(struct IPerlSock* piPerl)
+{
+ win32_endservent();
+}
+
+struct hostent*
+PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
+{
+ return win32_gethostbyaddr(addr, len, type);
+}
+
+struct hostent*
+PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_gethostbyname(name);
+}
+
+struct hostent*
+PerlSockGethostent(struct IPerlSock* piPerl)
+{
+ dTHX;
+ Perl_croak(aTHX_ "gethostent not implemented!\n");
+ return NULL;
+}
+
+int
+PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
+{
+ return win32_gethostname(name, namelen);
+}
+
+struct netent *
+PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
+{
+ return win32_getnetbyaddr(net, type);
+}
+
+struct netent *
+PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
+{
+ return win32_getnetbyname((char*)name);
+}
+
+struct netent *
+PerlSockGetnetent(struct IPerlSock* piPerl)
+{
+ return win32_getnetent();
+}
+
+int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getpeername(s, name, namelen);
+}
+
+struct protoent*
+PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
+{
+ return win32_getprotobyname(name);
+}
+
+struct protoent*
+PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
+{
+ return win32_getprotobynumber(number);
+}
+
+struct protoent*
+PerlSockGetprotoent(struct IPerlSock* piPerl)
+{
+ return win32_getprotoent();
+}
+
+struct servent*
+PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
+{
+ return win32_getservbyname(name, proto);
+}
+
+struct servent*
+PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
+{
+ return win32_getservbyport(port, proto);
+}
+
+struct servent*
+PerlSockGetservent(struct IPerlSock* piPerl)
+{
+ return win32_getservent();
+}
+
+int
+PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getsockname(s, name, namelen);
+}
+
+int
+PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
+{
+ return win32_getsockopt(s, level, optname, optval, optlen);
+}
+
+unsigned long
+PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
+{
+ return win32_inet_addr(cp);
+}
+
+char*
+PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
+{
+ return win32_inet_ntoa(in);
+}
+
+int
+PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
+{
+ return win32_listen(s, backlog);
+}
+
+int
+PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
+{
+ return win32_recv(s, buffer, len, flags);
+}
+
+int
+PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
+{
+ return win32_recvfrom(s, buffer, len, flags, from, fromlen);
+}
+
+int
+PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
+{
+ return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
+}
+
+int
+PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
+{
+ return win32_send(s, buffer, len, flags);
+}
+
+int
+PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
+{
+ return win32_sendto(s, buffer, len, flags, to, tolen);
+}
+
+void
+PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_sethostent(stayopen);
+}
+
+void
+PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setnetent(stayopen);
+}
+
+void
+PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setprotoent(stayopen);
+}
+
+void
+PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
+{
+ win32_setservent(stayopen);
+}
+
+int
+PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
+{
+ return win32_setsockopt(s, level, optname, optval, optlen);
+}
+
+int
+PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
+{
+ return win32_shutdown(s, how);
+}
+
+SOCKET
+PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
+{
+ return win32_socket(af, type, protocol);
+}
+
+int
+PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
+{
+ return Perl_my_socketpair(domain, type, protocol, fds);
+}
+
+int
+PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
+{
+ return win32_closesocket(s);
+}
+
+int
+PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
+{
+ return win32_ioctlsocket(s, cmd, argp);
+}
+
+struct IPerlSock perlSock =
+{
+ PerlSockHtonl,
+ PerlSockHtons,
+ PerlSockNtohl,
+ PerlSockNtohs,
+ PerlSockAccept,
+ PerlSockBind,
+ PerlSockConnect,
+ PerlSockEndhostent,
+ PerlSockEndnetent,
+ PerlSockEndprotoent,
+ PerlSockEndservent,
+ PerlSockGethostname,
+ PerlSockGetpeername,
+ PerlSockGethostbyaddr,
+ PerlSockGethostbyname,
+ PerlSockGethostent,
+ PerlSockGetnetbyaddr,
+ PerlSockGetnetbyname,
+ PerlSockGetnetent,
+ PerlSockGetprotobyname,
+ PerlSockGetprotobynumber,
+ PerlSockGetprotoent,
+ PerlSockGetservbyname,
+ PerlSockGetservbyport,
+ PerlSockGetservent,
+ PerlSockGetsockname,
+ PerlSockGetsockopt,
+ PerlSockInetAddr,
+ PerlSockInetNtoa,
+ PerlSockListen,
+ PerlSockRecv,
+ PerlSockRecvfrom,
+ PerlSockSelect,
+ PerlSockSend,
+ PerlSockSendto,
+ PerlSockSethostent,
+ PerlSockSetnetent,
+ PerlSockSetprotoent,
+ PerlSockSetservent,
+ PerlSockSetsockopt,
+ PerlSockShutdown,
+ PerlSockSocket,
+ PerlSockSocketpair,
+ PerlSockClosesocket,
+};
+
+
+/* IPerlProc */
+
+#define EXECF_EXEC 1
+#define EXECF_SPAWN 2
+
+void
+PerlProcAbort(struct IPerlProc* piPerl)
+{
+ win32_abort();
+}
+
+char *
+PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
+{
+ return win32_crypt(clear, salt);
+}
+
+void
+PerlProcExit(struct IPerlProc* piPerl, int status)
+{
+ exit(status);
+}
+
+void
+PerlProc_Exit(struct IPerlProc* piPerl, int status)
+{
+ _exit(status);
+}
+
+int
+PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
+{
+ return execl(cmdname, arg0, arg1, arg2, arg3);
+}
+
+int
+PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+int
+PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+uid_t
+PerlProcGetuid(struct IPerlProc* piPerl)
+{
+ return getuid();
+}
+
+uid_t
+PerlProcGeteuid(struct IPerlProc* piPerl)
+{
+ return geteuid();
+}
+
+gid_t
+PerlProcGetgid(struct IPerlProc* piPerl)
+{
+ return getgid();
+}
+
+gid_t
+PerlProcGetegid(struct IPerlProc* piPerl)
+{
+ return getegid();
+}
+
+char *
+PerlProcGetlogin(struct IPerlProc* piPerl)
+{
+ return g_getlogin();
+}
+
+int
+PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
+{
+ return win32_kill(pid, sig);
+}
+
+int
+PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
+{
+ dTHX;
+ Perl_croak(aTHX_ "killpg not implemented!\n");
+ return 0;
+}
+
+int
+PerlProcPauseProc(struct IPerlProc* piPerl)
+{
+ return win32_sleep((32767L << 16) + 32767);
+}
+
+PerlIO*
+PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
+{
+ dTHX;
+ PERL_FLUSHALL_FOR_CHILD;
+ return win32_popen(command, mode);
+}
+
+PerlIO*
+PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
+{
+ dTHX;
+ PERL_FLUSHALL_FOR_CHILD;
+ return win32_popenlist(mode, narg, args);
+}
+
+int
+PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
+{
+ return win32_pclose(stream);
+}
+
+int
+PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
+{
+ return win32_pipe(phandles, 512, O_BINARY);
+}
+
+int
+PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
+{
+ return setuid(u);
+}
+
+int
+PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
+{
+ return setgid(g);
+}
+
+int
+PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
+{
+ return win32_sleep(s);
+}
+
+int
+PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
+{
+ return win32_times(timebuf);
+}
+
+int
+PerlProcWait(struct IPerlProc* piPerl, int *status)
+{
+ return win32_wait(status);
+}
+
+int
+PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
+{
+ return win32_waitpid(pid, status, flags);
+}
+
+Sighandler_t
+PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
+{
+ return win32_signal(sig, subcode);
+}
+
+int
+PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
+{
+ return win32_gettimeofday(t, z);
+}
+
+#ifdef USE_ITHREADS
+static THREAD_RET_TYPE
+win32_start_child(LPVOID arg)
+{
+ PerlInterpreter *my_perl = (PerlInterpreter*)arg;
+ GV *tmpgv;
+ int status;
+#ifdef PERL_SYNC_FORK
+ static long sync_fork_id = 0;
+ long id = ++sync_fork_id;
+#endif
+
+
+ PERL_SET_THX(my_perl);
+ win32_checkTLS(my_perl);
+
+ /* set $$ to pseudo id */
+#ifdef PERL_SYNC_FORK
+ w32_pseudo_id = id;
+#else
+ w32_pseudo_id = GetCurrentThreadId();
+ if (IsWin95()) {
+ int pid = (int)w32_pseudo_id;
+ if (pid < 0)
+ w32_pseudo_id = -pid;
+ }
+#endif
+ 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) */
+ {
+ dSP;
+ dTARGET;
+ PUSHi(0);
+ PUTBACK;
+ }
+
+ /* continue from next op */
+ PL_op = PL_op->op_next;
+
+ {
+ dJMPENV;
+ volatile int oldscope = PL_scopestack_ix;
+
+restart:
+ JMPENV_PUSH(status);
+ switch (status) {
+ case 0:
+ CALLRUNOPS(aTHX);
+ status = 0;
+ break;
+ case 2:
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav && !PL_minus_c)
+ call_list(oldscope, PL_endav);
+ status = STATUS_NATIVE_EXPORT;
+ break;
+ case 3:
+ if (PL_restartop) {
+ POPSTACK_TO(PL_mainstack);
+ PL_op = PL_restartop;
+ PL_restartop = Nullop;
+ goto restart;
+ }
+ PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ FREETMPS;
+ status = 1;
+ break;
+ }
+ 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(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
+ return id;
+#else
+ return (DWORD)status;
+#endif
+}
+#endif /* USE_ITHREADS */
+
+int
+PerlProcFork(struct IPerlProc* piPerl)
+{
+ dTHX;
+#ifdef USE_ITHREADS
+ DWORD id;
+ HANDLE handle;
+ CPerlHost *h;
+
+ if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
+ errno = EAGAIN;
+ return -1;
+ }
+ h = new CPerlHost(*(CPerlHost*)w32_internal_host);
+ PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ 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
+# ifdef USE_RTL_THREAD_API
+ handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
+ (void*)new_perl, 0, (unsigned*)&id);
+# else
+ handle = CreateThread(NULL, 0, win32_start_child,
+ (LPVOID)new_perl, 0, &id);
+# endif
+ PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
+ if (!handle) {
+ errno = EAGAIN;
+ return -1;
+ }
+ if (IsWin95()) {
+ int pid = (int)id;
+ if (pid < 0)
+ id = -pid;
+ }
+ w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
+ w32_pseudo_child_pids[w32_num_pseudo_children] = id;
+ ++w32_num_pseudo_children;
+# endif
+ return -(int)id;
+#else
+ Perl_croak(aTHX_ "fork() not implemented!\n");
+ return -1;
+#endif /* USE_ITHREADS */
+}
+
+int
+PerlProcGetpid(struct IPerlProc* piPerl)
+{
+ return win32_getpid();
+}
+
+void*
+PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
+{
+ return win32_dynaload(filename);
+}
+
+void
+PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
+{
+ win32_str_os_error(sv, dwErr);
+}
+
+int
+PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
+{
+ return win32_spawnvp(mode, cmdname, argv);
+}
+
+int
+PerlProcLastHost(struct IPerlProc* piPerl)
+{
+ dTHX;
+ CPerlHost *h = (CPerlHost*)w32_internal_host;
+ return h->LastHost();
+}
+
+struct IPerlProc perlProc =
+{
+ PerlProcAbort,
+ PerlProcCrypt,
+ PerlProcExit,
+ PerlProc_Exit,
+ PerlProcExecl,
+ PerlProcExecv,
+ PerlProcExecvp,
+ PerlProcGetuid,
+ PerlProcGeteuid,
+ PerlProcGetgid,
+ PerlProcGetegid,
+ PerlProcGetlogin,
+ PerlProcKill,
+ PerlProcKillpg,
+ PerlProcPauseProc,
+ PerlProcPopen,
+ PerlProcPclose,
+ PerlProcPipe,
+ PerlProcSetuid,
+ PerlProcSetgid,
+ PerlProcSleep,
+ PerlProcTimes,
+ PerlProcWait,
+ PerlProcWaitpid,
+ PerlProcSignal,
+ PerlProcFork,
+ PerlProcGetpid,
+ PerlProcDynaLoader,
+ PerlProcGetOSError,
+ PerlProcSpawnvp,
+ PerlProcLastHost,
+ PerlProcPopenList,
+ PerlProcGetTimeOfDay
+};
+
+
+/*
+ * CPerlHost
+ */
+
+CPerlHost::CPerlHost(void)
+{
+ /* Construct a host from scratch */
+ InterlockedIncrement(&num_hosts);
+ m_pvDir = new VDir();
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = TRUE;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ m_pHostperlMem = &m_hostperlMem;
+ m_pHostperlMemShared = &m_hostperlMemShared;
+ m_pHostperlMemParse = &m_hostperlMemParse;
+ m_pHostperlEnv = &m_hostperlEnv;
+ m_pHostperlStdIO = &m_hostperlStdIO;
+ m_pHostperlLIO = &m_hostperlLIO;
+ m_pHostperlDir = &m_hostperlDir;
+ m_pHostperlSock = &m_hostperlSock;
+ m_pHostperlProc = &m_hostperlProc;
+}
+
+#define SETUPEXCHANGE(xptr, iptr, table) \
+ STMT_START { \
+ if (xptr) { \
+ iptr = *xptr; \
+ *xptr = &table; \
+ } \
+ else { \
+ iptr = &table; \
+ } \
+ } STMT_END
+
+CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
+ struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
+ struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
+ struct IPerlDir** ppDir, struct IPerlSock** ppSock,
+ struct IPerlProc** ppProc)
+{
+ InterlockedIncrement(&num_hosts);
+ m_pvDir = new VDir(0);
+ m_pVMem = new VMem();
+ m_pVMemShared = new VMem();
+ m_pVMemParse = new VMem();
+
+ m_pvDir->Init(NULL, m_pVMem);
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = FALSE;
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+
+ SETUPEXCHANGE(ppMem, m_pHostperlMem, m_hostperlMem);
+ SETUPEXCHANGE(ppMemShared, m_pHostperlMemShared, m_hostperlMemShared);
+ SETUPEXCHANGE(ppMemParse, m_pHostperlMemParse, m_hostperlMemParse);
+ SETUPEXCHANGE(ppEnv, m_pHostperlEnv, m_hostperlEnv);
+ SETUPEXCHANGE(ppStdIO, m_pHostperlStdIO, m_hostperlStdIO);
+ SETUPEXCHANGE(ppLIO, m_pHostperlLIO, m_hostperlLIO);
+ SETUPEXCHANGE(ppDir, m_pHostperlDir, m_hostperlDir);
+ SETUPEXCHANGE(ppSock, m_pHostperlSock, m_hostperlSock);
+ SETUPEXCHANGE(ppProc, m_pHostperlProc, m_hostperlProc);
+}
+#undef SETUPEXCHANGE
+
+CPerlHost::CPerlHost(CPerlHost& host)
+{
+ /* Construct a host from another host */
+ InterlockedIncrement(&num_hosts);
+ m_pVMem = new VMem();
+ m_pVMemShared = host.GetMemShared();
+ m_pVMemParse = host.GetMemParse();
+
+ /* duplicate directory info */
+ m_pvDir = new VDir(0);
+ m_pvDir->Init(host.GetDir(), m_pVMem);
+
+ CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
+ CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
+ CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
+ CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
+ CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
+ CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
+ CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
+ CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
+ CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
+ m_pHostperlMem = &m_hostperlMem;
+ m_pHostperlMemShared = &m_hostperlMemShared;
+ m_pHostperlMemParse = &m_hostperlMemParse;
+ m_pHostperlEnv = &m_hostperlEnv;
+ m_pHostperlStdIO = &m_hostperlStdIO;
+ m_pHostperlLIO = &m_hostperlLIO;
+ m_pHostperlDir = &m_hostperlDir;
+ m_pHostperlSock = &m_hostperlSock;
+ m_pHostperlProc = &m_hostperlProc;
+
+ m_dwEnvCount = 0;
+ m_lppEnvList = NULL;
+ m_bTopLevel = FALSE;
+
+ /* duplicate environment info */
+ LPSTR lpPtr;
+ DWORD dwIndex = 0;
+ while(lpPtr = host.GetIndex(dwIndex))
+ Add(lpPtr);
+}
+
+CPerlHost::~CPerlHost(void)
+{
+ Reset();
+ InterlockedDecrement(&num_hosts);
+ delete m_pvDir;
+ m_pVMemParse->Release();
+ m_pVMemShared->Release();
+ m_pVMem->Release();
+}
+
+LPSTR
+CPerlHost::Find(LPCSTR lpStr)
+{
+ LPSTR lpPtr;
+ LPSTR* lppPtr = Lookup(lpStr);
+ if(lppPtr != NULL) {
+ for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
+ ;
+
+ if(*lpPtr == '=')
+ ++lpPtr;
+
+ return lpPtr;
+ }
+ return NULL;
+}
+
+int
+lookup(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c2 == '\0' || c2 == '=')
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+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);
+}
+
+int
+compare(const void *arg1, const void *arg2)
+{ // Compare strings
+ char*ptr1, *ptr2;
+ char c1,c2;
+
+ ptr1 = *(char**)arg1;
+ ptr2 = *(char**)arg2;
+ for(;;) {
+ c1 = *ptr1++;
+ c2 = *ptr2++;
+ if(c1 == '\0' || c1 == '=') {
+ if(c1 == c2)
+ break;
+
+ return -1; // string 1 < string 2
+ }
+ else if(c2 == '\0' || c2 == '=')
+ return 1; // string 1 > string 2
+ else if(c1 != c2) {
+ c1 = toupper(c1);
+ c2 = toupper(c2);
+ if(c1 != c2) {
+ if(c1 < c2)
+ return -1; // string 1 < string 2
+
+ return 1; // string 1 > string 2
+ }
+ }
+ }
+ return 0;
+}
+
+void
+CPerlHost::Add(LPCSTR lpStr)
+{
+ dTHX;
+ char szBuffer[1024];
+ LPSTR *lpPtr;
+ int index, length = strlen(lpStr)+1;
+
+ for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
+ szBuffer[index] = lpStr[index];
+
+ szBuffer[index] = '\0';
+
+ // replacing ?
+ lpPtr = Lookup(szBuffer);
+ 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_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);
+ }
+ }
+ }
+}
+
+DWORD
+CPerlHost::CalculateEnvironmentSpace(void)
+{
+ DWORD index;
+ DWORD dwSize = 0;
+ for(index = 0; index < m_dwEnvCount; ++index)
+ dwSize += strlen(m_lppEnvList[index]) + 1;
+
+ return dwSize;
+}
+
+void
+CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
+{
+ dTHX;
+ Safefree(lpStr);
+}
+
+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;
+ }
+ }
+ return ptr;
+}
+
+void
+CPerlHost::FreeChildDir(char* pStr)
+{
+ dTHX;
+ Safefree(pStr);
+}
+
+LPSTR
+CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
+{
+ dTHX;
+ LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
+ DWORD dwSize, dwEnvIndex;
+ int nLength, compVal;
+
+ // get the process environment strings
+ lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
+
+ // step over current directory stuff
+ while(*lpTmp == '=')
+ lpTmp += strlen(lpTmp) + 1;
+
+ // save the start of the environment strings
+ lpEnvPtr = lpTmp;
+ for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
+ // calculate the size of the environment strings
+ dwSize += strlen(lpTmp) + 1;
+ }
+
+ // add the size of current directories
+ dwSize += vDir.CalculateEnvironmentSpace();
+
+ // add the additional space used by changes made to the environment
+ dwSize += CalculateEnvironmentSpace();
+
+ New(1, lpStr, dwSize, char);
+ lpPtr = lpStr;
+ if(lpStr != NULL) {
+ // build the local environment
+ lpStr = vDir.BuildEnvironmentSpace(lpStr);
+
+ dwEnvIndex = 0;
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ while(*lpEnvPtr != '\0') {
+ if(!lpLocalEnv) {
+ // all environment overrides have been added
+ // so copy string into place
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ // determine which string to copy next
+ compVal = compare(&lpEnvPtr, &lpLocalEnv);
+ if(compVal < 0) {
+ strcpy(lpStr, lpEnvPtr);
+ nLength = strlen(lpEnvPtr) + 1;
+ lpStr += nLength;
+ lpEnvPtr += nLength;
+ }
+ else {
+ char *ptr = strchr(lpLocalEnv, '=');
+ if(ptr && ptr[1]) {
+ strcpy(lpStr, lpLocalEnv);
+ lpStr += strlen(lpLocalEnv) + 1;
+ }
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ if(compVal == 0) {
+ // this string was replaced
+ lpEnvPtr += strlen(lpEnvPtr) + 1;
+ }
+ }
+ }
+ }
+
+ while(lpLocalEnv) {
+ // still have environment overrides to add
+ // so copy the strings into place if not an override
+ char *ptr = strchr(lpLocalEnv, '=');
+ if(ptr && ptr[1]) {
+ strcpy(lpStr, lpLocalEnv);
+ lpStr += strlen(lpLocalEnv) + 1;
+ }
+ lpLocalEnv = GetIndex(dwEnvIndex);
+ }
+
+ // add final NULL
+ *lpStr = '\0';
+ }
+
+ // release the process environment strings
+ FreeEnvironmentStrings(lpAllocPtr);
+
+ return lpPtr;
+}
+
+void
+CPerlHost::Reset(void)
+{
+ dTHX;
+ if(m_lppEnvList != NULL) {
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ Free(m_lppEnvList[index]);
+ m_lppEnvList[index] = NULL;
+ }
+ }
+ m_dwEnvCount = 0;
+ Free(m_lppEnvList);
+ m_lppEnvList = NULL;
+}
+
+void
+CPerlHost::Clearenv(void)
+{
+ dTHX;
+ char ch;
+ LPSTR lpPtr, lpStr, lpEnvPtr;
+ if (m_lppEnvList != NULL) {
+ /* set every entry to an empty string */
+ for(DWORD index = 0; index < m_dwEnvCount; ++index) {
+ char* ptr = strchr(m_lppEnvList[index], '=');
+ if(ptr) {
+ *++ptr = 0;
+ }
+ }
+ }
+
+ /* get the process environment strings */
+ lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
+
+ /* step over current directory stuff */
+ while(*lpStr == '=')
+ lpStr += strlen(lpStr) + 1;
+
+ while(*lpStr) {
+ lpPtr = strchr(lpStr, '=');
+ if(lpPtr) {
+ ch = *++lpPtr;
+ *lpPtr = 0;
+ Add(lpStr);
+ if (m_bTopLevel)
+ (void)win32_putenv(lpStr);
+ *lpPtr = ch;
+ }
+ lpStr += strlen(lpStr) + 1;
+ }
+
+ FreeEnvironmentStrings(lpEnvPtr);
+}
+
+
+char*
+CPerlHost::Getenv(const char *varname)
+{
+ dTHX;
+ if (!m_bTopLevel) {
+ char *pEnv = Find(varname);
+ if (pEnv && *pEnv)
+ return pEnv;
+ }
+ return win32_getenv(varname);
+}
+
+int
+CPerlHost::Putenv(const char *envstring)
+{
+ dTHX;
+ Add(envstring);
+ if (m_bTopLevel)
+ return win32_putenv(envstring);
+
+ return 0;
+}
+
+int
+CPerlHost::Chdir(const char *dirname)
+{
+ dTHX;
+ int ret;
+ if (!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);
+ if(ret < 0) {
+ errno = ENOENT;
+ }
+ return ret;
+}
+
+#endif /* ___PerlHost_H___ */
diff --git a/wince/perllib.c b/wince/perllib.c
index 527103f086..0b00246438 100644
--- a/wince/perllib.c
+++ b/wince/perllib.c
@@ -29,6 +29,49 @@ xs_init(pTHX)
#ifdef PERL_IMPLICIT_SYS
+extern "C" void win32_checkTLS(PerlInterpreter *host_perl);
+void
+win32_checkTLS(PerlInterpreter *host_perl)
+{
+ dTHX;
+ if (host_perl != my_perl) {
+ printf(" ... bad in win32_checkTLS\n");
+ printf(" %08X ne %08X\n",host_perl,my_perl);
+ int *nowhere = NULL;
+ *nowhere = 0;
+ abort();
+ }
+}
+
+#ifdef UNDER_CE
+int GetLogicalDrives() {
+ return 0; /* no logical drives on CE */
+}
+int GetLogicalDriveStrings(int size, char addr[]) {
+ return 0; /* no logical drives on CE */
+}
+/* TBD */
+DWORD GetFullPathNameA(LPCSTR fn, DWORD blen, LPTSTR buf, LPSTR *pfile) {
+ return 0;
+}
+/* TBD */
+DWORD GetFullPathNameW(CONST WCHAR *fn, DWORD blen, WCHAR * buf, WCHAR **pfile) {
+ return 0;
+}
+/* TBD */
+DWORD SetCurrentDirectoryA(LPSTR pPath) {
+ return 0;
+}
+/* TBD */
+DWORD SetCurrentDirectoryW(CONST WCHAR *pPath) {
+ return 0;
+}
+int xcesetuid(uid_t id){return 0;}
+int xceseteuid(uid_t id){ return 0;}
+int xcegetuid() {return 0;}
+int xcegeteuid(){ return 0;}
+#endif
+
#include "perlhost.h"
EXTERN_C void
@@ -127,6 +170,7 @@ perl_alloc(void)
w32_internal_host = pHost;
}
}
+ pHost->host_perl = my_perl; /* FIXME this statement shouldn't be here */
return my_perl;
}
@@ -256,3 +300,27 @@ DllMain(HANDLE hModule, /* DLL module handle */
return TRUE;
}
+
+#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags) {
+ dTHX;
+ CPerlHost *h;
+ h = new CPerlHost(*(CPerlHost*)PL_sys_intern.internal_host);
+ proto_perl = perl_clone_using(proto_perl, flags,
+ h->m_pHostperlMem,
+ h->m_pHostperlMemShared,
+ h->m_pHostperlMemParse,
+ h->m_pHostperlEnv,
+ h->m_pHostperlStdIO,
+ h->m_pHostperlLIO,
+ h->m_pHostperlDir,
+ h->m_pHostperlSock,
+ h->m_pHostperlProc
+ );
+ proto_perl->Isys_intern.internal_host = h;
+ h->host_perl = proto_perl;
+ return proto_perl;
+
+}
+#endif
diff --git a/wince/vdir.h b/wince/vdir.h
new file mode 100644
index 0000000000..10119ead9e
--- /dev/null
+++ b/wince/vdir.h
@@ -0,0 +1,691 @@
+/* vdir.h
+ *
+ * (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.
+ */
+
+#ifndef ___VDir_H___
+#define ___VDir_H___
+
+/*
+ * Allow one slot for each possible drive letter
+ * and one additional slot for a UNC name
+ */
+const int driveCount = ('Z'-'A')+1+1;
+
+class VDir
+{
+public:
+ VDir(int bManageDir = 1);
+ ~VDir() {};
+
+ void Init(VDir* pDir, VMem *pMem);
+ void SetDefaultA(char const *pDefault);
+ void SetDefaultW(WCHAR const *pDefault);
+ char* MapPathA(const char *pInName);
+ WCHAR* MapPathW(const WCHAR *pInName);
+ int SetCurrentDirectoryA(char *lpBuffer);
+ int SetCurrentDirectoryW(WCHAR *lpBuffer);
+ inline int GetDefault(void) { return nDefault; };
+
+ inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer)
+ {
+ char* ptr = dirTableA[nDefault];
+ while (dwBufSize--)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ return lpBuffer;
+ };
+ inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer)
+ {
+ WCHAR* ptr = dirTableW[nDefault];
+ while (dwBufSize--)
+ {
+ if ((*lpBuffer++ = *ptr++) == '\0')
+ break;
+ }
+ return lpBuffer;
+ };
+
+
+ DWORD CalculateEnvironmentSpace(void);
+ LPSTR BuildEnvironmentSpace(LPSTR lpStr);
+
+protected:
+ int SetDirA(char const *pPath, int index);
+ void FromEnvA(char *pEnv, int index);
+ inline const char *GetDefaultDirA(void)
+ {
+ return dirTableA[nDefault];
+ };
+
+ inline void SetDefaultDirA(char const *pPath, int index)
+ {
+ SetDirA(pPath, index);
+ nDefault = index;
+ };
+ int SetDirW(WCHAR const *pPath, int index);
+ inline const WCHAR *GetDefaultDirW(void)
+ {
+ return dirTableW[nDefault];
+ };
+
+ inline void SetDefaultDirW(WCHAR const *pPath, int index)
+ {
+ SetDirW(pPath, index);
+ nDefault = index;
+ };
+ inline const char *GetDirA(int index)
+ {
+ char *ptr = dirTableA[index];
+ if (!ptr) {
+ /* simulate the existance of this drive */
+ ptr = szLocalBufferA;
+ ptr[0] = 'A' + index;
+ ptr[1] = ':';
+ ptr[2] = '\\';
+ ptr[3] = 0;
+ }
+ return ptr;
+ };
+ inline const WCHAR *GetDirW(int index)
+ {
+ WCHAR *ptr = dirTableW[index];
+ if (!ptr) {
+ /* simulate the existance of this drive */
+ ptr = szLocalBufferW;
+ ptr[0] = 'A' + index;
+ ptr[1] = ':';
+ ptr[2] = '\\';
+ ptr[3] = 0;
+ }
+ return ptr;
+ };
+
+ inline int DriveIndex(char chr)
+ {
+ if (chr == '\\' || chr == '/')
+ return ('Z'-'A')+1;
+ return (chr | 0x20)-'a';
+ };
+
+ VMem *pMem;
+ int nDefault, bManageDirectory;
+ char *dirTableA[driveCount];
+ char szLocalBufferA[MAX_PATH+1];
+ WCHAR *dirTableW[driveCount];
+ WCHAR szLocalBufferW[MAX_PATH+1];
+};
+
+
+VDir::VDir(int bManageDir /* = 1 */)
+{
+ nDefault = 0;
+ bManageDirectory = bManageDir;
+ memset(dirTableA, 0, sizeof(dirTableA));
+ memset(dirTableW, 0, sizeof(dirTableW));
+}
+
+void VDir::Init(VDir* pDir, VMem *p)
+{
+ int index;
+ DWORD driveBits;
+ int nSave;
+ char szBuffer[MAX_PATH*driveCount];
+
+ pMem = p;
+ if (pDir) {
+ for (index = 0; index < driveCount; ++index) {
+ SetDirW(pDir->GetDirW(index), index);
+ }
+ nDefault = pDir->GetDefault();
+ }
+ else {
+ nSave = bManageDirectory;
+ bManageDirectory = 0;
+ driveBits = GetLogicalDrives();
+ if (GetLogicalDriveStrings(sizeof(szBuffer), szBuffer)) {
+ char* pEnv = (char*)GetEnvironmentStrings();
+ char* ptr = szBuffer;
+ for (index = 0; index < driveCount; ++index) {
+ if (driveBits & (1<<index)) {
+ ptr += SetDirA(ptr, index) + 1;
+ FromEnvA(pEnv, index);
+ }
+ }
+ FreeEnvironmentStrings(pEnv);
+ }
+ SetDefaultA(".");
+ bManageDirectory = nSave;
+ }
+}
+
+int VDir::SetDirA(char const *pPath, int index)
+{
+ char chr, *ptr;
+ int length = 0;
+ WCHAR wBuffer[MAX_PATH+1];
+ if (index < driveCount && pPath != NULL) {
+ length = strlen(pPath);
+ pMem->Free(dirTableA[index]);
+ ptr = dirTableA[index] = (char*)pMem->Malloc(length+2);
+ if (ptr != NULL) {
+ strcpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1,
+ wBuffer, (sizeof(wBuffer)/sizeof(WCHAR)));
+ length = wcslen(wBuffer);
+ pMem->Free(dirTableW[index]);
+ dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2);
+ if (dirTableW[index] != NULL) {
+ wcscpy(dirTableW[index], wBuffer);
+ }
+ }
+ }
+
+ if(bManageDirectory)
+ ::SetCurrentDirectoryA(pPath);
+
+ return length;
+}
+
+void VDir::FromEnvA(char *pEnv, int index)
+{ /* gets the directory for index from the environment variable. */
+ while (*pEnv != '\0') {
+ if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index)) {
+ SetDirA(&pEnv[4], index);
+ break;
+ }
+ else
+ pEnv += strlen(pEnv)+1;
+ }
+}
+
+void VDir::SetDefaultA(char const *pDefault)
+{
+ char szBuffer[MAX_PATH+1];
+ char *pPtr;
+
+ if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ }
+}
+
+int VDir::SetDirW(WCHAR const *pPath, int index)
+{
+ WCHAR chr, *ptr;
+ char szBuffer[MAX_PATH+1];
+ int length = 0;
+ if (index < driveCount && pPath != NULL) {
+ length = wcslen(pPath);
+ pMem->Free(dirTableW[index]);
+ ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2);
+ if (ptr != NULL) {
+ wcscpy(ptr, pPath);
+ ptr += length-1;
+ chr = *ptr++;
+ if (chr != '\\' && chr != '/') {
+ *ptr++ = '\\';
+ *ptr = '\0';
+ }
+ WideCharToMultiByte(CP_ACP, 0, dirTableW[index], -1, szBuffer, sizeof(szBuffer), NULL, NULL);
+ length = strlen(szBuffer);
+ pMem->Free(dirTableA[index]);
+ dirTableA[index] = (char*)pMem->Malloc(length+1);
+ if (dirTableA[index] != NULL) {
+ strcpy(dirTableA[index], szBuffer);
+ }
+ }
+ }
+
+ if(bManageDirectory)
+ ::SetCurrentDirectoryW(pPath);
+
+ return length;
+}
+
+void VDir::SetDefaultW(WCHAR const *pDefault)
+{
+ WCHAR szBuffer[MAX_PATH+1];
+ WCHAR *pPtr;
+
+ if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) {
+ if (*pDefault != '.' && pPtr != NULL)
+ *pPtr = '\0';
+
+ SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0]));
+ }
+}
+
+inline BOOL IsPathSep(char ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameA(char* lpBuffer, DWORD dwSize, char* Dest)
+{
+ char *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to Nullch
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameA(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+inline bool IsSpecialFileName(const char* pName)
+{
+ /* specical file names are devices that the system can open
+ * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$
+ * (x is a single digit, and names are case-insensitive)
+ */
+ char ch = (pName[0] & ~0x20);
+ switch (ch)
+ {
+ case 'A': /* AUX */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && !pName[3])
+ return true;
+ break;
+ case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */
+ ch = (pName[1] & ~0x20);
+ switch (ch)
+ {
+ case 'L': /* CLOCK$ */
+ if (((pName[2] & ~0x20) == 'O')
+ && ((pName[3] & ~0x20) == 'C')
+ && ((pName[4] & ~0x20) == 'K')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ break;
+ case 'O': /* COMx, CON, CONIN$ CONOUT$ */
+ if ((pName[2] & ~0x20) == 'M') {
+ if ((pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ }
+ else if ((pName[2] & ~0x20) == 'N') {
+ if (!pName[3])
+ return true;
+ else if ((pName[3] & ~0x20) == 'I') {
+ if (((pName[4] & ~0x20) == 'N')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ }
+ else if ((pName[3] & ~0x20) == 'O') {
+ if (((pName[4] & ~0x20) == 'U')
+ && ((pName[5] & ~0x20) == 'T')
+ && (pName[6] == '$')
+ && !pName[7])
+ return true;
+ }
+ }
+ break;
+ }
+ break;
+ case 'L': /* LPTx */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && (pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ break;
+ case 'N': /* NUL */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'L')
+ && !pName[3])
+ return true;
+ break;
+ case 'P': /* PRN */
+ if (((pName[1] & ~0x20) == 'R')
+ && ((pName[2] & ~0x20) == 'N')
+ && !pName[3])
+ return true;
+ break;
+ }
+ return false;
+}
+
+char *VDir::MapPathA(const char *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ char szBuffer[(MAX_PATH+1)*2];
+ char szlBuf[MAX_PATH+1];
+ int length = strlen(pInName);
+
+ if (!length)
+ return (char*)pInName;
+
+ if (length > MAX_PATH) {
+ strncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ /* relative path with drive letter */
+ strcpy(szBuffer, GetDirA(DriveIndex(*pInName)));
+ strcat(szBuffer, &pInName[2]);
+ if(strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ strcpy(szBuffer, GetDefaultDirA());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ strcpy(&szBuffer[2], pInName);
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ else {
+ /* relative path */
+ if (IsSpecialFileName(pInName)) {
+ return (char*)pInName;
+ }
+ else {
+ strcat(szBuffer, pInName);
+ if (strlen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA);
+ }
+ }
+ }
+ }
+
+ return szLocalBufferA;
+}
+
+int VDir::SetCurrentDirectoryA(char *lpBuffer)
+{
+ char *pPtr;
+ int length, nRet = -1;
+
+ pPtr = MapPathA(lpBuffer);
+ length = strlen(pPtr);
+ if(length > 3 && IsPathSep(pPtr[length-1])) {
+ /* don't remove the trailing slash from 'x:\' */
+ pPtr[length-1] = '\0';
+ }
+
+ DWORD r = GetFileAttributesA(pPtr);
+ if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
+ {
+ char szBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameA(pPtr, sizeof(szBuffer), szBuffer);
+ SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0]));
+ nRet = 0;
+ }
+
+ return nRet;
+}
+
+DWORD VDir::CalculateEnvironmentSpace(void)
+{ /* the current directory environment strings are stored as '=D:=d:\path' */
+ int index;
+ DWORD dwSize = 0;
+ for (index = 0; index < driveCount; ++index) {
+ if (dirTableA[index] != NULL) {
+ dwSize += strlen(dirTableA[index]) + 5; /* add 1 for trailing NULL and 4 for '=D:=' */
+ }
+ }
+ return dwSize;
+}
+
+LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr)
+{ /* store the current directory environment strings as '=D:=d:\path' */
+ int index, length;
+ LPSTR lpDirStr;
+ for (index = 0; index < driveCount; ++index) {
+ lpDirStr = dirTableA[index];
+ if (lpDirStr != NULL) {
+ lpStr[0] = '=';
+ lpStr[1] = lpDirStr[0];
+ lpStr[2] = '\0';
+ CharUpper(&lpStr[1]);
+ lpStr[2] = ':';
+ lpStr[3] = '=';
+ strcpy(&lpStr[4], lpDirStr);
+ length = strlen(lpDirStr);
+ lpStr += length + 5; /* add 1 for trailing NULL and 4 for '=D:=' */
+ if (length > 3 && IsPathSep(lpStr[-2])) {
+ lpStr[-2] = '\0'; /* remove the trailing path separator */
+ --lpStr;
+ }
+ }
+ }
+ return lpStr;
+}
+
+inline BOOL IsPathSep(WCHAR ch)
+{
+ return (ch == '\\' || ch == '/');
+}
+
+inline void DoGetFullPathNameW(WCHAR* lpBuffer, DWORD dwSize, WCHAR* Dest)
+{
+ WCHAR *pPtr;
+
+ /*
+ * On WinNT GetFullPathName does not fail, (or at least always
+ * succeeds when the drive is valid) WinNT does set *Dest to Nullch
+ * On Win98 GetFullPathName will set last error if it fails, but
+ * does not touch *Dest
+ */
+ *Dest = '\0';
+ GetFullPathNameW(lpBuffer, dwSize, Dest, &pPtr);
+}
+
+inline bool IsSpecialFileName(const WCHAR* pName)
+{
+ /* specical file names are devices that the system can open
+ * these include AUX, CON, NUL, PRN, COMx, LPTx, CLOCK$, CONIN$, CONOUT$
+ * (x is a single digit, and names are case-insensitive)
+ */
+ WCHAR ch = (pName[0] & ~0x20);
+ switch (ch)
+ {
+ case 'A': /* AUX */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && !pName[3])
+ return true;
+ break;
+ case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */
+ ch = (pName[1] & ~0x20);
+ switch (ch)
+ {
+ case 'L': /* CLOCK$ */
+ if (((pName[2] & ~0x20) == 'O')
+ && ((pName[3] & ~0x20) == 'C')
+ && ((pName[4] & ~0x20) == 'K')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ break;
+ case 'O': /* COMx, CON, CONIN$ CONOUT$ */
+ if ((pName[2] & ~0x20) == 'M') {
+ if ((pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ }
+ else if ((pName[2] & ~0x20) == 'N') {
+ if (!pName[3])
+ return true;
+ else if ((pName[3] & ~0x20) == 'I') {
+ if (((pName[4] & ~0x20) == 'N')
+ && (pName[5] == '$')
+ && !pName[6])
+ return true;
+ }
+ else if ((pName[3] & ~0x20) == 'O') {
+ if (((pName[4] & ~0x20) == 'U')
+ && ((pName[5] & ~0x20) == 'T')
+ && (pName[6] == '$')
+ && !pName[7])
+ return true;
+ }
+ }
+ break;
+ }
+ break;
+ case 'L': /* LPTx */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'X')
+ && (pName[3] >= '1') && (pName[3] <= '9')
+ && !pName[4])
+ return true;
+ break;
+ case 'N': /* NUL */
+ if (((pName[1] & ~0x20) == 'U')
+ && ((pName[2] & ~0x20) == 'L')
+ && !pName[3])
+ return true;
+ break;
+ case 'P': /* PRN */
+ if (((pName[1] & ~0x20) == 'R')
+ && ((pName[2] & ~0x20) == 'N')
+ && !pName[3])
+ return true;
+ break;
+ }
+ return false;
+}
+
+WCHAR* VDir::MapPathW(const WCHAR *pInName)
+{ /*
+ * possiblities -- relative path or absolute path with or without drive letter
+ * OR UNC name
+ */
+ WCHAR szBuffer[(MAX_PATH+1)*2];
+ WCHAR szlBuf[MAX_PATH+1];
+ int length = wcslen(pInName);
+
+ if (!length)
+ return (WCHAR*)pInName;
+
+ if (length > MAX_PATH) {
+ wcsncpy(szlBuf, pInName, MAX_PATH);
+ if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) {
+ /* absolute path - reduce length by 2 for drive specifier */
+ szlBuf[MAX_PATH-2] = '\0';
+ }
+ else
+ szlBuf[MAX_PATH] = '\0';
+ pInName = szlBuf;
+ }
+ /* strlen(pInName) is now <= MAX_PATH */
+
+ if (pInName[1] == ':') {
+ /* has drive letter */
+ if (IsPathSep(pInName[2])) {
+ /* absolute with drive letter */
+ DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ /* relative path with drive letter */
+ wcscpy(szBuffer, GetDirW(DriveIndex((char)*pInName)));
+ wcscat(szBuffer, &pInName[2]);
+ if(wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ else {
+ /* no drive letter */
+ if (IsPathSep(pInName[1]) && IsPathSep(pInName[0])) {
+ /* UNC name */
+ DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ wcscpy(szBuffer, GetDefaultDirW());
+ if (IsPathSep(pInName[0])) {
+ /* absolute path */
+ wcscpy(&szBuffer[2], pInName);
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ else {
+ /* relative path */
+ if (IsSpecialFileName(pInName)) {
+ return (WCHAR*)pInName;
+ }
+ else {
+ wcscat(szBuffer, pInName);
+ if (wcslen(szBuffer) > MAX_PATH)
+ szBuffer[MAX_PATH] = '\0';
+
+ DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW);
+ }
+ }
+ }
+ }
+ return szLocalBufferW;
+}
+
+int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer)
+{
+ WCHAR *pPtr;
+ int length, nRet = -1;
+
+ pPtr = MapPathW(lpBuffer);
+ length = wcslen(pPtr);
+ if(length > 3 && IsPathSep(pPtr[length-1])) {
+ /* don't remove the trailing slash from 'x:\' */
+ pPtr[length-1] = '\0';
+ }
+
+ DWORD r = GetFileAttributesW(pPtr);
+ if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY))
+ {
+ WCHAR wBuffer[(MAX_PATH+1)*2];
+ DoGetFullPathNameW(pPtr, (sizeof(wBuffer)/sizeof(WCHAR)), wBuffer);
+ SetDefaultDirW(wBuffer, DriveIndex((char)wBuffer[0]));
+ nRet = 0;
+ }
+
+ return nRet;
+}
+
+#endif /* ___VDir_H___ */
diff --git a/wince/vmem.h b/wince/vmem.h
new file mode 100644
index 0000000000..1fd421ca38
--- /dev/null
+++ b/wince/vmem.h
@@ -0,0 +1,1248 @@
+/* vmem.h
+ *
+ * (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.
+ *
+ * Options:
+ *
+ * Defining _USE_MSVCRT_MEM_ALLOC will cause all memory allocations
+ * to be forwarded to MSVCRT.DLL. Defining _USE_LINKED_LIST as well will
+ * track all allocations in a doubly linked list, so that the host can
+ * free all memory allocated when it goes away.
+ * If _USE_MSVCRT_MEM_ALLOC is not defined then Knuth's boundary tag algorithm
+ * is used; defining _USE_BUDDY_BLOCKS will use Knuth's algorithm R
+ * (Buddy system reservation)
+ *
+ */
+
+#ifndef ___VMEM_H_INC___
+#define ___VMEM_H_INC___
+
+// #define _USE_MSVCRT_MEM_ALLOC
+#define _USE_LINKED_LIST
+
+// #define _USE_BUDDY_BLOCKS
+
+// #define _DEBUG_MEM
+#ifdef _DEBUG_MEM
+#define ASSERT(f) if(!(f)) DebugBreak();
+
+inline void MEMODS(char *str)
+{
+ OutputDebugString(str);
+ OutputDebugString("\n");
+}
+
+inline void MEMODSlx(char *str, long x)
+{
+ char szBuffer[512];
+ sprintf(szBuffer, "%s %lx\n", str, x);
+ OutputDebugString(szBuffer);
+}
+
+#define WALKHEAP() WalkHeap(0)
+#define WALKHEAPTRACE() WalkHeap(1)
+
+#else
+
+#define ASSERT(f)
+#define MEMODS(x)
+#define MEMODSlx(x, y)
+#define WALKHEAP()
+#define WALKHEAPTRACE()
+
+#endif
+
+#ifdef _USE_MSVCRT_MEM_ALLOC
+
+#ifndef _USE_LINKED_LIST
+// #define _USE_LINKED_LIST
+#endif
+
+/*
+ * Pass all memory requests throught to msvcrt.dll
+ * optionaly track by using a doubly linked header
+ */
+
+typedef void (*LPFREE)(void *block);
+typedef void* (*LPMALLOC)(size_t size);
+typedef void* (*LPREALLOC)(void *block, size_t size);
+#ifdef _USE_LINKED_LIST
+class VMem;
+typedef struct _MemoryBlockHeader* PMEMORY_BLOCK_HEADER;
+typedef struct _MemoryBlockHeader {
+ PMEMORY_BLOCK_HEADER pNext;
+ PMEMORY_BLOCK_HEADER pPrev;
+ VMem *owner;
+} MEMORY_BLOCK_HEADER, *PMEMORY_BLOCK_HEADER;
+#endif
+
+class VMem
+{
+public:
+ VMem();
+ ~VMem();
+ virtual void* Malloc(size_t size);
+ virtual void* Realloc(void* pMem, size_t size);
+ virtual void Free(void* pMem);
+ virtual void GetLock(void);
+ virtual void FreeLock(void);
+ virtual int IsLocked(void);
+ virtual long Release(void);
+ virtual long AddRef(void);
+
+ inline BOOL CreateOk(void)
+ {
+ return TRUE;
+ };
+
+protected:
+#ifdef _USE_LINKED_LIST
+ void LinkBlock(PMEMORY_BLOCK_HEADER ptr)
+ {
+ PMEMORY_BLOCK_HEADER next = m_Dummy.pNext;
+ m_Dummy.pNext = ptr;
+ ptr->pPrev = &m_Dummy;
+ ptr->pNext = next;
+ ptr->owner = this;
+ next->pPrev = ptr;
+ }
+ void UnlinkBlock(PMEMORY_BLOCK_HEADER ptr)
+ {
+ PMEMORY_BLOCK_HEADER next = ptr->pNext;
+ PMEMORY_BLOCK_HEADER prev = ptr->pPrev;
+ prev->pNext = next;
+ next->pPrev = prev;
+ }
+
+ MEMORY_BLOCK_HEADER m_Dummy;
+#endif
+
+ long m_lRefCount; // number of current users
+ CRITICAL_SECTION m_cs; // access lock
+ HINSTANCE m_hLib;
+ LPFREE m_pfree;
+ LPMALLOC m_pmalloc;
+ LPREALLOC m_prealloc;
+};
+
+VMem::VMem()
+{
+ m_lRefCount = 1;
+ InitializeCriticalSection(&m_cs);
+#ifdef _USE_LINKED_LIST
+ m_Dummy.pNext = m_Dummy.pPrev = &m_Dummy;
+ m_Dummy.owner = this;
+#endif
+ m_hLib = LoadLibrary("msvcrt.dll");
+ if (m_hLib) {
+ m_pfree = (LPFREE)GetProcAddress(m_hLib, "free");
+ m_pmalloc = (LPMALLOC)GetProcAddress(m_hLib, "malloc");
+ m_prealloc = (LPREALLOC)GetProcAddress(m_hLib, "realloc");
+ }
+}
+
+VMem::~VMem(void)
+{
+#ifdef _USE_LINKED_LIST
+ while (m_Dummy.pNext != &m_Dummy) {
+ Free(m_Dummy.pNext+1);
+ }
+#endif
+ if (m_hLib)
+ FreeLibrary(m_hLib);
+ DeleteCriticalSection(&m_cs);
+}
+
+void* VMem::Malloc(size_t size)
+{
+#ifdef _USE_LINKED_LIST
+ GetLock();
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)m_pmalloc(size+sizeof(MEMORY_BLOCK_HEADER));
+ LinkBlock(ptr);
+ FreeLock();
+ return (ptr+1);
+#else
+ return m_pmalloc(size);
+#endif
+}
+
+void* VMem::Realloc(void* pMem, size_t size)
+{
+#ifdef _USE_LINKED_LIST
+ if (!pMem)
+ return Malloc(size);
+
+ if (!size) {
+ Free(pMem);
+ return NULL;
+ }
+
+ GetLock();
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
+ UnlinkBlock(ptr);
+ ptr = (PMEMORY_BLOCK_HEADER)m_prealloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER));
+ LinkBlock(ptr);
+ FreeLock();
+
+ return (ptr+1);
+#else
+ return m_prealloc(pMem, size);
+#endif
+}
+
+void VMem::Free(void* pMem)
+{
+#ifdef _USE_LINKED_LIST
+ if (pMem) {
+ PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER));
+ if (ptr->owner != this) {
+ if (ptr->owner) {
+#if 1
+ dTHX;
+ int *nowhere = NULL;
+ Perl_warn(aTHX_ "Free to wrong pool %p not %p",this,ptr->owner);
+ *nowhere = 0;
+#else
+ ptr->owner->Free(pMem);
+#endif
+ }
+ return;
+ }
+ GetLock();
+ UnlinkBlock(ptr);
+ ptr->owner = NULL;
+ m_pfree(ptr);
+ FreeLock();
+ }
+#else
+ m_pfree(pMem);
+#endif
+}
+
+void VMem::GetLock(void)
+{
+ EnterCriticalSection(&m_cs);
+}
+
+void VMem::FreeLock(void)
+{
+ LeaveCriticalSection(&m_cs);
+}
+
+int VMem::IsLocked(void)
+{
+#if 0
+ /* XXX TryEnterCriticalSection() is not available in some versions
+ * of Windows 95. Since this code is not used anywhere yet, we
+ * skirt the issue for now. */
+ BOOL bAccessed = TryEnterCriticalSection(&m_cs);
+ if(bAccessed) {
+ LeaveCriticalSection(&m_cs);
+ }
+ return !bAccessed;
+#else
+ ASSERT(0); /* alarm bells for when somebody calls this */
+ return 0;
+#endif
+}
+
+long VMem::Release(void)
+{
+ long lCount = InterlockedDecrement(&m_lRefCount);
+ if(!lCount)
+ delete this;
+ return lCount;
+}
+
+long VMem::AddRef(void)
+{
+ long lCount = InterlockedIncrement(&m_lRefCount);
+ return lCount;
+}
+
+#else /* _USE_MSVCRT_MEM_ALLOC */
+
+/*
+ * Knuth's boundary tag algorithm Vol #1, Page 440.
+ *
+ * Each block in the heap has tag words before and after it,
+ * TAG
+ * block
+ * TAG
+ * The size is stored in these tags as a long word, and includes the 8 bytes
+ * of overhead that the boundary tags consume. Blocks are allocated on long
+ * word boundaries, so the size is always multiples of long words. When the
+ * block is allocated, bit 0, (the tag bit), of the size is set to 1. When
+ * a block is freed, it is merged with adjacent free blocks, and the tag bit
+ * is set to 0.
+ *
+ * A linked list is used to manage the free list. The first two long words of
+ * the block contain double links. These links are only valid when the block
+ * is freed, therefore space needs to be reserved for them. Thus, the minimum
+ * block size (not counting the tags) is 8 bytes.
+ *
+ * Since memory allocation may occur on a single threaded, explict locks are not
+ * provided.
+ *
+ */
+
+const long lAllocStart = 0x00020000; /* start at 128K */
+const long minBlockSize = sizeof(void*)*2;
+const long sizeofTag = sizeof(long);
+const long blockOverhead = sizeofTag*2;
+const long minAllocSize = minBlockSize+blockOverhead;
+#ifdef _USE_BUDDY_BLOCKS
+const long lSmallBlockSize = 1024;
+const size_t nListEntries = ((lSmallBlockSize-minAllocSize)/sizeof(long));
+
+inline size_t CalcEntry(size_t size)
+{
+ ASSERT((size&(sizeof(long)-1)) == 0);
+ return ((size - minAllocSize) / sizeof(long));
+}
+#endif
+
+typedef BYTE* PBLOCK; /* pointer to a memory block */
+
+/*
+ * Macros for accessing hidden fields in a memory block:
+ *
+ * SIZE size of this block (tag bit 0 is 1 if block is allocated)
+ * PSIZE size of previous physical block
+ */
+
+#define SIZE(block) (*(ULONG*)(((PBLOCK)(block))-sizeofTag))
+#define PSIZE(block) (*(ULONG*)(((PBLOCK)(block))-(blockOverhead)))
+inline void SetTags(PBLOCK block, long size)
+{
+ SIZE(block) = size;
+ PSIZE(block+(size&~1)) = size;
+}
+
+/*
+ * Free list pointers
+ * PREV pointer to previous block
+ * NEXT pointer to next block
+ */
+
+#define PREV(block) (*(PBLOCK*)(block))
+#define NEXT(block) (*(PBLOCK*)((block)+sizeof(PBLOCK)))
+inline void SetLink(PBLOCK block, PBLOCK prev, PBLOCK next)
+{
+ PREV(block) = prev;
+ NEXT(block) = next;
+}
+inline void Unlink(PBLOCK p)
+{
+ PBLOCK next = NEXT(p);
+ PBLOCK prev = PREV(p);
+ NEXT(prev) = next;
+ PREV(next) = prev;
+}
+#ifndef _USE_BUDDY_BLOCKS
+inline void AddToFreeList(PBLOCK block, PBLOCK pInList)
+{
+ PBLOCK next = NEXT(pInList);
+ NEXT(pInList) = block;
+ SetLink(block, pInList, next);
+ PREV(next) = block;
+}
+#endif
+
+/* Macro for rounding up to the next sizeof(long) */
+#define ROUND_UP(n) (((ULONG)(n)+sizeof(long)-1)&~(sizeof(long)-1))
+#define ROUND_UP64K(n) (((ULONG)(n)+0x10000-1)&~(0x10000-1))
+#define ROUND_DOWN(n) ((ULONG)(n)&~(sizeof(long)-1))
+
+/*
+ * HeapRec - a list of all non-contiguous heap areas
+ *
+ * Each record in this array contains information about a non-contiguous heap area.
+ */
+
+const int maxHeaps = 32; /* 64 was overkill */
+const long lAllocMax = 0x80000000; /* max size of allocation */
+
+#ifdef _USE_BUDDY_BLOCKS
+typedef struct _FreeListEntry
+{
+ BYTE Dummy[minAllocSize]; // dummy free block
+} FREE_LIST_ENTRY, *PFREE_LIST_ENTRY;
+#endif
+
+#ifndef _USE_BUDDY_BLOCKS
+#define USE_BIGBLOCK_ALLOC
+#endif
+/*
+ * performance tuning
+ * Use VirtualAlloc() for blocks bigger than nMaxHeapAllocSize since
+ * Windows 95/98/Me have heap managers that are designed for memory
+ * blocks smaller than four megabytes.
+ */
+
+#ifdef USE_BIGBLOCK_ALLOC
+const int nMaxHeapAllocSize = (1024*512); /* don't allocate anything larger than this from the heap */
+#endif
+
+typedef struct _HeapRec
+{
+ PBLOCK base; /* base of heap area */
+ ULONG len; /* size of heap area */
+#ifdef USE_BIGBLOCK_ALLOC
+ BOOL bBigBlock; /* was allocate using VirtualAlloc */
+#endif
+} HeapRec;
+
+class VMem
+{
+public:
+ VMem();
+ ~VMem();
+ virtual void* Malloc(size_t size);
+ virtual void* Realloc(void* pMem, size_t size);
+ virtual void Free(void* pMem);
+ virtual void GetLock(void);
+ virtual void FreeLock(void);
+ virtual int IsLocked(void);
+ virtual long Release(void);
+ virtual long AddRef(void);
+
+ inline BOOL CreateOk(void)
+ {
+#ifdef _USE_BUDDY_BLOCKS
+ return TRUE;
+#else
+ return m_hHeap != NULL;
+#endif
+ };
+
+ void ReInit(void);
+
+protected:
+ void Init(void);
+ int Getmem(size_t size);
+
+ int HeapAdd(void* ptr, size_t size
+#ifdef USE_BIGBLOCK_ALLOC
+ , BOOL bBigBlock
+#endif
+ );
+
+ void* Expand(void* block, size_t size);
+
+#ifdef _USE_BUDDY_BLOCKS
+ inline PBLOCK GetFreeListLink(int index)
+ {
+ if (index >= nListEntries)
+ index = nListEntries-1;
+ return &m_FreeList[index].Dummy[sizeofTag];
+ }
+ inline PBLOCK GetOverSizeFreeList(void)
+ {
+ return &m_FreeList[nListEntries-1].Dummy[sizeofTag];
+ }
+ inline PBLOCK GetEOLFreeList(void)
+ {
+ return &m_FreeList[nListEntries].Dummy[sizeofTag];
+ }
+
+ void AddToFreeList(PBLOCK block, size_t size)
+ {
+ PBLOCK pFreeList = GetFreeListLink(CalcEntry(size));
+ PBLOCK next = NEXT(pFreeList);
+ NEXT(pFreeList) = block;
+ SetLink(block, pFreeList, next);
+ PREV(next) = block;
+ }
+#endif
+ inline size_t CalcAllocSize(size_t size)
+ {
+ /*
+ * Adjust the real size of the block to be a multiple of sizeof(long), and add
+ * the overhead for the boundary tags. Disallow negative or zero sizes.
+ */
+ return (size < minBlockSize) ? minAllocSize : (size_t)ROUND_UP(size) + blockOverhead;
+ }
+
+#ifdef _USE_BUDDY_BLOCKS
+ FREE_LIST_ENTRY m_FreeList[nListEntries+1]; // free list with dummy end of list entry as well
+#else
+ HANDLE m_hHeap; // memory heap for this script
+ char m_FreeDummy[minAllocSize]; // dummy free block
+ PBLOCK m_pFreeList; // pointer to first block on free list
+#endif
+ PBLOCK m_pRover; // roving pointer into the free list
+ HeapRec m_heaps[maxHeaps]; // list of all non-contiguous heap areas
+ int m_nHeaps; // no. of heaps in m_heaps
+ long m_lAllocSize; // current alloc size
+ long m_lRefCount; // number of current users
+ CRITICAL_SECTION m_cs; // access lock
+
+#ifdef _DEBUG_MEM
+ void WalkHeap(int complete);
+ void MemoryUsageMessage(char *str, long x, long y, int c);
+ FILE* m_pLog;
+#endif
+};
+
+VMem::VMem()
+{
+ m_lRefCount = 1;
+#ifndef _USE_BUDDY_BLOCKS
+ BOOL bRet = (NULL != (m_hHeap = HeapCreate(HEAP_NO_SERIALIZE,
+ lAllocStart, /* initial size of heap */
+ 0))); /* no upper limit on size of heap */
+ ASSERT(bRet);
+#endif
+
+ InitializeCriticalSection(&m_cs);
+#ifdef _DEBUG_MEM
+ m_pLog = 0;
+#endif
+
+ Init();
+}
+
+VMem::~VMem(void)
+{
+#ifndef _USE_BUDDY_BLOCKS
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, NULL));
+#endif
+ WALKHEAPTRACE();
+
+ DeleteCriticalSection(&m_cs);
+#ifdef _USE_BUDDY_BLOCKS
+ for(int index = 0; index < m_nHeaps; ++index) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+#else /* !_USE_BUDDY_BLOCKS */
+#ifdef USE_BIGBLOCK_ALLOC
+ for(int index = 0; index < m_nHeaps; ++index) {
+ if (m_heaps[index].bBigBlock) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+ }
+#endif
+ BOOL bRet = HeapDestroy(m_hHeap);
+ ASSERT(bRet);
+#endif /* _USE_BUDDY_BLOCKS */
+}
+
+void VMem::ReInit(void)
+{
+ for(int index = 0; index < m_nHeaps; ++index) {
+#ifdef _USE_BUDDY_BLOCKS
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ if (m_heaps[index].bBigBlock) {
+ VirtualFree(m_heaps[index].base, 0, MEM_RELEASE);
+ }
+ else
+#endif
+ HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base);
+#endif /* _USE_BUDDY_BLOCKS */
+ }
+
+ Init();
+}
+
+void VMem::Init(void)
+{
+#ifdef _USE_BUDDY_BLOCKS
+ PBLOCK pFreeList;
+ /*
+ * Initialize the free list by placing a dummy zero-length block on it.
+ * Set the end of list marker.
+ * Set the number of non-contiguous heaps to zero.
+ * Set the next allocation size.
+ */
+ for (int index = 0; index < nListEntries; ++index) {
+ pFreeList = GetFreeListLink(index);
+ SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0;
+ PREV(pFreeList) = NEXT(pFreeList) = pFreeList;
+ }
+ pFreeList = GetEOLFreeList();
+ SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0;
+ PREV(pFreeList) = NEXT(pFreeList) = NULL;
+ m_pRover = GetOverSizeFreeList();
+#else
+ /*
+ * Initialize the free list by placing a dummy zero-length block on it.
+ * Set the number of non-contiguous heaps to zero.
+ */
+ m_pFreeList = m_pRover = (PBLOCK)(&m_FreeDummy[sizeofTag]);
+ PSIZE(m_pFreeList+minAllocSize) = SIZE(m_pFreeList) = 0;
+ PREV(m_pFreeList) = NEXT(m_pFreeList) = m_pFreeList;
+#endif
+
+ m_nHeaps = 0;
+ m_lAllocSize = lAllocStart;
+}
+
+void* VMem::Malloc(size_t size)
+{
+ WALKHEAP();
+
+ PBLOCK ptr;
+ size_t lsize, rem;
+ /*
+ * Disallow negative or zero sizes.
+ */
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+#ifdef _USE_BUDDY_BLOCKS
+ /*
+ * Check the free list of small blocks if this is free use it
+ * Otherwise check the rover if it has no blocks then
+ * Scan the free list entries use the first free block
+ * split the block if needed, stop at end of list marker
+ */
+ {
+ int index = CalcEntry(realsize);
+ if (index < nListEntries-1) {
+ ptr = GetFreeListLink(index);
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr = m_pRover;
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr = GetFreeListLink(index+1);
+ while (NEXT(ptr)) {
+ lsize = SIZE(ptr);
+ if (lsize >= realsize) {
+ size_t rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ SetTags(ptr, lsize | 1);
+ return ptr;
+ }
+ ptr += sizeof(FREE_LIST_ENTRY);
+ }
+ }
+ }
+#endif
+
+ /*
+ * Start searching the free list at the rover. If we arrive back at rover without
+ * finding anything, allocate some memory from the heap and try again.
+ */
+ ptr = m_pRover; /* start searching at rover */
+ int loops = 2; /* allow two times through the loop */
+ for(;;) {
+ lsize = SIZE(ptr);
+ ASSERT((lsize&1)==0);
+ /* is block big enough? */
+ if(lsize >= realsize) {
+ /* if the remainder is too small, don't bother splitting the block. */
+ rem = lsize - realsize;
+ if(rem < minAllocSize) {
+ if(m_pRover == ptr)
+ m_pRover = NEXT(ptr);
+
+ /* Unlink the block from the free list. */
+ Unlink(ptr);
+ }
+ else {
+ /*
+ * split the block
+ * The remainder is big enough to split off into a new block.
+ * Use the end of the block, resize the beginning of the block
+ * no need to change the free list.
+ */
+ SetTags(ptr, rem);
+ ptr += SIZE(ptr);
+ lsize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, lsize | 1);
+ return ((void *)ptr);
+ }
+
+ /*
+ * This block was unsuitable. If we've gone through this list once already without
+ * finding anything, allocate some new memory from the heap and try again.
+ */
+ ptr = NEXT(ptr);
+ if(ptr == m_pRover) {
+ if(!(loops-- && Getmem(realsize))) {
+ return NULL;
+ }
+ ptr = m_pRover;
+ }
+ }
+}
+
+void* VMem::Realloc(void* block, size_t size)
+{
+ WALKHEAP();
+
+ /* if size is zero, free the block. */
+ if(size == 0) {
+ Free(block);
+ return (NULL);
+ }
+
+ /* if block pointer is NULL, do a Malloc(). */
+ if(block == NULL)
+ return Malloc(size);
+
+ /*
+ * Grow or shrink the block in place.
+ * if the block grows then the next block will be used if free
+ */
+ if(Expand(block, size) != NULL)
+ return block;
+
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize)
+ return NULL;
+
+ /*
+ * see if the previous block is free, and is it big enough to cover the new size
+ * if merged with the current block.
+ */
+ PBLOCK ptr = (PBLOCK)block;
+ size_t cursize = SIZE(ptr) & ~1;
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0 && (psize + cursize) >= realsize) {
+ PBLOCK prev = ptr - psize;
+ if(m_pRover == prev)
+ m_pRover = NEXT(prev);
+
+ /* Unlink the next block from the free list. */
+ Unlink(prev);
+
+ /* Copy contents of old block to new location, make it the current block. */
+ memmove(prev, ptr, cursize);
+ cursize += psize; /* combine sizes */
+ ptr = prev;
+
+ size_t rem = cursize - realsize;
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block. Set boundary
+ * tags for the resized block and the new block.
+ */
+ prev = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(prev, rem);
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(prev, rem);
+#else
+ AddToFreeList(prev, m_pFreeList);
+#endif
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+
+ /* Allocate a new block, copy the old to the new, and free the old. */
+ if((ptr = (PBLOCK)Malloc(size)) != NULL) {
+ memmove(ptr, block, cursize-blockOverhead);
+ Free(block);
+ }
+ return ((void *)ptr);
+}
+
+void VMem::Free(void* p)
+{
+ WALKHEAP();
+
+ /* Ignore null pointer. */
+ if(p == NULL)
+ return;
+
+ PBLOCK ptr = (PBLOCK)p;
+
+ /* Check for attempt to free a block that's already free. */
+ size_t size = SIZE(ptr);
+ if((size&1) == 0) {
+ MEMODSlx("Attempt to free previously freed block", (long)p);
+ return;
+ }
+ size &= ~1; /* remove allocated tag */
+
+ /* if previous block is free, add this block to it. */
+#ifndef _USE_BUDDY_BLOCKS
+ int linked = FALSE;
+#endif
+ size_t psize = PSIZE(ptr);
+ if((psize&1) == 0) {
+ ptr -= psize; /* point to previous block */
+ size += psize; /* merge the sizes of the two blocks */
+#ifdef _USE_BUDDY_BLOCKS
+ Unlink(ptr);
+#else
+ linked = TRUE; /* it's already on the free list */
+#endif
+ }
+
+ /* if the next physical block is free, merge it with this block. */
+ PBLOCK next = ptr + size; /* point to next physical block */
+ size_t nsize = SIZE(next);
+ if((nsize&1) == 0) {
+ /* block is free move rover if needed */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* unlink the next block from the free list. */
+ Unlink(next);
+
+ /* merge the sizes of this block and the next block. */
+ size += nsize;
+ }
+
+ /* Set the boundary tags for the block; */
+ SetTags(ptr, size);
+
+ /* Link the block to the head of the free list. */
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(ptr, size);
+#else
+ if(!linked) {
+ AddToFreeList(ptr, m_pFreeList);
+ }
+#endif
+}
+
+void VMem::GetLock(void)
+{
+ EnterCriticalSection(&m_cs);
+}
+
+void VMem::FreeLock(void)
+{
+ LeaveCriticalSection(&m_cs);
+}
+
+int VMem::IsLocked(void)
+{
+#if 0
+ /* XXX TryEnterCriticalSection() is not available in some versions
+ * of Windows 95. Since this code is not used anywhere yet, we
+ * skirt the issue for now. */
+ BOOL bAccessed = TryEnterCriticalSection(&m_cs);
+ if(bAccessed) {
+ LeaveCriticalSection(&m_cs);
+ }
+ return !bAccessed;
+#else
+ ASSERT(0); /* alarm bells for when somebody calls this */
+ return 0;
+#endif
+}
+
+
+long VMem::Release(void)
+{
+ long lCount = InterlockedDecrement(&m_lRefCount);
+ if(!lCount)
+ delete this;
+ return lCount;
+}
+
+long VMem::AddRef(void)
+{
+ long lCount = InterlockedIncrement(&m_lRefCount);
+ return lCount;
+}
+
+
+int VMem::Getmem(size_t requestSize)
+{ /* returns -1 is successful 0 if not */
+#ifdef USE_BIGBLOCK_ALLOC
+ BOOL bBigBlock;
+#endif
+ void *ptr;
+
+ /* Round up size to next multiple of 64K. */
+ size_t size = (size_t)ROUND_UP64K(requestSize);
+
+ /*
+ * if the size requested is smaller than our current allocation size
+ * adjust up
+ */
+ if(size < (unsigned long)m_lAllocSize)
+ size = m_lAllocSize;
+
+ /* Update the size to allocate on the next request */
+ if(m_lAllocSize != lAllocMax)
+ m_lAllocSize <<= 2;
+
+#ifndef _USE_BUDDY_BLOCKS
+ if(m_nHeaps != 0
+#ifdef USE_BIGBLOCK_ALLOC
+ && !m_heaps[m_nHeaps-1].bBigBlock
+#endif
+ ) {
+ /* Expand the last allocated heap */
+ ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_NO_SERIALIZE,
+ m_heaps[m_nHeaps-1].base,
+ m_heaps[m_nHeaps-1].len + size);
+ if(ptr != 0) {
+ HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size
+#ifdef USE_BIGBLOCK_ALLOC
+ , FALSE
+#endif
+ );
+ return -1;
+ }
+ }
+#endif /* _USE_BUDDY_BLOCKS */
+
+ /*
+ * if we didn't expand a block to cover the requested size
+ * allocate a new Heap
+ * the size of this block must include the additional dummy tags at either end
+ * the above ROUND_UP64K may not have added any memory to include this.
+ */
+ if(size == requestSize)
+ size = (size_t)ROUND_UP64K(requestSize+(blockOverhead));
+
+Restart:
+#ifdef _USE_BUDDY_BLOCKS
+ ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE);
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ bBigBlock = FALSE;
+ if (size >= nMaxHeapAllocSize) {
+ bBigBlock = TRUE;
+ ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE);
+ }
+ else
+#endif
+ ptr = HeapAlloc(m_hHeap, HEAP_NO_SERIALIZE, size);
+#endif /* _USE_BUDDY_BLOCKS */
+
+ if (!ptr) {
+ /* try to allocate a smaller chunk */
+ size >>= 1;
+ if(size > requestSize)
+ goto Restart;
+ }
+
+ if(ptr == 0) {
+ MEMODSlx("HeapAlloc failed on size!!!", size);
+ return 0;
+ }
+
+#ifdef _USE_BUDDY_BLOCKS
+ if (HeapAdd(ptr, size)) {
+ VirtualFree(ptr, 0, MEM_RELEASE);
+ return 0;
+ }
+#else
+#ifdef USE_BIGBLOCK_ALLOC
+ if (HeapAdd(ptr, size, bBigBlock)) {
+ if (bBigBlock) {
+ VirtualFree(ptr, 0, MEM_RELEASE);
+ }
+ }
+#else
+ HeapAdd(ptr, size);
+#endif
+#endif /* _USE_BUDDY_BLOCKS */
+ return -1;
+}
+
+int VMem::HeapAdd(void* p, size_t size
+#ifdef USE_BIGBLOCK_ALLOC
+ , BOOL bBigBlock
+#endif
+ )
+{ /* if the block can be succesfully added to the heap, returns 0; otherwise -1. */
+ int index;
+
+ /* Check size, then round size down to next long word boundary. */
+ if(size < minAllocSize)
+ return -1;
+
+ size = (size_t)ROUND_DOWN(size);
+ PBLOCK ptr = (PBLOCK)p;
+
+#ifdef USE_BIGBLOCK_ALLOC
+ if (!bBigBlock) {
+#endif
+ /*
+ * Search for another heap area that's contiguous with the bottom of this new area.
+ * (It should be extremely unusual to find one that's contiguous with the top).
+ */
+ for(index = 0; index < m_nHeaps; ++index) {
+ if(ptr == m_heaps[index].base + (int)m_heaps[index].len) {
+ /*
+ * The new block is contiguous with a previously allocated heap area. Add its
+ * length to that of the previous heap. Merge it with the dummy end-of-heap
+ * area marker of the previous heap.
+ */
+ m_heaps[index].len += size;
+ break;
+ }
+ }
+#ifdef USE_BIGBLOCK_ALLOC
+ }
+ else {
+ index = m_nHeaps;
+ }
+#endif
+
+ if(index == m_nHeaps) {
+ /* The new block is not contiguous, or is BigBlock. Add it to the heap list. */
+ if(m_nHeaps == maxHeaps) {
+ return -1; /* too many non-contiguous heaps */
+ }
+ m_heaps[m_nHeaps].base = ptr;
+ m_heaps[m_nHeaps].len = size;
+#ifdef USE_BIGBLOCK_ALLOC
+ m_heaps[m_nHeaps].bBigBlock = bBigBlock;
+#endif
+ m_nHeaps++;
+
+ /*
+ * Reserve the first LONG in the block for the ending boundary tag of a dummy
+ * block at the start of the heap area.
+ */
+ size -= blockOverhead;
+ ptr += blockOverhead;
+ PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */
+ }
+
+ /*
+ * Convert the heap to one large block. Set up its boundary tags, and those of
+ * marker block after it. The marker block before the heap will already have
+ * been set up if this heap is not contiguous with the end of another heap.
+ */
+ SetTags(ptr, size | 1);
+ PBLOCK next = ptr + size; /* point to dummy end block */
+ SIZE(next) = 1; /* mark the dummy end block as allocated */
+
+ /*
+ * Link the block to the start of the free list by calling free().
+ * This will merge the block with any adjacent free blocks.
+ */
+ Free(ptr);
+ return 0;
+}
+
+
+void* VMem::Expand(void* block, size_t size)
+{
+ /*
+ * Disallow negative or zero sizes.
+ */
+ size_t realsize = CalcAllocSize(size);
+ if((int)realsize < minAllocSize || size == 0)
+ return NULL;
+
+ PBLOCK ptr = (PBLOCK)block;
+
+ /* if the current size is the same as requested, do nothing. */
+ size_t cursize = SIZE(ptr) & ~1;
+ if(cursize == realsize) {
+ return block;
+ }
+
+ /* if the block is being shrunk, convert the remainder of the block into a new free block. */
+ if(realsize <= cursize) {
+ size_t nextsize = cursize - realsize; /* size of new remainder block */
+ if(nextsize >= minAllocSize) {
+ /*
+ * Split the block
+ * Set boundary tags for the resized block and the new block.
+ */
+ SetTags(ptr, realsize | 1);
+ ptr += realsize;
+
+ /*
+ * add the new block to the free list.
+ * call Free to merge this block with next block if free
+ */
+ SetTags(ptr, nextsize | 1);
+ Free(ptr);
+ }
+
+ return block;
+ }
+
+ PBLOCK next = ptr + cursize;
+ size_t nextsize = SIZE(next);
+
+ /* Check the next block for consistency.*/
+ if((nextsize&1) == 0 && (nextsize + cursize) >= realsize) {
+ /*
+ * The next block is free and big enough. Add the part that's needed
+ * to our block, and split the remainder off into a new block.
+ */
+ if(m_pRover == next)
+ m_pRover = NEXT(next);
+
+ /* Unlink the next block from the free list. */
+ Unlink(next);
+ cursize += nextsize; /* combine sizes */
+
+ size_t rem = cursize - realsize; /* size of remainder */
+ if(rem >= minAllocSize) {
+ /*
+ * The remainder is big enough to be a new block.
+ * Set boundary tags for the resized block and the new block.
+ */
+ next = ptr + realsize;
+ /*
+ * add the new block to the free list.
+ * next block cannot be free
+ */
+ SetTags(next, rem);
+#ifdef _USE_BUDDY_BLOCKS
+ AddToFreeList(next, rem);
+#else
+ AddToFreeList(next, m_pFreeList);
+#endif
+ cursize = realsize;
+ }
+ /* Set the boundary tags to mark it as allocated. */
+ SetTags(ptr, cursize | 1);
+ return ((void *)ptr);
+ }
+ return NULL;
+}
+
+#ifdef _DEBUG_MEM
+#define LOG_FILENAME ".\\MemLog.txt"
+
+void VMem::MemoryUsageMessage(char *str, long x, long y, int c)
+{
+ char szBuffer[512];
+ if(str) {
+ if(!m_pLog)
+ m_pLog = fopen(LOG_FILENAME, "w");
+ sprintf(szBuffer, str, x, y, c);
+ fputs(szBuffer, m_pLog);
+ }
+ else {
+ if(m_pLog) {
+ fflush(m_pLog);
+ fclose(m_pLog);
+ m_pLog = 0;
+ }
+ }
+}
+
+void VMem::WalkHeap(int complete)
+{
+ if(complete) {
+ MemoryUsageMessage(NULL, 0, 0, 0);
+ size_t total = 0;
+ for(int i = 0; i < m_nHeaps; ++i) {
+ total += m_heaps[i].len;
+ }
+ MemoryUsageMessage("VMem heaps used %d. Total memory %08x\n", m_nHeaps, total, 0);
+
+ /* Walk all the heaps - verify structures */
+ for(int index = 0; index < m_nHeaps; ++index) {
+ PBLOCK ptr = m_heaps[index].base;
+ size_t size = m_heaps[index].len;
+#ifndef _USE_BUDDY_BLOCKS
+#ifdef USE_BIGBLOCK_ALLOC
+ if (!m_heaps[m_nHeaps].bBigBlock)
+#endif
+ ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, ptr));
+#endif
+
+ /* set over reserved header block */
+ size -= blockOverhead;
+ ptr += blockOverhead;
+ PBLOCK pLast = ptr + size;
+ ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */
+ ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */
+ while(ptr < pLast) {
+ ASSERT(ptr > m_heaps[index].base);
+ size_t cursize = SIZE(ptr) & ~1;
+ ASSERT((PSIZE(ptr+cursize) & ~1) == cursize);
+ MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(ptr)&1) ? 'x' : ' ');
+ if(!(SIZE(ptr)&1)) {
+ /* this block is on the free list */
+ PBLOCK tmp = NEXT(ptr);
+ while(tmp != ptr) {
+ ASSERT((SIZE(tmp)&1)==0);
+ if(tmp == m_pFreeList)
+ break;
+ ASSERT(NEXT(tmp));
+ tmp = NEXT(tmp);
+ }
+ if(tmp == ptr) {
+ MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0);
+ }
+ }
+ ptr += cursize;
+ }
+ }
+ MemoryUsageMessage(NULL, 0, 0, 0);
+ }
+}
+#endif /* _DEBUG_MEM */
+
+#endif /* _USE_MSVCRT_MEM_ALLOC */
+
+#endif /* ___VMEM_H_INC___ */
diff --git a/wince/win32.h b/wince/win32.h
index e116ac10f4..1ddfa743f0 100644
--- a/wince/win32.h
+++ b/wince/win32.h
@@ -116,7 +116,7 @@ struct utsname {
/* Define USE_SOCKETS_AS_HANDLES to enable emulation of windows sockets as
* real filehandles. XXX Should always be defined (the other version is untested) */
-/* #define USE_SOCKETS_AS_HANDLES */
+#define USE_SOCKETS_AS_HANDLES
/* read() and write() aren't transparent for socket handles */
#define PERL_SOCK_SYSREAD_IS_RECV
@@ -246,6 +246,7 @@ START_EXTERN_C
#define init_os_extras Perl_init_os_extras
DllExport void Perl_win32_init(int *argcp, char ***argvp);
+DllExport void Perl_win32_term(void);
DllExport void Perl_init_os_extras();
DllExport void win32_str_os_error(void *sv, DWORD err);
DllExport int RunPerl(int argc, char **argv, char **env);
@@ -321,6 +322,11 @@ END_EXTERN_C
# define PERL_SCRIPT_MODE "rb"
#endif
+#ifndef Sighandler_t
+typedef Signal_t (*Sighandler_t) (int);
+#define Sighandler_t Sighandler_t
+#endif
+
/*
* Now Win32 specific per-thread data stuff
*/
@@ -339,6 +345,8 @@ struct thread_intern {
# ifdef USE_RTL_THREAD_API
void * retv; /* slot for thread return value */
# endif
+ BOOL Wuse_showwindow;
+ WORD Wshowwindow;
};
#define HAVE_INTERP_INTERN
@@ -360,9 +368,16 @@ struct interp_intern {
#endif
void * internal_host;
struct thread_intern thr_intern;
+ UINT timerid;
+ unsigned poll_count;
+ Sighandler_t sigtable[SIG_SIZE];
};
+DllExport int win32_async_check(pTHX);
+#define WIN32_POLL_INTERVAL 32768
+#define PERL_ASYNC_CHECK() if (w32_do_async || PL_sig_pending) win32_async_check(aTHX)
+
#define w32_perlshell_tokens (PL_sys_intern.perlshell_tokens)
#define w32_perlshell_vec (PL_sys_intern.perlshell_vec)
#define w32_perlshell_items (PL_sys_intern.perlshell_items)
@@ -377,23 +392,29 @@ struct interp_intern {
#define w32_pseudo_child_pids (w32_pseudo_children->pids)
#define w32_pseudo_child_handles (w32_pseudo_children->handles)
#define w32_internal_host (PL_sys_intern.internal_host)
+#define w32_timerid (PL_sys_intern.timerid)
+#define w32_sighandler (PL_sys_intern.sigtable)
+#define w32_poll_count (PL_sys_intern.poll_count)
+#define w32_do_async (w32_poll_count++ > WIN32_POLL_INTERVAL)
#define w32_strerror_buffer (PL_sys_intern.thr_intern.Wstrerror_buffer)
#define w32_getlogin_buffer (PL_sys_intern.thr_intern.Wgetlogin_buffer)
#define w32_crypt_buffer (PL_sys_intern.thr_intern.Wcrypt_buffer)
#define w32_servent (PL_sys_intern.thr_intern.Wservent)
#define w32_init_socktype (PL_sys_intern.thr_intern.Winit_socktype)
+#define w32_use_showwindow (PL_sys_intern.thr_intern.Wuse_showwindow)
+#define w32_showwindow (PL_sys_intern.thr_intern.Wshowwindow)
/* UNICODE<>ANSI translation helpers */
/* Use CP_ACP when mode is ANSI */
/* Use CP_UTF8 when mode is UTF8 */
#define A2WHELPER_LEN(lpa, alen, lpw, nBytes)\
- (lpw[0] = 0, MultiByteToWideChar((IN_BYTE) ? CP_ACP : CP_UTF8, 0, \
+ (lpw[0] = 0, MultiByteToWideChar((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpa, alen, lpw, (nBytes/sizeof(WCHAR))))
#define A2WHELPER(lpa, lpw, nBytes) A2WHELPER_LEN(lpa, -1, lpw, nBytes)
#define W2AHELPER_LEN(lpw, wlen, lpa, nChars)\
- (lpa[0] = '\0', WideCharToMultiByte((IN_BYTE) ? CP_ACP : CP_UTF8, 0, \
+ (lpa[0] = '\0', WideCharToMultiByte((IN_BYTES) ? CP_ACP : CP_UTF8, 0, \
lpw, wlen, (LPSTR)lpa, nChars,NULL,NULL))
#define W2AHELPER(lpw, lpa, nChars) W2AHELPER_LEN(lpw, -1, lpa, nChars)
@@ -413,6 +434,64 @@ struct interp_intern {
} STMT_END
#endif
+#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX)
+#ifdef PERL_CORE
+
+/* C doesn't like repeat struct definitions */
+#ifndef _CRTIMP
+#define _CRTIMP __declspec(dllimport)
+#endif
+
+/*
+ * Control structure for lowio file handles
+ */
+typedef struct {
+ intptr_t osfhnd;/* underlying OS file HANDLE */
+ char osfile; /* attributes of file (e.g., open in text mode?) */
+ char pipech; /* one char buffer for handles opened on pipes */
+ int lockinitflag;
+ CRITICAL_SECTION lock;
+} ioinfo;
+
+
+/*
+ * Array of arrays of control structures for lowio files.
+ */
+EXTERN_C _CRTIMP ioinfo* __pioinfo[];
+
+/*
+ * Definition of IOINFO_L2E, the log base 2 of the number of elements in each
+ * array of ioinfo structs.
+ */
+#define IOINFO_L2E 5
+
+/*
+ * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array
+ */
+#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
+
+/*
+ * Access macros for getting at an ioinfo struct and its fields from a
+ * file handle
+ */
+#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1)))
+#define _osfhnd(i) (_pioinfo(i)->osfhnd)
+#define _osfile(i) (_pioinfo(i)->osfile)
+#define _pipech(i) (_pioinfo(i)->pipech)
+
+/* since we are not doing a dup2(), this works fine */
+#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh)
+#endif
+#endif
+
+/* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */
+#if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX)
+#undef PERLIO_NOT_STDIO
+#endif
+#define PERLIO_NOT_STDIO 0
+
+#include "perlio.h"
+
/*
* This provides a layer of functions and macros to ensure extensions will
* get to use the same RTL functions as the core.
diff --git a/wince/win32io.c b/wince/win32io.c
index 22a142749b..99a804d5f8 100644
--- a/wince/win32io.c
+++ b/wince/win32io.c
@@ -338,12 +338,14 @@ PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
}
PerlIO_funcs PerlIO_win32 = {
+ sizeof(PerlIO_funcs),
"win32",
sizeof(PerlIOWin32),
PERLIO_K_RAW,
PerlIOWin32_pushed,
PerlIOWin32_popped,
PerlIOWin32_open,
+ PerlIOBase_binmode,
NULL, /* getarg */
PerlIOWin32_fileno,
PerlIOWin32_dup,
@@ -366,5 +368,4 @@ PerlIO_funcs PerlIO_win32 = {
NULL, /* set_ptrcnt */
};
-
#endif
diff --git a/wince/win32iop.h b/wince/win32iop.h
index 020f2387fa..2b2703c8e0 100644
--- a/wince/win32iop.h
+++ b/wince/win32iop.h
@@ -72,14 +72,17 @@ DllExport int win32_fgetpos(FILE *pf,fpos_t *p);
DllExport int win32_fsetpos(FILE *pf,const fpos_t *p);
DllExport void win32_rewind(FILE *pf);
DllExport FILE* win32_tmpfile(void);
+DllExport int win32_tmpfd(void);
DllExport void win32_abort(void);
DllExport int win32_fstat(int fd,struct stat *sbufptr);
DllExport int win32_stat(const char *name,struct stat *sbufptr);
DllExport int win32_pipe( int *phandles, unsigned int psize, int textmode );
-DllExport FILE* win32_popen( const char *command, const char *mode );
+DllExport PerlIO* win32_popen( const char *command, const char *mode );
+DllExport PerlIO* win32_popenlist(const char *mode, IV narg, SV **args);
DllExport int win32_pclose( FILE *pf);
DllExport int win32_rename( const char *oname, const char *newname);
DllExport int win32_setmode( int fd, int mode);
+DllExport int win32_chsize(int fd, Off_t size);
DllExport long win32_lseek( int fd, long offset, int origin);
DllExport long win32_tell( int fd);
DllExport int win32_dup( int fd);
@@ -136,6 +139,7 @@ DllExport int win32_stat(const char *path, struct stat *buf);
DllExport char* win32_longpath(char *path);
DllExport int win32_ioctl(int i, unsigned int u, char *data);
DllExport int win32_link(const char *oldname, const char *newname);
+DllExport int win32_gettimeofday(struct timeval *tp, void *not_used);
DllExport int win32_unlink(const char *f);
DllExport int win32_utime(const char *f, struct utimbuf *t);
DllExport int win32_uname(struct utsname *n);
@@ -147,6 +151,7 @@ DllExport void* win32_dynaload(const char*filename);
DllExport int win32_access(const char *path, int mode);
DllExport int win32_chmod(const char *path, int mode);
DllExport int win32_getpid(void);
+DllExport Sighandler_t win32_signal(int sig, Sighandler_t subcode);
DllExport char * win32_crypt(const char *txt, const char *salt);
diff --git a/wince/win32thread.c b/wince/win32thread.c
index 141c5d68a0..1f327d6d41 100644
--- a/wince/win32thread.c
+++ b/wince/win32thread.c
@@ -1,5 +1,3 @@
-/* Time-stamp: <01/08/01 21:00:29 keuchel@w2k> */
-
#include "EXTERN.h"
#include "perl.h"
diff --git a/wince/win32thread.h b/wince/win32thread.h
index 879819f6ab..f7f2cf1f4d 100644
--- a/wince/win32thread.h
+++ b/wince/win32thread.h
@@ -1,5 +1,3 @@
-/* Time-stamp: <01/08/01 21:00:36 keuchel@w2k> */
-
#ifndef _WIN32THREAD_H
#define _WIN32THREAD_H
@@ -57,7 +55,7 @@ typedef HANDLE perl_mutex;
#define COND_INIT(c) \
STMT_START { \
(c)->waiters = 0; \
- (c)->sem = CreateSemaphore(NULL,0,LONG_MAX,NULL); \
+ (c)->sem = CreateSemaphoreW(NULL,0,LONG_MAX,NULL); \
if ((c)->sem == NULL) \
Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \
} STMT_END
@@ -162,11 +160,18 @@ END_EXTERN_C
#define ALLOC_THREAD_KEY \
STMT_START { \
if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \
- fprintf(stderr,"panic: TlsAlloc"); \
+ PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \
exit(1); \
} \
} STMT_END
+#define FREE_THREAD_KEY \
+ STMT_START { \
+ TlsFree(PL_thr_key); \
+ } STMT_END
+
+#define PTHREAD_ATFORK(prepare,parent,child) NOOP
+
#if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
#define JOIN(t, avp) \
STMT_START { \
diff --git a/wince/wince.c b/wince/wince.c
index cec2facf94..675d934479 100644
--- a/wince/wince.c
+++ b/wince/wince.c
@@ -9,6 +9,7 @@
#define WIN32_LEAN_AND_MEAN
#define WIN32IO_IS_STDIO
#include <windows.h>
+#include <signal.h>
#define PERLIO_NOT_STDIO 0
@@ -341,6 +342,7 @@ Perl_do_exec(pTHX_ char *cmd)
DllExport int
win32_pipe(int *pfd, unsigned int size, int mode)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "pipe");
return -1;
}
@@ -348,17 +350,20 @@ win32_pipe(int *pfd, unsigned int size, int mode)
DllExport int
win32_times(struct tms *timebuf)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "times");
return -1;
}
/* TODO */
-bool
-win32_signal()
+Sighandler_t
+win32_signal(int sig, Sighandler_t subcode)
{
+ dTHX;
Perl_croak_nocontext("signal() TBD on this platform");
return FALSE;
}
+
DllExport void
win32_clearenv()
{
@@ -387,6 +392,7 @@ win32_readdir(DIR *dirp)
DllExport long
win32_telldir(DIR *dirp)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "telldir");
return -1;
}
@@ -394,12 +400,14 @@ win32_telldir(DIR *dirp)
DllExport void
win32_seekdir(DIR *dirp, long loc)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "seekdir");
}
DllExport void
win32_rewinddir(DIR *dirp)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "rewinddir");
}
@@ -413,6 +421,7 @@ win32_closedir(DIR *dirp)
DllExport int
win32_kill(int pid, int sig)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "kill");
return -1;
}
@@ -598,6 +607,152 @@ win32_uname(struct utsname *name)
return 0;
}
+void
+sig_terminate(pTHX_ int sig)
+{
+ Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
+ /* exit() seems to be safe, my_exit() or die() is a problem in ^C
+ thread
+ */
+ exit(sig);
+}
+
+DllExport int
+win32_async_check(pTHX)
+{
+ MSG msg;
+ int ours = 1;
+ /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
+ * and ignores window messages - should co-exist better with windows apps e.g. Tk
+ */
+ while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
+ int sig;
+ switch(msg.message) {
+
+#if 0
+ /* Perhaps some other messages could map to signals ? ... */
+ case WM_CLOSE:
+ case WM_QUIT:
+ /* Treat WM_QUIT like SIGHUP? */
+ sig = SIGHUP;
+ goto Raise;
+ break;
+#endif
+
+ /* We use WM_USER to fake kill() with other signals */
+ case WM_USER: {
+ sig = msg.wParam;
+ Raise:
+ if (do_raise(aTHX_ sig)) {
+ sig_terminate(aTHX_ sig);
+ }
+ break;
+ }
+
+ case WM_TIMER: {
+ /* alarm() is a one-shot but SetTimer() repeats so kill it */
+ if (w32_timerid) {
+ KillTimer(NULL,w32_timerid);
+ w32_timerid=0;
+ }
+ /* Now fake a call to signal handler */
+ if (do_raise(aTHX_ 14)) {
+ sig_terminate(aTHX_ 14);
+ }
+ break;
+ }
+
+ /* Otherwise do normal Win32 thing - in case it is useful */
+ default:
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ ours = 0;
+ break;
+ }
+ }
+ w32_poll_count = 0;
+
+ /* Above or other stuff may have set a signal flag */
+ if (PL_sig_pending) {
+ despatch_signals();
+ }
+ return ours;
+}
+
+/* This function will not return until the timeout has elapsed, or until
+ * one of the handles is ready. */
+DllExport DWORD
+win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
+{
+ /* We may need several goes at this - so compute when we stop */
+ DWORD ticks = 0;
+ if (timeout != INFINITE) {
+ ticks = GetTickCount();
+ timeout += ticks;
+ }
+ while (1) {
+ DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
+ if (resultp)
+ *resultp = result;
+ if (result == WAIT_TIMEOUT) {
+ /* Ran out of time - explicit return of zero to avoid -ve if we
+ have scheduling issues
+ */
+ return 0;
+ }
+ if (timeout != INFINITE) {
+ ticks = GetTickCount();
+ }
+ if (result == WAIT_OBJECT_0 + count) {
+ /* Message has arrived - check it */
+ (void)win32_async_check(aTHX);
+ }
+ else {
+ /* Not timeout or message - one of handles is ready */
+ break;
+ }
+ }
+ /* compute time left to wait */
+ ticks = timeout - ticks;
+ /* If we are past the end say zero */
+ return (ticks > 0) ? ticks : 0;
+}
+
+/* Timing related stuff */
+
+int
+do_raise(pTHX_ int sig)
+{
+ if (sig < SIG_SIZE) {
+ Sighandler_t handler = w32_sighandler[sig];
+ if (handler == SIG_IGN) {
+ return 0;
+ }
+ else if (handler != SIG_DFL) {
+ (*handler)(sig);
+ return 0;
+ }
+ else {
+ /* Choose correct default behaviour */
+ switch (sig) {
+#ifdef SIGCLD
+ case SIGCLD:
+#endif
+#ifdef SIGCHLD
+ case SIGCHLD:
+#endif
+ case 0:
+ return 0;
+ case SIGTERM:
+ default:
+ break;
+ }
+ }
+ }
+ /* Tell caller to exit thread/process as approriate */
+ return 1;
+}
+
static UINT timerid = 0;
static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
@@ -720,6 +875,10 @@ win32_stderr(void)
return (stderr);
}
+char *g_getlogin() {
+ return "no-getlogin";
+}
+
DllExport FILE *
win32_stdin(void)
{
@@ -967,6 +1126,7 @@ win32_fstat(int fd, struct stat *sbufptr)
DllExport int
win32_link(const char *oldname, const char *newname)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "link");
return -1;
@@ -988,6 +1148,12 @@ win32_setmode(int fd, int mode)
return 0;
}
+DllExport int
+win32_chsize(int fd, Off_t size)
+{
+ return chsize(fd, size);
+}
+
DllExport long
win32_lseek(int fd, long offset, int origin)
{
@@ -1022,6 +1188,7 @@ win32_close(int fd)
DllExport int
win32_eof(int fd)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "eof");
return -1;
}
@@ -1029,14 +1196,12 @@ win32_eof(int fd)
DllExport int
win32_dup(int fd)
{
- //vv Perl_croak(aTHX_ PL_no_func, "dup");
- return xcedup(fd); // from celib/ceio.c; requires some more work on it.
+ return xcedup(fd); /* from celib/ceio.c; requires some more work on it */
}
DllExport int
win32_dup2(int fd1,int fd2)
{
- //Perl_croak(aTHX_ PL_no_func, "dup2");
return xcedup2(fd1,fd2);
}
@@ -1091,6 +1256,7 @@ win32_perror(const char *str)
DllExport void
win32_setbuf(FILE *pf, char *buf)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "setbuf");
}
@@ -1257,9 +1423,452 @@ win32_free(void *block)
free(block);
}
+/* returns pointer to the next unquoted space or the end of the string */
+static char*
+find_next_space(const char *s)
+{
+ bool in_quotes = FALSE;
+ while (*s) {
+ /* ignore doubled backslashes, or backslash+quote */
+ if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
+ s += 2;
+ }
+ /* keep track of when we're within quotes */
+ else if (*s == '"') {
+ s++;
+ in_quotes = !in_quotes;
+ }
+ /* break it up only at spaces that aren't in quotes */
+ else if (!in_quotes && isSPACE(*s))
+ return (char*)s;
+ else
+ s++;
+ }
+ return (char*)s;
+}
+
+static char *
+create_command_line(char *cname, STRLEN clen, const char * const *args)
+{
+ dTHX;
+ int index, argc;
+ char *cmd, *ptr;
+ const char *arg;
+ STRLEN len = 0;
+ bool bat_file = FALSE;
+ bool cmd_shell = FALSE;
+ bool dumb_shell = FALSE;
+ bool extra_quotes = FALSE;
+ bool quote_next = FALSE;
+
+ if (!cname)
+ cname = (char*)args[0];
+
+ /* The NT cmd.exe shell has the following peculiarity that needs to be
+ * worked around. It strips a leading and trailing dquote when any
+ * of the following is true:
+ * 1. the /S switch was used
+ * 2. there are more than two dquotes
+ * 3. there is a special character from this set: &<>()@^|
+ * 4. no whitespace characters within the two dquotes
+ * 5. string between two dquotes isn't an executable file
+ * To work around this, we always add a leading and trailing dquote
+ * to the string, if the first argument is either "cmd.exe" or "cmd",
+ * and there were at least two or more arguments passed to cmd.exe
+ * (not including switches).
+ * XXX the above rules (from "cmd /?") don't seem to be applied
+ * always, making for the convolutions below :-(
+ */
+ if (cname) {
+ if (!clen)
+ clen = strlen(cname);
+
+ if (clen > 4
+ && (stricmp(&cname[clen-4], ".bat") == 0
+ || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
+ {
+ bat_file = TRUE;
+ len += 3;
+ }
+ else {
+ char *exe = strrchr(cname, '/');
+ char *exe2 = strrchr(cname, '\\');
+ if (exe2 > exe)
+ exe = exe2;
+ if (exe)
+ ++exe;
+ else
+ exe = cname;
+ if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
+ cmd_shell = TRUE;
+ len += 3;
+ }
+ else if (stricmp(exe, "command.com") == 0
+ || stricmp(exe, "command") == 0)
+ {
+ dumb_shell = TRUE;
+ }
+ }
+ }
+
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
+ for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
+ STRLEN curlen = strlen(arg);
+ if (!(arg[0] == '"' && arg[curlen-1] == '"'))
+ len += 2; /* assume quoting needed (worst case) */
+ len += curlen + 1;
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
+ }
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
+
+ argc = index;
+ New(1310, cmd, len, char);
+ ptr = cmd;
+
+ if (bat_file) {
+ *ptr++ = '"';
+ extra_quotes = TRUE;
+ }
+
+ for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
+ bool do_quote = 0;
+ STRLEN curlen = strlen(arg);
+
+ /* we want to protect empty arguments and ones with spaces with
+ * dquotes, but only if they aren't already there */
+ if (!dumb_shell) {
+ if (!curlen) {
+ do_quote = 1;
+ }
+ else if (quote_next) {
+ /* see if it really is multiple arguments pretending to
+ * be one and force a set of quotes around it */
+ if (*find_next_space(arg))
+ do_quote = 1;
+ }
+ else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
+ STRLEN i = 0;
+ while (i < curlen) {
+ if (isSPACE(arg[i])) {
+ do_quote = 1;
+ }
+ else if (arg[i] == '"') {
+ do_quote = 0;
+ break;
+ }
+ i++;
+ }
+ }
+ }
+
+ if (do_quote)
+ *ptr++ = '"';
+
+ strcpy(ptr, arg);
+ ptr += curlen;
+
+ if (do_quote)
+ *ptr++ = '"';
+
+ if (args[index+1])
+ *ptr++ = ' ';
+
+ if (!extra_quotes
+ && cmd_shell
+ && curlen >= 2
+ && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
+ && stricmp(arg+curlen-2, "/c") == 0)
+ {
+ /* is there a next argument? */
+ if (args[index+1]) {
+ /* are there two or more next arguments? */
+ if (args[index+2]) {
+ *ptr++ = '"';
+ extra_quotes = TRUE;
+ }
+ else {
+ /* single argument, force quoting if it has spaces */
+ quote_next = TRUE;
+ }
+ }
+ }
+ }
+
+ if (extra_quotes)
+ *ptr++ = '"';
+
+ *ptr = '\0';
+
+ return cmd;
+}
+
+static char *
+qualified_path(const char *cmd)
+{
+ dTHX;
+ char *pathstr;
+ char *fullcmd, *curfullcmd;
+ STRLEN cmdlen = 0;
+ int has_slash = 0;
+
+ if (!cmd)
+ return Nullch;
+ fullcmd = (char*)cmd;
+ while (*fullcmd) {
+ if (*fullcmd == '/' || *fullcmd == '\\')
+ has_slash++;
+ fullcmd++;
+ cmdlen++;
+ }
+
+ /* look in PATH */
+ pathstr = PerlEnv_getenv("PATH");
+ New(0, fullcmd, MAX_PATH+1, char);
+ curfullcmd = fullcmd;
+
+ while (1) {
+ DWORD res;
+
+ /* start by appending the name to the current prefix */
+ strcpy(curfullcmd, cmd);
+ curfullcmd += cmdlen;
+
+ /* if it doesn't end with '.', or has no extension, try adding
+ * a trailing .exe first */
+ if (cmd[cmdlen-1] != '.'
+ && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
+ {
+ strcpy(curfullcmd, ".exe");
+ res = GetFileAttributes(fullcmd);
+ if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
+ return fullcmd;
+ *curfullcmd = '\0';
+ }
+
+ /* that failed, try the bare name */
+ res = GetFileAttributes(fullcmd);
+ if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
+ return fullcmd;
+
+ /* quit if no other path exists, or if cmd already has path */
+ if (!pathstr || !*pathstr || has_slash)
+ break;
+
+ /* skip leading semis */
+ while (*pathstr == ';')
+ pathstr++;
+
+ /* build a new prefix from scratch */
+ curfullcmd = fullcmd;
+ while (*pathstr && *pathstr != ';') {
+ if (*pathstr == '"') { /* foo;"baz;etc";bar */
+ pathstr++; /* skip initial '"' */
+ while (*pathstr && *pathstr != '"') {
+ if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
+ *curfullcmd++ = *pathstr;
+ pathstr++;
+ }
+ if (*pathstr)
+ pathstr++; /* skip trailing '"' */
+ }
+ else {
+ if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
+ *curfullcmd++ = *pathstr;
+ pathstr++;
+ }
+ }
+ if (*pathstr)
+ pathstr++; /* skip trailing semi */
+ if (curfullcmd > fullcmd /* append a dir separator */
+ && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
+ {
+ *curfullcmd++ = '\\';
+ }
+ }
+
+ Safefree(fullcmd);
+ return Nullch;
+}
+
+/* XXX this needs to be made more compatible with the spawnvp()
+ * provided by the various RTLs. In particular, searching for
+ * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
+ * This doesn't significantly affect perl itself, because we
+ * always invoke things using PERL5SHELL if a direct attempt to
+ * spawn the executable fails.
+ *
+ * XXX splitting and rejoining the commandline between do_aspawn()
+ * and win32_spawnvp() could also be avoided.
+ */
+
+#define P_WAIT 0
+#define P_NOWAIT 1
+DllExport int
+win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
+{
+#ifdef USE_RTL_SPAWNVP
+ return spawnvp(mode, cmdname, (char * const *)argv);
+#else
+ dTHX;
+ int ret;
+ void* env;
+ char* dir;
+ child_IO_table tbl;
+ STARTUPINFO StartupInfo;
+ PROCESS_INFORMATION ProcessInformation;
+ DWORD create = 0;
+ char *cmd;
+ char *fullcmd = Nullch;
+ char *cname = (char *)cmdname;
+ STRLEN clen = 0;
+
+ if (cname) {
+ clen = strlen(cname);
+ /* if command name contains dquotes, must remove them */
+ if (strchr(cname, '"')) {
+ cmd = cname;
+ New(0,cname,clen+1,char);
+ clen = 0;
+ while (*cmd) {
+ if (*cmd != '"') {
+ cname[clen] = *cmd;
+ ++clen;
+ }
+ ++cmd;
+ }
+ cname[clen] = '\0';
+ }
+ }
+
+ cmd = create_command_line(cname, clen, argv);
+
+ env = PerlEnv_get_childenv();
+ dir = PerlEnv_get_childdir();
+
+ switch(mode) {
+ case P_NOWAIT: /* asynch + remember result */
+ if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
+ errno = EAGAIN;
+ ret = -1;
+ goto RETVAL;
+ }
+ /* Create a new process group so we can use GenerateConsoleCtrlEvent()
+ * in win32_kill()
+ */
+ /* not supported on CE create |= CREATE_NEW_PROCESS_GROUP; */
+ /* FALL THROUGH */
+
+ case P_WAIT: /* synchronous execution */
+ break;
+ default: /* invalid mode */
+ errno = EINVAL;
+ ret = -1;
+ goto RETVAL;
+ }
+ memset(&StartupInfo,0,sizeof(StartupInfo));
+ StartupInfo.cb = sizeof(StartupInfo);
+ memset(&tbl,0,sizeof(tbl));
+ PerlEnv_get_child_IO(&tbl);
+ StartupInfo.dwFlags = tbl.dwFlags;
+ StartupInfo.dwX = tbl.dwX;
+ StartupInfo.dwY = tbl.dwY;
+ StartupInfo.dwXSize = tbl.dwXSize;
+ StartupInfo.dwYSize = tbl.dwYSize;
+ StartupInfo.dwXCountChars = tbl.dwXCountChars;
+ StartupInfo.dwYCountChars = tbl.dwYCountChars;
+ StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
+ StartupInfo.wShowWindow = tbl.wShowWindow;
+ StartupInfo.hStdInput = tbl.childStdIn;
+ StartupInfo.hStdOutput = tbl.childStdOut;
+ StartupInfo.hStdError = tbl.childStdErr;
+ if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
+ StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
+ StartupInfo.hStdError == INVALID_HANDLE_VALUE)
+ {
+ create |= CREATE_NEW_CONSOLE;
+ }
+ else {
+ StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
+ }
+ if (w32_use_showwindow) {
+ StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
+ StartupInfo.wShowWindow = w32_showwindow;
+ }
+
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
+ cname,cmd));
+RETRY:
+ if (!CreateProcess(cname, /* search PATH to find executable */
+ cmd, /* executable, and its arguments */
+ NULL, /* process attributes */
+ NULL, /* thread attributes */
+ TRUE, /* inherit handles */
+ create, /* creation flags */
+ (LPVOID)env, /* inherit environment */
+ dir, /* inherit cwd */
+ &StartupInfo,
+ &ProcessInformation))
+ {
+ /* initial NULL argument to CreateProcess() does a PATH
+ * search, but it always first looks in the directory
+ * where the current process was started, which behavior
+ * is undesirable for backward compatibility. So we
+ * jump through our own hoops by picking out the path
+ * we really want it to use. */
+ if (!fullcmd) {
+ fullcmd = qualified_path(cname);
+ if (fullcmd) {
+ if (cname != cmdname)
+ Safefree(cname);
+ cname = fullcmd;
+ DEBUG_p(PerlIO_printf(Perl_debug_log,
+ "Retrying [%s] with same args\n",
+ cname));
+ goto RETRY;
+ }
+ }
+ errno = ENOENT;
+ ret = -1;
+ goto RETVAL;
+ }
+
+ if (mode == P_NOWAIT) {
+ /* asynchronous spawn -- store handle, return PID */
+ ret = (int)ProcessInformation.dwProcessId;
+ if (IsWin95() && ret < 0)
+ ret = -ret;
+
+ w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
+ w32_child_pids[w32_num_children] = (DWORD)ret;
+ ++w32_num_children;
+ }
+ else {
+ DWORD status;
+ win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
+ /* FIXME: if msgwait returned due to message perhaps forward the
+ "signal" to the process
+ */
+ GetExitCodeProcess(ProcessInformation.hProcess, &status);
+ ret = (int)status;
+ CloseHandle(ProcessInformation.hProcess);
+ }
+
+ CloseHandle(ProcessInformation.hThread);
+
+RETVAL:
+ PerlEnv_free_childenv(env);
+ PerlEnv_free_childdir(dir);
+ Safefree(cmd);
+ if (cname != cmdname)
+ Safefree(cname);
+ return ret;
+#endif
+}
+
DllExport int
win32_execv(const char *cmdname, const char *const *argv)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "execv");
return -1;
}
@@ -1267,6 +1876,7 @@ win32_execv(const char *cmdname, const char *const *argv)
DllExport int
win32_execvp(const char *cmdname, const char *const *argv)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "execvp");
return -1;
}
@@ -1562,9 +2172,24 @@ Perl_win32_term(void)
MALLOC_TERM;
}
-DllExport int
+DllExport void
+Perl_win32_term(void)
+{
+ OP_REFCNT_TERM;
+ MALLOC_TERM;
+}
+
+void
+win32_get_child_IO(child_IO_table* ptbl)
+{
+ ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
+ ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
+ ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
+}
+
win32_flock(int fd, int oper)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "flock");
return -1;
}
@@ -1572,6 +2197,7 @@ win32_flock(int fd, int oper)
DllExport int
win32_waitpid(int pid, int *status, int flags)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "waitpid");
return -1;
}
@@ -1579,6 +2205,7 @@ win32_waitpid(int pid, int *status, int flags)
DllExport int
win32_wait(int *status)
{
+ dTHX;
Perl_croak(aTHX_ PL_no_func, "wait");
return -1;
}
@@ -1590,7 +2217,13 @@ do_spawn(char *cmd)
}
int
-do_aspawn(void *vreally, void **vmark, void **vsp)
+Perl_do_spawn(pTHX_ char *cmd)
+{
+ return do_spawn(aTHX_ cmd);
+}
+
+int
+Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
{
Perl_croak(aTHX_ PL_no_func, "aspawn");
return -1;
@@ -1618,46 +2251,6 @@ wce_hitreturn()
/* //////////////////////////////////////////////////////////////////// */
-void
-win32_argv2utf8(int argc, char** argv)
-{
- /* do nothing... */
-}
-
-void
-Perl_sys_intern_init(pTHX)
-{
- w32_perlshell_tokens = Nullch;
- w32_perlshell_vec = (char**)NULL;
- w32_perlshell_items = 0;
- w32_fdpid = newAV();
- New(1313, w32_children, 1, child_tab);
- w32_num_children = 0;
-# ifdef USE_ITHREADS
- w32_pseudo_id = 0;
- New(1313, w32_pseudo_children, 1, child_tab);
- w32_num_pseudo_children = 0;
-# endif
-
-#ifndef UNDER_CE
- w32_init_socktype = 0;
-#endif
-}
-
-void
-Perl_sys_intern_clear(pTHX)
-{
- Safefree(w32_perlshell_tokens);
- Safefree(w32_perlshell_vec);
- /* NOTE: w32_fdpid is freed by sv_clean_all() */
- Safefree(w32_children);
-# ifdef USE_ITHREADS
- Safefree(w32_pseudo_children);
-# endif
-}
-
-/* //////////////////////////////////////////////////////////////////// */
-
#undef getcwd
char *
@@ -1678,18 +2271,16 @@ win32_open_osfhandle(intptr_t osfhandle, int flags)
int fh;
char fileflags=0; /* _osfile flags */
- XCEMessageBoxA(NULL, "NEED TO IMPLEMENT in wince/wince.c(win32_open_osfhandle)", "error", 0);
Perl_croak_nocontext("win32_open_osfhandle() TBD on this platform");
return 0;
}
int
-win32_get_osfhandle(intptr_t osfhandle, int flags)
+win32_get_osfhandle(int fd)
{
int fh;
char fileflags=0; /* _osfile flags */
- XCEMessageBoxA(NULL, "NEED TO IMPLEMENT in wince/wince.c(win32_get_osfhandle)", "error", 0);
Perl_croak_nocontext("win32_get_osfhandle() TBD on this platform");
return 0;
}
@@ -1703,10 +2294,17 @@ win32_get_osfhandle(intptr_t osfhandle, int flags)
DllExport PerlIO*
win32_popen(const char *command, const char *mode)
{
- XCEMessageBoxA(NULL, "NEED TO IMPLEMENT in wince/wince.c(win32_popen)", "error", 0);
Perl_croak_nocontext("win32_popen() TBD on this platform");
}
+DllExport PerlIO*
+win32_popenlist(const char *mode, IV narg, SV **args)
+{
+ dTHX;
+ Perl_croak(aTHX_ "List form of pipe open not implemented");
+ return NULL;
+}
+
/*
* pclose() clone
*/
@@ -1790,3 +2388,111 @@ win32_fdupopen(FILE *pf)
#endif
return pfdup;
}
+
+#ifdef HAVE_INTERP_INTERN
+
+
+static void
+win32_csighandler(int sig)
+{
+#if 0
+ dTHXa(PERL_GET_SIG_CONTEXT);
+ Perl_warn(aTHX_ "Got signal %d",sig);
+#endif
+ /* Does nothing */
+}
+
+void
+Perl_sys_intern_init(pTHX)
+{
+ int i;
+ w32_perlshell_tokens = Nullch;
+ w32_perlshell_vec = (char**)NULL;
+ w32_perlshell_items = 0;
+ w32_fdpid = newAV();
+ New(1313, w32_children, 1, child_tab);
+ w32_num_children = 0;
+# ifdef USE_ITHREADS
+ w32_pseudo_id = 0;
+ New(1313, w32_pseudo_children, 1, child_tab);
+ w32_num_pseudo_children = 0;
+# endif
+ w32_init_socktype = 0;
+ w32_timerid = 0;
+ w32_poll_count = 0;
+}
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+ Safefree(w32_perlshell_tokens);
+ Safefree(w32_perlshell_vec);
+ /* NOTE: w32_fdpid is freed by sv_clean_all() */
+ Safefree(w32_children);
+ if (w32_timerid) {
+ KillTimer(NULL,w32_timerid);
+ w32_timerid=0;
+ }
+# ifdef USE_ITHREADS
+ Safefree(w32_pseudo_children);
+# endif
+}
+
+# ifdef USE_ITHREADS
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
+{
+ dst->perlshell_tokens = Nullch;
+ dst->perlshell_vec = (char**)NULL;
+ dst->perlshell_items = 0;
+ dst->fdpid = newAV();
+ Newz(1313, dst->children, 1, child_tab);
+ dst->pseudo_id = 0;
+ Newz(1313, dst->pseudo_children, 1, child_tab);
+ dst->thr_intern.Winit_socktype = 0;
+ dst->timerid = 0;
+ dst->poll_count = 0;
+ Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
+}
+# endif /* USE_ITHREADS */
+#endif /* HAVE_INTERP_INTERN */
+
+static void
+win32_free_argvw(pTHX_ void *ptr)
+{
+ char** argv = (char**)ptr;
+ while(*argv) {
+ Safefree(*argv);
+ *argv++ = Nullch;
+ }
+}
+
+void
+win32_argv2utf8(int argc, char** argv)
+{
+ /* do nothing, since we're not aware of command line arguments
+ * currently ...
+ */
+}
+
+#if 0
+void
+Perl_sys_intern_clear(pTHX)
+{
+ Safefree(w32_perlshell_tokens);
+ Safefree(w32_perlshell_vec);
+ /* NOTE: w32_fdpid is freed by sv_clean_all() */
+ Safefree(w32_children);
+# ifdef USE_ITHREADS
+ Safefree(w32_pseudo_children);
+# endif
+}
+
+#endif
+// added to remove undefied symbol error in CodeWarrior compilation
+int
+Perl_Ireentrant_buffer_ptr(aTHX)
+{
+ return 0;
+}
diff --git a/wince/wince.h b/wince/wince.h
index 29ec27472b..c82c7a696f 100644
--- a/wince/wince.h
+++ b/wince/wince.h
@@ -17,9 +17,30 @@
#include "time.h"
#include "cectype.h"
+#ifndef START_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+#endif
+
+START_EXTERN_C
+
+#ifndef _IOFBF
#define _IOFBF 0x0000
+#endif
+#ifndef _IOLBF
#define _IOLBF 0x0040
+#endif
+#ifndef _IONBF
#define _IONBF 0x0004
+#endif
#if UNDER_CE <= 200
XCE_EXPORT double xceatof(const char *);
@@ -29,7 +50,7 @@ XCE_EXPORT int xcetolower(int c);
#define toupper xcetoupper
#define tolower xcetolower
#else
-double atof(const char *);
+XCE_EXPORT double atof(const char *);
#endif
XCE_EXPORT void XCEShowMessageA(const char *fmt, ...);
@@ -123,11 +144,12 @@ XCE_EXPORT FARPROC XCEAPI XCEGetProcAddressA(HMODULE hMod, const char *name);
#define strupr xcestrupr
#define time xcetime
-XCE_EXPORT LPVOID XCEGetEnvironmentStrings(VOID);
XCE_EXPORT BOOL XCEFreeEnvironmentStrings(LPCSTR buf);
#define GetEnvironmentStrings XCEGetEnvironmentStrings
#define FreeEnvironmentStrings XCEFreeEnvironmentStrings
void wce_hitreturn();
+END_EXTERN_C
+
#endif
View Lorry Controller Status