X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5db1039675bdeda8d9e4e8a1462abefb8ede0419..af23cf166818c49709cd7a912b616557b93c8ea1:/win32/perlhost.h diff --git a/win32/perlhost.h b/win32/perlhost.h index 15f03c6..be7d61d 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -1,38 +1,42 @@ /* perlhost.h * - * (c) 1999 Microsoft Corporation. All rights reserved. + * (c) 1999 Microsoft Corporation. All rights reserved. * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/ * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ +#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" -#if !defined(PERL_OBJECT) -START_EXTERN_C +#ifndef WC_NO_BEST_FIT_CHARS +# define WC_NO_BEST_FIT_CHARS 0x00000400 #endif -extern char * g_win32_get_privlib(char *pl); -extern char * g_win32_get_sitelib(char *pl); + +START_EXTERN_C +extern char * g_win32_get_privlib(const char *pl, STRLEN *const len); +extern char * g_win32_get_sitelib(const char *pl, STRLEN *const len); +extern char * g_win32_get_vendorlib(const char *pl, + STRLEN *const len); extern char * g_getlogin(void); -extern int do_spawn2(char *cmd, int exectype); -#if !defined(PERL_OBJECT) END_EXTERN_C -#endif - -#ifdef PERL_OBJECT -extern int g_do_aspawn(void *vreally, void **vmark, void **vsp); -#define do_aspawn g_do_aspawn -#endif class CPerlHost { public: + /* Constructors */ CPerlHost(void); CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, @@ -58,6 +62,7 @@ public: void PerlDestroy(void); /* IPerlMem */ + /* Locks provided but should be unnecessary as this is private pool */ inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); }; inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); }; inline void Free(void* ptr) { m_pVMem->Free(ptr); }; @@ -74,12 +79,32 @@ public: inline int IsLocked(void) { return m_pVMem->IsLocked(); }; /* IPerlMemShared */ + /* Locks used to serialize access to the pool */ + inline void GetLockShared(void) { m_pVMemShared->GetLock(); }; + inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); }; + inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); }; inline void* MallocShared(size_t size) { - return m_pVMemShared->Malloc(size); + void *result; + GetLockShared(); + result = m_pVMemShared->Malloc(size); + FreeLockShared(); + return result; + }; + inline void* ReallocShared(void* ptr, size_t size) + { + void *result; + GetLockShared(); + result = m_pVMemShared->Realloc(ptr, size); + FreeLockShared(); + return result; + }; + inline void FreeShared(void* ptr) + { + GetLockShared(); + m_pVMemShared->Free(ptr); + FreeLockShared(); }; - inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); }; - inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); }; inline void* CallocShared(size_t num, size_t size) { size_t count = num*size; @@ -88,11 +113,14 @@ public: ZeroMemory(lpVoid, count); return lpVoid; }; - inline void GetLockShared(void) { m_pVMem->GetLock(); }; - inline void FreeLockShared(void) { m_pVMem->FreeLock(); }; - inline int IsLockedShared(void) { return m_pVMem->IsLocked(); }; /* IPerlMemParse */ + /* Assume something else is using locks to mangaging serialize + on a batch basis + */ + inline void GetLockParse(void) { m_pVMemParse->GetLock(); }; + inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); }; + inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); }; inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); }; inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); }; inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); }; @@ -104,9 +132,6 @@ public: ZeroMemory(lpVoid, count); return lpVoid; }; - inline void GetLockParse(void) { m_pVMem->GetLock(); }; - inline void FreeLockParse(void) { m_pVMem->FreeLock(); }; - inline int IsLockedParse(void) { return m_pVMem->IsLocked(); }; /* IPerlEnv */ char *Getenv(const char *varname); @@ -195,24 +220,42 @@ protected: DWORD m_dwEnvCount; LPSTR* m_lppEnvList; + BOOL m_bTopLevel; // is this a toplevel host? + static long num_hosts; +public: + inline int LastHost(void) { return num_hosts == 1L; }; + struct interpreter *host_perl; }; +long CPerlHost::num_hosts = 0L; -#define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y)) +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 STRUCT2PTR(piPerl, m_hostperlMem); + return STRUCT2RAWPTR(piPerl, m_hostperlMem); } inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl) { - return STRUCT2PTR(piPerl, m_hostperlMemShared); + return STRUCT2RAWPTR(piPerl, m_hostperlMemShared); } inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl) { - return STRUCT2PTR(piPerl, m_hostperlMemParse); + return STRUCT2RAWPTR(piPerl, m_hostperlMemParse); } inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl) @@ -475,18 +518,31 @@ PerlEnvOsId(struct IPerlEnv* piPerl) } char* -PerlEnvLibPath(struct IPerlEnv* piPerl, char *pl) +PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) { - return g_win32_get_privlib(pl); + return g_win32_get_privlib(pl, len); } char* -PerlEnvSiteLibPath(struct IPerlEnv* piPerl, char *pl) +PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) { - return g_win32_get_sitelib(pl); + return g_win32_get_sitelib(pl, len); } -struct IPerlEnv perlEnv = +char* +PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl, + STRLEN *const len) +{ + return g_win32_get_vendorlib(pl, len); +} + +void +PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr) +{ + win32_get_child_IO(ptr); +} + +struct IPerlEnv perlEnv = { PerlEnvGetenv, PerlEnvPutenv, @@ -500,82 +556,84 @@ struct IPerlEnv perlEnv = PerlEnvOsId, PerlEnvLibPath, PerlEnvSiteLibPath, + PerlEnvVendorLibPath, + PerlEnvGetChildIO, }; #undef IPERL2HOST #define IPERL2HOST(x) IPerlStdIO2Host(x) /* PerlStdIO */ -PerlIO* +FILE* PerlStdIOStdin(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stdin(); + return win32_stdin(); } -PerlIO* +FILE* PerlStdIOStdout(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stdout(); + return win32_stdout(); } -PerlIO* +FILE* PerlStdIOStderr(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_stderr(); + return win32_stderr(); } -PerlIO* +FILE* PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode) { - return (PerlIO*)win32_fopen(path, mode); + return win32_fopen(path, mode); } int -PerlStdIOClose(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fclose(((FILE*)pf)); + return win32_fclose((pf)); } int -PerlStdIOEof(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_feof((FILE*)pf); + return win32_feof(pf); } int -PerlStdIOError(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_ferror((FILE*)pf); + return win32_ferror(pf); } void -PerlStdIOClearerr(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf) { - win32_clearerr((FILE*)pf); + win32_clearerr(pf); } int -PerlStdIOGetc(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_getc((FILE*)pf); + return win32_getc(pf); } -char* -PerlStdIOGetBase(struct IPerlStdIO* piPerl, PerlIO* pf) +STDCHAR* +PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_base - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_base(f); #else - return Nullch; + return NULL; #endif } int -PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef FILE_bufsiz - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_bufsiz(f); #else return (-1); @@ -583,172 +641,171 @@ PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, PerlIO* pf) } int -PerlStdIOGetCnt(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_cnt(f); #else return (-1); #endif } -char* -PerlStdIOGetPtr(struct IPerlStdIO* piPerl, PerlIO* pf) +STDCHAR* +PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf) { #ifdef USE_STDIO_PTR - FILE *f = (FILE*)pf; + FILE *f = pf; return FILE_ptr(f); #else - return Nullch; + return NULL; #endif } char* -PerlStdIOGets(struct IPerlStdIO* piPerl, PerlIO* pf, char* s, int n) +PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n) { - return win32_fgets(s, n, (FILE*)pf); + return win32_fgets(s, n, pf); } int -PerlStdIOPutc(struct IPerlStdIO* piPerl, PerlIO* pf, int c) +PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c) { - return win32_fputc(c, (FILE*)pf); + return win32_fputc(c, pf); } int -PerlStdIOPuts(struct IPerlStdIO* piPerl, PerlIO* pf, const char *s) +PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s) { - return win32_fputs(s, (FILE*)pf); + return win32_fputs(s, pf); } int -PerlStdIOFlush(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fflush((FILE*)pf); + return win32_fflush(pf); } int -PerlStdIOUngetc(struct IPerlStdIO* piPerl, PerlIO* pf,int c) +PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf) { - return win32_ungetc(c, (FILE*)pf); + return win32_ungetc(c, pf); } int -PerlStdIOFileno(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_fileno((FILE*)pf); + return win32_fileno(pf); } -PerlIO* +FILE* PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode) { - return (PerlIO*)win32_fdopen(fd, mode); + return win32_fdopen(fd, mode); } -PerlIO* -PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, PerlIO* pf) +FILE* +PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf) { - return (PerlIO*)win32_freopen(path, mode, (FILE*)pf); + return win32_freopen(path, mode, (FILE*)pf); } SSize_t -PerlStdIORead(struct IPerlStdIO* piPerl, PerlIO* pf, void *buffer, Size_t size) +PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf) { - return win32_fread(buffer, 1, size, (FILE*)pf); + return win32_fread(buffer, size, count, pf); } SSize_t -PerlStdIOWrite(struct IPerlStdIO* piPerl, PerlIO* pf, const void *buffer, Size_t size) +PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf) { - return win32_fwrite(buffer, 1, size, (FILE*)pf); + return win32_fwrite(buffer, size, count, pf); } void -PerlStdIOSetBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer) +PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer) { - win32_setbuf((FILE*)pf, buffer); + win32_setbuf(pf, buffer); } int -PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, PerlIO* pf, char* buffer, int type, Size_t size) +PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size) { - return win32_setvbuf((FILE*)pf, buffer, type, size); + return win32_setvbuf(pf, buffer, type, size); } void -PerlStdIOSetCnt(struct IPerlStdIO* piPerl, PerlIO* pf, int n) +PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n) { #ifdef STDIO_CNT_LVALUE - FILE *f = (FILE*)pf; + FILE *f = pf; FILE_cnt(f) = n; #endif } void -PerlStdIOSetPtrCnt(struct IPerlStdIO* piPerl, PerlIO* pf, char * ptr, int n) +PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr) { #ifdef STDIO_PTR_LVALUE - FILE *f = (FILE*)pf; + FILE *f = pf; FILE_ptr(f) = ptr; - FILE_cnt(f) = n; #endif } void -PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf) { - win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0); + win32_setvbuf(pf, NULL, _IOLBF, 0); } int -PerlStdIOPrintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format,...) +PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...) { va_list(arglist); va_start(arglist, format); - return win32_vfprintf((FILE*)pf, format, arglist); + return win32_vfprintf(pf, format, arglist); } int -PerlStdIOVprintf(struct IPerlStdIO* piPerl, PerlIO* pf, const char *format, va_list arglist) +PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist) { - return win32_vfprintf((FILE*)pf, format, arglist); + return win32_vfprintf(pf, format, arglist); } -long -PerlStdIOTell(struct IPerlStdIO* piPerl, PerlIO* pf) +Off_t +PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf) { - return win32_ftell((FILE*)pf); + return win32_ftell(pf); } int -PerlStdIOSeek(struct IPerlStdIO* piPerl, PerlIO* pf, off_t offset, int origin) +PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin) { - return win32_fseek((FILE*)pf, offset, origin); + return win32_fseek(pf, offset, origin); } void -PerlStdIORewind(struct IPerlStdIO* piPerl, PerlIO* pf) +PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf) { - win32_rewind((FILE*)pf); + win32_rewind(pf); } -PerlIO* +FILE* PerlStdIOTmpfile(struct IPerlStdIO* piPerl) { - return (PerlIO*)win32_tmpfile(); + return win32_tmpfile(); } int -PerlStdIOGetpos(struct IPerlStdIO* piPerl, PerlIO* pf, Fpos_t *p) +PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p) { - return win32_fgetpos((FILE*)pf, p); + return win32_fgetpos(pf, p); } int -PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p) +PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p) { - return win32_fsetpos((FILE*)pf, p); + return win32_fsetpos(pf, p); } void PerlStdIOInit(struct IPerlStdIO* piPerl) @@ -762,70 +819,74 @@ PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl) } int -PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, long osfhandle, int flags) +PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags) { return win32_open_osfhandle(osfhandle, flags); } -int +intptr_t PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum) { return win32_get_osfhandle(filenum); } -PerlIO* -PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) +FILE* +PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) { - PerlIO* pfdup; +#ifndef UNDER_CE + FILE* pfdup; fpos_t pos; char mode[3]; - int fileno = win32_dup(win32_fileno((FILE*)pf)); + int fileno = win32_dup(win32_fileno(pf)); /* open the file in the same mode */ #ifdef __BORLANDC__ - if(((FILE*)pf)->flags & _F_READ) { + if((pf)->flags & _F_READ) { mode[0] = 'r'; mode[1] = 0; } - else if(((FILE*)pf)->flags & _F_WRIT) { + else if((pf)->flags & _F_WRIT) { mode[0] = 'a'; mode[1] = 0; } - else if(((FILE*)pf)->flags & _F_RDWR) { + else if((pf)->flags & _F_RDWR) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #else - if(((FILE*)pf)->_flag & _IOREAD) { + if((pf)->_flag & _IOREAD) { mode[0] = 'r'; mode[1] = 0; } - else if(((FILE*)pf)->_flag & _IOWRT) { + else if((pf)->_flag & _IOWRT) { mode[0] = 'a'; mode[1] = 0; } - else if(((FILE*)pf)->_flag & _IORW) { + else if((pf)->_flag & _IORW) { mode[0] = 'r'; mode[1] = '+'; mode[2] = 0; } #endif - /* it appears that the binmode is attached to the + /* it appears that the binmode is attached to the * file descriptor so binmode files will be handled * correctly */ - pfdup = (PerlIO*)win32_fdopen(fileno, mode); + pfdup = win32_fdopen(fileno, mode); /* move the file pointer to the same position */ - if (!fgetpos((FILE*)pf, &pos)) { - fsetpos((FILE*)pfdup, &pos); + if (!fgetpos(pf, &pos)) { + fsetpos(pfdup, &pos); } return pfdup; +#else + return 0; +#endif } -struct IPerlStdIO perlStdIO = +struct IPerlStdIO perlStdIO = { PerlStdIOStdin, PerlStdIOStdout, @@ -853,7 +914,7 @@ struct IPerlStdIO perlStdIO = PerlStdIOSetBuf, PerlStdIOSetVBuf, PerlStdIOSetCnt, - PerlStdIOSetPtrCnt, + PerlStdIOSetPtr, PerlStdIOSetlinebuf, PerlStdIOPrintf, PerlStdIOVprintf, @@ -892,9 +953,9 @@ PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t g } int -PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) +PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size) { - return chsize(handle, size); + return win32_chsize(handle, size); } int @@ -922,21 +983,28 @@ PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) } int -PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) +PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer) { - return fstat(handle, 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); + u_long u_long_arg; + int retval; + + /* mauke says using memcpy avoids alignment issues */ + memcpy(&u_long_arg, data, sizeof u_long_arg); + retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg); + memcpy(data, &u_long_arg, sizeof u_long_arg); + return retval; } int PerlLIOIsatty(struct IPerlLIO* piPerl, int fd) { - return isatty(fd); + return win32_isatty(fd); } int @@ -945,14 +1013,14 @@ PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname) return win32_link(oldname, newname); } -long -PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin) +Off_t +PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin) { return win32_lseek(handle, offset, origin); } int -PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) +PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer) { return win32_stat(path, buffer); } @@ -994,7 +1062,7 @@ PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode) } int -PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) +PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer) { return win32_stat(path, buffer); } @@ -1018,7 +1086,7 @@ PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename) } int -PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times) +PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times) { return win32_utime(filename, times); } @@ -1089,7 +1157,7 @@ PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) } DIR* -PerlDirOpen(struct IPerlDir* piPerl, char *filename) +PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { return win32_opendir(filename); } @@ -1227,7 +1295,7 @@ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { - dTHXo; + dTHX; Perl_croak(aTHX_ "gethostent not implemented!\n"); return NULL; } @@ -1402,9 +1470,7 @@ PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) int PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds) { - dTHXo; - Perl_croak(aTHX_ "socketpair not implemented!\n"); - return 0; + return Perl_my_socketpair(domain, type, protocol, fds); } int @@ -1554,9 +1620,7 @@ PerlProcKill(struct IPerlProc* piPerl, int pid, int sig) int PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig) { - dTHXo; - Perl_croak(aTHX_ "killpg not implemented!\n"); - return 0; + return win32_kill(pid, -sig); } int @@ -1568,15 +1632,23 @@ PerlProcPauseProc(struct IPerlProc* piPerl) PerlIO* PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) { - dTHXo; + dTHX; PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)win32_popen(command, mode); + 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((FILE*)stream); + return win32_pclose(stream); } int @@ -1624,40 +1696,62 @@ PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags) Sighandler_t PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) { - return 0; + return win32_signal(sig, subcode); +} + +int +PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z) +{ + return win32_gettimeofday(t, z); } #ifdef USE_ITHREADS -static DWORD WINAPI +static THREAD_RET_TYPE win32_start_child(LPVOID arg) { PerlInterpreter *my_perl = (PerlInterpreter*)arg; GV *tmpgv; int status; -#ifdef PERL_OBJECT - CPerlObj *pPerl = (CPerlObj*)my_perl; -#endif + HWND parent_message_hwnd; #ifdef PERL_SYNC_FORK static long sync_fork_id = 0; long id = ++sync_fork_id; #endif - PERL_SET_INTERP(my_perl); + 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_setiv(GvSV(tmpgv), -(IV)w32_pseudo_id); + if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) { + SV *sv = GvSV(tmpgv); + SvREADONLY_off(sv); + sv_setiv(sv, -(IV)w32_pseudo_id); + SvREADONLY_on(sv); + } +#ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); +#endif + + /* create message window and tell parent about it */ + parent_message_hwnd = w32_message_hwnd; + w32_message_hwnd = win32_create_message_window(); + if (parent_message_hwnd != NULL) + PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd); /* push a zero on the stack (we are the child) */ { - djSP; + dSP; dTARGET; PUSHi(0); PUTBACK; @@ -1668,13 +1762,23 @@ win32_start_child(LPVOID arg) { dJMPENV; - volatile int oldscope = PL_scopestack_ix; + volatile int oldscope = 1; /* We are responsible for all scopes */ restart: JMPENV_PUSH(status); switch (status) { case 0: CALLRUNOPS(aTHX); + /* We may have additional unclosed scopes if fork() was called + * from within a BEGIN block. See perlfork.pod for more details. + * We cannot clean up these other scopes because they belong to a + * different interpreter, but we also cannot leave PL_scopestack_ix + * dangling because that can trigger an assertion in perl_destruct(). + */ + if (PL_scopestack_ix > oldscope) { + PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1]; + PL_scopestack_ix = oldscope; + } status = 0; break; case 2: @@ -1684,13 +1788,13 @@ restart: PL_curstash = PL_defstash; if (PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); - status = STATUS_NATIVE_EXPORT; + status = STATUS_EXIT; break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); PL_op = PL_restartop; - PL_restartop = Nullop; + PL_restartop = (OP*)NULL; goto restart; } PerlIO_printf(Perl_error_log, "panic: restartop\n"); @@ -1701,11 +1805,22 @@ restart: JMPENV_POP; /* XXX hack to avoid perl_destruct() freeing optree */ - PL_main_root = Nullop; + win32_checkTLS(my_perl); + PL_main_root = (OP*)NULL; + } + + win32_checkTLS(my_perl); + /* close the std handles to avoid fd leaks */ + { + do_close(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 @@ -1719,12 +1834,19 @@ restart: int PerlProcFork(struct IPerlProc* piPerl) { - dTHXo; + dTHX; #ifdef USE_ITHREADS DWORD id; HANDLE handle; - CPerlHost *h = new CPerlHost(); - PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHXo, 1, + 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, + CLONEf_COPY_STACKS, h->m_pHostperlMem, h->m_pHostperlMemShared, h->m_pHostperlMemParse, @@ -1735,15 +1857,34 @@ PerlProcFork(struct IPerlProc* piPerl) 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_INTERP(aTHXo); + PERL_SET_THX(aTHX); # else + if (w32_message_hwnd == INVALID_HANDLE_VALUE) + w32_message_hwnd = win32_create_message_window(); + new_perl->Isys_intern.message_hwnd = w32_message_hwnd; + w32_pseudo_child_message_hwnds[w32_num_pseudo_children] = + (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE; +# ifdef USE_RTL_THREAD_API + handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child, + (void*)new_perl, 0, (unsigned*)&id); +# else handle = CreateThread(NULL, 0, win32_start_child, (LPVOID)new_perl, 0, &id); - PERL_SET_INTERP(aTHXo); - if (!handle) - Perl_croak(aTHX_ "panic: pseudo fork() failed"); +# 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; @@ -1773,19 +1914,6 @@ PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr) win32_str_os_error(sv, dwErr); } -BOOL -PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd) -{ - do_spawn2(cmd, EXECF_EXEC); - return FALSE; -} - -int -PerlProcSpawn(struct IPerlProc* piPerl, char* cmds) -{ - return do_spawn2(cmds, EXECF_SPAWN); -} - int PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv) { @@ -1793,9 +1921,11 @@ PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const c } int -PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp) +PerlProcLastHost(struct IPerlProc* piPerl) { - return do_aspawn(vreally, vmark, vsp); + dTHX; + CPerlHost *h = (CPerlHost*)w32_internal_host; + return h->LastHost(); } struct IPerlProc perlProc = @@ -1829,10 +1959,10 @@ struct IPerlProc perlProc = PerlProcGetpid, PerlProcDynaLoader, PerlProcGetOSError, - PerlProcDoCmd, - PerlProcSpawn, PerlProcSpawnvp, - PerlProcASpawn, + PerlProcLastHost, + PerlProcPopenList, + PerlProcGetTimeOfDay }; @@ -1842,6 +1972,8 @@ struct IPerlProc perlProc = CPerlHost::CPerlHost(void) { + /* Construct a host from scratch */ + InterlockedIncrement(&num_hosts); m_pvDir = new VDir(); m_pVMem = new VMem(); m_pVMemShared = new VMem(); @@ -1851,6 +1983,7 @@ CPerlHost::CPerlHost(void) m_dwEnvCount = 0; m_lppEnvList = NULL; + m_bTopLevel = TRUE; CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); @@ -1890,7 +2023,8 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, struct IPerlDir** ppDir, struct IPerlSock** ppSock, struct IPerlProc** ppProc) { - m_pvDir = new VDir(); + InterlockedIncrement(&num_hosts); + m_pvDir = new VDir(0); m_pVMem = new VMem(); m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); @@ -1899,6 +2033,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, m_dwEnvCount = 0; m_lppEnvList = NULL; + m_bTopLevel = FALSE; CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); @@ -1924,12 +2059,14 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, 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(); + m_pvDir = new VDir(0); m_pvDir->Init(host.GetDir(), m_pVMem); CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem)); @@ -1941,18 +2078,19 @@ CPerlHost::CPerlHost(CPerlHost& host) CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir)); CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock)); CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc)); - m_pHostperlMem = &host.m_hostperlMem; - m_pHostperlMemShared = &host.m_hostperlMemShared; - m_pHostperlMemParse = &host.m_hostperlMemParse; - m_pHostperlEnv = &host.m_hostperlEnv; - m_pHostperlStdIO = &host.m_hostperlStdIO; - m_pHostperlLIO = &host.m_hostperlLIO; - m_pHostperlDir = &host.m_hostperlDir; - m_pHostperlSock = &host.m_hostperlSock; - m_pHostperlProc = &host.m_hostperlProc; + 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; @@ -1963,7 +2101,8 @@ CPerlHost::CPerlHost(CPerlHost& host) CPerlHost::~CPerlHost(void) { -// Reset(); + Reset(); + InterlockedDecrement(&num_hosts); delete m_pvDir; m_pVMemParse->Release(); m_pVMemShared->Release(); @@ -2023,6 +2162,12 @@ lookup(const void *arg1, const void *arg2) LPSTR* CPerlHost::Lookup(LPCSTR lpStr) { +#ifdef UNDER_CE + if (!m_lppEnvList || !m_dwEnvCount) + return NULL; +#endif + if (!lpStr) + return NULL; return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup); } @@ -2051,7 +2196,7 @@ compare(const void *arg1, const void *arg2) if(c1 != c2) { if(c1 < c2) return -1; // string 1 < string 2 - + return 1; // string 1 > string 2 } } @@ -2062,7 +2207,7 @@ compare(const void *arg1, const void *arg2) void CPerlHost::Add(LPCSTR lpStr) { - dTHXo; + dTHX; char szBuffer[1024]; LPSTR *lpPtr; int index, length = strlen(lpStr)+1; @@ -2074,20 +2219,24 @@ CPerlHost::Add(LPCSTR lpStr) // replacing ? lpPtr = Lookup(szBuffer); - if(lpPtr != NULL) { - Renew(*lpPtr, length, char); + if (lpPtr != NULL) { + // must allocate things via host memory allocation functions + // rather than perl's Renew() et al, as the perl interpreter + // may either not be initialized enough when we allocate these, + // or may already be dead when we go to free these + *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char)); strcpy(*lpPtr, lpStr); } else { - ++m_dwEnvCount; - Renew(m_lppEnvList, m_dwEnvCount, LPSTR); - New(1, m_lppEnvList[m_dwEnvCount-1], length, char); - if(m_lppEnvList[m_dwEnvCount-1] != NULL) { - strcpy(m_lppEnvList[m_dwEnvCount-1], lpStr); - qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare); + m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR)); + if (m_lppEnvList) { + m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char)); + if (m_lppEnvList[m_dwEnvCount] != NULL) { + strcpy(m_lppEnvList[m_dwEnvCount], lpStr); + ++m_dwEnvCount; + qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare); + } } - else - --m_dwEnvCount; } } @@ -2105,24 +2254,23 @@ CPerlHost::CalculateEnvironmentSpace(void) void CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr) { - dTHXo; + dTHX; Safefree(lpStr); } char* CPerlHost::GetChildDir(void) { - dTHXo; - int length; + dTHX; char* ptr; - New(0, ptr, MAX_PATH+1, char); - if(ptr) { - m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr); - length = strlen(ptr)-1; - if(length > 0) { - if((ptr[length] == '\\') || (ptr[length] == '/')) - ptr[length] = 0; - } + size_t length; + + Newx(ptr, MAX_PATH+1, char); + m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr); + length = strlen(ptr); + if (length > 3) { + if ((ptr[length-1] == '\\') || (ptr[length-1] == '/')) + ptr[length-1] = 0; } return ptr; } @@ -2130,14 +2278,14 @@ CPerlHost::GetChildDir(void) void CPerlHost::FreeChildDir(char* pStr) { - dTHXo; + dTHX; Safefree(pStr); } LPSTR CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) { - dTHXo; + dTHX; LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr; DWORD dwSize, dwEnvIndex; int nLength, compVal; @@ -2162,7 +2310,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) // add the additional space used by changes made to the environment dwSize += CalculateEnvironmentSpace(); - New(1, lpStr, dwSize, char); + Newx(lpStr, dwSize, char); lpPtr = lpStr; if(lpStr != NULL) { // build the local environment @@ -2171,7 +2319,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) dwEnvIndex = 0; lpLocalEnv = GetIndex(dwEnvIndex); while(*lpEnvPtr != '\0') { - if(lpLocalEnv == NULL) { + if(!lpLocalEnv) { // all environment overrides have been added // so copy string into place strcpy(lpStr, lpEnvPtr); @@ -2179,7 +2327,7 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) lpStr += nLength; lpEnvPtr += nLength; } - else { + else { // determine which string to copy next compVal = compare(&lpEnvPtr, &lpLocalEnv); if(compVal < 0) { @@ -2203,6 +2351,17 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) } } + 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'; } @@ -2216,22 +2375,25 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) void CPerlHost::Reset(void) { - dTHXo; + dTHX; if(m_lppEnvList != NULL) { for(DWORD index = 0; index < m_dwEnvCount; ++index) { - Safefree(m_lppEnvList[index]); + Free(m_lppEnvList[index]); m_lppEnvList[index] = NULL; } } m_dwEnvCount = 0; + Free(m_lppEnvList); + m_lppEnvList = NULL; } void CPerlHost::Clearenv(void) { + dTHX; char ch; LPSTR lpPtr, lpStr, lpEnvPtr; - if(m_lppEnvList != NULL) { + 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], '='); @@ -2254,6 +2416,8 @@ CPerlHost::Clearenv(void) ch = *++lpPtr; *lpPtr = 0; Add(lpStr); + if (m_bTopLevel) + (void)win32_putenv(lpStr); *lpPtr = ch; } lpStr += strlen(lpStr) + 1; @@ -2266,37 +2430,36 @@ CPerlHost::Clearenv(void) char* CPerlHost::Getenv(const char *varname) { - char* pEnv = Find(varname); - if(pEnv == NULL) { - pEnv = win32_getenv(varname); - } - else { - if(!*pEnv) - pEnv = 0; + dTHX; + if (!m_bTopLevel) { + char *pEnv = Find(varname); + if (pEnv && *pEnv) + return 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) { - dTHXo; + dTHX; int ret; - if (USING_WIDE()) { - WCHAR wBuffer[MAX_PATH]; - A2WHELPER(dirname, wBuffer, sizeof(wBuffer)); - ret = m_pvDir->SetCurrentDirectoryW(wBuffer); + if (!dirname) { + errno = ENOENT; + return -1; } - else - ret = m_pvDir->SetCurrentDirectoryA((char*)dirname); + ret = m_pvDir->SetCurrentDirectoryA((char*)dirname); if(ret < 0) { errno = ENOENT; }