/* #include "config.h" */
-#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
-# define PerlIO FILE
-#endif
+
+#define PerlIO FILE
#include <sys/stat.h>
#include "EXTERN.h"
#include <stdarg.h>
#include <float.h>
#include <time.h>
-
-#if defined(_MSC_VER) || defined(__MINGW32__)
-# include <sys/utime.h>
-#else
-# include <utime.h>
-#endif
+#include <sys/utime.h>
+#include <wchar.h>
#ifdef __GNUC__
/* Mingw32 defaults to globing command line
#define EXECF_SPAWN_NOWAIT 3
#if defined(PERL_IMPLICIT_SYS)
-# undef win32_get_privlib
-# define win32_get_privlib g_win32_get_privlib
-# undef win32_get_sitelib
-# define win32_get_sitelib g_win32_get_sitelib
-# undef win32_get_vendorlib
-# define win32_get_vendorlib g_win32_get_vendorlib
# undef getlogin
# define getlogin g_getlogin
#endif
-static void get_shell(void);
-static long tokenize(const char *str, char **dest, char ***destv);
-static int do_spawn2(pTHX_ const char *cmd, int exectype);
-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, 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, 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 long find_pseudo_pid(int pid);
-#endif
-
-START_EXTERN_C
-HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
-char w32_module_name[MAX_PATH+1];
-END_EXTERN_C
-
-static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
-
/* 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
#endif
#ifdef SET_INVALID_PARAMETER_HANDLER
-void my_invalid_parameter_handler(const wchar_t* expression,
+static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
+static void my_invalid_parameter_handler(const wchar_t* expression,
+ const wchar_t* function, const wchar_t* file,
+ unsigned int line, uintptr_t pReserved);
+#endif
+
+#ifndef WIN32_NO_REGISTRY
+static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
+static char* get_regstr(const char *valuename, SV **svp);
+#endif
+
+static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
+ char *trailing, ...);
+static char* win32_get_xlib(const char *pl,
+ WIN32_NO_REGISTRY_M_(const char *xlib)
+ const char *libname, STRLEN *const len);
+
+static BOOL has_shell_metachars(const char *ptr);
+static long tokenize(const char *str, char **dest, char ***destv);
+static void get_shell(void);
+static char* find_next_space(const char *s);
+static int do_spawn2(pTHX_ const char *cmd, int exectype);
+static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
+ const int *handles);
+static int do_spawnvp_handles(int mode, const char *cmdname,
+ const char * const *argv, const int *handles);
+static PerlIO * do_popen(const char *mode, const char *command, IV narg,
+ SV **args);
+static long find_pid(pTHX_ int pid);
+static void remove_dead_process(long child);
+static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
+static int my_killpg(int pid, int sig);
+static int my_kill(int pid, int sig);
+static void out_of_memory(void);
+static char* wstr_to_str(const wchar_t* wstr);
+static long filetime_to_clock(PFILETIME ft);
+static BOOL filetime_from_time(PFILETIME ft, time_t t);
+static char* create_command_line(char *cname, STRLEN clen,
+ const char * const *args);
+static char* qualified_path(const char *cmd, bool other_exts);
+static void ansify_path(void);
+static LRESULT win32_process_message(HWND hwnd, UINT msg,
+ WPARAM wParam, LPARAM lParam);
+
+#ifdef USE_ITHREADS
+static long find_pseudo_pid(pTHX_ int pid);
+static void remove_dead_pseudo_process(long child);
+static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
+#endif
+
+#ifdef HAVE_INTERP_INTERN
+static void win32_csighandler(int sig);
+#endif
+
+START_EXTERN_C
+HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
+char w32_module_name[MAX_PATH+1];
+#ifdef WIN32_DYN_IOINFO_SIZE
+Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
+#endif
+END_EXTERN_C
+
+static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
+
+#ifndef WIN32_NO_REGISTRY
+/* initialized by Perl_win32_init/PERL_SYS_INIT */
+static HKEY HKCU_Perl_hnd;
+static HKEY HKLM_Perl_hnd;
+#endif
+
+#ifdef SET_INVALID_PARAMETER_HANDLER
+static BOOL silent_invalid_parameter_handler = FALSE;
+
+static BOOL
+set_silent_invalid_parameter_handler(BOOL newvalue)
+{
+ BOOL oldvalue = silent_invalid_parameter_handler;
+# ifdef _DEBUG
+ silent_invalid_parameter_handler = newvalue;
+# endif
+ return oldvalue;
+}
+
+static void
+my_invalid_parameter_handler(const wchar_t* expression,
const wchar_t* function,
const wchar_t* file,
unsigned int line,
uintptr_t pReserved)
{
# ifdef _DEBUG
- wprintf(L"Invalid parameter detected in function %s."
- L" File: %s Line: %d\n", function, file, line);
- wprintf(L"Expression: %s\n", expression);
+ char* ansi_expression;
+ char* ansi_function;
+ char* ansi_file;
+ if (silent_invalid_parameter_handler)
+ return;
+ ansi_expression = wstr_to_str(expression);
+ ansi_function = wstr_to_str(function);
+ ansi_file = wstr_to_str(file);
+ fprintf(stderr, "Invalid parameter detected in function %s. "
+ "File: %s, line: %d\n", ansi_function, ansi_file, line);
+ fprintf(stderr, "Expression: %s\n", ansi_expression);
+ free(ansi_expression);
+ free(ansi_function);
+ free(ansi_file);
# endif
}
#endif
? 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;
-
- DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
- (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
- GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
+ WCHAR modulename[MAX_PATH];
+ WCHAR fullname[MAX_PATH];
+ char *ansi;
- GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
+ DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
+ (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
+ GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
- /* 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);
+ GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
- /* 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));
+ /* 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);
- /* 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));
+ /* 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(w32_module_name, "\\\\?\\", 4) == 0)
- memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
+ /* remove \\?\ prefix */
+ if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
+ memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
- /* 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);*/
- }
+ ansi = win32_ansipath(fullname);
+ my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
+ win32_free(ansi);
/* normalize to forward slashes */
ptr = w32_module_name;
}
}
+#ifndef WIN32_NO_REGISTRY
/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
static char*
-get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
+get_regstr_from(HKEY handle, const char *valuename, SV **svp)
{
/* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
- HKEY handle;
DWORD type;
- const char *subkey = "Software\\Perl";
char *str = NULL;
long retval;
+ DWORD datalen;
- retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
- if (retval == ERROR_SUCCESS) {
- DWORD datalen;
- retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
- if (retval == ERROR_SUCCESS
- && (type == REG_SZ || type == REG_EXPAND_SZ))
- {
- dTHX;
- if (!*svp)
- *svp = sv_2mortal(newSVpvn("",0));
- SvGROW(*svp, datalen);
- retval = RegQueryValueEx(handle, valuename, 0, NULL,
- (PBYTE)SvPVX(*svp), &datalen);
- if (retval == ERROR_SUCCESS) {
- str = SvPVX(*svp);
- SvCUR_set(*svp,datalen-1);
- }
+ retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
+ if (retval == ERROR_SUCCESS
+ && (type == REG_SZ || type == REG_EXPAND_SZ))
+ {
+ dTHX;
+ if (!*svp)
+ *svp = sv_2mortal(newSVpvs(""));
+ SvGROW(*svp, datalen);
+ retval = RegQueryValueEx(handle, valuename, 0, NULL,
+ (PBYTE)SvPVX(*svp), &datalen);
+ if (retval == ERROR_SUCCESS) {
+ str = SvPVX(*svp);
+ SvCUR_set(*svp,datalen-1);
}
- RegCloseKey(handle);
}
return str;
}
static char*
get_regstr(const char *valuename, SV **svp)
{
- char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
- if (!str)
- str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
+ char *str;
+ if (HKCU_Perl_hnd) {
+ str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
+ if (!str)
+ goto try_HKLM;
+ }
+ else {
+ try_HKLM:
+ if (HKLM_Perl_hnd)
+ str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
+ else
+ str = NULL;
+ }
return str;
}
+#endif /* ifndef WIN32_NO_REGISTRY */
/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
static char *
if (!ptr || stricmp(ptr+1, strip) != 0) {
/* ... but not if component matches m|5\.$patchlevel.*| */
if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
- && strncmp(strip, base, baselen) == 0
- && strncmp(ptr+1, base, baselen) == 0))
+ && strnEQ(strip, base, baselen)
+ && strnEQ(ptr+1, base, baselen)))
{
*optr = '/';
ptr = optr;
/* directory exists */
dTHX;
if (!*prev_pathp)
- *prev_pathp = sv_2mortal(newSVpvn("",0));
+ *prev_pathp = sv_2mortal(newSVpvs(""));
else if (SvPVX(*prev_pathp))
- sv_catpvn(*prev_pathp, ";", 1);
+ sv_catpvs(*prev_pathp, ";");
sv_catpv(*prev_pathp, mod_name);
if(len)
*len = SvCUR(*prev_pathp);
return NULL;
}
-char *
-win32_get_privlib(const char *pl, STRLEN *const len)
+EXTERN_C char *
+win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
{
- dTHX;
char *stdlib = "lib";
- char buffer[MAX_PATH+1];
SV *sv = NULL;
+#ifndef WIN32_NO_REGISTRY
+ char buffer[MAX_PATH+1];
/* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
sprintf(buffer, "%s-%s", stdlib, pl);
if (!get_regstr(buffer, &sv))
(void)get_regstr(stdlib, &sv);
+#endif
/* $stdlib .= ";$EMD/../../lib" */
return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
}
static char *
-win32_get_xlib(const char *pl, const char *xlib, const char *libname,
- STRLEN *const len)
+win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib)
+ const char *libname, STRLEN *const len)
{
- dTHX;
+#ifndef WIN32_NO_REGISTRY
char regstr[40];
+#endif
char pathstr[MAX_PATH+1];
SV *sv1 = NULL;
SV *sv2 = NULL;
+#ifndef WIN32_NO_REGISTRY
/* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
sprintf(regstr, "%s-%s", xlib, pl);
(void)get_regstr(regstr, &sv1);
+#endif
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
sprintf(pathstr, "%s/%s/lib", libname, pl);
(void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
+#ifndef WIN32_NO_REGISTRY
/* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
(void)get_regstr(xlib, &sv2);
+#endif
/* $xlib .=
* ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
if (!sv1) {
sv1 = sv2;
} else if (sv2) {
- sv_catpvn(sv1, ";", 1);
+ dTHX;
+ sv_catpvs(sv1, ";");
sv_catsv(sv1, sv2);
}
return SvPVX(sv1);
}
-char *
+EXTERN_C char *
win32_get_sitelib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "sitelib", "site", len);
+ return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len);
}
#ifndef PERL_VENDORLIB_NAME
# define PERL_VENDORLIB_NAME "vendor"
#endif
-char *
+EXTERN_C char *
win32_get_vendorlib(const char *pl, STRLEN *const len)
{
- return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
+ return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len);
}
static BOOL
char **retvstart = 0;
int items = -1;
if (str) {
- dTHX;
int slen = strlen(str);
- register char *ret;
- register char **retv;
+ char *ret;
+ char **retv;
Newx(ret, slen+2, char);
Newx(retv, (slen+3)/2, char*);
int status;
int flag = P_WAIT;
int index = 0;
+ int eno;
PERL_ARGS_ASSERT_DO_ASPAWN;
(const char*)(really ? SvPV_nolen(really) : argv[0]),
(const char* const*)argv);
- if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
+ if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) {
/* possible shell-builtin, invoke with shell */
int sh_items;
sh_items = w32_perlshell_items;
}
static int
-do_spawn2(pTHX_ const char *cmd, int exectype)
+do_spawn2(pTHX_ const char *cmd, int exectype) {
+ return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
+}
+
+static int
+do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
{
char **a;
char *s;
(const char* const*)argv);
break;
case EXECF_SPAWN_NOWAIT:
- status = win32_spawnvp(P_NOWAIT, argv[0],
- (const char* const*)argv);
+ status = do_spawnvp_handles(P_NOWAIT, argv[0],
+ (const char* const*)argv, handles);
break;
case EXECF_EXEC:
status = win32_execvp(argv[0], (const char* const*)argv);
(const char* const*)argv);
break;
case EXECF_SPAWN_NOWAIT:
- status = win32_spawnvp(P_NOWAIT, argv[0],
- (const char* const*)argv);
+ status = do_spawnvp_handles(P_NOWAIT, argv[0],
+ (const char* const*)argv, handles);
break;
case EXECF_EXEC:
status = win32_execvp(argv[0], (const char* const*)argv);
DllExport DIR *
win32_opendir(const char *filename)
{
- dTHX;
+ dTHXa(NULL);
DIR *dirp;
long len;
long idx;
/* do the FindFirstFile call */
MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
+ aTHXa(PERL_GET_THX);
dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
if (dirp->handle == INVALID_HANDLE_VALUE) {
/* Now set up for the next call to readdir */
dirp->curr += len + 1;
if (dirp->curr >= dirp->end) {
- dTHX;
BOOL res;
char buffer[MAX_PATH*2];
* new name and its null terminator */
while (newsize > dirp->size) {
long curpos = dirp->curr - dirp->start;
+ Renew(dirp->start, dirp->size * 2, char);
dirp->size *= 2;
- Renew(dirp->start, dirp->size, char);
dirp->curr = dirp->start + curpos;
}
strcpy(dirp->start + endpos, buffer);
DllExport int
win32_closedir(DIR *dirp)
{
- dTHX;
if (dirp->handle != INVALID_HANDLE_VALUE)
FindClose(dirp->handle);
Safefree(dirp->start);
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;
+ PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
long pos;
DIR *dup;
return (agid == ROOT_GID ? 0 : -1);
}
-char *
+EXTERN_C char *
getlogin(void)
{
dTHX;
* XXX this needs strengthening (for PerlIO)
* -- BKS, 11-11-200
*/
+#if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
int mkstemp(const char *path)
{
dTHX;
goto retry;
return fd;
}
+#endif
static long
-find_pid(int pid)
+find_pid(pTHX_ int pid)
{
- dTHX;
long child = w32_num_children;
while (--child >= 0) {
if ((int)w32_child_pids[child] == pid)
#ifdef USE_ITHREADS
static long
-find_pseudo_pid(int pid)
+find_pseudo_pid(pTHX_ int pid)
{
- dTHX;
long child = w32_num_pseudo_children;
while (--child >= 0) {
if ((int)w32_pseudo_child_pids[child] == pid)
return 0;
}
-int
-killpg(int pid, int sig)
+/* returns number of processes killed */
+static int
+my_killpg(int pid, int sig)
{
HANDLE process_handle;
HANDLE snapshot_handle;
if (Process32First(snapshot_handle, &entry)) {
do {
if (entry.th32ParentProcessID == (DWORD)pid)
- killed += killpg(entry.th32ProcessID, sig);
+ killed += my_killpg(entry.th32ProcessID, sig);
entry.dwSize = sizeof(entry);
}
while (Process32Next(snapshot_handle, &entry));
return killed;
}
+/* returns number of processes killed */
static int
my_kill(int pid, int sig)
{
HANDLE process_handle;
if (sig < 0)
- return killpg(pid, -sig);
+ return my_killpg(pid, -sig);
process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
/* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
return retval;
}
+#ifdef USE_ITHREADS
+/* Get a child pseudo-process HWND, with retrying and delaying/yielding.
+ * The "tries" parameter is the number of retries to make, with a Sleep(1)
+ * (waiting and yielding the time slot) between each try. Specifying 0 causes
+ * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
+ * recommended
+ * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
+ * returned) or croaks if the child pseudo-process doesn't schedule and deliver
+ * a HWND in the time period allowed.
+ */
+static HWND
+get_hwnd_delay(pTHX, long child, DWORD tries)
+{
+ HWND hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+
+ /* Pseudo-process has not yet properly initialized since hwnd isn't set.
+ * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
+ * thread 100% of the time since threads are attached to a CPU for NUMA and
+ * caching reasons, and the child thread was attached to a different CPU
+ * therefore there is no workload on that CPU and Sleep(0) returns control
+ * without yielding the time slot.
+ * https://github.com/Perl/perl5/issues/11267
+ */
+ Sleep(0);
+ win32_async_check(aTHX);
+ hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+
+ {
+ unsigned int count = 0;
+ /* No Sleep(1) if tries==0, just fail instead if we get this far. */
+ while (count++ < tries) {
+ Sleep(1);
+ win32_async_check(aTHX);
+ hwnd = w32_pseudo_child_message_hwnds[child];
+ if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
+ }
+ }
+
+ Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
+}
+#endif
+
DllExport int
win32_kill(int pid, int sig)
{
#ifdef USE_ITHREADS
if (pid < 0) {
/* it is a pseudo-forked child */
- child = find_pseudo_pid(-pid);
+ child = find_pseudo_pid(aTHX_ -pid);
if (child >= 0) {
- HWND hwnd = w32_pseudo_child_message_hwnds[child];
HANDLE hProcess = w32_pseudo_child_handles[child];
switch (sig) {
- case 0:
- /* "Does process exist?" use of kill */
- return 0;
-
- case 9:
- /* kill -9 style un-graceful exit */
- if (TerminateThread(hProcess, sig)) {
- /* Allow the scheduler to finish cleaning up the other thread.
- * Otherwise, if we ExitProcess() before another context switch
- * happens we will end up with a process exit code of "sig" instead
- * of our own exit status.
- * See also: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
- */
- Sleep(0);
- remove_dead_pseudo_process(child);
+ case 0:
+ /* "Does process exist?" use of kill */
return 0;
- }
- break;
- default: {
- int count = 0;
- /* pseudo-process has not yet properly initialized if hwnd isn't set */
- while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
- /* 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) {
- /* We fake signals to pseudo-processes using Win32
- * message queue. In Win9X the pids are negative already. */
- if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
- PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
- {
- /* Don't wait for child process to terminate after we send a SIGTERM
- * because the child may be blocked in a system call and never receive
- * the signal.
- */
- if (sig == SIGTERM) {
- Sleep(0);
- w32_pseudo_child_sigterm[child] = 1;
- }
- /* It might be us ... */
- PERL_ASYNC_CHECK();
- return 0;
- }
- }
- break;
- }
- } /* switch */
+ case 9: {
+ /* kill -9 style un-graceful exit */
+ /* Do a wait to make sure child starts and isn't in DLL
+ * Loader Lock */
+ HWND hwnd = get_hwnd_delay(aTHX, child, 5);
+ if (TerminateThread(hProcess, sig)) {
+ /* Allow the scheduler to finish cleaning up the other
+ * thread.
+ * Otherwise, if we ExitProcess() before another context
+ * switch happens we will end up with a process exit
+ * code of "sig" instead of our own exit status.
+ * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
+ */
+ Sleep(0);
+ remove_dead_pseudo_process(child);
+ return 0;
+ }
+ break;
+ }
+
+ default: {
+ HWND hwnd = get_hwnd_delay(aTHX, child, 5);
+ /* We fake signals to pseudo-processes using Win32
+ * message queue. */
+ if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
+ PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
+ {
+ /* Don't wait for child process to terminate after we send a
+ * SIGTERM because the child may be blocked in a system call
+ * and never receive the signal.
+ */
+ if (sig == SIGTERM) {
+ Sleep(0);
+ w32_pseudo_child_sigterm[child] = 1;
+ }
+ /* It might be us ... */
+ PERL_ASYNC_CHECK();
+ return 0;
+ }
+ break;
+ }
+ } /* switch */
}
}
else
#endif
{
- child = find_pid(pid);
+ child = find_pid(aTHX_ pid);
if (child >= 0) {
if (my_kill(pid, sig)) {
DWORD exitcode = 0;
DllExport int
win32_stat(const char *path, Stat_t *sbuf)
{
- dTHX;
char buffer[MAX_PATH+1];
int l = strlen(path);
+ dTHX;
int res;
int nlink = 1;
BOOL expect_dir = FALSE;
- GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
- GV_NOTQUAL, SVt_PV);
- BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
-
if (l > 1) {
switch(path[l - 1]) {
/* FindFirstFile() and stat() are buggy with a trailing
path = PerlDir_mapA(path);
l = strlen(path);
- if (!sloppy) {
+ if (!w32_sloppystat) {
/* We must open & close the file once; otherwise file attribute changes */
/* might not yet have propagated to "other" hard links of the same file. */
/* This also gives us an opportunity to determine the number of links. */
nlink = bhi.nNumberOfLinks;
CloseHandle(handle);
}
+ else {
+ DWORD err = GetLastError();
+ /* very common case, skip CRT stat and its also failing syscalls */
+ if(err == ERROR_FILE_NOT_FOUND) {
+ errno = ENOENT;
+ return -1;
+ }
+ }
}
/* path will be mapped correctly above */
-#if defined(WIN64) || defined(USE_LARGE_FILES)
res = _stati64(path, sbuf);
-#else
- res = stat(path, sbuf);
-#endif
sbuf->st_nlink = nlink;
if (res < 0) {
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);
- }
+
+ if (PL_curinterp)
+ croak_no_mem();
exit(1);
}
+void
+win32_croak_not_implemented(const char * fname)
+{
+ PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
+
+ Perl_croak_nocontext("%s not implemented!\n", fname);
+}
+
+/* Converts a wide character (UTF-16) string to the Windows ANSI code page,
+ * potentially using the system's default replacement character for any
+ * unrepresentable characters. The caller must free() the returned string. */
+static char*
+wstr_to_str(const wchar_t* wstr)
+{
+ BOOL used_default = FALSE;
+ size_t wlen = wcslen(wstr) + 1;
+ int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
+ NULL, 0, NULL, NULL);
+ char* str = (char*)malloc(len);
+ if (!str)
+ out_of_memory();
+ WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
+ str, len, NULL, &used_default);
+ return str;
+}
+
/* 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.
+ * is 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.
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);
+ name = (char*)win32_malloc(len);
if (!name)
out_of_memory();
if (use_default) {
DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
if (shortlen) {
- WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
+ WCHAR *shortname = (WCHAR*)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);
+ name = (char*)win32_realloc(name, len);
if (!name)
out_of_memory();
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
return name;
}
+/* the returned string must be freed with win32_freeenvironmentstrings which is
+ * implemented as a macro
+ * void win32_freeenvironmentstrings(void* block)
+ */
DllExport char *
win32_getenvironmentstrings(void)
{
/* Get the process environment strings */
lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
- for(wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
+ for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
env_len = wcslen(lpWTmp);
/* calculate the size of the environment strings */
wenvstrings_len += env_len + 1;
}
- /* Get the number of bytes required to store the UTF16 encoded string */
+ /* Get the number of bytes required to store the ACP encoded string */
aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
- lpWStr, wenvstrings_len, NULL, 0, 0, 0);
+ lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
if(!lpTmp)
out_of_memory();
/* Convert the string from UTF-16 encoding to ACP encoding */
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
- aenvstrings_len, 0, 0);
+ aenvstrings_len, NULL, NULL);
- return(lpStr);
-}
+ FreeEnvironmentStringsW(lpWStr);
-DllExport void
-win32_freeenvironmentstrings(void* block)
-{
- win32_free(block);
+ return(lpStr);
}
DllExport char *
needlen = GetEnvironmentVariableA(name,NULL,0);
if (needlen != 0) {
- curitem = sv_2mortal(newSVpvn("", 0));
+ curitem = sv_2mortal(newSVpvs(""));
do {
SvGROW(curitem, needlen+1);
needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
char *end = strchr(cur,'=');
if (end && end != cur) {
*end = '\0';
- if (!strcmp(cur,name)) {
+ if (strEQ(cur,name)) {
curitem = sv_2mortal(newSVpv(end+1,0));
*end = '=';
break;
}
FreeEnvironmentStrings(envv);
}
+#ifndef WIN32_NO_REGISTRY
else {
/* last ditch: allow any environment variables that begin with 'PERL'
to be obtained from the registry, if found there */
- if (strncmp(name, "PERL", 4) == 0)
+ if (strBEGINs(name, "PERL"))
(void)get_regstr(name, &curitem);
}
+#endif
}
if (curitem && SvCUR(curitem))
return SvPVX(curitem);
DllExport int
win32_putenv(const char *name)
{
- dTHX;
char* curitem;
char* val;
int relval = -1;
if (name) {
- Newx(curitem,strlen(name)+1,char);
+ curitem = (char *) win32_malloc(strlen(name)+1);
strcpy(curitem, name);
val = strchr(curitem, '=');
if (val) {
if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
relval = 0;
}
- Safefree(curitem);
+ win32_free(curitem);
}
return relval;
}
}
}
}
- /* Tell caller to exit thread/process as approriate */
+ /* Tell caller to exit thread/process as appropriate */
return 1;
}
win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
{
/* We may need several goes at this - so compute when we stop */
- DWORD ticks = 0;
+ FT_t ticks = {0};
+ unsigned __int64 endtime = timeout;
if (timeout != INFINITE) {
- ticks = GetTickCount();
- timeout += ticks;
- }
- while (1) {
- DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
+ GetSystemTimeAsFileTime(&ticks.ft_val);
+ ticks.ft_i64 /= 10000;
+ endtime += ticks.ft_i64;
+ }
+ /* This was a race condition. Do not let a non INFINITE timeout to
+ * MsgWaitForMultipleObjects roll under 0 creating a near
+ * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
+ * user who did a CORE perl function with a non infinity timeout,
+ * sleep for example. This is 64 to 32 truncation minefield.
+ *
+ * This scenario can only be created if the timespan from the return of
+ * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
+ * generate the scenario, manual breakpoints in a C debugger are required,
+ * or a context switch occurred in win32_async_check in PeekMessage, or random
+ * messages are delivered to the *thread* message queue of the Perl thread
+ * from another process (msctf.dll doing IPC among its instances, VS debugger
+ * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
+ */
+ while (ticks.ft_i64 <= endtime) {
+ /* if timeout's type is lengthened, remember to split 64b timeout
+ * into multiple non-infinity runs of MWFMO */
+ DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
+ (DWORD)(endtime - ticks.ft_i64),
+ QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
if (resultp)
*resultp = result;
if (result == WAIT_TIMEOUT) {
return 0;
}
if (timeout != INFINITE) {
- ticks = GetTickCount();
- }
+ GetSystemTimeAsFileTime(&ticks.ft_val);
+ ticks.ft_i64 /= 10000;
+ }
if (result == WAIT_OBJECT_0 + count) {
/* Message has arrived - check it */
(void)win32_async_check(aTHX);
+
+ /* retry */
+ if (ticks.ft_i64 > endtime)
+ endtime = ticks.ft_i64;
+
+ continue;
}
else {
/* Not timeout or message - one of handles is ready */
break;
}
}
- /* compute time left to wait */
- ticks = timeout - ticks;
/* If we are past the end say zero */
- return (ticks > 0) ? ticks : 0;
+ if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
+ return 0;
+ /* compute time left to wait */
+ ticks.ft_i64 = endtime - ticks.ft_i64;
+ /* if more ms than DWORD, then return max DWORD */
+ return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
}
int
-win32_internal_wait(int *status, DWORD timeout)
+win32_internal_wait(pTHX_ int *status, DWORD timeout)
{
/* XXX this wait emulation only knows about processes
* spawned via win32_spawnvp(P_NOWAIT, ...).
*/
- dTHX;
int i, retval;
DWORD exitcode, waitcode;
int retval = -1;
long child;
if (pid == -1) /* XXX threadid == 1 ? */
- return win32_internal_wait(status, timeout);
+ return win32_internal_wait(aTHX_ status, timeout);
#ifdef USE_ITHREADS
else if (pid < 0) {
- child = find_pseudo_pid(-pid);
+ child = find_pseudo_pid(aTHX_ -pid);
if (child >= 0) {
HANDLE hThread = w32_pseudo_child_handles[child];
DWORD waitcode;
else {
HANDLE hProcess;
DWORD waitcode;
- child = find_pid(pid);
+ child = find_pid(aTHX_ pid);
if (child >= 0) {
hProcess = w32_child_handles[child];
win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
DllExport int
win32_wait(int *status)
{
- return win32_internal_wait(status, INFINITE);
+ dTHX;
+ return win32_internal_wait(aTHX_ status, INFINITE);
}
DllExport unsigned int
{
dTHX;
/* Win32 times are in ms so *1000 in and /1000 out */
- return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
+ if (t > UINT_MAX / 1000) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "sleep(%lu) too large", t);
+ }
+ return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
+}
+
+DllExport int
+win32_pause(void)
+{
+ dTHX;
+ win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
+ return -1;
}
DllExport unsigned int
}
if (i == -1) {
if (GetLastError() == ERROR_LOCK_VIOLATION)
- errno = WSAEWOULDBLOCK;
+ errno = EWOULDBLOCK;
else
errno = EINVAL;
}
#undef LK_LEN
+extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
+
+/* Get the errno value corresponding to the given err. This function is not
+ * intended to handle conversion of general GetLastError() codes. It only exists
+ * to translate Windows sockets error codes from WSAGetLastError(). Such codes
+ * used to be assigned to errno/$! in earlier versions of perl; this function is
+ * used to catch any old Perl code which is still trying to assign such values
+ * to $! and convert them to errno values instead.
+ */
+int
+win32_get_errno(int err)
+{
+ return convert_wsa_error_to_errno(err);
+}
+
/*
* redirected io subsystem for all XS modules
*
return (feof(fp));
}
+#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
+extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
+#endif
+
/*
* Since the errors returned by the socket error function
* WSAGetLastError() are not known by the library routine strerror
- * we have to roll our own.
+ * we have to roll our own to cover the case of socket errors
+ * that could not be converted to regular errno values by
+ * get_last_socket_error() in win32/win32sck.c.
*/
DllExport char *
#endif
if (e < 0 || e > sys_nerr) {
- dTHX;
+ dTHXa(NULL);
if (e < 0)
e = GetLastError();
+#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
+ /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
+ * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
+ * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
+ * We must therefore still roll our own messages for these codes, and
+ * additionally map them to corresponding Windows (sockets) error codes
+ * first to avoid getting the wrong system message.
+ */
+ else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) {
+ e = convert_errno_to_wsa_error(e);
+ }
+#endif
+ aTHXa(PERL_GET_THX);
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
|FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
w32_strerror_buffer, sizeof(w32_strerror_buffer),
DllExport FILE *
win32_fopen(const char *filename, const char *mode)
{
- dTHX;
+ dTHXa(NULL);
FILE *f;
if (!*filename)
if (stricmp(filename, "/dev/null")==0)
filename = "NUL";
+ aTHXa(PERL_GET_THX);
f = fopen(PerlDir_mapA(filename), mode);
/* avoid buffering headaches for child processes */
if (f && *mode == 'a')
return f;
}
-#ifndef USE_SOCKETS_AS_HANDLES
-#undef fdopen
-#define fdopen my_fdopen
-#endif
-
DllExport FILE *
win32_fdopen(int handle, const char *mode)
{
- dTHX;
FILE *f;
f = fdopen(handle, (char *) mode);
/* avoid buffering headaches for child processes */
DllExport FILE *
win32_freopen(const char *path, const char *mode, FILE *stream)
{
- dTHX;
+ dTHXa(NULL);
if (stricmp(path, "/dev/null")==0)
path = "NUL";
+ aTHXa(PERL_GET_THX);
return freopen(PerlDir_mapA(path), mode, stream);
}
DllExport int
win32_fclose(FILE *pf)
{
+#ifdef WIN32_NO_SOCKETS
+ return fclose(pf);
+#else
return my_fclose(pf); /* defined in win32sck.c */
+#endif
}
DllExport int
DllExport Off_t
win32_ftell(FILE *pf)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
fpos_t pos;
if (fgetpos(pf, &pos))
return -1;
return (Off_t)pos;
-#else
- return ftell(pf);
-#endif
}
DllExport int
win32_fseek(FILE *pf, Off_t offset,int origin)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
fpos_t pos;
switch (origin) {
case SEEK_CUR:
return -1;
}
return fsetpos(pf, &offset);
-#else
- return fseek(pf, (long)offset, origin);
-#endif
}
DllExport int
DllExport int
win32_tmpfd(void)
{
- dTHX;
+ return win32_tmpfd_mode(0);
+}
+
+DllExport int
+win32_tmpfd_mode(int mode)
+{
char prefix[MAX_PATH+1];
char filename[MAX_PATH+1];
DWORD len = GetTempPath(MAX_PATH, prefix);
+ mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
+ mode |= O_RDWR;
if (len && len < MAX_PATH) {
if (GetTempFileName(prefix, "plx", 0, filename)) {
HANDLE fh = CreateFile(filename,
| FILE_FLAG_DELETE_ON_CLOSE,
NULL);
if (fh != INVALID_HANDLE_VALUE) {
- int fd = win32_open_osfhandle((intptr_t)fh, 0);
+ int fd = win32_open_osfhandle((intptr_t)fh, mode);
if (fd >= 0) {
+ PERL_DEB(dTHX;)
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Created tmpfile=%s\n",filename));
return fd;
DllExport int
win32_fstat(int fd, Stat_t *sbufptr)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
return _fstati64(fd, sbufptr);
-#else
- return fstat(fd, sbufptr);
-#endif
}
DllExport int
DllExport PerlIO*
win32_popenlist(const char *mode, IV narg, SV **args)
{
- dTHX;
- Perl_croak(aTHX_ "List form of pipe open not implemented");
- return NULL;
-}
+ get_shell();
-/*
- * a popen() clone that respects PERL5SHELL
- *
- * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
- */
+ return do_popen(mode, NULL, narg, args);
+}
-DllExport PerlIO*
-win32_popen(const char *command, const char *mode)
-{
-#ifdef USE_RTL_POPEN
- return _popen(command, mode);
-#else
- dTHX;
+STATIC PerlIO*
+do_popen(const char *mode, const char *command, IV narg, SV **args) {
int p[2];
+ int handles[3];
int parent, child;
- int stdfd, oldfd;
+ int stdfd;
int ourmode;
int childpid;
DWORD nhandle;
- HANDLE old_h;
int lock_held = 0;
+ const char **args_pvs = NULL;
/* establish which ends read and write */
if (strchr(mode,'w')) {
if (win32_pipe(p, 512, ourmode) == -1)
return NULL;
- /* save the old std handle (this needs to happen before the
- * dup2(), since that might call SetStdHandle() too) */
- OP_REFCNT_LOCK;
- lock_held = 1;
- old_h = GetStdHandle(nhandle);
+ /* Previously this code redirected stdin/out temporarily so the
+ child process inherited those handles, this caused race
+ conditions when another thread was writing/reading those
+ handles.
- /* save current stdfd */
- if ((oldfd = win32_dup(stdfd)) == -1)
- goto cleanup;
+ To avoid that we just feed the handles to CreateProcess() so
+ the handles are redirected only in the child.
+ */
+ handles[child] = p[child];
+ handles[parent] = -1;
+ handles[2] = -1;
- /* make stdfd go to child end of pipe (implicitly closes stdfd) */
- /* stdfd will be inherited by the child */
- if (win32_dup2(p[child], stdfd) == -1)
+ /* CreateProcess() requires inheritable handles */
+ if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
+ HANDLE_FLAG_INHERIT)) {
goto cleanup;
-
- /* close the child end in parent */
- win32_close(p[child]);
-
- /* set the new std handle (in case dup2() above didn't) */
- SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
+ }
/* start the child */
{
dTHX;
- if ((childpid = do_spawn_nowait((char*)command)) == -1)
- goto cleanup;
-
- /* revert stdfd to whatever it was before */
- if (win32_dup2(oldfd, stdfd) == -1)
- goto cleanup;
-
- /* close saved handle */
- win32_close(oldfd);
-
- /* restore the old std handle (this needs to happen after the
- * dup2(), since that might call SetStdHandle() too */
- if (lock_held) {
- SetStdHandle(nhandle, old_h);
- OP_REFCNT_UNLOCK;
- lock_held = 0;
+
+ if (command) {
+ if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
+ goto cleanup;
+
}
+ else {
+ int i;
+ const char *exe_name;
+
+ Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
+ SAVEFREEPV(args_pvs);
+ for (i = 0; i < narg; ++i)
+ args_pvs[i] = SvPV_nolen(args[i]);
+ args_pvs[i] = NULL;
+ exe_name = qualified_path(args_pvs[0], TRUE);
+ if (!exe_name)
+ /* let CreateProcess() try to find it instead */
+ exe_name = args_pvs[0];
+
+ if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
+ goto cleanup;
+ }
+ }
+
+ win32_close(p[child]);
sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
/* we don't need to check for errors here */
win32_close(p[0]);
win32_close(p[1]);
- if (oldfd != -1) {
- win32_dup2(oldfd, stdfd);
- win32_close(oldfd);
- }
- if (lock_held) {
- SetStdHandle(nhandle, old_h);
- OP_REFCNT_UNLOCK;
- lock_held = 0;
- }
+
return (NULL);
+}
+/*
+ * a popen() clone that respects PERL5SHELL
+ *
+ * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
+ */
+
+DllExport PerlIO*
+win32_popen(const char *command, const char *mode)
+{
+#ifdef USE_RTL_POPEN
+ return _popen(command, mode);
+#else
+ return do_popen(mode, command, 0, NULL);
#endif /* USE_RTL_POPEN */
}
DllExport int
win32_link(const char *oldname, const char *newname)
{
- dTHX;
+ dTHXa(NULL);
WCHAR wOldName[MAX_PATH+1];
WCHAR wNewName[MAX_PATH+1];
if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
- (wcscpy(wOldName, PerlDir_mapW(wOldName)),
+ ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
{
return 0;
case ERROR_NOT_SAME_DEVICE:
errno = EXDEV;
break;
+ case ERROR_DISK_FULL:
+ errno = ENOSPC;
+ break;
+ case ERROR_NOT_ENOUGH_QUOTA:
+ errno = EDQUOT;
+ break;
default:
/* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
errno = EINVAL;
case ERROR_PATH_NOT_FOUND:
errno = ENOENT;
break;
+ case ERROR_DISK_FULL:
+ errno = ENOSPC;
+ break;
+ case ERROR_NOT_ENOUGH_QUOTA:
+ errno = EDQUOT;
+ break;
default:
errno = EACCES;
break;
DllExport int
win32_chsize(int fd, Off_t size)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
int retval = 0;
Off_t cur, end, extend;
retval = -1;
}
}
-finish:
win32_lseek(fd, cur, SEEK_SET);
return retval;
-#else
- return chsize(fd, (long)size);
-#endif
}
DllExport Off_t
win32_lseek(int fd, Off_t offset, int origin)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
return _lseeki64(fd, offset, origin);
-#else
- return lseek(fd, (long)offset, origin);
-#endif
}
DllExport Off_t
win32_tell(int fd)
{
-#if defined(WIN64) || defined(USE_LARGE_FILES)
return _telli64(fd);
-#else
- return tell(fd);
-#endif
}
DllExport int
win32_open(const char *path, int flag, ...)
{
- dTHX;
+ dTHXa(NULL);
va_list ap;
int pmode;
if (stricmp(path, "/dev/null")==0)
path = "NUL";
+ aTHXa(PERL_GET_THX);
return open(PerlDir_mapA(path), flag, pmode);
}
DllExport int
win32_close(int fd)
{
+#ifdef WIN32_NO_SOCKETS
+ return close(fd);
+#else
return my_close(fd);
+#endif
}
DllExport int
DllExport int
win32_chdir(const char *dir)
{
- dTHX;
- if (!dir) {
+ if (!dir || !*dir) {
errno = ENOENT;
return -1;
}
static char *
create_command_line(char *cname, STRLEN clen, const char * const *args)
{
- dTHX;
+ PERL_DEB(dTHX;)
int index, argc;
char *cmd, *ptr;
const char *arg;
return cmd;
}
+static const char *exe_extensions[] =
+ {
+ ".exe", /* this must be first */
+ ".cmd",
+ ".bat"
+ };
+
static char *
-qualified_path(const char *cmd)
+qualified_path(const char *cmd, bool other_exts)
{
- dTHX;
char *pathstr;
char *fullcmd, *curfullcmd;
STRLEN cmdlen = 0;
}
/* look in PATH */
- pathstr = PerlEnv_getenv("PATH");
-
+ {
+ dTHX;
+ pathstr = PerlEnv_getenv("PATH");
+ }
/* worst case: PATH is a single directory; we need additional space
* to append "/", ".exe" and trailing "\0" */
Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
if (cmd[cmdlen-1] != '.'
&& (cmdlen < 4 || cmd[cmdlen-4] != '.'))
{
- strcpy(curfullcmd, ".exe");
- res = GetFileAttributes(fullcmd);
- if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
- return fullcmd;
+ int i;
+ /* first extension is .exe */
+ int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
+ for (i = 0; i < ext_limit; ++i) {
+ strcpy(curfullcmd, exe_extensions[i]);
+ res = GetFileAttributes(fullcmd);
+ if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
+ return fullcmd;
+ }
+
*curfullcmd = '\0';
}
DllExport char*
win32_get_childdir(void)
{
- dTHX;
char* ptr;
char szfilename[MAX_PATH+1];
DllExport void
win32_free_childdir(char* d)
{
- dTHX;
Safefree(d);
}
win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
{
#ifdef USE_RTL_SPAWNVP
- return spawnvp(mode, cmdname, (char * const *)argv);
+ return _spawnvp(mode, cmdname, (char * const *)argv);
#else
- dTHX;
+ return do_spawnvp_handles(mode, cmdname, argv, NULL);
+#endif
+}
+
+static int
+do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
+ const int *handles) {
+ dTHXa(NULL);
int ret;
void* env;
char* dir;
cmd = create_command_line(cname, clen, argv);
+ aTHXa(PERL_GET_THX);
env = PerlEnv_get_childenv();
dir = PerlEnv_get_childdir();
ret = -1;
goto RETVAL;
}
+
memset(&StartupInfo,0,sizeof(StartupInfo));
StartupInfo.cb = sizeof(StartupInfo);
memset(&tbl,0,sizeof(tbl));
StartupInfo.dwYCountChars = tbl.dwYCountChars;
StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
StartupInfo.wShowWindow = tbl.wShowWindow;
- StartupInfo.hStdInput = tbl.childStdIn;
- StartupInfo.hStdOutput = tbl.childStdOut;
- StartupInfo.hStdError = tbl.childStdErr;
+ StartupInfo.hStdInput = handles && handles[0] != -1 ?
+ (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
+ StartupInfo.hStdOutput = handles && handles[1] != -1 ?
+ (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
+ StartupInfo.hStdError = handles && handles[2] != -1 ?
+ (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
StartupInfo.hStdError == INVALID_HANDLE_VALUE)
* jump through our own hoops by picking out the path
* we really want it to use. */
if (!fullcmd) {
- fullcmd = qualified_path(cname);
+ fullcmd = qualified_path(cname, FALSE);
if (fullcmd) {
if (cname != cmdname)
Safefree(cname);
w32_child_pids[w32_num_children] = (DWORD)ret;
++w32_num_children;
}
- else {
+ else {
DWORD status;
win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
/* FIXME: if msgwait returned due to message perhaps forward the
if (cname != cmdname)
Safefree(cname);
return ret;
-#endif
}
DllExport int
/* if this is a pseudo-forked child, we just want to spawn
* the new program, and return */
if (w32_pseudo_id)
- return spawnv(P_WAIT, cmdname, argv);
+ return _spawnv(P_WAIT, cmdname, argv);
#endif
- return execv(cmdname, argv);
+ return _execv(cmdname, argv);
}
DllExport int
return status;
}
#endif
- return execvp(cmdname, argv);
+ return _execvp(cmdname, argv);
}
DllExport void
int fileno = win32_dup(win32_fileno(pf));
/* open the file in the same mode */
- if((pf)->_flag & _IOREAD) {
+ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
mode[0] = 'r';
mode[1] = 0;
}
- else if((pf)->_flag & _IOWRT) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
mode[0] = 'a';
mode[1] = 0;
}
- else if((pf)->_flag & _IORW) {
+ else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
mode[0] = 'r';
mode[1] = '+';
mode[2] = 0;
DllExport void*
win32_dynaload(const char* filename)
{
- dTHX;
+ dTHXa(NULL);
char buf[MAX_PATH+1];
- char *first;
+ const char *first;
/* LoadLibrary() doesn't recognize forward slashes correctly,
* so turn 'em back. */
filename = buf;
}
}
+ aTHXa(PERL_GET_THX);
return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
}
unsigned short showwindow = w32_showwindow;
if (items > 1)
- Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
+ croak_xs_usage(cv, "[showwindow]");
if (items == 0 || !SvOK(ST(0)))
w32_use_showwindow = FALSE;
XSRETURN(1);
}
+
+#ifdef PERL_IS_MINIPERL
+/* shelling out is much slower, full perl uses Win32.pm */
+XS(w32_GetCwd)
+{
+ dXSARGS;
+ /* Make the host for current directory */
+ char* ptr = PerlEnv_get_childdir();
+ /*
+ * If ptr != Nullch
+ * then it worked, set PV valid,
+ * else return 'undef'
+ */
+ if (ptr) {
+ SV *sv = sv_newmortal();
+ sv_setpv(sv, ptr);
+ PerlEnv_free_childdir(ptr);
+
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+
+ ST(0) = sv;
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+#endif
+
void
Perl_init_os_extras(void)
{
- dTHX;
+ dTHXa(NULL);
char *file = __FILE__;
/* Initialize Win32CORE if it has been statically linked. */
+#ifndef PERL_IS_MINIPERL
void (*pfn_init)(pTHX);
- pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
+ HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
+ ? GetModuleHandle(NULL)
+ : w32_perldll_handle);
+ pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
+ aTHXa(PERL_GET_THX);
if (pfn_init)
pfn_init(aTHX);
+#else
+ aTHXa(PERL_GET_THX);
+#endif
newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
+#ifdef PERL_IS_MINIPERL
+ newXS("Win32::GetCwd", w32_GetCwd, file);
+#endif
}
void *
/* fetch Unicode version of PATH */
len = 2000;
- wide_path = win32_malloc(len*sizeof(WCHAR));
+ wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
while (wide_path) {
size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
+ if (newlen == 0) {
+ win32_free(wide_path);
+ return;
+ }
if (newlen < len)
break;
len = newlen;
- wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
+ wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
}
if (!wide_path)
return;
ansi_len = strlen(ansi_dir);
if (ansi_path) {
size_t newlen = len + 1 + ansi_len;
- ansi_path = win32_realloc(ansi_path, newlen+1);
+ ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
if (!ansi_path)
break;
ansi_path[len] = ';';
}
else {
len = ansi_len;
- ansi_path = win32_malloc(5+len+1);
+ ansi_path = (char*)win32_malloc(5+len+1);
if (!ansi_path)
break;
memcpy(ansi_path, "PATH=", 5);
* 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 some runtime libraries 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(ansi_path);
}
win32_free(wide_path);
}
g_osver.dwOSVersionInfoSize = sizeof(g_osver);
GetVersionEx(&g_osver);
+#ifdef WIN32_DYN_IOINFO_SIZE
+ {
+ Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
+ if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
+ fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
+ exit(1);
+ }
+ ioinfo_size /= IOINFO_ARRAY_ELTS;
+ w32_ioinfo_size = ioinfo_size;
+ }
+#endif
+
ansify_path();
+
+#ifndef WIN32_NO_REGISTRY
+ {
+ LONG retval;
+ retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
+ if (retval != ERROR_SUCCESS) {
+ HKCU_Perl_hnd = NULL;
+ }
+ retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
+ if (retval != ERROR_SUCCESS) {
+ HKLM_Perl_hnd = NULL;
+ }
+ }
+#endif
}
void
Perl_win32_term(void)
{
- dTHX;
HINTS_REFCNT_TERM;
OP_REFCNT_TERM;
PERLIO_TERM;
MALLOC_TERM;
+ LOCALE_TERM;
+ ENV_TERM;
+#ifndef WIN32_NO_REGISTRY
+ /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
+ but no point of checking and we can't die() at this point */
+ RegCloseKey(HKLM_Perl_hnd);
+ RegCloseKey(HKCU_Perl_hnd);
+ /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
+#endif
}
void
Sighandler_t
win32_signal(int sig, Sighandler_t subcode)
{
- dTHX;
+ dTHXa(NULL);
if (sig < SIG_SIZE) {
int save_errno = errno;
- Sighandler_t result = signal(sig, subcode);
+ Sighandler_t result;
+#ifdef SET_INVALID_PARAMETER_HANDLER
+ /* Silence our invalid parameter handler since we expect to make some
+ * calls with invalid signal numbers giving a SIG_ERR result. */
+ BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
+#endif
+ result = signal(sig, subcode);
+#ifdef SET_INVALID_PARAMETER_HANDLER
+ set_silent_invalid_parameter_handler(oldvalue);
+#endif
+ aTHXa(PERL_GET_THX);
if (result == SIG_ERR) {
result = w32_sighandler[sig];
errno = save_errno;
* are relativley infrequent code-paths, is better than the added
* complexity of getting the correct context passed into
* win32_create_message_window() */
+ dTHX;
switch(msg) {
#ifdef USE_ITHREADS
case WM_USER_MESSAGE: {
- long child = find_pseudo_pid((int)wParam);
+ long child = find_pseudo_pid(aTHX_ (int)wParam);
if (child >= 0) {
- dTHX;
w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
return 1;
}
#endif
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))
}
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;
w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
w32_poll_count = 0;
+#ifdef PERL_IS_MINIPERL
+ w32_sloppystat = TRUE;
+#else
+ w32_sloppystat = FALSE;
+#endif
for (i=0; i < SIG_SIZE; i++) {
w32_sighandler[i] = SIG_DFL;
}
void
Perl_sys_intern_clear(pTHX)
{
+
Safefree(w32_perlshell_tokens);
Safefree(w32_perlshell_vec);
/* NOTE: w32_fdpid is freed by sv_clean_all() */
dst->timerid = 0;
dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
dst->poll_count = 0;
+ dst->sloppystat = src->sloppystat;
Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
}
# endif /* USE_ITHREADS */
https://perl5.git.perl.org / perl5.git / blobdiff