diff options
| -rw-r--r-- | README.win32 | 14 | ||||
| -rw-r--r-- | dosish.h | 16 | ||||
| -rw-r--r-- | lib/Cwd.pm | 4 | ||||
| -rw-r--r-- | lib/ExtUtils/Liblist.pm | 20 | ||||
| -rw-r--r-- | pod/perlfaq2.pod | 29 | ||||
| -rw-r--r-- | pp_sys.c | 6 | ||||
| -rw-r--r-- | util.c | 4 | ||||
| -rw-r--r-- | utils/perldoc.PL | 2 | ||||
| -rw-r--r-- | win32/config_H.bc | 8 | ||||
| -rw-r--r-- | win32/config_H.gc | 8 | ||||
| -rw-r--r-- | win32/config_H.vc | 8 | ||||
| -rw-r--r-- | win32/config_h.PL | 8 | ||||
| -rw-r--r-- | win32/perllib.c | 4 | ||||
| -rw-r--r-- | win32/win32.c | 240 | ||||
| -rw-r--r-- | win32/win32.h | 8 | ||||
| -rw-r--r-- | win32/win32iop.h | 4 | ||||
| -rw-r--r-- | win32/win32sck.c | 2 | ||||
| -rw-r--r-- | win32/win32thread.c | 29 | ||||
| -rw-r--r-- | win32/win32thread.h | 45 |
19 files changed, 312 insertions, 147 deletions
diff --git a/README.win32 b/README.win32 index 1b596eb1b6..fb42850597 100644 --- a/README.win32 +++ b/README.win32 @@ -503,9 +503,9 @@ The following functions are currently unavailable: C<fork()>, 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 * @@ -524,9 +524,9 @@ functionality of ioctlsocket() in the Winsock API). =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 * @@ -598,7 +598,7 @@ sundry hacks since then. Borland support was added in 5.004_01 (Gurusamy Sarathy). -Last updated: 23 December 1997 +Last updated: 3 January 1998 =cut @@ -45,12 +45,6 @@ #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 @@ -124,11 +118,15 @@ #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 */ diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 6952411ca2..048842b4ac 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -339,13 +339,13 @@ sub _os2_cwd { } 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; diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm index d821e83729..aebb057d58 100644 --- a/lib/ExtUtils/Liblist.pm +++ b/lib/ExtUtils/Liblist.pm @@ -231,7 +231,9 @@ sub _win32_ext { } # 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; @@ -522,14 +524,14 @@ Unix-OS/2 version in several respects: 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 * diff --git a/pod/perlfaq2.pod b/pod/perlfaq2.pod index 8a954da64e..bbc361a5ba 100644 --- a/pod/perlfaq2.pod +++ b/pod/perlfaq2.pod @@ -15,21 +15,22 @@ development team) is distributed only in source code form. You can 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? @@ -3097,7 +3097,7 @@ PP(pp_fork) PP(pp_wait) { -#if !defined(DOSISH) || defined(OS2) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) djSP; dTARGET; int childpid; int argflags; @@ -3113,7 +3113,7 @@ PP(pp_wait) PP(pp_waitpid) { -#if !defined(DOSISH) || defined(OS2) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) djSP; dTARGET; int childpid; int optype; @@ -3126,7 +3126,7 @@ PP(pp_waitpid) SETi(childpid); RETURN; #else - DIE(no_func, "Unsupported function wait"); + DIE(no_func, "Unsupported function waitpid"); #endif } @@ -2060,7 +2060,7 @@ my_pclose(FILE *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) I32 wait4pid(int pid, int *statusp, int flags) { @@ -2118,7 +2118,7 @@ wait4pid(int pid, int *statusp, int flags) } #endif } -#endif /* !DOSISH */ +#endif /* !DOSISH || OS2 || WIN32 */ void /*SUPPRESS 590*/ diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 0ac8e0a806..3acb461f98 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -153,7 +153,7 @@ sub minus_f_nocase { # 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; diff --git a/win32/config_H.bc b/win32/config_H.bc index 846d81d1e4..f587e019c8 100644 --- a/win32/config_H.bc +++ b/win32/config_H.bc @@ -1467,7 +1467,7 @@ * 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 @@ -1714,7 +1714,7 @@ * 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 @@ -1770,7 +1770,7 @@ * 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. @@ -1786,7 +1786,7 @@ * 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 diff --git a/win32/config_H.gc b/win32/config_H.gc index 35737e7ca0..3e56046835 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -1467,7 +1467,7 @@ * 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 @@ -1714,7 +1714,7 @@ * 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 @@ -1770,7 +1770,7 @@ * 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. @@ -1786,7 +1786,7 @@ * 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 diff --git a/win32/config_H.vc b/win32/config_H.vc index 72caabb9f9..42578bad8e 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -1467,7 +1467,7 @@ * 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 @@ -1714,7 +1714,7 @@ * 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 @@ -1770,7 +1770,7 @@ * 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. @@ -1786,7 +1786,7 @@ * 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 diff --git a/win32/config_h.PL b/win32/config_h.PL index 7f2869c945..8a1665a75a 100644 --- a/win32/config_h.PL +++ b/win32/config_h.PL @@ -37,19 +37,19 @@ while (<SH>) 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; } diff --git a/win32/perllib.c b/win32/perllib.c index b73a12e31b..4b57963a99 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -47,7 +47,7 @@ RunPerl(int argc, char **argv, char **env, void *iosubsystem) return (exitstatus); } -extern HANDLE PerlDllHandle; +extern HANDLE w32_perldll_handle; BOOL APIENTRY DllMain(HANDLE hModule, /* DLL module handle */ @@ -66,7 +66,7 @@ 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 diff --git a/win32/win32.c b/win32/win32.c index f75ec6c88d..b965629383 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -47,13 +47,21 @@ int _CRT_glob = 0; #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 @@ -75,30 +83,28 @@ char crypt_buffer[30]; # 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"); @@ -109,12 +115,12 @@ win32PerlLibPath(char *sfx,...) 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'; @@ -187,23 +193,24 @@ my_pclose(PerlIO *fp) } 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 @@ -214,57 +221,74 @@ GetShell(void) */ 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; @@ -272,13 +296,11 @@ do_spawn2(char *cmd, int exectype) 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); @@ -308,19 +330,22 @@ do_spawn2(char *cmd, int exectype) 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], @@ -339,11 +364,12 @@ do_spawn2(char *cmd, int exectype) 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 @@ -352,6 +378,12 @@ do_spawn(char *cmd) return do_spawn2(cmd, EXECF_SPAWN); } +int +do_spawn_nowait(char *cmd) +{ + return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); +} + bool do_exec(char *cmd) { @@ -683,7 +715,7 @@ win32_getenv(const char *name) #endif static long -FileTimeToClock(PFILETIME ft) +filetime_to_clock(PFILETIME ft) { __int64 qw = ft->dwHighDateTime; qw <<= 32; @@ -700,8 +732,8 @@ win32_times(struct tms *timebuf) 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; @@ -716,8 +748,53 @@ win32_times(struct tms *timebuf) 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) { @@ -1267,7 +1344,18 @@ win32_chdir(const char *dir) 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 diff --git a/win32/win32.h b/win32/win32.h index 1b1f64adac..8075ee7389 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -164,10 +164,11 @@ DllExport void Perl_init_os_extras(void); 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); @@ -217,6 +218,9 @@ struct thread_intern { # 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 */ diff --git a/win32/win32iop.h b/win32/win32iop.h index 5e03f952f2..e71bf3865e 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -112,9 +112,9 @@ DllExport char* win32_getenv(const char *name); 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); @@ -140,6 +140,7 @@ END_EXTERN_C #undef times #undef alarm #undef ioctl +#undef wait #ifdef __BORLANDC__ #undef ungetc @@ -239,6 +240,7 @@ END_EXTERN_C #define times win32_times #define alarm win32_alarm #define ioctl win32_ioctl +#define wait win32_wait #ifdef HAVE_DES_FCRYPT #undef crypt diff --git a/win32/win32sck.c b/win32/win32sck.c index a6e7a990b8..5ac2ef6c65 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -223,7 +223,7 @@ win32_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) return r; } -DllExport int +int win32_ioctlsocket(SOCKET s, long cmd, u_long *argp) { int r; diff --git a/win32/win32thread.c b/win32/win32thread.c index 3ea73c32a5..44f32e27fd 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -84,11 +84,40 @@ int 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); diff --git a/win32/win32thread.h b/win32/win32thread.h index 1a16c78b67..acb136c690 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -100,8 +100,39 @@ typedef HANDLE perl_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 *); @@ -131,12 +162,22 @@ END_EXTERN_C #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) |