From: Vadim Konovalov Date: Sun, 6 Jul 2003 18:46:09 +0000 (+0400) Subject: [PATCH] improve WinCE port X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=216db7eec92546173ac6bab178225bf585542186;p=p5sagit%2Fp5-mst-13.2.git [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" Date: Sun, 6 Jul 2003 19:50:47 +0400 Message-ID: <000b01c343d6$7ff96920$5b5dc3d9@vad> p4raw-id: //depot/perl@20031 --- diff --git a/MANIFEST b/MANIFEST index 870897d..7b937b8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1314,38 +1314,38 @@ lib/Math/BigInt/t/isa.t Test for Math::BigInt inheritance lib/Math/BigInt/t/mbimbf.inc Actual BigInt/BigFloat accuracy, precision and fallback, round_mode tests lib/Math/BigInt/t/mbimbf.t BigInt/BigFloat accuracy, precision and fallback, round_mode lib/Math/BigInt/t/mbi_rand.t Test Math::BigInt randomly +lib/Math/BigInt/t/require.t Test if require Math::BigInt works lib/Math/BigInt/t/req_mbf0.t test: require Math::BigFloat; ->bzero(); lib/Math/BigInt/t/req_mbf1.t test: require Math::BigFloat; ->bone(); lib/Math/BigInt/t/req_mbfa.t test: require Math::BigFloat; ->bnan(); lib/Math/BigInt/t/req_mbfi.t test: require Math::BigFloat; ->binf(); lib/Math/BigInt/t/req_mbfn.t test: require Math::BigFloat; ->new(); lib/Math/BigInt/t/req_mbfw.t require Math::BigFloat; import ( with => ); -lib/Math/BigInt/t/require.t Test if require Math::BigInt works lib/Math/BigInt/t/sub_mbf.t Empty subclass test of BigFloat lib/Math/BigInt/t/sub_mbi.t Empty subclass test of BigInt lib/Math/BigInt/t/sub_mif.t Test A & P with subclasses using mbimbf.inc lib/Math/BigInt/t/trap.t Test whether trap_nan and trap_inf work -lib/Math/BigInt/t/upgradef.t Test if use Math::BigFloat(); under upgrade works lib/Math/BigInt/t/upgrade.inc Actual tests for upgrade.t lib/Math/BigInt/t/upgrade.t Test if use Math::BigInt(); under upgrade works +lib/Math/BigInt/t/upgradef.t Test if use Math::BigFloat(); under upgrade works +lib/Math/BigInt/t/use.t Test if use Math::BigInt(); works lib/Math/BigInt/t/use_lib1.t Test combinations of Math::BigInt and BigFloat lib/Math/BigInt/t/use_lib2.t Test combinations of Math::BigInt and BigFloat lib/Math/BigInt/t/use_lib3.t Test combinations of Math::BigInt and BigFloat lib/Math/BigInt/t/use_lib4.t Test combinations of Math::BigInt and BigFloat lib/Math/BigInt/t/use_mbfw.t use BigFloat w/ with and lib at the same time -lib/Math/BigInt/t/use.t Test if use Math::BigInt(); works lib/Math/BigInt/t/with_sub.t Test use Math::BigFloat with => package lib/Math/BigInt/Trace.pm bignum tracing -lib/Math/BigRat/t/bigratup.t test under $Math::BigInt::upgrade -lib/Math/BigRat/t/requirer.t see if require works properly -lib/Math/BigRat/t/trap.t see if trap_nan and trap_inf work lib/Math/BigRat.pm Math::BigRat lib/Math/BigRat/t/bigfltpm.inc Math::BigRat test lib/Math/BigRat/t/bigfltrt.t Math::BigRat test lib/Math/BigRat/t/bigrat.t Math::BigRat test lib/Math/BigRat/t/bigratpm.inc Math::BigRat test lib/Math/BigRat/t/bigratpm.t Math::BigRat test +lib/Math/BigRat/t/bigratup.t test under $Math::BigInt::upgrade lib/Math/BigRat/t/big_ap.t Math::BigRat test +lib/Math/BigRat/t/requirer.t see if require works properly +lib/Math/BigRat/t/trap.t see if trap_nan and trap_inf work lib/Math/Complex.pm A Complex package lib/Math/Complex.t See if Math::Complex works lib/Math/Trig.pm A simple interface to complex trigonometry @@ -2975,6 +2975,7 @@ wince/makedist.pl WinCE port wince/Makefile.ce WinCE port wince/makeico.pl WinCE port wince/perl.rc WinCE port +wince/perlhost.h Perl "host" implementation wince/perllib.c WinCE port wince/perlmain.c WinCE port wince/README.compile WinCE port @@ -2982,6 +2983,8 @@ wince/README.perlce WinCE port wince/registry.bat WinCE port wince/runperl.c WinCE port wince/splittree.pl WinCE port +wince/vdir.h Perl "host" virtual directory manager for CE +wince/vmem.h Perl "host" memory manager for CE wince/win32.h WinCE port wince/win32io.c WinCE port wince/win32iop.h WinCE port diff --git a/wince/Makefile.ce b/wince/Makefile.ce index f6ea3f2..5d45220 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 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 11ce700..c108de4 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 0000000..9e93b57 --- /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 +#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 527103f..0b00246 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 0000000..10119ea --- /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<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 0000000..1fd421c --- /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 e116ac1..1ddfa74 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 22a1427..99a804d 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 020f238..2b2703c 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 141c5d6..1f327d6 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 879819f..f7f2cf1 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 cec2fac..675d9344 100644 --- a/wince/wince.c +++ b/wince/wince.c @@ -9,6 +9,7 @@ #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include +#include #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 29ec274..c82c7a6 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