* "The Road goes ever on and on, down from the door where it began."
*/
-#ifdef __cplusplus
-extern "C" {
-#endif
#include "EXTERN.h"
#include "perl.h"
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif
+
#include "XSUB.h"
-#ifdef __cplusplus
+#ifdef PERL_OBJECT
+#include "win32iop.h"
+#include <fcntl.h>
+#endif
+
+
+/* Register any extra external extensions */
+char *staticlinkmodules[] = {
+ "DynaLoader",
+ NULL,
+};
+
+EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
+
+static void
+xs_init(pTHXo)
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+}
+
+#ifdef PERL_OBJECT
+// IPerlMem
+void*
+PerlMemMalloc(struct IPerlMem*, size_t size)
+{
+ return win32_malloc(size);
+}
+void*
+PerlMemRealloc(struct IPerlMem*, void* ptr, size_t size)
+{
+ return win32_realloc(ptr, size);
+}
+void
+PerlMemFree(struct IPerlMem*, void* ptr)
+{
+ win32_free(ptr);
+}
+
+struct IPerlMem perlMem =
+{
+ PerlMemMalloc,
+ PerlMemRealloc,
+ PerlMemFree,
+};
+
+
+// IPerlEnv
+extern char * g_win32_get_privlib(char *pl);
+extern char * g_win32_get_sitelib(char *pl);
+
+
+char*
+PerlEnvGetenv(struct IPerlEnv*, const char *varname)
+{
+ return win32_getenv(varname);
+};
+int
+PerlEnvPutenv(struct IPerlEnv*, const char *envstring)
+{
+ return win32_putenv(envstring);
+};
+
+char*
+PerlEnvGetenv_len(struct IPerlEnv*, const char* varname, unsigned long* len)
+{
+ char *e = win32_getenv(varname);
+ if (e)
+ *len = strlen(e);
+ return e;
+}
+
+int
+PerlEnvUname(struct IPerlEnv*, struct utsname *name)
+{
+ return win32_uname(name);
+}
+
+void
+PerlEnvClearenv(struct IPerlEnv*)
+{
+ dTHXo;
+ char *envv = GetEnvironmentStrings();
+ char *cur = envv;
+ STRLEN len;
+ while (*cur) {
+ char *end = strchr(cur,'=');
+ if (end && end != cur) {
+ *end = '\0';
+ my_setenv(cur,Nullch);
+ *end = '=';
+ cur = end + strlen(end+1)+2;
+ }
+ else if ((len = strlen(cur)))
+ cur += len+1;
+ }
+ FreeEnvironmentStrings(envv);
+}
+
+void*
+PerlEnvGetChildEnv(struct IPerlEnv*)
+{
+ return NULL;
+}
+
+void
+PerlEnvFreeChildEnv(struct IPerlEnv*, void* env)
+{
+}
+
+char*
+PerlEnvGetChildDir(struct IPerlEnv*)
+{
+ return NULL;
+}
+
+void
+PerlEnvFreeChildDir(struct IPerlEnv*, char* dir)
+{
+}
+
+unsigned long
+PerlEnvOsId(struct IPerlEnv*)
+{
+ return win32_os_id();
+}
+
+char*
+PerlEnvLibPath(struct IPerlEnv*, char *pl)
+{
+ return g_win32_get_privlib(pl);
+}
+
+char*
+PerlEnvSiteLibPath(struct IPerlEnv*, char *pl)
+{
+ return g_win32_get_sitelib(pl);
+}
+
+struct IPerlEnv perlEnv =
+{
+ PerlEnvGetenv,
+ PerlEnvPutenv,
+ PerlEnvGetenv_len,
+ PerlEnvUname,
+ PerlEnvClearenv,
+ PerlEnvGetChildEnv,
+ PerlEnvFreeChildEnv,
+ PerlEnvGetChildDir,
+ PerlEnvFreeChildDir,
+ PerlEnvOsId,
+ PerlEnvLibPath,
+ PerlEnvSiteLibPath,
+};
+
+
+// PerlStdIO
+PerlIO*
+PerlStdIOStdin(struct IPerlStdIO*)
+{
+ return (PerlIO*)win32_stdin();
+}
+
+PerlIO*
+PerlStdIOStdout(struct IPerlStdIO*)
+{
+ return (PerlIO*)win32_stdout();
+}
+
+PerlIO*
+PerlStdIOStderr(struct IPerlStdIO*)
+{
+ return (PerlIO*)win32_stderr();
+}
+
+PerlIO*
+PerlStdIOOpen(struct IPerlStdIO*, const char *path, const char *mode)
+{
+ return (PerlIO*)win32_fopen(path, mode);
+}
+
+int
+PerlStdIOClose(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_fclose(((FILE*)pf));
+}
+
+int
+PerlStdIOEof(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_feof((FILE*)pf);
+}
+
+int
+PerlStdIOError(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_ferror((FILE*)pf);
+}
+
+void
+PerlStdIOClearerr(struct IPerlStdIO*, PerlIO* pf)
+{
+ win32_clearerr((FILE*)pf);
+}
+
+int
+PerlStdIOGetc(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_getc((FILE*)pf);
}
-# define EXTERN_C extern "C"
+
+char*
+PerlStdIOGetBase(struct IPerlStdIO*, PerlIO* pf)
+{
+#ifdef FILE_base
+ FILE *f = (FILE*)pf;
+ return FILE_base(f);
#else
-# define EXTERN_C extern
+ return Nullch;
#endif
+}
-static void xs_init _((void));
+int
+PerlStdIOGetBufsiz(struct IPerlStdIO*, PerlIO* pf)
+{
+#ifdef FILE_bufsiz
+ FILE *f = (FILE*)pf;
+ return FILE_bufsiz(f);
+#else
+ return (-1);
+#endif
+}
-__declspec(dllexport) int
-RunPerl(int argc, char **argv, char **env, void *iosubsystem)
+int
+PerlStdIOGetCnt(struct IPerlStdIO*, PerlIO* pf)
{
- int exitstatus;
- PerlInterpreter *my_perl;
- void *pOldIOSubsystem;
+#ifdef USE_STDIO_PTR
+ FILE *f = (FILE*)pf;
+ return FILE_cnt(f);
+#else
+ return (-1);
+#endif
+}
- pOldIOSubsystem = SetIOSubSystem(iosubsystem);
+char*
+PerlStdIOGetPtr(struct IPerlStdIO*, PerlIO* pf)
+{
+#ifdef USE_STDIO_PTR
+ FILE *f = (FILE*)pf;
+ return FILE_ptr(f);
+#else
+ return Nullch;
+#endif
+}
- PERL_SYS_INIT(&argc,&argv);
+char*
+PerlStdIOGets(struct IPerlStdIO*, PerlIO* pf, char* s, int n)
+{
+ return win32_fgets(s, n, (FILE*)pf);
+}
- perl_init_i18nl10n(1);
+int
+PerlStdIOPutc(struct IPerlStdIO*, PerlIO* pf, int c)
+{
+ return win32_fputc(c, (FILE*)pf);
+}
- if (!(my_perl = perl_alloc()))
- return (1);
- perl_construct( my_perl );
- perl_destruct_level = 0;
+int
+PerlStdIOPuts(struct IPerlStdIO*, PerlIO* pf, const char *s)
+{
+ return win32_fputs(s, (FILE*)pf);
+}
- exitstatus = perl_parse( my_perl, xs_init, argc, argv, env);
- if (!exitstatus) {
- exitstatus = perl_run( my_perl );
- }
+int
+PerlStdIOFlush(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_fflush((FILE*)pf);
+}
- perl_destruct( my_perl );
- perl_free( my_perl );
+int
+PerlStdIOUngetc(struct IPerlStdIO*, PerlIO* pf,int c)
+{
+ return win32_ungetc(c, (FILE*)pf);
+}
- PERL_SYS_TERM();
+int
+PerlStdIOFileno(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_fileno((FILE*)pf);
+}
+
+PerlIO*
+PerlStdIOFdopen(struct IPerlStdIO*, int fd, const char *mode)
+{
+ return (PerlIO*)win32_fdopen(fd, mode);
+}
- SetIOSubSystem(pOldIOSubsystem);
+PerlIO*
+PerlStdIOReopen(struct IPerlStdIO*, const char*path, const char*mode, PerlIO* pf)
+{
+ return (PerlIO*)win32_freopen(path, mode, (FILE*)pf);
+}
- return (exitstatus);
+SSize_t
+PerlStdIORead(struct IPerlStdIO*, PerlIO* pf, void *buffer, Size_t size)
+{
+ return win32_fread(buffer, 1, size, (FILE*)pf);
}
-extern HANDLE PerlDllHandle;
+SSize_t
+PerlStdIOWrite(struct IPerlStdIO*, PerlIO* pf, const void *buffer, Size_t size)
+{
+ return win32_fwrite(buffer, 1, size, (FILE*)pf);
+}
-BOOL APIENTRY
-DllMain(HANDLE hModule, /* DLL module handle */
- DWORD fdwReason, /* reason called */
- LPVOID lpvReserved) /* reserved */
-{
- switch (fdwReason) {
- /* The DLL is attaching to a process due to process
- * initialization or a call to LoadLibrary.
- */
- case DLL_PROCESS_ATTACH:
-/* #define DEFAULT_BINMODE */
-#ifdef DEFAULT_BINMODE
- _setmode( _fileno( stdin ), _O_BINARY );
- _setmode( _fileno( stdout ), _O_BINARY );
- _setmode( _fileno( stderr ), _O_BINARY );
- _fmode = _O_BINARY;
+void
+PerlStdIOSetBuf(struct IPerlStdIO*, PerlIO* pf, char* buffer)
+{
+ win32_setbuf((FILE*)pf, buffer);
+}
+
+int
+PerlStdIOSetVBuf(struct IPerlStdIO*, PerlIO* pf, char* buffer, int type, Size_t size)
+{
+ return win32_setvbuf((FILE*)pf, buffer, type, size);
+}
+
+void
+PerlStdIOSetCnt(struct IPerlStdIO*, PerlIO* pf, int n)
+{
+#ifdef STDIO_CNT_LVALUE
+ FILE *f = (FILE*)pf;
+ FILE_cnt(f) = n;
#endif
- PerlDllHandle = hModule;
- break;
+}
- /* The DLL is detaching from a process due to
- * process termination or call to FreeLibrary.
- */
- case DLL_PROCESS_DETACH:
- break;
+void
+PerlStdIOSetPtrCnt(struct IPerlStdIO*, PerlIO* pf, char * ptr, int n)
+{
+#ifdef STDIO_PTR_LVALUE
+ FILE *f = (FILE*)pf;
+ FILE_ptr(f) = ptr;
+ FILE_cnt(f) = n;
+#endif
+}
- /* The attached process creates a new thread. */
- case DLL_THREAD_ATTACH:
- break;
+void
+PerlStdIOSetlinebuf(struct IPerlStdIO*, PerlIO* pf)
+{
+ win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0);
+}
- /* The thread of the attached process terminates. */
- case DLL_THREAD_DETACH:
- break;
+int
+PerlStdIOPrintf(struct IPerlStdIO*, PerlIO* pf, const char *format,...)
+{
+ va_list(arglist);
+ va_start(arglist, format);
+ return win32_vfprintf((FILE*)pf, format, arglist);
+}
- default:
- break;
- }
- return TRUE;
+int
+PerlStdIOVprintf(struct IPerlStdIO*, PerlIO* pf, const char *format, va_list arglist)
+{
+ return win32_vfprintf((FILE*)pf, format, arglist);
}
-/* Register any extra external extensions */
+long
+PerlStdIOTell(struct IPerlStdIO*, PerlIO* pf)
+{
+ return win32_ftell((FILE*)pf);
+}
-char *staticlinkmodules[] = {
- "DynaLoader",
- NULL,
-};
+int
+PerlStdIOSeek(struct IPerlStdIO*, PerlIO* pf, off_t offset, int origin)
+{
+ return win32_fseek((FILE*)pf, offset, origin);
+}
-EXTERN_C void boot_DynaLoader _((CV* cv));
-
-static
-XS(w32_GetCwd)
-{
- dXSARGS;
- SV *sv = sv_newmortal();
- /* Make one call with zero size - return value is required size */
- DWORD len = GetCurrentDirectory((DWORD)0,NULL);
- SvUPGRADE(sv,SVt_PV);
- SvGROW(sv,len);
- SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
- /*
- * If result != 0
- * then it worked, set PV valid,
- * else leave it 'undef'
- */
- if (SvCUR(sv))
- SvPOK_on(sv);
- EXTEND(sp,1);
- ST(0) = sv;
- XSRETURN(1);
-}
-
-static
-XS(w32_SetCwd)
-{
- dXSARGS;
- if (items != 1)
- croak("usage: Win32::SetCurrentDirectory($cwd)");
- if (SetCurrentDirectory(SvPV(ST(0),na)))
- XSRETURN_YES;
-
- XSRETURN_NO;
-}
-
-static
-XS(w32_GetNextAvailDrive)
-{
- dXSARGS;
- char ix = 'C';
- char root[] = "_:\\";
- while (ix <= 'Z') {
- root[0] = ix++;
- if (GetDriveType(root) == 1) {
- root[2] = '\0';
- XSRETURN_PV(root);
- }
- }
- XSRETURN_UNDEF;
+void
+PerlStdIORewind(struct IPerlStdIO*, PerlIO* pf)
+{
+ win32_rewind((FILE*)pf);
}
-static
-XS(w32_GetLastError)
+PerlIO*
+PerlStdIOTmpfile(struct IPerlStdIO*)
{
- dXSARGS;
- XSRETURN_IV(GetLastError());
+ return (PerlIO*)win32_tmpfile();
}
-static
-XS(w32_LoginName)
+int
+PerlStdIOGetpos(struct IPerlStdIO*, PerlIO* pf, Fpos_t *p)
{
- dXSARGS;
- char name[256];
- DWORD size = sizeof(name);
- if (GetUserName(name,&size)) {
- /* size includes NULL */
- ST(0) = sv_2mortal(newSVpv(name,size-1));
- XSRETURN(1);
- }
- XSRETURN_UNDEF;
+ return win32_fgetpos((FILE*)pf, p);
}
-static
-XS(w32_NodeName)
+int
+PerlStdIOSetpos(struct IPerlStdIO*, PerlIO* pf, const Fpos_t *p)
{
- dXSARGS;
- char name[MAX_COMPUTERNAME_LENGTH+1];
- DWORD size = sizeof(name);
- if (GetComputerName(name,&size)) {
- /* size does NOT include NULL :-( */
- ST(0) = sv_2mortal(newSVpv(name,size));
- XSRETURN(1);
- }
- XSRETURN_UNDEF;
+ return win32_fsetpos((FILE*)pf, p);
+}
+void
+PerlStdIOInit(struct IPerlStdIO*)
+{
+}
+
+void
+PerlStdIOInitOSExtras(struct IPerlStdIO*)
+{
+ dTHXo;
+ xs_init(pPerl);
+ Perl_init_os_extras();
}
+int
+PerlStdIOOpenOSfhandle(struct IPerlStdIO*, long osfhandle, int flags)
+{
+ return win32_open_osfhandle(osfhandle, flags);
+}
-static
-XS(w32_DomainName)
+int
+PerlStdIOGetOSfhandle(struct IPerlStdIO*, int filenum)
{
- dXSARGS;
- char name[256];
- DWORD size = sizeof(name);
- if (GetUserName(name,&size)) {
- char sid[1024];
- DWORD sidlen = sizeof(sid);
- char dname[256];
- DWORD dnamelen = sizeof(dname);
- SID_NAME_USE snu;
- if (LookupAccountName(NULL, name, &sid, &sidlen,
- dname, &dnamelen, &snu)) {
- XSRETURN_PV(dname); /* all that for this */
- }
- }
- XSRETURN_UNDEF;
-}
-
-static
-XS(w32_FsType)
-{
- dXSARGS;
- char fsname[256];
- DWORD flags, filecomplen;
- if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
- &flags, fsname, sizeof(fsname))) {
- if (GIMME == G_ARRAY) {
- XPUSHs(sv_2mortal(newSVpv(fsname,0)));
- XPUSHs(sv_2mortal(newSViv(flags)));
- XPUSHs(sv_2mortal(newSViv(filecomplen)));
- PUTBACK;
- return;
- }
- XSRETURN_PV(fsname);
- }
- XSRETURN_UNDEF;
+ return win32_get_osfhandle(filenum);
}
-static
-XS(w32_GetOSVersion)
+
+struct IPerlStdIO perlStdIO =
{
- dXSARGS;
- OSVERSIONINFO osver;
+ 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,
+ PerlStdIOSetPtrCnt,
+ PerlStdIOSetlinebuf,
+ PerlStdIOPrintf,
+ PerlStdIOVprintf,
+ PerlStdIOTell,
+ PerlStdIOSeek,
+ PerlStdIORewind,
+ PerlStdIOTmpfile,
+ PerlStdIOGetpos,
+ PerlStdIOSetpos,
+ PerlStdIOInit,
+ PerlStdIOInitOSExtras,
+};
- osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- if (GetVersionEx(&osver)) {
- XPUSHs(newSVpv(osver.szCSDVersion, 0));
- XPUSHs(newSViv(osver.dwMajorVersion));
- XPUSHs(newSViv(osver.dwMinorVersion));
- XPUSHs(newSViv(osver.dwBuildNumber));
- XPUSHs(newSViv(osver.dwPlatformId));
- PUTBACK;
- return;
- }
- XSRETURN_UNDEF;
+
+// IPerlLIO
+int
+PerlLIOAccess(struct IPerlLIO*, const char *path, int mode)
+{
+ return access(path, mode);
}
-static
-XS(w32_IsWinNT)
+int
+PerlLIOChmod(struct IPerlLIO*, const char *filename, int pmode)
{
- dXSARGS;
- XSRETURN_IV(IsWinNT());
+ return chmod(filename, pmode);
}
-static
-XS(w32_IsWin95)
+int
+PerlLIOChown(struct IPerlLIO*, const char *filename, uid_t owner, gid_t group)
{
- dXSARGS;
- XSRETURN_IV(IsWin95());
+ return chown(filename, owner, group);
}
-static
-XS(w32_FormatMessage)
+int
+PerlLIOChsize(struct IPerlLIO*, int handle, long size)
{
- dXSARGS;
- DWORD source = 0;
- char msgbuf[1024];
+ return chsize(handle, size);
+}
- if (items != 1)
- croak("usage: Win32::FormatMessage($errno)");
+int
+PerlLIOClose(struct IPerlLIO*, int handle)
+{
+ return win32_close(handle);
+}
- if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
- &source, SvIV(ST(0)), 0,
- msgbuf, sizeof(msgbuf)-1, NULL))
- XSRETURN_PV(msgbuf);
+int
+PerlLIODup(struct IPerlLIO*, int handle)
+{
+ return win32_dup(handle);
+}
- XSRETURN_UNDEF;
+int
+PerlLIODup2(struct IPerlLIO*, int handle1, int handle2)
+{
+ return win32_dup2(handle1, handle2);
}
-static
-XS(w32_Spawn)
+int
+PerlLIOFlock(struct IPerlLIO*, int fd, int oper)
{
- dXSARGS;
- char *cmd, *args;
- PROCESS_INFORMATION stProcInfo;
- STARTUPINFO stStartInfo;
- BOOL bSuccess = FALSE;
+ return win32_flock(fd, oper);
+}
- if(items != 3)
- croak("usage: Win32::Spawn($cmdName, $args, $PID)");
+int
+PerlLIOFileStat(struct IPerlLIO*, int handle, struct stat *buffer)
+{
+ return fstat(handle, buffer);
+}
- cmd = SvPV(ST(0),na);
- args = SvPV(ST(1), na);
+int
+PerlLIOIOCtl(struct IPerlLIO*, int i, unsigned int u, char *data)
+{
+ return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
+}
- memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
- stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
- stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
- stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
+int
+PerlLIOIsatty(struct IPerlLIO*, int fd)
+{
+ return isatty(fd);
+}
- if(CreateProcess(
- cmd, /* Image path */
- args, /* Arguments for command line */
- NULL, /* Default process security */
- NULL, /* Default thread security */
- FALSE, /* Must be TRUE to use std handles */
- NORMAL_PRIORITY_CLASS, /* No special scheduling */
- NULL, /* Inherit our environment block */
- NULL, /* Inherit our currrent directory */
- &stStartInfo, /* -> Startup info */
- &stProcInfo)) /* <- Process info (if OK) */
- {
- CloseHandle(stProcInfo.hThread);/* library source code does this. */
- sv_setiv(ST(2), stProcInfo.dwProcessId);
- bSuccess = TRUE;
- }
- XSRETURN_IV(bSuccess);
+long
+PerlLIOLseek(struct IPerlLIO*, int handle, long offset, int origin)
+{
+ return win32_lseek(handle, offset, origin);
}
-static
-XS(w32_GetTickCount)
+int
+PerlLIOLstat(struct IPerlLIO* p, const char *path, struct stat *buffer)
{
- dXSARGS;
- XSRETURN_IV(GetTickCount());
+ return win32_stat(path, buffer);
}
-static
-XS(w32_GetShortPathName)
+char*
+PerlLIOMktemp(struct IPerlLIO*, char *Template)
{
- dXSARGS;
- SV *shortpath;
+ return mktemp(Template);
+}
- if(items != 1)
- croak("usage: Win32::GetShortPathName($longPathName)");
+int
+PerlLIOOpen(struct IPerlLIO*, const char *filename, int oflag)
+{
+ return win32_open(filename, oflag);
+}
- shortpath = sv_mortalcopy(ST(0));
- SvUPGRADE(shortpath, SVt_PV);
- /* src == target is allowed */
- if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath)))
- ST(0) = shortpath;
+int
+PerlLIOOpen3(struct IPerlLIO*, const char *filename, int oflag, int pmode)
+{
+ int ret;
+ if(stricmp(filename, "/dev/null") == 0)
+ ret = open("NUL", oflag, pmode);
else
- ST(0) = &sv_undef;
- XSRETURN(1);
+ ret = open(filename, oflag, pmode);
+
+ return ret;
}
-static void
-xs_init()
+int
+PerlLIORead(struct IPerlLIO*, int handle, void *buffer, unsigned int count)
{
- char *file = __FILE__;
- dXSUB_SYS;
- newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ return win32_read(handle, buffer, count);
+}
+
+int
+PerlLIORename(struct IPerlLIO*, const char *OldFileName, const char *newname)
+{
+ return win32_rename(OldFileName, newname);
+}
+
+int
+PerlLIOSetmode(struct IPerlLIO*, int handle, int mode)
+{
+ return win32_setmode(handle, mode);
+}
+
+int
+PerlLIONameStat(struct IPerlLIO*, const char *path, struct stat *buffer)
+{
+ return win32_stat(path, buffer);
+}
- /* XXX should be removed after checking with Nick */
- newXS("Win32::GetCurrentDirectory", w32_GetCwd, file);
-
- /* these names are Activeware compatible */
- newXS("Win32::GetCwd", w32_GetCwd, file);
- newXS("Win32::SetCwd", w32_SetCwd, file);
- newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
- newXS("Win32::GetLastError", w32_GetLastError, file);
- newXS("Win32::LoginName", w32_LoginName, file);
- newXS("Win32::NodeName", w32_NodeName, file);
- newXS("Win32::DomainName", w32_DomainName, file);
- newXS("Win32::FsType", w32_FsType, file);
- newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
- newXS("Win32::IsWinNT", w32_IsWinNT, file);
- newXS("Win32::IsWin95", w32_IsWin95, file);
- newXS("Win32::FormatMessage", w32_FormatMessage, file);
- newXS("Win32::Spawn", w32_Spawn, file);
- newXS("Win32::GetTickCount", w32_GetTickCount, file);
- newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
-
- /* XXX Bloat Alert! The following Activeware preloads really
- * ought to be part of Win32::Sys::*, so they're not included
- * here.
- */
- /* LookupAccountName
- * LookupAccountSID
- * InitiateSystemShutdown
- * AbortSystemShutdown
- * ExpandEnvrironmentStrings
- */
+char*
+PerlLIOTmpnam(struct IPerlLIO*, char *string)
+{
+ return tmpnam(string);
+}
+
+int
+PerlLIOUmask(struct IPerlLIO*, int pmode)
+{
+ return umask(pmode);
+}
+
+int
+PerlLIOUnlink(struct IPerlLIO*, const char *filename)
+{
+ chmod(filename, S_IREAD | S_IWRITE);
+ return unlink(filename);
+}
+
+int
+PerlLIOUtime(struct IPerlLIO*, char *filename, struct utimbuf *times)
+{
+ return win32_utime(filename, times);
+}
+
+int
+PerlLIOWrite(struct IPerlLIO*, 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,
+ PerlLIOLseek,
+ PerlLIOLstat,
+ PerlLIOMktemp,
+ PerlLIOOpen,
+ PerlLIOOpen3,
+ PerlLIORead,
+ PerlLIORename,
+ PerlLIOSetmode,
+ PerlLIONameStat,
+ PerlLIOTmpnam,
+ PerlLIOUmask,
+ PerlLIOUnlink,
+ PerlLIOUtime,
+ PerlLIOWrite,
+};
+
+// IPerlDIR
+int
+PerlDirMakedir(struct IPerlDir*, const char *dirname, int mode)
+{
+ return win32_mkdir(dirname, mode);
+}
+
+int
+PerlDirChdir(struct IPerlDir*, const char *dirname)
+{
+ return win32_chdir(dirname);
+}
+
+int
+PerlDirRmdir(struct IPerlDir*, const char *dirname)
+{
+ return win32_rmdir(dirname);
+}
+
+int
+PerlDirClose(struct IPerlDir*, DIR *dirp)
+{
+ return win32_closedir(dirp);
+}
+
+DIR*
+PerlDirOpen(struct IPerlDir*, char *filename)
+{
+ return win32_opendir(filename);
+}
+
+struct direct *
+PerlDirRead(struct IPerlDir*, DIR *dirp)
+{
+ return win32_readdir(dirp);
+}
+
+void
+PerlDirRewind(struct IPerlDir*, DIR *dirp)
+{
+ win32_rewinddir(dirp);
+}
+
+void
+PerlDirSeek(struct IPerlDir*, DIR *dirp, long loc)
+{
+ win32_seekdir(dirp, loc);
+}
+
+long
+PerlDirTell(struct IPerlDir*, DIR *dirp)
+{
+ return win32_telldir(dirp);
+}
+
+struct IPerlDir perlDir =
+{
+ PerlDirMakedir,
+ PerlDirChdir,
+ PerlDirRmdir,
+ PerlDirClose,
+ PerlDirOpen,
+ PerlDirRead,
+ PerlDirRewind,
+ PerlDirSeek,
+ PerlDirTell,
+};
+
+
+// IPerlSock
+u_long
+PerlSockHtonl(struct IPerlSock*, u_long hostlong)
+{
+ return win32_htonl(hostlong);
+}
+
+u_short
+PerlSockHtons(struct IPerlSock*, u_short hostshort)
+{
+ return win32_htons(hostshort);
+}
+
+u_long
+PerlSockNtohl(struct IPerlSock*, u_long netlong)
+{
+ return win32_ntohl(netlong);
+}
+
+u_short
+PerlSockNtohs(struct IPerlSock*, u_short netshort)
+{
+ return win32_ntohs(netshort);
+}
+
+SOCKET PerlSockAccept(struct IPerlSock*, SOCKET s, struct sockaddr* addr, int* addrlen)
+{
+ return win32_accept(s, addr, addrlen);
+}
+
+int
+PerlSockBind(struct IPerlSock*, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_bind(s, name, namelen);
+}
+
+int
+PerlSockConnect(struct IPerlSock*, SOCKET s, const struct sockaddr* name, int namelen)
+{
+ return win32_connect(s, name, namelen);
+}
+
+void
+PerlSockEndhostent(struct IPerlSock*)
+{
+ win32_endhostent();
+}
+
+void
+PerlSockEndnetent(struct IPerlSock*)
+{
+ win32_endnetent();
+}
+
+void
+PerlSockEndprotoent(struct IPerlSock*)
+{
+ win32_endprotoent();
+}
+
+void
+PerlSockEndservent(struct IPerlSock*)
+{
+ win32_endservent();
+}
+
+struct hostent*
+PerlSockGethostbyaddr(struct IPerlSock*, const char* addr, int len, int type)
+{
+ return win32_gethostbyaddr(addr, len, type);
+}
+
+struct hostent*
+PerlSockGethostbyname(struct IPerlSock*, const char* name)
+{
+ return win32_gethostbyname(name);
+}
+
+struct hostent*
+PerlSockGethostent(struct IPerlSock*)
+{
+ dTHXo;
+ croak("gethostent not implemented!\n");
+ return NULL;
+}
+
+int
+PerlSockGethostname(struct IPerlSock*, char* name, int namelen)
+{
+ return win32_gethostname(name, namelen);
+}
+
+struct netent *
+PerlSockGetnetbyaddr(struct IPerlSock*, long net, int type)
+{
+ return win32_getnetbyaddr(net, type);
+}
+
+struct netent *
+PerlSockGetnetbyname(struct IPerlSock*, const char *name)
+{
+ return win32_getnetbyname((char*)name);
+}
+
+struct netent *
+PerlSockGetnetent(struct IPerlSock*)
+{
+ return win32_getnetent();
+}
+
+int PerlSockGetpeername(struct IPerlSock*, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getpeername(s, name, namelen);
+}
+
+struct protoent*
+PerlSockGetprotobyname(struct IPerlSock*, const char* name)
+{
+ return win32_getprotobyname(name);
+}
+
+struct protoent*
+PerlSockGetprotobynumber(struct IPerlSock*, int number)
+{
+ return win32_getprotobynumber(number);
+}
+
+struct protoent*
+PerlSockGetprotoent(struct IPerlSock*)
+{
+ return win32_getprotoent();
+}
+
+struct servent*
+PerlSockGetservbyname(struct IPerlSock*, const char* name, const char* proto)
+{
+ return win32_getservbyname(name, proto);
+}
+
+struct servent*
+PerlSockGetservbyport(struct IPerlSock*, int port, const char* proto)
+{
+ return win32_getservbyport(port, proto);
+}
+
+struct servent*
+PerlSockGetservent(struct IPerlSock*)
+{
+ return win32_getservent();
+}
+
+int
+PerlSockGetsockname(struct IPerlSock*, SOCKET s, struct sockaddr* name, int* namelen)
+{
+ return win32_getsockname(s, name, namelen);
+}
+
+int
+PerlSockGetsockopt(struct IPerlSock*, SOCKET s, int level, int optname, char* optval, int* optlen)
+{
+ return win32_getsockopt(s, level, optname, optval, optlen);
+}
+
+unsigned long
+PerlSockInetAddr(struct IPerlSock*, const char* cp)
+{
+ return win32_inet_addr(cp);
+}
+
+char*
+PerlSockInetNtoa(struct IPerlSock*, struct in_addr in)
+{
+ return win32_inet_ntoa(in);
+}
+
+int
+PerlSockListen(struct IPerlSock*, SOCKET s, int backlog)
+{
+ return win32_listen(s, backlog);
+}
+
+int
+PerlSockRecv(struct IPerlSock*, SOCKET s, char* buffer, int len, int flags)
+{
+ return win32_recv(s, buffer, len, flags);
+}
+
+int
+PerlSockRecvfrom(struct IPerlSock*, 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*, 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*, SOCKET s, const char* buffer, int len, int flags)
+{
+ return win32_send(s, buffer, len, flags);
+}
+
+int
+PerlSockSendto(struct IPerlSock*, 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*, int stayopen)
+{
+ win32_sethostent(stayopen);
+}
+
+void
+PerlSockSetnetent(struct IPerlSock*, int stayopen)
+{
+ win32_setnetent(stayopen);
+}
+
+void
+PerlSockSetprotoent(struct IPerlSock*, int stayopen)
+{
+ win32_setprotoent(stayopen);
+}
+
+void
+PerlSockSetservent(struct IPerlSock*, int stayopen)
+{
+ win32_setservent(stayopen);
+}
+
+int
+PerlSockSetsockopt(struct IPerlSock*, SOCKET s, int level, int optname, const char* optval, int optlen)
+{
+ return win32_setsockopt(s, level, optname, optval, optlen);
+}
+
+int
+PerlSockShutdown(struct IPerlSock*, SOCKET s, int how)
+{
+ return win32_shutdown(s, how);
+}
+
+SOCKET
+PerlSockSocket(struct IPerlSock*, int af, int type, int protocol)
+{
+ return win32_socket(af, type, protocol);
+}
+
+int
+PerlSockSocketpair(struct IPerlSock*, int domain, int type, int protocol, int* fds)
+{
+ dTHXo;
+ croak("socketpair not implemented!\n");
+ return 0;
+}
+
+int
+PerlSockClosesocket(struct IPerlSock*, SOCKET s)
+{
+ return win32_closesocket(s);
+}
+
+int
+PerlSockIoctlsocket(struct IPerlSock*, 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
+
+extern char * g_getlogin(void);
+extern int do_spawn2(char *cmd, int exectype);
+extern int g_do_aspawn(void *vreally, void **vmark, void **vsp);
+
+void
+PerlProcAbort(struct IPerlProc*)
+{
+ win32_abort();
+}
+
+char *
+PerlProcCrypt(struct IPerlProc*, const char* clear, const char* salt)
+{
+ return win32_crypt(clear, salt);
+}
+
+void
+PerlProcExit(struct IPerlProc*, int status)
+{
+ exit(status);
+}
+
+void
+PerlProc_Exit(struct IPerlProc*, int status)
+{
+ _exit(status);
+}
+
+int
+PerlProcExecl(struct IPerlProc*, 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*, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+int
+PerlProcExecvp(struct IPerlProc*, const char *cmdname, const char *const *argv)
+{
+ return win32_execvp(cmdname, argv);
+}
+
+uid_t
+PerlProcGetuid(struct IPerlProc*)
+{
+ return getuid();
+}
+
+uid_t
+PerlProcGeteuid(struct IPerlProc*)
+{
+ return geteuid();
+}
+
+gid_t
+PerlProcGetgid(struct IPerlProc*)
+{
+ return getgid();
+}
+
+gid_t
+PerlProcGetegid(struct IPerlProc*)
+{
+ return getegid();
+}
+
+char *
+PerlProcGetlogin(struct IPerlProc*)
+{
+ return g_getlogin();
+}
+
+int
+PerlProcKill(struct IPerlProc*, int pid, int sig)
+{
+ return win32_kill(pid, sig);
+}
+
+int
+PerlProcKillpg(struct IPerlProc*, int pid, int sig)
+{
+ dTHXo;
+ croak("killpg not implemented!\n");
+ return 0;
+}
+
+int
+PerlProcPauseProc(struct IPerlProc*)
+{
+ return win32_sleep((32767L << 16) + 32767);
+}
+
+PerlIO*
+PerlProcPopen(struct IPerlProc*, const char *command, const char *mode)
+{
+ win32_fflush(stdout);
+ win32_fflush(stderr);
+ return (PerlIO*)win32_popen(command, mode);
+}
+
+int
+PerlProcPclose(struct IPerlProc*, PerlIO *stream)
+{
+ return win32_pclose((FILE*)stream);
+}
+
+int
+PerlProcPipe(struct IPerlProc*, int *phandles)
+{
+ return win32_pipe(phandles, 512, O_BINARY);
+}
+
+int
+PerlProcSetuid(struct IPerlProc*, uid_t u)
+{
+ return setuid(u);
+}
+
+int
+PerlProcSetgid(struct IPerlProc*, gid_t g)
+{
+ return setgid(g);
+}
+
+int
+PerlProcSleep(struct IPerlProc*, unsigned int s)
+{
+ return win32_sleep(s);
+}
+
+int
+PerlProcTimes(struct IPerlProc*, struct tms *timebuf)
+{
+ return win32_times(timebuf);
+}
+
+int
+PerlProcWait(struct IPerlProc*, int *status)
+{
+ return win32_wait(status);
+}
+
+int
+PerlProcWaitpid(struct IPerlProc*, int pid, int *status, int flags)
+{
+ return win32_waitpid(pid, status, flags);
+}
+
+Sighandler_t
+PerlProcSignal(struct IPerlProc*, int sig, Sighandler_t subcode)
+{
+ return 0;
+}
+
+void*
+PerlProcDynaLoader(struct IPerlProc*, const char* filename)
+{
+ return win32_dynaload(filename);
+}
+
+void
+PerlProcGetOSError(struct IPerlProc*, SV* sv, DWORD dwErr)
+{
+ win32_str_os_error(aTHX_ sv, dwErr);
+}
+
+BOOL
+PerlProcDoCmd(struct IPerlProc*, char *cmd)
+{
+ do_spawn2(cmd, EXECF_EXEC);
+ return FALSE;
+}
+
+int
+PerlProcSpawn(struct IPerlProc*, char* cmds)
+{
+ return do_spawn2(cmds, EXECF_SPAWN);
+}
+
+int
+PerlProcSpawnvp(struct IPerlProc*, int mode, const char *cmdname, const char *const *argv)
+{
+ return win32_spawnvp(mode, cmdname, argv);
+}
+
+int
+PerlProcASpawn(struct IPerlProc*, void *vreally, void **vmark, void **vsp)
+{
+ return g_do_aspawn(vreally, vmark, vsp);
+}
+
+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,
+ PerlProcDynaLoader,
+ PerlProcGetOSError,
+ PerlProcDoCmd,
+ PerlProcSpawn,
+ PerlProcSpawnvp,
+ PerlProcASpawn,
+};
+
+//#include "perlhost.h"
+
+
+EXTERN_C void perl_get_host_info(IPerlMemInfo* perlMemInfo,
+ IPerlEnvInfo* perlEnvInfo, IPerlStdIOInfo* perlStdIOInfo,
+ IPerlLIOInfo* perlLIOInfo, IPerlDirInfo* perlDirInfo,
+ IPerlSockInfo* perlSockInfo, IPerlProcInfo* perlProcInfo)
+{
+ if(perlMemInfo) {
+ Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
+ perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
+ }
+ if(perlEnvInfo) {
+ Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
+ perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
+ }
+ if(perlStdIOInfo) {
+ Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
+ perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
+ }
+ if(perlLIOInfo) {
+ Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
+ perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
+ }
+ if(perlDirInfo) {
+ Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
+ perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
+ }
+ if(perlSockInfo) {
+ Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
+ perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
+ }
+ if(perlProcInfo) {
+ Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
+ perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
+ }
+}
+
+EXTERN_C PerlInterpreter* perl_alloc_using(IPerlMem* pMem,
+ IPerlEnv* pEnv, IPerlStdIO* pStdIO,
+ IPerlLIO* pLIO, IPerlDir* pDir,
+ IPerlSock* pSock, IPerlProc* pProc)
+{
+ CPerlObj* pPerl = NULL;
+ try
+ {
+ pPerl = Perl_alloc(pMem, pEnv, pStdIO, pLIO, pDir, pSock, pProc);
+ }
+ catch(...)
+ {
+ win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
+ pPerl = NULL;
+ }
+ if(pPerl)
+ {
+ SetPerlInterpreter(pPerl);
+ return (PerlInterpreter*)pPerl;
+ }
+ SetPerlInterpreter(NULL);
+ return NULL;
+}
+
+#undef perl_alloc
+#undef perl_construct
+#undef perl_destruct
+#undef perl_free
+#undef perl_run
+#undef perl_parse
+EXTERN_C PerlInterpreter* perl_alloc(void)
+{
+ CPerlObj* pPerl = NULL;
+ try
+ {
+ pPerl = Perl_alloc(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
+ &perlDir, &perlSock, &perlProc);
+ }
+ catch(...)
+ {
+ win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
+ pPerl = NULL;
+ }
+ if(pPerl)
+ {
+ SetPerlInterpreter(pPerl);
+ return (PerlInterpreter*)pPerl;
+ }
+ SetPerlInterpreter(NULL);
+ return NULL;
+}
+
+EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
+{
+ CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ try
+ {
+ pPerl->perl_construct();
+ }
+ catch(...)
+ {
+ win32_fprintf(stderr, "%s\n",
+ "Error: Unable to construct data structures");
+ pPerl->perl_free();
+ SetPerlInterpreter(NULL);
+ }
+}
+
+EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
+{
+ CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ try
+ {
+ pPerl->perl_destruct();
+ }
+ catch(...)
+ {
+ }
+}
+
+EXTERN_C void perl_free(PerlInterpreter* sv_interp)
+{
+ CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ try
+ {
+ pPerl->perl_free();
+ }
+ catch(...)
+ {
+ }
+ SetPerlInterpreter(NULL);
+}
+
+EXTERN_C int perl_run(PerlInterpreter* sv_interp)
+{
+ CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ int retVal;
+ try
+ {
+ retVal = pPerl->perl_run();
+ }
+/*
+ catch(int x)
+ {
+ // this is where exit() should arrive
+ retVal = x;
+ }
+*/
+ catch(...)
+ {
+ win32_fprintf(stderr, "Error: Runtime exception\n");
+ retVal = -1;
+ }
+ return retVal;
+}
+
+EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
+{
+ int retVal;
+ CPerlObj* pPerl = (CPerlObj*)sv_interp;
+ try
+ {
+ retVal = pPerl->perl_parse(xsinit, argc, argv, env);
+ }
+/*
+ catch(int x)
+ {
+ // this is where exit() should arrive
+ retVal = x;
+ }
+*/
+ catch(...)
+ {
+ win32_fprintf(stderr, "Error: Parse exception\n");
+ retVal = -1;
+ }
+ *win32_errno() = 0;
+ return retVal;
+}
+
+#undef PL_perl_destruct_level
+#define PL_perl_destruct_level int dummy
+#endif /* PERL_OBJECT */
+
+extern HANDLE w32_perldll_handle;
+static DWORD g_TlsAllocIndex;
+
+EXTERN_C DllExport bool
+SetPerlInterpreter(void *interp)
+{
+ return TlsSetValue(g_TlsAllocIndex, interp);
+}
+
+EXTERN_C DllExport void*
+GetPerlInterpreter(void)
+{
+ return TlsGetValue(g_TlsAllocIndex);
+}
+
+EXTERN_C DllExport int
+RunPerl(int argc, char **argv, char **env)
+{
+ int exitstatus;
+ PerlInterpreter *my_perl;
+ struct perl_thread *thr;
+
+#ifndef __BORLANDC__
+ /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
+ * want to free() argv after main() returns. As luck would have it,
+ * Borland's CRT does the right thing to argv[0] already. */
+ char szModuleName[MAX_PATH];
+ char *ptr;
+
+ GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
+ (void)win32_longpath(szModuleName);
+ argv[0] = szModuleName;
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+#define PERLVAR(var,type) /**/
+#define PERLVARA(var,type) /**/
+#define PERLVARI(var,type,init) PL_Vars.var = init;
+#define PERLVARIC(var,type,init) PL_Vars.var = init;
+#include "perlvars.h"
+#undef PERLVAR
+#undef PERLVARA
+#undef PERLVARI
+#undef PERLVARIC
+#endif
+
+ PERL_SYS_INIT(&argc,&argv);
+
+ if (!(my_perl = perl_alloc()))
+ return (1);
+ perl_construct( my_perl );
+ PL_perl_destruct_level = 0;
+
+#ifdef PERL_OBJECT
+ /* PERL_OBJECT build sets Dynaloader in PerlStdIOInitOSExtras */
+ exitstatus = perl_parse(my_perl, NULL, argc, argv, env);
+#else
+ exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
+#endif
+ if (!exitstatus) {
+ exitstatus = perl_run( my_perl );
+ }
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ PERL_SYS_TERM();
+
+ return (exitstatus);
+}
+
+BOOL APIENTRY
+DllMain(HANDLE hModule, /* DLL module handle */
+ DWORD fdwReason, /* reason called */
+ LPVOID lpvReserved) /* reserved */
+{
+ switch (fdwReason) {
+ /* The DLL is attaching to a process due to process
+ * initialization or a call to LoadLibrary.
+ */
+ case DLL_PROCESS_ATTACH:
+/* #define DEFAULT_BINMODE */
+#ifdef DEFAULT_BINMODE
+ setmode( fileno( stdin ), O_BINARY );
+ setmode( fileno( stdout ), O_BINARY );
+ setmode( fileno( stderr ), O_BINARY );
+ _fmode = O_BINARY;
+#endif
+ g_TlsAllocIndex = TlsAlloc();
+ DisableThreadLibraryCalls(hModule);
+ w32_perldll_handle = hModule;
+ break;
+
+ /* The DLL is detaching from a process due to
+ * process termination or call to FreeLibrary.
+ */
+ case DLL_PROCESS_DETACH:
+ TlsFree(g_TlsAllocIndex);
+ break;
+
+ /* The attached process creates a new thread. */
+ case DLL_THREAD_ATTACH:
+ break;
+
+ /* The thread of the attached process terminates. */
+ case DLL_THREAD_DETACH:
+ break;
+
+ default:
+ break;
+ }
+ return TRUE;
}