/* WIN32.C
*
* (c) 1995 Microsoft Corporation. All rights reserved.
- * Developed by hip communications inc., http://info.hip.com/info/
+ * Developed by hip communications inc.
* Portions (c) 1993 Intergraph Corporation. All rights reserved.
*
* You may distribute under the terms of either the GNU General Public
#ifndef HWND_MESSAGE
# define HWND_MESSAGE ((HWND)-3)
#endif
+#ifndef WC_NO_BEST_FIT_CHARS
+# define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */
+#endif
#include <winnt.h>
+#include <commctrl.h>
+#include <tlhelp32.h>
#include <io.h>
#include <signal.h>
+#define SystemProcessesAndThreadsInformation 5
+
+/* Inline some definitions from the DDK */
+typedef struct {
+ USHORT Length;
+ USHORT MaximumLength;
+ PWSTR Buffer;
+} UNICODE_STRING;
+
+typedef struct {
+ ULONG NextEntryDelta;
+ ULONG ThreadCount;
+ ULONG Reserved1[6];
+ LARGE_INTEGER CreateTime;
+ LARGE_INTEGER UserTime;
+ LARGE_INTEGER KernelTime;
+ UNICODE_STRING ProcessName;
+ LONG BasePriority;
+ ULONG ProcessId;
+ ULONG InheritedFromProcessId;
+ /* Remainder of the structure depends on the Windows version,
+ * but we don't need those additional fields anyways... */
+} SYSTEM_PROCESSES;
+
/* #include "config.h" */
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
#include "EXTERN.h"
#include "perl.h"
-/* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
-#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
-# include <shellapi.h>
-#else
-EXTERN_C LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
-#endif
-
#define NO_XSLOCKS
#define PERL_NO_GET_CONTEXT
#include "XSUB.h"
-#include "Win32iop.h"
#include <fcntl.h>
#ifndef __GNUC__
/* assert.h conflicts with #define of assert in perl.h */
static BOOL has_shell_metachars(const char *ptr);
static long filetime_to_clock(PFILETIME ft);
static BOOL filetime_from_time(PFILETIME ft, time_t t);
-static char * get_emd_part(SV **leading, char *trailing, ...);
+static char * get_emd_part(SV **leading, STRLEN *const len,
+ char *trailing, ...);
static void remove_dead_process(long deceased);
static long find_pid(int pid);
static char * qualified_path(const char *cmd);
static char * win32_get_xlib(const char *pl, const char *xlib,
- const char *libname);
+ const char *libname, STRLEN *const len);
+static LRESULT win32_process_message(HWND hwnd, UINT msg,
+ WPARAM wParam, LPARAM lParam);
#ifdef USE_ITHREADS
static void remove_dead_pseudo_process(long child);
static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
+static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
+static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
+static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
+static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
+
#ifdef __BORLANDC__
/* Silence STDERR grumblings from Borland's math library. */
DllExport int
}
#endif
-#if _MSC_VER >= 1400
+/* VS2005 (MSC version 14) provides a mechanism to set an invalid
+ * parameter handler. This functionality is not available in the
+ * 64-bit compiler from the Platform SDK, which unfortunately also
+ * believes itself to be MSC version 14.
+ *
+ * There is no #define related to _set_invalid_parameter_handler(),
+ * but we can check for one of the constants defined for
+ * _set_abort_behavior(), which was introduced into stdlib.h at
+ * the same time.
+ */
+
+#if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
+# define SET_INVALID_PARAMETER_HANDLER
+#endif
+
+#ifdef SET_INVALID_PARAMETER_HANDLER
void my_invalid_parameter_handler(const wchar_t* expression,
const wchar_t* function,
const wchar_t* file,
return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
}
+int
+IsWin2000(void)
+{
+ return (g_osver.dwMajorVersion > 4);
+}
+
EXTERN_C void
set_w32_module_name(void)
{
+ /* this function may be called at DLL_PROCESS_ATTACH time */
char* ptr;
- GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
- ? GetModuleHandle(NULL)
- : w32_perldll_handle),
- w32_module_name, sizeof(w32_module_name));
+ HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
+ ? GetModuleHandle(NULL)
+ : w32_perldll_handle);
+
+ OSVERSIONINFO osver; /* g_osver may not yet be initialized */
+ osver.dwOSVersionInfoSize = sizeof(osver);
+ GetVersionEx(&osver);
+
+ if (osver.dwMajorVersion > 4) {
+ WCHAR modulename[MAX_PATH];
+ WCHAR fullname[MAX_PATH];
+ char *ansi;
- /* remove \\?\ prefix */
- if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
- memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
+ DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
+ (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
+ GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
- /* try to get full path to binary (which may be mangled when perl is
- * run from a 16-bit app) */
- /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
- (void)win32_longpath(w32_module_name);
- /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
+ GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
+
+ /* Make sure we get an absolute pathname in case the module was loaded
+ * explicitly by LoadLibrary() with a relative path. */
+ GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
+
+ /* Make sure we start with the long path name of the module because we
+ * later scan for pathname components to match "5.xx" to locate
+ * compatible sitelib directories, and the short pathname might mangle
+ * this path segment (e.g. by removing the dot on NTFS to something
+ * like "5xx~1.yy") */
+ if (pfnGetLongPathNameW)
+ pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
+
+ /* remove \\?\ prefix */
+ if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
+ memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
+
+ ansi = win32_ansipath(fullname);
+ my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
+ win32_free(ansi);
+ }
+ else {
+ GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
+
+ /* remove \\?\ prefix */
+ if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
+ memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
+
+ /* try to get full path to binary (which may be mangled when perl is
+ * run from a 16-bit app) */
+ /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
+ win32_longpath(w32_module_name);
+ /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
+ }
/* normalize to forward slashes */
ptr = w32_module_name;
HKEY handle;
DWORD type;
const char *subkey = "Software\\Perl";
- char *str = Nullch;
+ char *str = NULL;
long retval;
retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
static char *
-get_emd_part(SV **prev_pathp, char *trailing_path, ...)
+get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
{
char base[10];
va_list ap;
else if (SvPVX(*prev_pathp))
sv_catpvn(*prev_pathp, ";", 1);
sv_catpv(*prev_pathp, mod_name);
+ if(len)
+ *len = SvCUR(*prev_pathp);
return SvPVX(*prev_pathp);
}
- return Nullch;
+ return NULL;
}
char *
-win32_get_privlib(const char *pl)
+win32_get_privlib(const char *pl, STRLEN *const len)
{
dTHX;
char *stdlib = "lib";
char buffer[MAX_PATH+1];
- SV *sv = Nullsv;
+ SV *sv = NULL;
/* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
sprintf(buffer, "%s-%s", stdlib, pl);
(void)get_regstr(stdlib, &sv);
/* $stdlib .= ";$EMD/../../lib" */
- return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
+ return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
}
static char *
-win32_get_xlib(const char *pl, const char *xlib, const char *libname)
+win32_get_xlib(const char *pl, const char *xlib, const char *libname,
+ STRLEN *const len)
{
dTHX;
char regstr[40];
char pathstr[MAX_PATH+1];
- SV *sv1 = Nullsv;
- SV *sv2 = Nullsv;
+ SV *sv1 = NULL;
+ SV *sv2 = NULL;
/* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
sprintf(regstr, "%s-%s", xlib, pl);
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
sprintf(pathstr, "%s/%s/lib", libname, pl);
- (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
+ (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
/* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
(void)get_regstr(xlib, &sv2);
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
sprintf(pathstr, "%s/lib", libname);
- (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
+ (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
if (!sv1 && !sv2)
- return Nullch;
- if (!sv1)
- return SvPVX(sv2);
- if (!sv2)
- return SvPVX(sv1);
-
- sv_catpvn(sv1, ";", 1);
- sv_catsv(sv1, sv2);
+ return NULL;
+ if (!sv1) {
+ sv1 = sv2;
+ } else if (sv2) {
+ sv_catpvn(sv1, ";", 1);
+ sv_catsv(sv1, sv2);
+ }
+ if (len)
+ *len = SvCUR(sv1);
return SvPVX(sv1);
}
char *
-win32_get_sitelib(const char *pl)
+win32_get_sitelib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "sitelib", "site");
+ return win32_get_xlib(pl, "sitelib", "site", len);
}
#ifndef PERL_VENDORLIB_NAME
#endif
char *
-win32_get_vendorlib(const char *pl)
+win32_get_vendorlib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
+ return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
}
static BOOL
static long
tokenize(const char *str, char **dest, char ***destv)
{
- char *retstart = Nullch;
+ char *retstart = NULL;
char **retvstart = 0;
int items = -1;
if (str) {
++items;
ret++;
}
- retvstart[items] = Nullch;
+ retvstart[items] = NULL;
*ret++ = '\0';
*ret = '\0';
}
int flag = P_WAIT;
int index = 0;
+ PERL_ARGS_ASSERT_DO_ASPAWN;
+
if (sp <= mark)
return -1;
}
if (flag == P_NOWAIT) {
- if (IsWin95())
- PL_statusvalue = -1; /* >16bits hint for pp_system() */
+ PL_statusvalue = -1; /* >16bits hint for pp_system() */
}
else {
if (status < 0) {
if (*s)
*s++ = '\0';
}
- *a = Nullch;
+ *a = NULL;
if (argv[0]) {
switch (exectype) {
case EXECF_SPAWN:
while (++i < w32_perlshell_items)
argv[i] = w32_perlshell_vec[i];
argv[i++] = (char *)cmd;
- argv[i] = Nullch;
+ argv[i] = NULL;
switch (exectype) {
case EXECF_SPAWN:
status = win32_spawnvp(P_WAIT, argv[0],
Safefree(argv);
}
if (exectype == EXECF_SPAWN_NOWAIT) {
- if (IsWin95())
- PL_statusvalue = -1; /* >16bits hint for pp_system() */
+ PL_statusvalue = -1; /* >16bits hint for pp_system() */
}
else {
if (status < 0) {
int
Perl_do_spawn(pTHX_ char *cmd)
{
+ PERL_ARGS_ASSERT_DO_SPAWN;
+
return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
}
int
Perl_do_spawn_nowait(pTHX_ char *cmd)
{
+ PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
+
return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
}
bool
Perl_do_exec(pTHX_ const char *cmd)
{
+ PERL_ARGS_ASSERT_DO_EXEC;
+
do_spawn2(aTHX_ cmd, EXECF_EXEC);
return FALSE;
}
long len;
long idx;
char scanname[MAX_PATH+3];
- Stat_t sbuf;
WIN32_FIND_DATAA aFindData;
+ WIN32_FIND_DATAW wFindData;
+ bool using_wide;
+ char buffer[MAX_PATH*2];
+ char *ptr;
len = strlen(filename);
- if (len > MAX_PATH)
+ if (len == 0) {
+ errno = ENOENT;
return NULL;
-
- /* check to see if filename is a directory */
- if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
+ }
+ if (len > MAX_PATH) {
+ errno = ENAMETOOLONG;
return NULL;
+ }
+
+#if 0 /* This call to stat is unnecessary. The FindFirstFile() below will
+ * fail with ERROR_PATH_NOT_FOUND if filename is not a directory. */
+ {
+ /* check to see if filename is a directory */
+ Stat_t sbuf;
+ if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
+ return NULL;
+ }
+#endif
/* Get us a DIR structure */
Newxz(dirp, 1, DIR);
scanname[len] = '\0';
/* do the FindFirstFile call */
- dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
+ if (IsWin2000()) {
+ WCHAR wscanname[sizeof(scanname)];
+ MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
+ dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
+ using_wide = TRUE;
+ }
+ else {
+ dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
+ }
if (dirp->handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
/* FindFirstFile() fails on empty drives! */
return NULL;
}
+ if (using_wide) {
+ BOOL use_default = FALSE;
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ wFindData.cFileName, -1,
+ buffer, sizeof(buffer), NULL, &use_default);
+ if (use_default && *wFindData.cAlternateFileName) {
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ wFindData.cAlternateFileName, -1,
+ buffer, sizeof(buffer), NULL, NULL);
+ }
+ ptr = buffer;
+ }
+ else {
+ ptr = aFindData.cFileName;
+ }
/* now allocate the first part of the string table for
* the filenames that we find.
*/
- idx = strlen(aFindData.cFileName)+1;
+ idx = strlen(ptr)+1;
if (idx < 256)
- dirp->size = 128;
+ dirp->size = 256;
else
dirp->size = idx;
Newx(dirp->start, dirp->size, char);
- strcpy(dirp->start, aFindData.cFileName);
+ strcpy(dirp->start, ptr);
dirp->nfiles++;
dirp->end = dirp->curr = dirp->start;
dirp->end += idx;
dirp->curr += len + 1;
if (dirp->curr >= dirp->end) {
dTHX;
- BOOL res;
- WIN32_FIND_DATAA aFindData;
+ BOOL res;
+ WIN32_FIND_DATAA aFindData;
+ char buffer[MAX_PATH*2];
+ char *ptr;
+ if (dirp->handle == INVALID_HANDLE_VALUE) {
+ res = 0;
+ }
/* finding the next file that matches the wildcard
* (which should be all of them in this directory!).
*/
- res = FindNextFileA(dirp->handle, &aFindData);
+ else if (IsWin2000()) {
+ WIN32_FIND_DATAW wFindData;
+ res = FindNextFileW(dirp->handle, &wFindData);
+ if (res) {
+ BOOL use_default = FALSE;
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ wFindData.cFileName, -1,
+ buffer, sizeof(buffer), NULL, &use_default);
+ if (use_default && *wFindData.cAlternateFileName) {
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
+ wFindData.cAlternateFileName, -1,
+ buffer, sizeof(buffer), NULL, NULL);
+ }
+ ptr = buffer;
+ }
+ }
+ else {
+ res = FindNextFileA(dirp->handle, &aFindData);
+ ptr = aFindData.cFileName;
+ }
if (res) {
long endpos = dirp->end - dirp->start;
- long newsize = endpos + strlen(aFindData.cFileName) + 1;
+ long newsize = endpos + strlen(ptr) + 1;
/* bump the string table size by enough for the
* new name and its null terminator */
while (newsize > dirp->size) {
Renew(dirp->start, dirp->size, char);
dirp->curr = dirp->start + curpos;
}
- strcpy(dirp->start + endpos, aFindData.cFileName);
+ strcpy(dirp->start + endpos, ptr);
dirp->end = dirp->start + newsize;
dirp->nfiles++;
}
- else
+ else {
dirp->curr = NULL;
+ if (dirp->handle != INVALID_HANDLE_VALUE) {
+ FindClose(dirp->handle);
+ dirp->handle = INVALID_HANDLE_VALUE;
+ }
+ }
}
return &(dirp->dirstr);
}
DllExport long
win32_telldir(DIR *dirp)
{
- return (dirp->curr - dirp->start);
+ return dirp->curr ? (dirp->curr - dirp->start) : -1;
}
DllExport void
win32_seekdir(DIR *dirp, long loc)
{
- dirp->curr = dirp->start + loc;
+ dirp->curr = loc == -1 ? NULL : dirp->start + loc;
}
/* Rewinddir resets the string pointer to the start */
return 1;
}
+/* duplicate a open DIR* for interpreter cloning */
+DllExport DIR *
+win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
+{
+ dVAR;
+ PerlInterpreter *const from = param->proto_perl;
+ PerlInterpreter *const to = PERL_GET_THX;
+
+ long pos;
+ DIR *dup;
+
+ /* switch back to original interpreter because win32_readdir()
+ * might Renew(dirp->start).
+ */
+ if (from != to) {
+ PERL_SET_THX(from);
+ }
+
+ /* mark current position; read all remaining entries into the
+ * cache, and then restore to current position.
+ */
+ pos = win32_telldir(dirp);
+ while (win32_readdir(dirp)) {
+ /* read all entries into cache */
+ }
+ win32_seekdir(dirp, pos);
+
+ /* switch back to new interpreter to allocate new DIR structure */
+ if (from != to) {
+ PERL_SET_THX(to);
+ }
+
+ Newx(dup, 1, DIR);
+ memcpy(dup, dirp, sizeof(DIR));
+
+ Newx(dup->start, dirp->size, char);
+ memcpy(dup->start, dirp->start, dirp->size);
+
+ dup->end = dup->start + (dirp->end - dirp->start);
+ if (dirp->curr)
+ dup->curr = dup->start + (dirp->curr - dirp->start);
+
+ return dup;
+}
/*
* various stubs
}
#endif
+static int
+terminate_process(DWORD pid, HANDLE process_handle, int sig)
+{
+ switch(sig) {
+ case 0:
+ /* "Does process exist?" use of kill */
+ return 1;
+ case 2:
+ if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
+ return 1;
+ break;
+ case SIGBREAK:
+ case SIGTERM:
+ if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
+ return 1;
+ break;
+ default: /* For now be backwards compatible with perl 5.6 */
+ case 9:
+ /* Note that we will only be able to kill processes owned by the
+ * current process owner, even when we are running as an administrator.
+ * To kill processes of other owners we would need to set the
+ * 'SeDebugPrivilege' privilege before obtaining the process handle.
+ */
+ if (TerminateProcess(process_handle, sig))
+ return 1;
+ break;
+ }
+ return 0;
+}
+
+/* Traverse process tree using ToolHelp functions */
+static int
+kill_process_tree_toolhelp(DWORD pid, int sig)
+{
+ HANDLE process_handle;
+ HANDLE snapshot_handle;
+ int killed = 0;
+
+ process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+ if (process_handle == NULL)
+ return 0;
+
+ killed += terminate_process(pid, process_handle, sig);
+
+ snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
+ if (snapshot_handle != INVALID_HANDLE_VALUE) {
+ PROCESSENTRY32 entry;
+
+ entry.dwSize = sizeof(entry);
+ if (pfnProcess32First(snapshot_handle, &entry)) {
+ do {
+ if (entry.th32ParentProcessID == pid)
+ killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
+ entry.dwSize = sizeof(entry);
+ }
+ while (pfnProcess32Next(snapshot_handle, &entry));
+ }
+ CloseHandle(snapshot_handle);
+ }
+ CloseHandle(process_handle);
+ return killed;
+}
+
+/* Traverse process tree using undocumented system information structures.
+ * This is only necessary on Windows NT, which lacks the ToolHelp functions.
+ */
+static int
+kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
+{
+ HANDLE process_handle;
+ SYSTEM_PROCESSES *p = process_info;
+ int killed = 0;
+
+ process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+ if (process_handle == NULL)
+ return 0;
+
+ killed += terminate_process(pid, process_handle, sig);
+
+ while (1) {
+ if (p->InheritedFromProcessId == (DWORD)pid)
+ killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
+
+ if (p->NextEntryDelta == 0)
+ break;
+
+ p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
+ }
+
+ CloseHandle(process_handle);
+ return killed;
+}
+
+int
+killpg(int pid, int sig)
+{
+ /* Use "documented" method whenever available */
+ if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
+ return kill_process_tree_toolhelp((DWORD)pid, sig);
+ }
+
+ /* Fall back to undocumented Windows internals on Windows NT */
+ if (pfnZwQuerySystemInformation) {
+ dTHX;
+ char *buffer;
+ DWORD size = 0;
+
+ pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
+ Newx(buffer, size, char);
+
+ if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
+ int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
+ Safefree(buffer);
+ return killed;
+ }
+ }
+ return 0;
+}
+
+static int
+my_kill(int pid, int sig)
+{
+ int retval = 0;
+ HANDLE process_handle;
+
+ if (sig < 0)
+ return killpg(pid, -sig);
+
+ process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
+ /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
+ if (process_handle != NULL) {
+ retval = terminate_process(pid, process_handle, sig);
+ CloseHandle(process_handle);
+ }
+ return retval;
+}
+
DllExport int
win32_kill(int pid, int sig)
{
dTHX;
- HANDLE hProcess;
long child;
- int retval;
#ifdef USE_ITHREADS
if (pid < 0) {
/* it is a pseudo-forked child */
child = find_pseudo_pid(-pid);
if (child >= 0) {
HWND hwnd = w32_pseudo_child_message_hwnds[child];
- hProcess = w32_pseudo_child_handles[child];
+ HANDLE hProcess = w32_pseudo_child_handles[child];
switch (sig) {
case 0:
/* "Does process exist?" use of kill */
/* Yield and wait for the other thread to send us its message_hwnd */
Sleep(0);
win32_async_check(aTHX);
+ hwnd = w32_pseudo_child_message_hwnds[child];
++count;
}
if (hwnd != INVALID_HANDLE_VALUE) {
{
child = find_pid(pid);
if (child >= 0) {
- hProcess = w32_child_handles[child];
- switch(sig) {
- case 0:
- /* "Does process exist?" use of kill */
- return 0;
- case 2:
- if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
- return 0;
- break;
- case SIGBREAK:
- case SIGTERM:
- if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
- return 0;
- break;
- default: /* For now be backwards compatible with perl5.6 */
- case 9:
- if (TerminateProcess(hProcess, sig)) {
- remove_dead_process(child);
- return 0;
- }
- break;
+ if (my_kill(pid, sig)) {
+ DWORD exitcode = 0;
+ if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
+ exitcode != STILL_ACTIVE)
+ {
+ remove_dead_process(child);
+ }
+ return 0;
}
}
else {
alien_process:
- retval = -1;
- hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
- (IsWin95() ? -pid : pid));
- if (hProcess) {
- switch(sig) {
- case 0:
- /* "Does process exist?" use of kill */
- retval = 0;
- break;
- case 2:
- if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
- retval = 0;
- break;
- case SIGBREAK:
- case SIGTERM:
- if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
- retval = 0;
- break;
- default: /* For now be backwards compatible with perl5.6 */
- case 9:
- if (TerminateProcess(hProcess, sig))
- retval = 0;
- break;
- }
- }
- CloseHandle(hProcess);
- if (retval == 0)
+ if (my_kill((IsWin95() ? -pid : pid), sig))
return 0;
}
}
errno = ENOTDIR;
return -1;
}
+ if (S_ISDIR(sbuf->st_mode)) {
+ /* Ensure the "write" bit is switched off in the mode for
+ * directories with the read-only attribute set. Borland (at least)
+ * switches it on for directories, which is technically correct
+ * (directories are indeed always writable unless denied by DACLs),
+ * but we want stat() and -w to reflect the state of the read-only
+ * attribute for symmetry with chmod(). */
+ DWORD r = GetFileAttributesA(path);
+ if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
+ sbuf->st_mode &= ~S_IWRITE;
+ }
+ }
#ifdef __BORLANDC__
- if (S_ISDIR(sbuf->st_mode))
- sbuf->st_mode |= S_IWRITE | S_IEXEC;
+ if (S_ISDIR(sbuf->st_mode)) {
+ sbuf->st_mode |= S_IEXEC;
+ }
else if (S_ISREG(sbuf->st_mode)) {
int perms;
if (l >= 4 && path[l-4] == '.') {
char *start = path;
char sep;
if (!path)
- return Nullch;
+ return NULL;
/* drive prefix */
if (isALPHA(path[0]) && path[1] == ':') {
else {
FindClose(fhand);
errno = ERANGE;
- return Nullch;
+ return NULL;
}
}
else {
/* failed a step, just return without side effects */
/*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
errno = EINVAL;
- return Nullch;
+ return NULL;
}
}
strcpy(path,tmpbuf);
return path;
}
+static void
+out_of_memory(void)
+{
+ if (PL_curinterp) {
+ dTHX;
+ /* Can't use PerlIO to write as it allocates memory */
+ PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ PL_no_mem, strlen(PL_no_mem));
+ my_exit(1);
+ }
+ exit(1);
+}
+
+/* The win32_ansipath() function takes a Unicode filename and converts it
+ * into the current Windows codepage. If some characters cannot be mapped,
+ * then it will convert the short name instead.
+ *
+ * The buffer to the ansi pathname must be freed with win32_free() when it
+ * it no longer needed.
+ *
+ * The argument to win32_ansipath() must exist before this function is
+ * called; otherwise there is no way to determine the short path name.
+ *
+ * Ideas for future refinement:
+ * - Only convert those segments of the path that are not in the current
+ * codepage, but leave the other segments in their long form.
+ * - If the resulting name is longer than MAX_PATH, start converting
+ * additional path segments into short names until the full name
+ * is shorter than MAX_PATH. Shorten the filename part last!
+ */
+DllExport char *
+win32_ansipath(const WCHAR *widename)
+{
+ char *name;
+ BOOL use_default = FALSE;
+ size_t widelen = wcslen(widename)+1;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ NULL, 0, NULL, NULL);
+ name = win32_malloc(len);
+ if (!name)
+ out_of_memory();
+
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
+ name, len, NULL, &use_default);
+ if (use_default) {
+ DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
+ if (shortlen) {
+ WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
+ if (!shortname)
+ out_of_memory();
+ shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
+
+ len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
+ NULL, 0, NULL, NULL);
+ name = win32_realloc(name, len);
+ if (!name)
+ out_of_memory();
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
+ name, len, NULL, NULL);
+ win32_free(shortname);
+ }
+ }
+ return name;
+}
+
DllExport char *
win32_getenv(const char *name)
{
dTHX;
DWORD needlen;
- SV *curitem = Nullsv;
+ SV *curitem = NULL;
needlen = GetEnvironmentVariableA(name,NULL,0);
if (needlen != 0) {
if (curitem && SvCUR(curitem))
return SvPVX(curitem);
- return Nullch;
+ return NULL;
}
DllExport int
* Has these advantages over putenv() & co.:
* * enables us to store a truly empty value in the
* environment (like in UNIX).
- * * we don't have to deal with RTL globals, bugs and leaks.
+ * * we don't have to deal with RTL globals, bugs and leaks
+ * (specifically, see http://support.microsoft.com/kb/235601).
* * Much faster.
- * Why you may want to enable USE_WIN32_RTL_ENV:
+ * Why you may want to use the RTL environment handling
+ * (previously enabled by USE_WIN32_RTL_ENV):
* * environ[] and RTL functions will not reflect changes,
* which might be an issue if extensions want to access
* the env. via RTL. This cuts both ways, since RTL will
GetSystemInfo(&info);
#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
- || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
+ || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
procarch = info.u.s.wProcessorArchitecture;
#else
procarch = info.wProcessorArchitecture;
MSG msg;
HWND hwnd = w32_message_hwnd;
+ /* Reset w32_poll_count before doing anything else, incase we dispatch
+ * messages that end up calling back into perl */
w32_poll_count = 0;
- if (hwnd == INVALID_HANDLE_VALUE) {
- /* Call PeekMessage() to mark all pending messages in the queue as "old".
- * This is necessary when we are being called by win32_msgwait() to
- * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
- * message over and over. An example how this can happen is when
- * Perl is calling win32_waitpid() inside a GUI application and the GUI
- * is generating messages before the process terminated.
- */
- PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
- if (PL_sig_pending)
- despatch_signals();
- return 1;
- }
-
- /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
- * and ignores window messages - should co-exist better with windows apps e.g. Tk
- */
- if (hwnd == NULL)
- hwnd = (HWND)-1;
-
- while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
- PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
- {
- switch (msg.message) {
-#ifdef USE_ITHREADS
- case WM_USER_MESSAGE: {
- int child = find_pseudo_pid(msg.wParam);
- if (child >= 0)
- w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
- break;
- }
-#endif
-
- case WM_USER_KILL: {
- /* We use WM_USER to fake kill() with other signals */
- int sig = msg.wParam;
- if (do_raise(aTHX_ sig))
- sig_terminate(aTHX_ sig);
- break;
- }
-
- case WM_TIMER: {
- /* alarm() is a one-shot but SetTimer() repeats so kill it */
- if (w32_timerid && w32_timerid==msg.wParam) {
- KillTimer(w32_message_hwnd, w32_timerid);
- w32_timerid=0;
+ if (hwnd != INVALID_HANDLE_VALUE) {
+ /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
+ * and ignores window messages - should co-exist better with windows apps e.g. Tk
+ */
+ if (hwnd == NULL)
+ hwnd = (HWND)-1;
+
+ while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
+ PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
+ {
+ /* re-post a WM_QUIT message (we'll mark it as read later) */
+ if(msg.message == WM_QUIT) {
+ PostQuitMessage((int)msg.wParam);
+ break;
+ }
- /* Now fake a call to signal handler */
- if (do_raise(aTHX_ 14))
- sig_terminate(aTHX_ 14);
+ if(!CallMsgFilter(&msg, MSGF_USER))
+ {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
}
- break;
- }
- } /* switch */
+ }
}
+ /* Call PeekMessage() to mark all pending messages in the queue as "old".
+ * This is necessary when we are being called by win32_msgwait() to
+ * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
+ * message over and over. An example how this can happen is when
+ * Perl is calling win32_waitpid() inside a GUI application and the GUI
+ * is generating messages before the process terminated.
+ */
+ PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
+
/* Above or other stuff may have set a signal flag */
- if (PL_sig_pending) {
- despatch_signals();
- }
+ if (PL_sig_pending)
+ despatch_signals();
+
return 1;
}
timeout += ticks;
}
while (1) {
- DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
+ DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
if (resultp)
*resultp = result;
if (result == WAIT_TIMEOUT) {
return des_fcrypt(txt, salt, w32_crypt_buffer);
#else
Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
- return Nullch;
+ return NULL;
#endif
}
/* simulate flock by locking a range on the file */
-#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
#define LK_LEN 0xffff0000
DllExport int
return -1;
}
fh = (HANDLE)_get_osfhandle(fd);
+ if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
+ return -1;
+
memset(&o, 0, sizeof(o));
switch(oper) {
case LOCK_SH: /* shared lock */
- LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
+ if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
+ i = 0;
break;
case LOCK_EX: /* exclusive lock */
- LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
+ if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
+ i = 0;
break;
case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
- LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
+ if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
+ i = 0;
break;
case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
- LK_ERR(LockFileEx(fh,
- LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
- 0, LK_LEN, 0, &o),i);
+ if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
+ 0, LK_LEN, 0, &o))
+ i = 0;
break;
case LOCK_UN: /* unlock lock */
- LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
+ if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
+ i = 0;
break;
default: /* unknown */
errno = EINVAL;
- break;
+ return -1;
+ }
+ if (i == -1) {
+ if (GetLastError() == ERROR_LOCK_VIOLATION)
+ errno = WSAEWOULDBLOCK;
+ else
+ errno = EINVAL;
}
return i;
}
-#undef LK_ERR
#undef LK_LEN
/*
}
DllExport FILE *
-win32_stdout()
+win32_stdout(void)
{
return (stdout);
}
#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
extern int sys_nerr;
#endif
- DWORD source = 0;
if (e < 0 || e > sys_nerr) {
dTHX;
if (e < 0)
e = GetLastError();
- if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
- w32_strerror_buffer,
- sizeof(w32_strerror_buffer), NULL) == 0)
+ if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
+ w32_strerror_buffer, sizeof(w32_strerror_buffer),
+ NULL) == 0)
+ {
strcpy(w32_strerror_buffer, "Unknown Error");
-
+ }
return w32_strerror_buffer;
}
+#undef strerror
return strerror(e);
+#define strerror win32_strerror
}
DllExport void
if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
#if defined(WIN64) || defined(USE_LARGE_FILES)
- sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
+ sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
#endif
sbufptr->st_mode &= 0xFE00;
if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
lock_held = 0;
}
- LOCK_FDPID_MUTEX;
sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
- UNLOCK_FDPID_MUTEX;
/* set process id so that it can be returned by perl's open() */
PL_forkprocess = childpid;
int childpid, status;
SV *sv;
- LOCK_FDPID_MUTEX;
sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
if (SvIOK(sv))
childpid = 0;
if (!childpid) {
- UNLOCK_FDPID_MUTEX;
errno = EBADF;
return -1;
}
fclose(pf);
#endif
SvIVX(sv) = 0;
- UNLOCK_FDPID_MUTEX;
if (win32_waitpid(childpid, &status, 0) == -1)
return -1;
int retval = 0;
char szTmpName[MAX_PATH+1];
char dname[MAX_PATH+1];
- char *endname = Nullch;
+ char *endname = NULL;
STRLEN tmplen = 0;
DWORD from_attr, to_attr;
retval = rename(szOldName, szNewName);
/* if we created a temporary file before ... */
- if (endname != Nullch) {
+ if (endname != NULL) {
/* ...and rename succeeded, delete temporary file/directory */
if (retval == 0)
DeleteFile(szTmpName);
}
DllExport int
+win32_isatty(int fd)
+{
+ /* The Microsoft isatty() function returns true for *all*
+ * character mode devices, including "nul". Our implementation
+ * should only return true if the handle has a console buffer.
+ */
+ DWORD mode;
+ HANDLE fh = (HANDLE)_get_osfhandle(fd);
+ if (fh == (HANDLE)-1) {
+ /* errno is already set to EBADF */
+ return 0;
+ }
+
+ if (GetConsoleMode(fh, &mode))
+ return 1;
+
+ errno = ENOTTY;
+ return 0;
+}
+
+DllExport int
win32_dup(int fd)
{
return dup(fd);
int has_slash = 0;
if (!cmd)
- return Nullch;
+ return NULL;
fullcmd = (char*)cmd;
while (*fullcmd) {
if (*fullcmd == '/' || *fullcmd == '\\')
}
Safefree(fullcmd);
- return Nullch;
+ return NULL;
}
/* The following are just place holders.
PROCESS_INFORMATION ProcessInformation;
DWORD create = 0;
char *cmd;
- char *fullcmd = Nullch;
+ char *fullcmd = NULL;
char *cname = (char *)cmdname;
STRLEN clen = 0;
return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
}
-static void
-forward(pTHX_ const char *function)
+XS(w32_SetChildShowWindow)
{
dXSARGS;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), NULL);
- PUSHMARK(SP-items);
- call_pv(function, GIMME_V);
-}
-
-#define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
-FORWARD(GetCwd)
-FORWARD(SetCwd)
-FORWARD(GetNextAvailDrive)
-FORWARD(GetLastError)
-FORWARD(SetLastError)
-FORWARD(LoginName)
-FORWARD(NodeName)
-FORWARD(DomainName)
-FORWARD(FsType)
-FORWARD(GetOSVersion)
-FORWARD(IsWinNT)
-FORWARD(IsWin95)
-FORWARD(FormatMessage)
-FORWARD(Spawn)
-FORWARD(GetTickCount)
-FORWARD(GetShortPathName)
-FORWARD(GetFullPathName)
-FORWARD(GetLongPathName)
-FORWARD(CopyFile)
-FORWARD(Sleep)
-FORWARD(SetChildShowWindow)
-#undef FORWARD
+ BOOL use_showwindow = w32_use_showwindow;
+ /* use "unsigned short" because Perl has redefined "WORD" */
+ unsigned short showwindow = w32_showwindow;
+
+ if (items > 1)
+ Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
+
+ if (items == 0 || !SvOK(ST(0)))
+ w32_use_showwindow = FALSE;
+ else {
+ w32_use_showwindow = TRUE;
+ w32_showwindow = (unsigned short)SvIV(ST(0));
+ }
+
+ EXTEND(SP, 1);
+ if (use_showwindow)
+ ST(0) = sv_2mortal(newSViv(showwindow));
+ else
+ ST(0) = &PL_sv_undef;
+ XSRETURN(1);
+}
void
Perl_init_os_extras(void)
{
dTHX;
char *file = __FILE__;
- dXSUB_SYS;
-
- /* 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::SetLastError", w32_SetLastError, 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);
- newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
- newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
- newXS("Win32::CopyFile", w32_CopyFile, file);
- newXS("Win32::Sleep", w32_Sleep, file);
+
+ /* Initialize Win32CORE if it has been statically linked. */
+ void (*pfn_init)(pTHX);
+#if defined(__BORLANDC__)
+ /* makedef.pl seems to have given up on fixing this issue in the .def file */
+ pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
+#else
+ pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
+#endif
+ if (pfn_init)
+ pfn_init(aTHX);
+
newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
}
}
-#if _MSC_VER >= 1400
+#ifdef SET_INVALID_PARAMETER_HANDLER
# include <crtdbg.h>
#endif
+static void
+ansify_path(void)
+{
+ size_t len;
+ char *ansi_path;
+ WCHAR *wide_path;
+ WCHAR *wide_dir;
+
+ /* win32_ansipath() requires Windows 2000 or later */
+ if (!IsWin2000())
+ return;
+
+ /* fetch Unicode version of PATH */
+ len = 2000;
+ wide_path = win32_malloc(len*sizeof(WCHAR));
+ while (wide_path) {
+ size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
+ if (newlen < len)
+ break;
+ len = newlen;
+ wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
+ }
+ if (!wide_path)
+ return;
+
+ /* convert to ANSI pathnames */
+ wide_dir = wide_path;
+ ansi_path = NULL;
+ while (wide_dir) {
+ WCHAR *sep = wcschr(wide_dir, ';');
+ char *ansi_dir;
+ size_t ansi_len;
+ size_t wide_len;
+
+ if (sep)
+ *sep++ = '\0';
+
+ /* remove quotes around pathname */
+ if (*wide_dir == '"')
+ ++wide_dir;
+ wide_len = wcslen(wide_dir);
+ if (wide_len && wide_dir[wide_len-1] == '"')
+ wide_dir[wide_len-1] = '\0';
+
+ /* append ansi_dir to ansi_path */
+ ansi_dir = win32_ansipath(wide_dir);
+ ansi_len = strlen(ansi_dir);
+ if (ansi_path) {
+ size_t newlen = len + 1 + ansi_len;
+ ansi_path = win32_realloc(ansi_path, newlen+1);
+ if (!ansi_path)
+ break;
+ ansi_path[len] = ';';
+ memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
+ len = newlen;
+ }
+ else {
+ len = ansi_len;
+ ansi_path = win32_malloc(5+len+1);
+ if (!ansi_path)
+ break;
+ memcpy(ansi_path, "PATH=", 5);
+ memcpy(ansi_path+5, ansi_dir, len+1);
+ len += 5;
+ }
+ win32_free(ansi_dir);
+ wide_dir = sep;
+ }
+
+ if (ansi_path) {
+ /* Update C RTL environ array. This will only have full effect if
+ * perl_parse() is later called with `environ` as the `env` argument.
+ * Otherwise S_init_postdump_symbols() will overwrite PATH again.
+ *
+ * We do have to ansify() the PATH before Perl has been fully
+ * initialized because S_find_script() uses the PATH when perl
+ * is being invoked with the -S option. This happens before %ENV
+ * is initialized in S_init_postdump_symbols().
+ *
+ * XXX Is this a bug? Should S_find_script() use the environment
+ * XXX passed in the `env` arg to parse_perl()?
+ */
+ putenv(ansi_path);
+ /* Keep system environment in sync because S_init_postdump_symbols()
+ * will not call mg_set() if it initializes %ENV from `environ`.
+ */
+ SetEnvironmentVariableA("PATH", ansi_path+5);
+ /* We are intentionally leaking the ansi_path string here because
+ * the Borland runtime library puts it directly into the environ
+ * array. The Microsoft runtime library seems to make a copy,
+ * but will leak the copy should it be replaced again later.
+ * Since this code is only called once during PERL_SYS_INIT this
+ * shouldn't really matter.
+ */
+ }
+ win32_free(wide_path);
+}
+
void
Perl_win32_init(int *argcp, char ***argvp)
{
-#if _MSC_VER >= 1400
+ HMODULE module;
+
+#ifdef SET_INVALID_PARAMETER_HANDLER
_invalid_parameter_handler oldHandler, newHandler;
newHandler = my_invalid_parameter_handler;
oldHandler = _set_invalid_parameter_handler(newHandler);
_control87(MCW_EM, MCW_EM);
#endif
MALLOC_INIT;
+
+ /* When the manifest resource requests Common-Controls v6 then
+ * user32.dll no longer registers all the Windows classes used for
+ * standard controls but leaves some of them to be registered by
+ * comctl32.dll. InitCommonControls() doesn't do anything but calling
+ * it makes sure comctl32.dll gets loaded into the process and registers
+ * the standard control classes. Without this even normal Windows APIs
+ * like MessageBox() can fail under some versions of Windows XP.
+ */
+ InitCommonControls();
+
+ module = GetModuleHandle("ntdll.dll");
+ if (module) {
+ *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
+ }
+
+ module = GetModuleHandle("kernel32.dll");
+ if (module) {
+ *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
+ *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
+ *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
+ }
+
+ g_osver.dwOSVersionInfoSize = sizeof(g_osver);
+ GetVersionEx(&g_osver);
+
+ ansify_path();
}
void
}
}
+/* The PerlMessageWindowClass's WindowProc */
+LRESULT CALLBACK
+win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
+{
+ return win32_process_message(hwnd, msg, wParam, lParam) ?
+ 0 : DefWindowProc(hwnd, msg, wParam, lParam);
+}
-#ifdef HAVE_INTERP_INTERN
+/* we use a message filter hook to process thread messages, passing any
+ * messages that we don't process on to the rest of the hook chain
+ * Anyone else writing a message loop that wants to play nicely with perl
+ * should do
+ * CallMsgFilter(&msg, MSGF_***);
+ * between their GetMessage and DispatchMessage calls. */
+LRESULT CALLBACK
+win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
+ LPMSG pmsg = (LPMSG)lParam;
+ /* we'll process it if code says we're allowed, and it's a thread message */
+ if (code >= 0 && pmsg->hwnd == NULL
+ && win32_process_message(pmsg->hwnd, pmsg->message,
+ pmsg->wParam, pmsg->lParam))
+ {
+ return TRUE;
+ }
-static void
-win32_csighandler(int sig)
+ /* XXX: MSDN says that hhk is ignored, but we should really use the
+ * return value from SetWindowsHookEx() in win32_create_message_window(). */
+ return CallNextHookEx(NULL, code, wParam, lParam);
+}
+
+/* The real message handler. Can be called with
+ * hwnd == NULL to process our thread messages. Returns TRUE for any messages
+ * that it processes */
+static LRESULT
+win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
{
-#if 0
- dTHXa(PERL_GET_SIG_CONTEXT);
- Perl_warn(aTHX_ "Got signal %d",sig);
+ /* BEWARE. The context retrieved using dTHX; is the context of the
+ * 'parent' thread during the CreateWindow() phase - i.e. for all messages
+ * up to and including WM_CREATE. If it ever happens that you need the
+ * 'child' context before this, then it needs to be passed into
+ * win32_create_message_window(), and passed to the WM_NCCREATE handler
+ * from the lparam of CreateWindow(). It could then be stored/retrieved
+ * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
+ * the dTHX calls here. */
+ /* XXX For now it is assumed that the overhead of the dTHX; for what
+ * are relativley infrequent code-paths, is better than the added
+ * complexity of getting the correct context passed into
+ * win32_create_message_window() */
+
+ switch(msg) {
+
+#ifdef USE_ITHREADS
+ case WM_USER_MESSAGE: {
+ long child = find_pseudo_pid((int)wParam);
+ if (child >= 0) {
+ dTHX;
+ w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
+ return 1;
+ }
+ break;
+ }
#endif
- /* Does nothing */
+
+ case WM_USER_KILL: {
+ dTHX;
+ /* We use WM_USER_KILL to fake kill() with other signals */
+ int sig = (int)wParam;
+ if (do_raise(aTHX_ sig))
+ sig_terminate(aTHX_ sig);
+
+ return 1;
+ }
+
+ case WM_TIMER: {
+ dTHX;
+ /* alarm() is a one-shot but SetTimer() repeats so kill it */
+ if (w32_timerid && w32_timerid==(UINT)wParam) {
+ KillTimer(w32_message_hwnd, w32_timerid);
+ w32_timerid=0;
+
+ /* Now fake a call to signal handler */
+ if (do_raise(aTHX_ 14))
+ sig_terminate(aTHX_ 14);
+
+ return 1;
+ }
+ break;
+ }
+
+ default:
+ break;
+
+ } /* switch */
+
+ /* Above or other stuff may have set a signal flag, and we may not have
+ * been called from win32_async_check() (e.g. some other GUI's message
+ * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
+ * handler that die's, and the message loop that calls here is wrapped
+ * in an eval, then you may well end up with orphaned windows - signals
+ * are dispatched by win32_async_check() */
+
+ return 0;
+}
+
+void
+win32_create_message_window_class(void)
+{
+ /* create the window class for "message only" windows */
+ WNDCLASS wc;
+
+ Zero(&wc, 1, wc);
+ wc.lpfnWndProc = win32_message_window_proc;
+ wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
+ wc.lpszClassName = "PerlMessageWindowClass";
+
+ /* second and subsequent calls will fail, but class
+ * will already be registered */
+ RegisterClass(&wc);
}
HWND
-win32_create_message_window()
+win32_create_message_window(void)
{
+ HWND hwnd = NULL;
+
/* "message-only" windows have been implemented in Windows 2000 and later.
* On earlier versions we'll continue to post messages to a specific
* thread and use hwnd==NULL. This is brittle when either an embedding
* "right" place with DispatchMessage() anymore, as there is no WindowProc
* if there is no window handle.
*/
- if (g_osver.dwMajorVersion < 5)
- return NULL;
+ /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
+ * documentation to the contrary, however, there is some evidence that
+ * there may be problems with the implementation on Win98. As it is not
+ * officially supported we take the cautious route and stick with thread
+ * messages (hwnd == NULL) on platforms prior to Win2k.
+ */
+ if (IsWin2000()) {
+ win32_create_message_window_class();
- return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
+ hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
+ 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
+ }
+
+ /* If we din't create a window for any reason, then we'll use thread
+ * messages for our signalling, so we install a hook which
+ * is called by CallMsgFilter in win32_async_check(), or any other
+ * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
+ * that use OLE, etc. */
+ if(!hwnd) {
+ SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
+ NULL, GetCurrentThreadId());
+ }
+
+ return hwnd;
+}
+
+#ifdef HAVE_INTERP_INTERN
+
+static void
+win32_csighandler(int sig)
+{
+#if 0
+ dTHXa(PERL_GET_SIG_CONTEXT);
+ Perl_warn(aTHX_ "Got signal %d",sig);
+#endif
+ /* Does nothing */
}
#if defined(__MINGW32__) && defined(__cplusplus)
{
int i;
- if (g_osver.dwOSVersionInfoSize == 0) {
- g_osver.dwOSVersionInfoSize = sizeof(g_osver);
- GetVersionEx(&g_osver);
- }
-
- w32_perlshell_tokens = Nullch;
+ w32_perlshell_tokens = NULL;
w32_perlshell_vec = (char**)NULL;
w32_perlshell_items = 0;
w32_fdpid = newAV();
for (i=0; i < SIG_SIZE; i++) {
w32_sighandler[i] = SIG_DFL;
}
-# ifdef MULTIPLICTY
+# ifdef MULTIPLICITY
if (my_perl == PL_curinterp) {
# else
{
/* Force C runtime signal stuff to set its console handler */
signal(SIGINT,win32_csighandler);
signal(SIGBREAK,win32_csighandler);
+
+ /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
+ * flag. This has the side-effect of disabling Ctrl-C events in all
+ * processes in this group. At least on Windows NT and later we
+ * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
+ * with a NULL handler. This is not valid on Windows 9X.
+ */
+ if (IsWinNT())
+ SetConsoleCtrlHandler(NULL,FALSE);
+
/* Push our handler on top */
SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
}
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
{
- dst->perlshell_tokens = Nullch;
+ PERL_ARGS_ASSERT_SYS_INTERN_DUP;
+
+ dst->perlshell_tokens = NULL;
dst->perlshell_vec = (char**)NULL;
dst->perlshell_items = 0;
dst->fdpid = newAV();
}
# endif /* USE_ITHREADS */
#endif /* HAVE_INTERP_INTERN */
-
-static void
-win32_free_argvw(pTHX_ void *ptr)
-{
- char** argv = (char**)ptr;
- while(*argv) {
- Safefree(*argv);
- *argv++ = Nullch;
- }
-}
-
-void
-win32_argv2utf8(int argc, char** argv)
-{
- dTHX;
- char* psz;
- int length, wargc;
- LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
- if (lpwStr && argc) {
- while (argc--) {
- length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
- Newxz(psz, length, char);
- WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
- argv[argc] = psz;
- }
- call_atexit(win32_free_argvw, argv);
- }
- GlobalFree((HGLOBAL)lpwStr);
-}
https://perl5.git.perl.org / perl5.git / blobdiff