C<dump()>, C<chown()>, C<link()>, C<symlink()>, C<chroot()>,
C<setpgrp()> and related security functions, C<setpriority()>,
C<getpriority()>, C<syscall()>, C<fcntl()>, C<getpw*()>,
-C<wait*()>, C<msg*()>, C<shm*()>, C<sem*()>, C<alarm()>,
-C<socketpair()>, C<*netent()>, C<*protoent()>, C<*servent()>,
-C<*hostent()>, C<getnetby*()>.
+C<msg*()>, C<shm*()>, C<sem*()>, C<alarm()>, C<socketpair()>,
+C<*netent()>, C<*protoent()>, C<*servent()>, C<*hostent()>,
+C<getnetby*()>.
This list is possibly incomplete.
=item *
=item *
-C<$?> is set in a way compatible with Unix, so the exitstatus of the
-subprocess is actually obtained by "$? >> 8". Failure to spawn() the
-subprocess is indicated by setting $? to "255 << 8".
+Failure to spawn() a subprocess is indicated by setting $? to "255 << 8".
+C<$?> is set in a way compatible with Unix (i.e. the exitstatus of the
+subprocess is obtained by "$? >> 8", as described in the documentation).
=item *
Borland support was added in 5.004_01 (Gurusamy Sarathy).
-Last updated: 23 December 1997
+Last updated: 3 January 1998
=cut
#define dXSUB_SYS
#define TMPPATH "plXXXXXX"
-#ifdef WIN32
-#define HAS_IOCTL
-#define HAS_UTIME
-#define HAS_KILL
-#endif
-
/*
* 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were
* running on DOS, *and* if we had to cope with 16 bit memory addressing
#ifndef WIN32
# define Stat(fname,bufptr) stat((fname),(bufptr))
#else
+# define HAS_IOCTL
+# define HAS_UTIME
+# define HAS_KILL
+# define HAS_WAIT
/*
* This provides a layer of functions and macros to ensure extensions will
* get to use the same RTL functions as the core.
*/
-#ifndef HASATTRIBUTE
-# include <win32iop.h>
-#endif
+# ifndef HASATTRIBUTE
+# include <win32iop.h>
+# endif
#endif /* WIN32 */
}
sub _win32_cwd {
- $ENV{'PWD'} = Win32::GetCurrentDirectory();
+ $ENV{'PWD'} = Win32::GetCwd();
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
- defined &Win32::GetCurrentDirectory);
+ defined &Win32::GetCwd);
*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
}
# Handle possible library arguments.
- $thislib =~ s/^-l//;
+ if ($thislib =~ s/^-l// and $thislib !~ /^lib/i) {
+ $thislib = "lib$thislib";
+ }
$thislib .= $libext if $thislib !~ /\Q$libext\E$/i;
my($found_lib)=0;
Input library and path specifications are accepted with or without the
C<-l> and C<-L> prefices used by Unix linkers. C<-lfoo> specifies the
-library C<foo.lib> and C<-Ls:ome\dir> specifies a directory to look for
-the libraries that follow. If neither prefix is present, a token is
-considered a directory to search if it is in fact a directory, and a
-library to search for otherwise. The C<$Config{lib_ext}> suffix will
-be appended to any entries that are not directories and don't already
-have the suffix. Authors who wish their extensions to be portable to
-Unix or OS/2 should use the Unix prefixes, since the Unix-OS/2 version
-of ext() requires them.
+library C<libfoo.lib> (unless C<foo> already starts with C<lib>), and
+C<-Ls:ome\dir> specifies a directory to look for the libraries that follow.
+If neither prefix is present, a token is considered a directory to search
+if it is in fact a directory, and a library to search for otherwise. The
+C<$Config{lib_ext}> suffix will be appended to any entries that are not
+directories and don't already have the suffix. Authors who wish their
+extensions to be portable to Unix or OS/2 should use the Unix prefixes,
+since the Unix-OS/2 version of ext() requires them.
=item *
find this at http://www.perl.com/CPAN/src/latest.tar.gz, which is a
gzipped archive in POSIX tar format. This source builds with no
porting whatsoever on most Unix systems (Perl's native environment),
-as well as Plan 9, VMS, QNX, OS/2, and the Amiga.
-
-Although it's rumored that the (imminent) 5.004 release may build
-on Windows NT, this is yet to be proven. Binary distributions
-for 32-bit Microsoft systems and for Apple systems can be found
-http://www.perl.com/CPAN/ports/ directory. Because these are not part of
-the standard distribution, they may and in fact do differ from the base
-Perl port in a variety of ways. You'll have to check their respective
-release notes to see just what the differences are. These differences
-can be either positive (e.g. extensions for the features of the particular
-platform that are not supported in the source release of perl) or negative
-(e.g. might be based upon a less current source release of perl).
-
-A useful FAQ for Win32 Perl users is
+as well as Windows NT, Plan 9, VMS, QNX, OS/2, and the Amiga.
+
+Binary distributions for various platforms can be found
+http://www.perl.com/CPAN/ports/ directory. Some of these ports (especially
+the ones that are not part of the standard sources) may behave differently
+than what is documented in the standard source documentation. These
+differences can be either positive (e.g. extensions for the features of the
+particular platform that are not supported in the source release of perl)
+or negative (e.g. might be based upon a less current source release of perl).
+
+A useful FAQ for Win32 Perl users is:
http://www.endcontsw.com/people/evangelo/Perl_for_Win32_FAQ.html
+[This FAQ is seriously outdated as of Jan 1998--it is only relevant to
+the perl that ActiveState distributes, especially where it describes
+various inadequacies and differences with the standard perl extension
+build support.]
=head2 How can I get a binary version of Perl?
PP(pp_wait)
{
-#if !defined(DOSISH) || defined(OS2)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
djSP; dTARGET;
int childpid;
int argflags;
PP(pp_waitpid)
{
-#if !defined(DOSISH) || defined(OS2)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
djSP; dTARGET;
int childpid;
int optype;
SETi(childpid);
RETURN;
#else
- DIE(no_func, "Unsupported function wait");
+ DIE(no_func, "Unsupported function waitpid");
#endif
}
}
#endif /* !DOSISH */
-#if !defined(DOSISH) || defined(OS2)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
I32
wait4pid(int pid, int *statusp, int flags)
{
}
#endif
}
-#endif /* !DOSISH */
+#endif /* !DOSISH || OS2 || WIN32 */
void
/*SUPPRESS 590*/
# on a case-forgiving file system we can simply use -f $file
if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') {
return $file if -f $file and -r _;
- warn "Ignored $file: unreadable\n" unless -r _;
+ warn "Ignored $file: unreadable\n" if -f _;
return '';
}
local *DIR;
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define ARCHLIB "c:\\perl\\lib\\MSWin32-x86-thread" /**/
-#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL)) /**/
+#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/
/* BINCOMPAT3:
* This symbol, if defined, indicates that Perl 5.004 should be
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define PRIVLIB "c:\\perl\\lib" /**/
-#define PRIVLIB_EXP (win32PerlLibPath(NULL)) /**/
+#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/
/* SH_PATH:
* This symbol contains the full pathname to the shell used on this
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITEARCH "c:\\perl\\lib\\site" /**/
-#define SITEARCH_EXP (win32PerlLibPath("site",ARCHNAME,NULL)) /**/
+#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITELIB "c:\\perl\\lib\\site" /**/
-#define SITELIB_EXP (win32PerlLibPath("site",NULL)) /**/
+#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/
/* STARTPERL:
* This variable contains the string to put in front of a perl
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define ARCHLIB "c:\\perl\\lib\\MSWin32-x86-thread" /**/
-#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL)) /**/
+#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/
/* BINCOMPAT3:
* This symbol, if defined, indicates that Perl 5.004 should be
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define PRIVLIB "c:\\perl\\lib" /**/
-#define PRIVLIB_EXP (win32PerlLibPath(NULL)) /**/
+#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/
/* SH_PATH:
* This symbol contains the full pathname to the shell used on this
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITEARCH "c:\\perl\\lib\\site" /**/
-#define SITEARCH_EXP (win32PerlLibPath("site",ARCHNAME,NULL)) /**/
+#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITELIB "c:\\perl\\lib\\site" /**/
-#define SITELIB_EXP (win32PerlLibPath("site",NULL)) /**/
+#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/
/* STARTPERL:
* This variable contains the string to put in front of a perl
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define ARCHLIB "c:\\perl\\lib\\MSWin32-x86-thread" /**/
-#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL)) /**/
+#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL)) /**/
/* BINCOMPAT3:
* This symbol, if defined, indicates that Perl 5.004 should be
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define PRIVLIB "c:\\perl\\lib" /**/
-#define PRIVLIB_EXP (win32PerlLibPath(NULL)) /**/
+#define PRIVLIB_EXP (win32_perllib_path(NULL)) /**/
/* SH_PATH:
* This symbol contains the full pathname to the shell used on this
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITEARCH "c:\\perl\\lib\\site" /**/
-#define SITEARCH_EXP (win32PerlLibPath("site",ARCHNAME,NULL)) /**/
+#define SITEARCH_EXP (win32_perllib_path("site",ARCHNAME,NULL)) /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
#define SITELIB "c:\\perl\\lib\\site" /**/
-#define SITELIB_EXP (win32PerlLibPath("site",NULL)) /**/
+#define SITELIB_EXP (win32_perllib_path("site",NULL)) /**/
/* STARTPERL:
* This variable contains the string to put in front of a perl
s#/[ *\*]*\*/#/**/#;
if (/^\s*#define\s+ARCHLIB_EXP/)
{
- $_ = "#define ARCHLIB_EXP (win32PerlLibPath(ARCHNAME,NULL))\t/**/\n";
+ $_ = "#define ARCHLIB_EXP (win32_perllib_path(ARCHNAME,NULL))\t/**/\n";
}
if (/^\s*#define\s+PRIVLIB_EXP/)
{
- $_ = "#define PRIVLIB_EXP (win32PerlLibPath(NULL))\t/**/\n"
+ $_ = "#define PRIVLIB_EXP (win32_perllib_path(NULL))\t/**/\n"
}
if (/^\s*#define\s+SITEARCH_EXP/)
{
- $_ = "#define SITEARCH_EXP (win32PerlLibPath(\"site\",ARCHNAME,NULL))\t/**/\n";
+ $_ = "#define SITEARCH_EXP (win32_perllib_path(\"site\",ARCHNAME,NULL))\t/**/\n";
}
if (/^\s*#define\s+SITELIB_EXP/)
{
- $_ = "#define SITELIB_EXP (win32PerlLibPath(\"site\",NULL))\t/**/\n";
+ $_ = "#define SITELIB_EXP (win32_perllib_path(\"site\",NULL))\t/**/\n";
}
print H;
}
return (exitstatus);
}
-extern HANDLE PerlDllHandle;
+extern HANDLE w32_perldll_handle;
BOOL APIENTRY
DllMain(HANDLE hModule, /* DLL module handle */
setmode( fileno( stderr ), O_BINARY );
_fmode = O_BINARY;
#endif
- PerlDllHandle = hModule;
+ w32_perldll_handle = hModule;
break;
/* The DLL is detaching from a process due to
#define EXECF_SPAWN 2
#define EXECF_SPAWN_NOWAIT 3
-static DWORD IdOS(void);
-
-BOOL ProbeEnv = FALSE;
-DWORD Win32System = (DWORD)-1;
-char szShellPath[MAX_PATH+1];
-char szPerlLibRoot[MAX_PATH+1];
-HANDLE PerlDllHandle = INVALID_HANDLE_VALUE;
+static DWORD os_id(void);
+static char * get_shell(void);
+static int do_spawn2(char *cmd, int exectype);
+static BOOL has_redirection(char *ptr);
+static long filetime_to_clock(PFILETIME ft);
+
+BOOL w32_env_probed = FALSE;
+DWORD w32_platform = (DWORD)-1;
+char w32_shellpath[MAX_PATH+1];
+char w32_perllib_root[MAX_PATH+1];
+HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
+#ifndef __BORLANDC__
+long w32_num_children = 0;
+HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS];
+#endif
#ifdef USE_THREADS
# ifdef USE_DECLSPEC_THREAD
# endif
#endif
-static int do_spawn2(char *cmd, int exectype);
-
int
IsWin95(void) {
- return (IdOS() == VER_PLATFORM_WIN32_WINDOWS);
+ return (os_id() == VER_PLATFORM_WIN32_WINDOWS);
}
int
IsWinNT(void) {
- return (IdOS() == VER_PLATFORM_WIN32_NT);
+ return (os_id() == VER_PLATFORM_WIN32_NT);
}
char *
-win32PerlLibPath(char *sfx,...)
+win32_perllib_path(char *sfx,...)
{
va_list ap;
char *end;
va_start(ap,sfx);
- GetModuleFileName((PerlDllHandle == INVALID_HANDLE_VALUE)
+ GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE)
? GetModuleHandle(NULL)
- : PerlDllHandle,
- szPerlLibRoot,
- sizeof(szPerlLibRoot));
- *(end = strrchr(szPerlLibRoot, '\\')) = '\0';
+ : w32_perldll_handle,
+ w32_perllib_root,
+ sizeof(w32_perllib_root));
+ *(end = strrchr(w32_perllib_root, '\\')) = '\0';
if (stricmp(end-4,"\\bin") == 0)
end -= 4;
strcpy(end,"\\lib");
sfx = va_arg(ap,char *);
}
va_end(ap);
- return (szPerlLibRoot);
+ return (w32_perllib_root);
}
-BOOL
-HasRedirection(char *ptr)
+static BOOL
+has_redirection(char *ptr)
{
int inquote = 0;
char quote = '\0';
}
static DWORD
-IdOS(void)
+os_id(void)
{
static OSVERSIONINFO osver;
- if (osver.dwPlatformId != Win32System) {
+ if (osver.dwPlatformId != w32_platform) {
memset(&osver, 0, sizeof(OSVERSIONINFO));
osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&osver);
- Win32System = osver.dwPlatformId;
+ w32_platform = osver.dwPlatformId;
}
- return (Win32System);
+ return (w32_platform);
}
+/* XXX PERL5SHELL must be tokenized to allow switches to be passed */
static char *
-GetShell(void)
+get_shell(void)
{
- if (!ProbeEnv) {
+ if (!w32_env_probed) {
char* defaultshell = (IsWinNT() ? "cmd.exe" : "command.com");
/* we don't use COMSPEC here for two reasons:
* 1. the same reason perl on UNIX doesn't use SHELL--rampant and
*/
char *usershell = getenv("PERL5SHELL");
- ProbeEnv = TRUE;
- strcpy(szShellPath, usershell ? usershell : defaultshell);
+ w32_env_probed = TRUE;
+ strcpy(w32_shellpath, usershell ? usershell : defaultshell);
}
- return szShellPath;
+ return w32_shellpath;
}
int
-do_aspawn(void* really, void ** mark, void ** arglast)
+do_aspawn(void *vreally, void **vmark, void **vsp)
{
+ SV *really = (SV*)vreally;
+ SV **mark = (SV**)vmark;
+ SV **sp = (SV**)vsp;
char **argv;
- char *strPtr;
- char *cmd;
+ char *str;
int status;
- unsigned int length;
+ int flag = P_WAIT;
int index = 0;
- SV *sv = (SV*)really;
- SV** pSv = (SV**)mark;
- New(1310, argv, (arglast - mark) + 4, char*);
+ if (sp <= mark)
+ return -1;
- if(sv != Nullsv) {
- cmd = SvPV(sv, length);
- }
- else {
- argv[index++] = cmd = GetShell();
- if (IsWinNT())
- argv[index++] = "/x"; /* always enable command extensions */
- argv[index++] = "/c";
+ New(1301, argv, (sp - mark) + 4, char*);
+
+ if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
+ ++mark;
+ flag = SvIVx(*mark);
}
- while(++pSv <= (SV**)arglast) {
- sv = *pSv;
- strPtr = SvPV(sv, length);
- if(strPtr != NULL && *strPtr != '\0')
- argv[index++] = strPtr;
+ while(++mark <= sp) {
+ if (*mark && (str = SvPV(*mark, na)))
+ argv[index++] = str;
+ else
+ argv[index++] = "";
}
argv[index++] = 0;
- status = win32_spawnvp(P_WAIT, cmd, (const char* const*)argv);
+ status = win32_spawnvp(flag,
+ (really ? SvPV(really,na) : argv[0]),
+ (const char* const*)argv);
+
+ if (status < 0 && errno == ENOEXEC) {
+ /* possible shell-builtin, invoke with shell */
+ int sh_items = 2;
+ while (--index >= 0)
+ argv[index+sh_items] = argv[index];
+ if (IsWinNT())
+ argv[--sh_items] = "/x/c"; /* always enable command extensions */
+ else
+ argv[--sh_items] = "/c";
+ argv[--sh_items] = get_shell();
+
+ status = win32_spawnvp(flag,
+ (really ? SvPV(really,na) : argv[0]),
+ (const char* const*)argv);
+ }
Safefree(argv);
-
if (status < 0) {
if (dowarn)
- warn("Can't spawn \"%s\": %s", cmd, strerror(errno));
- status = 255;
+ warn("Can't spawn \"%s\": %s", argv[0], strerror(errno));
+ status = 255 * 256;
}
- return (statusvalue = status*256);
+ else if (flag != P_NOWAIT)
+ status *= 256;
+ return (statusvalue = status);
}
-int
+static int
do_spawn2(char *cmd, int exectype)
{
char **a;
char **argv;
int status = -1;
BOOL needToTry = TRUE;
- char *shell, *cmd2;
-
- /* save an extra exec if possible */
- shell = GetShell();
+ char *cmd2;
- /* see if there are shell metacharacters in it */
- if(!HasRedirection(cmd)) {
+ /* Save an extra exec if possible. See if there are shell
+ * metacharacters in it */
+ if(!has_redirection(cmd)) {
New(1301,argv, strlen(cmd) / 2 + 2, char*);
New(1302,cmd2, strlen(cmd) + 1, char);
strcpy(cmd2, cmd);
status = win32_execvp(argv[0], (const char* const*)argv);
break;
}
- if(status != -1 || errno == 0)
+ if (status != -1 || errno == 0)
needToTry = FALSE;
}
Safefree(argv);
Safefree(cmd2);
}
- if(needToTry) {
- char *argv[5];
+ if (needToTry) {
+ char *argv[4];
int i = 0;
- argv[i++] = shell;
+ argv[i++] = get_shell();
if (IsWinNT())
- argv[i++] = "/x";
- argv[i++] = "/c"; argv[i++] = cmd; argv[i] = Nullch;
+ argv[i++] = "/x/c";
+ else
+ argv[i++] = "/c";
+ argv[i++] = cmd;
+ argv[i] = Nullch;
switch (exectype) {
case EXECF_SPAWN:
status = win32_spawnvp(P_WAIT, argv[0],
if (dowarn)
warn("Can't %s \"%s\": %s",
(exectype == EXECF_EXEC ? "exec" : "spawn"),
- needToTry ? shell : argv[0],
- strerror(errno));
- status = 255;
+ argv[0], strerror(errno));
+ status = 255 * 256;
}
- return (statusvalue = status*256);
+ else if (exectype != EXECF_SPAWN_NOWAIT)
+ status *= 256;
+ return (statusvalue = status);
}
int
return do_spawn2(cmd, EXECF_SPAWN);
}
+int
+do_spawn_nowait(char *cmd)
+{
+ return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+}
+
bool
do_exec(char *cmd)
{
#endif
static long
-FileTimeToClock(PFILETIME ft)
+filetime_to_clock(PFILETIME ft)
{
__int64 qw = ft->dwHighDateTime;
qw <<= 32;
FILETIME dummy;
if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
&kernel,&user)) {
- timebuf->tms_utime = FileTimeToClock(&user);
- timebuf->tms_stime = FileTimeToClock(&kernel);
+ timebuf->tms_utime = filetime_to_clock(&user);
+ timebuf->tms_stime = filetime_to_clock(&kernel);
timebuf->tms_cutime = 0;
timebuf->tms_cstime = 0;
return 0;
}
-static UINT timerid = 0;
+DllExport int
+win32_wait(int *status)
+{
+#ifdef __BORLANDC__
+ return wait(status);
+#else
+ /* XXX this wait emulation only knows about processes
+ * spawned via win32_spawnvp(P_NOWAIT, ...).
+ */
+ int i, retval;
+ DWORD exitcode, waitcode;
+
+ if (!w32_num_children) {
+ errno = ECHILD;
+ return -1;
+ }
+
+ /* if a child exists, wait for it to die */
+ waitcode = WaitForMultipleObjects(w32_num_children,
+ w32_child_pids,
+ FALSE,
+ INFINITE);
+ if (waitcode != WAIT_FAILED) {
+ if (waitcode >= WAIT_ABANDONED_0
+ && waitcode < WAIT_ABANDONED_0 + w32_num_children)
+ i = waitcode - WAIT_ABANDONED_0;
+ else
+ i = waitcode - WAIT_OBJECT_0;
+ if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) {
+ CloseHandle(w32_child_pids[i]);
+ *status = (int)((exitcode & 0xff) << 8);
+ retval = (int)w32_child_pids[i];
+ Copy(&w32_child_pids[i+1], &w32_child_pids[i],
+ (w32_num_children-i-1), HANDLE);
+ w32_num_children--;
+ return retval;
+ }
+ }
+
+FAILED:
+ errno = GetLastError();
+ return -1;
+
+#endif
+}
+static UINT timerid = 0;
static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
{
DllExport int
win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
{
- return spawnvp(mode, cmdname, (char * const *) argv);
+ int status;
+
+ status = spawnvp(mode, cmdname, (char * const *) argv);
+#ifndef __BORLANDC__
+ /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId
+ * while VC RTL returns pinfo.hProcess. For purposes of the custom
+ * implementation of win32_wait(), we assume the latter.
+ */
+ if (mode == P_NOWAIT && status >= 0)
+ w32_child_pids[w32_num_children++] = (HANDLE)status;
+#endif
+ return status;
}
DllExport int
extern FILE * my_fdopen(int, char *);
#endif
extern int my_fclose(FILE *);
-extern int do_aspawn(void* really, void ** mark, void ** arglast);
+extern int do_aspawn(void *really, void **mark, void **sp);
extern int do_spawn(char *cmd);
+extern int do_spawn_nowait(char *cmd);
extern char do_exec(char *cmd);
-extern char * win32PerlLibPath(char *sfx,...);
+extern char * win32_perllib_path(char *sfx,...);
extern int IsWin95(void);
extern int IsWinNT(void);
# ifdef HAVE_DES_FCRYPT
char Wcrypt_buffer[30];
# endif
+# ifdef USE_RTL_THREAD_API
+ void * retv; /* slot for thread return value */
+# endif
};
# endif /* !USE_DECLSPEC_THREAD */
#endif /* USE_THREADS */
DllExport unsigned win32_sleep(unsigned int);
DllExport int win32_times(struct tms *timebuf);
DllExport unsigned win32_alarm(unsigned int sec);
-DllExport int win32_flock(int fd, int oper);
DllExport int win32_stat(const char *path, struct stat *buf);
DllExport int win32_ioctl(int i, unsigned int u, char *data);
+DllExport int win32_wait(int *status);
#ifdef HAVE_DES_FCRYPT
DllExport char * win32_crypt(const char *txt, const char *salt);
#undef times
#undef alarm
#undef ioctl
+#undef wait
#ifdef __BORLANDC__
#undef ungetc
#define times win32_times
#define alarm win32_alarm
#define ioctl win32_ioctl
+#define wait win32_wait
#ifdef HAVE_DES_FCRYPT
#undef crypt
return r;
}
-DllExport int
+int
win32_ioctlsocket(SOCKET s, long cmd, u_long *argp)
{
int r;
Perl_thread_create(struct perl_thread *thr, thread_func_t *fn)
{
DWORD junk;
+ unsigned long th;
MUTEX_LOCK(&thr->mutex);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"%p: create OS thread\n", thr));
+#ifdef USE_RTL_THREAD_API
+ /* See comment about USE_RTL_THREAD_API in win32thread.h */
+#if defined(__BORLANDC__)
+ th = _beginthreadNT(fn, /* start address */
+ 0, /* stack size */
+ (void *)thr, /* parameters */
+ (void *)NULL, /* security attrib */
+ 0, /* creation flags */
+ (unsigned long *)&junk); /* tid */
+ if (th == (unsigned long)-1)
+ th = 0;
+#elif defined(_MSC_VER_)
+ th = _beginthreadex((void *)NULL, /* security attrib */
+ 0, /* stack size */
+ fn, /* start address */
+ (void*)thr, /* parameters */
+ 0, /* creation flags */
+ (unsigned *)&junk); /* tid */
+#else /* compilers using CRTDLL.DLL only have _beginthread() */
+ th = _beginthread(fn, /* start address */
+ 0, /* stack size */
+ (void*)thr); /* parameters */
+ if (th == (unsigned long)-1)
+ th = 0;
+#endif
+ thr->self = (HANDLE)th;
+#else /* !USE_RTL_THREAD_API */
thr->self = CreateThread(NULL, 0, fn, (void*)thr, 0, &junk);
+#endif /* !USE_RTL_THREAD_API */
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"%p: OS thread = %p, id=%ld\n", thr, thr->self, junk));
MUTEX_UNLOCK(&thr->mutex);
#define THREAD_CREATE(t, f) Perl_thread_create(t, f)
#define THREAD_POST_CREATE(t) NOOP
-#define THREAD_RET_TYPE DWORD WINAPI
-#define THREAD_RET_CAST(p) ((DWORD)(p))
+
+/* XXX Docs mention that the RTL versions of thread creation routines
+ * should be used, but that advice only seems applicable when the RTL
+ * is not in a DLL. RTL DLLs in both Borland and VC seem to do all of
+ * the init/deinit required upon DLL_THREAD_ATTACH/DETACH. So we seem
+ * to be completely safe using straight Win32 API calls, rather than
+ * the much braindamaged RTL calls.
+ *
+ * _beginthread() in the RTLs call CloseHandle() just after the thread
+ * function returns, which means: 1) we have a race on our hands
+ * 2) it is impossible to implement join() semantics.
+ *
+ * IOW, do *NOT* turn on USE_RTL_THREAD_API! It is here
+ * for experimental purposes only. GSAR 98-01-02
+ */
+#ifdef USE_RTL_THREAD_API
+# include <process.h>
+# if defined(__BORLANDC__)
+ /* Borland RTL doesn't allow a return value from thread function! */
+# define THREAD_RET_TYPE void _USERENTRY
+# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
+# elif defined (_MSC_VER)
+# define THREAD_RET_TYPE unsigned __stdcall
+# define THREAD_RET_CAST(p) ((unsigned)(p))
+# else
+ /* CRTDLL.DLL doesn't allow a return value from thread function! */
+# define THREAD_RET_TYPE void __cdecl
+# define THREAD_RET_CAST(p) ((void)(thr->i.retv = (void *)(p)))
+# endif
+#else /* !USE_RTL_THREAD_API */
+# define THREAD_RET_TYPE DWORD WINAPI
+# define THREAD_RET_CAST(p) ((DWORD)(p))
+#endif /* !USE_RTL_THREAD_API */
typedef THREAD_RET_TYPE thread_func_t(void *);
#define ALLOC_THREAD_KEY Perl_alloc_thread_key()
#define SET_THREAD_SELF(thr) Perl_set_thread_self(thr)
+#if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER)
+#define JOIN(t, avp) \
+ STMT_START { \
+ if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
+ || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0)) \
+ croak("panic: JOIN"); \
+ *avp = (AV *)((t)->i.retv); \
+ } STMT_END
+#else /* !USE_RTL_THREAD_API || _MSC_VER */
#define JOIN(t, avp) \
STMT_START { \
if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \
|| (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0)) \
croak("panic: JOIN"); \
} STMT_END
+#endif /* !USE_RTL_THREAD_API || _MSC_VER */
#define YIELD Sleep(0)
projects / p5sagit/p5-mst-13.2.git / commitdiff