3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc.
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
16 # define Win32_Winsock
20 # define _WIN32_WINNT 0x0500 /* needed for CreateHardlink() etc. */
26 # define HWND_MESSAGE ((HWND)-3)
29 #ifndef PROCESSOR_ARCHITECTURE_AMD64
30 # define PROCESSOR_ARCHITECTURE_AMD64 9
33 #ifndef WC_NO_BEST_FIT_CHARS
34 # define WC_NO_BEST_FIT_CHARS 0x00000400
43 /* #include "config.h" */
45 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
54 #define PERL_NO_GET_CONTEXT
59 /* assert.h conflicts with #define of assert in perl.h */
68 #if defined(_MSC_VER) || defined(__MINGW32__)
69 # include <sys/utime.h>
75 /* Mingw32 defaults to globing command line
76 * So we turn it off like this:
81 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
82 /* Mingw32-1.1 is missing some prototypes */
84 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
85 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
86 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
92 #if defined(__BORLANDC__)
94 # define _utimbuf utimbuf
99 #define EXECF_SPAWN_NOWAIT 3
101 #if defined(PERL_IMPLICIT_SYS)
102 # undef win32_get_privlib
103 # define win32_get_privlib g_win32_get_privlib
104 # undef win32_get_sitelib
105 # define win32_get_sitelib g_win32_get_sitelib
106 # undef win32_get_vendorlib
107 # define win32_get_vendorlib g_win32_get_vendorlib
109 # define getlogin g_getlogin
112 static void get_shell(void);
113 static long tokenize(const char *str, char **dest, char ***destv);
114 static int do_spawn2(pTHX_ const char *cmd, int exectype);
115 static BOOL has_shell_metachars(const char *ptr);
116 static long filetime_to_clock(PFILETIME ft);
117 static BOOL filetime_from_time(PFILETIME ft, time_t t);
118 static char * get_emd_part(SV **leading, STRLEN *const len,
119 char *trailing, ...);
120 static void remove_dead_process(long deceased);
121 static long find_pid(int pid);
122 static char * qualified_path(const char *cmd);
123 static char * win32_get_xlib(const char *pl, const char *xlib,
124 const char *libname, STRLEN *const len);
125 static LRESULT win32_process_message(HWND hwnd, UINT msg,
126 WPARAM wParam, LPARAM lParam);
129 static void remove_dead_pseudo_process(long child);
130 static long find_pseudo_pid(int pid);
134 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
135 char w32_module_name[MAX_PATH+1];
138 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
141 /* Silence STDERR grumblings from Borland's math library. */
143 _matherr(struct _exception *a)
150 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
151 * parameter handler. This functionality is not available in the
152 * 64-bit compiler from the Platform SDK, which unfortunately also
153 * believes itself to be MSC version 14.
155 * There is no #define related to _set_invalid_parameter_handler(),
156 * but we can check for one of the constants defined for
157 * _set_abort_behavior(), which was introduced into stdlib.h at
161 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
162 # define SET_INVALID_PARAMETER_HANDLER
165 #ifdef SET_INVALID_PARAMETER_HANDLER
166 void my_invalid_parameter_handler(const wchar_t* expression,
167 const wchar_t* function,
173 wprintf(L"Invalid parameter detected in function %s."
174 L" File: %s Line: %d\n", function, file, line);
175 wprintf(L"Expression: %s\n", expression);
181 set_w32_module_name(void)
183 /* this function may be called at DLL_PROCESS_ATTACH time */
185 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
186 ? GetModuleHandle(NULL)
187 : w32_perldll_handle);
189 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
190 osver.dwOSVersionInfoSize = sizeof(osver);
191 GetVersionEx(&osver);
193 if (osver.dwMajorVersion > 4) {
194 WCHAR modulename[MAX_PATH];
195 WCHAR fullname[MAX_PATH];
198 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
199 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
200 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
202 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
204 /* Make sure we get an absolute pathname in case the module was loaded
205 * explicitly by LoadLibrary() with a relative path. */
206 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
208 /* Make sure we start with the long path name of the module because we
209 * later scan for pathname components to match "5.xx" to locate
210 * compatible sitelib directories, and the short pathname might mangle
211 * this path segment (e.g. by removing the dot on NTFS to something
212 * like "5xx~1.yy") */
213 if (pfnGetLongPathNameW)
214 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
216 /* remove \\?\ prefix */
217 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
218 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
220 ansi = win32_ansipath(fullname);
221 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
225 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
227 /* remove \\?\ prefix */
228 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
229 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
231 /* try to get full path to binary (which may be mangled when perl is
232 * run from a 16-bit app) */
233 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
234 win32_longpath(w32_module_name);
235 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
238 /* normalize to forward slashes */
239 ptr = w32_module_name;
247 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
249 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
251 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
254 const char *subkey = "Software\\Perl";
258 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
259 if (retval == ERROR_SUCCESS) {
261 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
262 if (retval == ERROR_SUCCESS
263 && (type == REG_SZ || type == REG_EXPAND_SZ))
267 *svp = sv_2mortal(newSVpvn("",0));
268 SvGROW(*svp, datalen);
269 retval = RegQueryValueEx(handle, valuename, 0, NULL,
270 (PBYTE)SvPVX(*svp), &datalen);
271 if (retval == ERROR_SUCCESS) {
273 SvCUR_set(*svp,datalen-1);
281 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
283 get_regstr(const char *valuename, SV **svp)
285 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
287 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
291 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
293 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
297 char mod_name[MAX_PATH+1];
303 va_start(ap, trailing_path);
304 strip = va_arg(ap, char *);
306 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
307 baselen = strlen(base);
309 if (!*w32_module_name) {
310 set_w32_module_name();
312 strcpy(mod_name, w32_module_name);
313 ptr = strrchr(mod_name, '/');
314 while (ptr && strip) {
315 /* look for directories to skip back */
318 ptr = strrchr(mod_name, '/');
319 /* avoid stripping component if there is no slash,
320 * or it doesn't match ... */
321 if (!ptr || stricmp(ptr+1, strip) != 0) {
322 /* ... but not if component matches m|5\.$patchlevel.*| */
323 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
324 && strncmp(strip, base, baselen) == 0
325 && strncmp(ptr+1, base, baselen) == 0))
331 strip = va_arg(ap, char *);
339 strcpy(++ptr, trailing_path);
341 /* only add directory if it exists */
342 if (GetFileAttributes(mod_name) != (DWORD) -1) {
343 /* directory exists */
346 *prev_pathp = sv_2mortal(newSVpvn("",0));
347 else if (SvPVX(*prev_pathp))
348 sv_catpvn(*prev_pathp, ";", 1);
349 sv_catpv(*prev_pathp, mod_name);
351 *len = SvCUR(*prev_pathp);
352 return SvPVX(*prev_pathp);
359 win32_get_privlib(const char *pl, STRLEN *const len)
362 char *stdlib = "lib";
363 char buffer[MAX_PATH+1];
366 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
367 sprintf(buffer, "%s-%s", stdlib, pl);
368 if (!get_regstr(buffer, &sv))
369 (void)get_regstr(stdlib, &sv);
371 /* $stdlib .= ";$EMD/../../lib" */
372 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
376 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
381 char pathstr[MAX_PATH+1];
385 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
386 sprintf(regstr, "%s-%s", xlib, pl);
387 (void)get_regstr(regstr, &sv1);
390 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
391 sprintf(pathstr, "%s/%s/lib", libname, pl);
392 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
394 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
395 (void)get_regstr(xlib, &sv2);
398 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
399 sprintf(pathstr, "%s/lib", libname);
400 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
407 sv_catpvn(sv1, ";", 1);
417 win32_get_sitelib(const char *pl, STRLEN *const len)
419 return win32_get_xlib(pl, "sitelib", "site", len);
422 #ifndef PERL_VENDORLIB_NAME
423 # define PERL_VENDORLIB_NAME "vendor"
427 win32_get_vendorlib(const char *pl, STRLEN *const len)
429 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
433 has_shell_metachars(const char *ptr)
439 * Scan string looking for redirection (< or >) or pipe
440 * characters (|) that are not in a quoted string.
441 * Shell variable interpolation (%VAR%) can also happen inside strings.
473 #if !defined(PERL_IMPLICIT_SYS)
474 /* since the current process environment is being updated in util.c
475 * the library functions will get the correct environment
478 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
480 PERL_FLUSHALL_FOR_CHILD;
481 return win32_popen(cmd, mode);
485 Perl_my_pclose(pTHX_ PerlIO *fp)
487 return win32_pclose(fp);
491 DllExport unsigned long
494 return (unsigned long)g_osver.dwPlatformId;
503 return -((int)w32_pseudo_id);
508 /* Tokenize a string. Words are null-separated, and the list
509 * ends with a doubled null. Any character (except null and
510 * including backslash) may be escaped by preceding it with a
511 * backslash (the backslash will be stripped).
512 * Returns number of words in result buffer.
515 tokenize(const char *str, char **dest, char ***destv)
517 char *retstart = NULL;
518 char **retvstart = 0;
522 int slen = strlen(str);
524 register char **retv;
525 Newx(ret, slen+2, char);
526 Newx(retv, (slen+3)/2, char*);
534 if (*ret == '\\' && *str)
536 else if (*ret == ' ') {
552 retvstart[items] = NULL;
565 if (!w32_perlshell_tokens) {
566 /* we don't use COMSPEC here for two reasons:
567 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
568 * uncontrolled unportability of the ensuing scripts.
569 * 2. PERL5SHELL could be set to a shell that may not be fit for
570 * interactive use (which is what most programs look in COMSPEC
573 const char* defaultshell = "cmd.exe /x/d/c";
574 const char *usershell = PerlEnv_getenv("PERL5SHELL");
575 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
576 &w32_perlshell_tokens,
582 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
590 PERL_ARGS_ASSERT_DO_ASPAWN;
596 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
598 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
603 while (++mark <= sp) {
604 if (*mark && (str = SvPV_nolen(*mark)))
611 status = win32_spawnvp(flag,
612 (const char*)(really ? SvPV_nolen(really) : argv[0]),
613 (const char* const*)argv);
615 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
616 /* possible shell-builtin, invoke with shell */
618 sh_items = w32_perlshell_items;
620 argv[index+sh_items] = argv[index];
621 while (--sh_items >= 0)
622 argv[sh_items] = w32_perlshell_vec[sh_items];
624 status = win32_spawnvp(flag,
625 (const char*)(really ? SvPV_nolen(really) : argv[0]),
626 (const char* const*)argv);
629 if (flag == P_NOWAIT) {
630 PL_statusvalue = -1; /* >16bits hint for pp_system() */
634 if (ckWARN(WARN_EXEC))
635 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
640 PL_statusvalue = status;
646 /* returns pointer to the next unquoted space or the end of the string */
648 find_next_space(const char *s)
650 bool in_quotes = FALSE;
652 /* ignore doubled backslashes, or backslash+quote */
653 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
656 /* keep track of when we're within quotes */
657 else if (*s == '"') {
659 in_quotes = !in_quotes;
661 /* break it up only at spaces that aren't in quotes */
662 else if (!in_quotes && isSPACE(*s))
671 do_spawn2(pTHX_ const char *cmd, int exectype)
677 BOOL needToTry = TRUE;
680 /* Save an extra exec if possible. See if there are shell
681 * metacharacters in it */
682 if (!has_shell_metachars(cmd)) {
683 Newx(argv, strlen(cmd) / 2 + 2, char*);
684 Newx(cmd2, strlen(cmd) + 1, char);
687 for (s = cmd2; *s;) {
688 while (*s && isSPACE(*s))
692 s = find_next_space(s);
700 status = win32_spawnvp(P_WAIT, argv[0],
701 (const char* const*)argv);
703 case EXECF_SPAWN_NOWAIT:
704 status = win32_spawnvp(P_NOWAIT, argv[0],
705 (const char* const*)argv);
708 status = win32_execvp(argv[0], (const char* const*)argv);
711 if (status != -1 || errno == 0)
721 Newx(argv, w32_perlshell_items + 2, char*);
722 while (++i < w32_perlshell_items)
723 argv[i] = w32_perlshell_vec[i];
724 argv[i++] = (char *)cmd;
728 status = win32_spawnvp(P_WAIT, argv[0],
729 (const char* const*)argv);
731 case EXECF_SPAWN_NOWAIT:
732 status = win32_spawnvp(P_NOWAIT, argv[0],
733 (const char* const*)argv);
736 status = win32_execvp(argv[0], (const char* const*)argv);
742 if (exectype == EXECF_SPAWN_NOWAIT) {
743 PL_statusvalue = -1; /* >16bits hint for pp_system() */
747 if (ckWARN(WARN_EXEC))
748 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
749 (exectype == EXECF_EXEC ? "exec" : "spawn"),
750 cmd, strerror(errno));
755 PL_statusvalue = status;
761 Perl_do_spawn(pTHX_ char *cmd)
763 PERL_ARGS_ASSERT_DO_SPAWN;
765 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
769 Perl_do_spawn_nowait(pTHX_ char *cmd)
771 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
773 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
777 Perl_do_exec(pTHX_ const char *cmd)
779 PERL_ARGS_ASSERT_DO_EXEC;
781 do_spawn2(aTHX_ cmd, EXECF_EXEC);
785 /* The idea here is to read all the directory names into a string table
786 * (separated by nulls) and when one of the other dir functions is called
787 * return the pointer to the current file name.
790 win32_opendir(const char *filename)
796 char scanname[MAX_PATH+3];
797 WCHAR wscanname[sizeof(scanname)];
798 WIN32_FIND_DATAW wFindData;
799 char buffer[MAX_PATH*2];
802 len = strlen(filename);
807 if (len > MAX_PATH) {
808 errno = ENAMETOOLONG;
812 /* Get us a DIR structure */
815 /* Create the search pattern */
816 strcpy(scanname, filename);
818 /* bare drive name means look in cwd for drive */
819 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
820 scanname[len++] = '.';
821 scanname[len++] = '/';
823 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
824 scanname[len++] = '/';
826 scanname[len++] = '*';
827 scanname[len] = '\0';
829 /* do the FindFirstFile call */
830 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
831 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
833 if (dirp->handle == INVALID_HANDLE_VALUE) {
834 DWORD err = GetLastError();
835 /* FindFirstFile() fails on empty drives! */
837 case ERROR_FILE_NOT_FOUND:
839 case ERROR_NO_MORE_FILES:
840 case ERROR_PATH_NOT_FOUND:
843 case ERROR_NOT_ENOUGH_MEMORY:
855 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
856 wFindData.cFileName, -1,
857 buffer, sizeof(buffer), NULL, &use_default);
858 if (use_default && *wFindData.cAlternateFileName) {
859 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
860 wFindData.cAlternateFileName, -1,
861 buffer, sizeof(buffer), NULL, NULL);
864 /* now allocate the first part of the string table for
865 * the filenames that we find.
867 idx = strlen(buffer)+1;
872 Newx(dirp->start, dirp->size, char);
873 strcpy(dirp->start, buffer);
875 dirp->end = dirp->curr = dirp->start;
881 /* Readdir just returns the current string pointer and bumps the
882 * string pointer to the nDllExport entry.
884 DllExport struct direct *
885 win32_readdir(DIR *dirp)
890 /* first set up the structure to return */
891 len = strlen(dirp->curr);
892 strcpy(dirp->dirstr.d_name, dirp->curr);
893 dirp->dirstr.d_namlen = len;
896 dirp->dirstr.d_ino = dirp->curr - dirp->start;
898 /* Now set up for the next call to readdir */
899 dirp->curr += len + 1;
900 if (dirp->curr >= dirp->end) {
903 char buffer[MAX_PATH*2];
905 if (dirp->handle == INVALID_HANDLE_VALUE) {
908 /* finding the next file that matches the wildcard
909 * (which should be all of them in this directory!).
912 WIN32_FIND_DATAW wFindData;
913 res = FindNextFileW(dirp->handle, &wFindData);
915 BOOL use_default = FALSE;
916 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
917 wFindData.cFileName, -1,
918 buffer, sizeof(buffer), NULL, &use_default);
919 if (use_default && *wFindData.cAlternateFileName) {
920 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
921 wFindData.cAlternateFileName, -1,
922 buffer, sizeof(buffer), NULL, NULL);
927 long endpos = dirp->end - dirp->start;
928 long newsize = endpos + strlen(buffer) + 1;
929 /* bump the string table size by enough for the
930 * new name and its null terminator */
931 while (newsize > dirp->size) {
932 long curpos = dirp->curr - dirp->start;
934 Renew(dirp->start, dirp->size, char);
935 dirp->curr = dirp->start + curpos;
937 strcpy(dirp->start + endpos, buffer);
938 dirp->end = dirp->start + newsize;
943 if (dirp->handle != INVALID_HANDLE_VALUE) {
944 FindClose(dirp->handle);
945 dirp->handle = INVALID_HANDLE_VALUE;
949 return &(dirp->dirstr);
955 /* Telldir returns the current string pointer position */
957 win32_telldir(DIR *dirp)
959 return dirp->curr ? (dirp->curr - dirp->start) : -1;
963 /* Seekdir moves the string pointer to a previously saved position
964 * (returned by telldir).
967 win32_seekdir(DIR *dirp, long loc)
969 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
972 /* Rewinddir resets the string pointer to the start */
974 win32_rewinddir(DIR *dirp)
976 dirp->curr = dirp->start;
979 /* free the memory allocated by opendir */
981 win32_closedir(DIR *dirp)
984 if (dirp->handle != INVALID_HANDLE_VALUE)
985 FindClose(dirp->handle);
986 Safefree(dirp->start);
991 /* duplicate a open DIR* for interpreter cloning */
993 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
996 PerlInterpreter *const from = param->proto_perl;
997 PerlInterpreter *const to = PERL_GET_THX;
1002 /* switch back to original interpreter because win32_readdir()
1003 * might Renew(dirp->start).
1009 /* mark current position; read all remaining entries into the
1010 * cache, and then restore to current position.
1012 pos = win32_telldir(dirp);
1013 while (win32_readdir(dirp)) {
1014 /* read all entries into cache */
1016 win32_seekdir(dirp, pos);
1018 /* switch back to new interpreter to allocate new DIR structure */
1024 memcpy(dup, dirp, sizeof(DIR));
1026 Newx(dup->start, dirp->size, char);
1027 memcpy(dup->start, dirp->start, dirp->size);
1029 dup->end = dup->start + (dirp->end - dirp->start);
1031 dup->curr = dup->start + (dirp->curr - dirp->start);
1043 * Just pretend that everyone is a superuser. NT will let us know if
1044 * we don\'t really have permission to do something.
1047 #define ROOT_UID ((uid_t)0)
1048 #define ROOT_GID ((gid_t)0)
1077 return (auid == ROOT_UID ? 0 : -1);
1083 return (agid == ROOT_GID ? 0 : -1);
1090 char *buf = w32_getlogin_buffer;
1091 DWORD size = sizeof(w32_getlogin_buffer);
1092 if (GetUserName(buf,&size))
1098 chown(const char *path, uid_t owner, gid_t group)
1105 * XXX this needs strengthening (for PerlIO)
1108 int mkstemp(const char *path)
1111 char buf[MAX_PATH+1];
1115 if (i++ > 10) { /* give up */
1119 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1123 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1133 long child = w32_num_children;
1134 while (--child >= 0) {
1135 if ((int)w32_child_pids[child] == pid)
1142 remove_dead_process(long child)
1146 CloseHandle(w32_child_handles[child]);
1147 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1148 (w32_num_children-child-1), HANDLE);
1149 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1150 (w32_num_children-child-1), DWORD);
1157 find_pseudo_pid(int pid)
1160 long child = w32_num_pseudo_children;
1161 while (--child >= 0) {
1162 if ((int)w32_pseudo_child_pids[child] == pid)
1169 remove_dead_pseudo_process(long child)
1173 CloseHandle(w32_pseudo_child_handles[child]);
1174 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1175 (w32_num_pseudo_children-child-1), HANDLE);
1176 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1177 (w32_num_pseudo_children-child-1), DWORD);
1178 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1179 (w32_num_pseudo_children-child-1), HWND);
1180 w32_num_pseudo_children--;
1186 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1190 /* "Does process exist?" use of kill */
1193 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1198 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1201 default: /* For now be backwards compatible with perl 5.6 */
1203 /* Note that we will only be able to kill processes owned by the
1204 * current process owner, even when we are running as an administrator.
1205 * To kill processes of other owners we would need to set the
1206 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1208 if (TerminateProcess(process_handle, sig))
1216 killpg(int pid, int sig)
1218 HANDLE process_handle;
1219 HANDLE snapshot_handle;
1222 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1223 if (process_handle == NULL)
1226 killed += terminate_process(pid, process_handle, sig);
1228 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1229 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1230 PROCESSENTRY32 entry;
1232 entry.dwSize = sizeof(entry);
1233 if (Process32First(snapshot_handle, &entry)) {
1235 if (entry.th32ParentProcessID == (DWORD)pid)
1236 killed += killpg(entry.th32ProcessID, sig);
1237 entry.dwSize = sizeof(entry);
1239 while (Process32Next(snapshot_handle, &entry));
1241 CloseHandle(snapshot_handle);
1243 CloseHandle(process_handle);
1248 my_kill(int pid, int sig)
1251 HANDLE process_handle;
1254 return killpg(pid, -sig);
1256 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1257 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1258 if (process_handle != NULL) {
1259 retval = terminate_process(pid, process_handle, sig);
1260 CloseHandle(process_handle);
1266 win32_kill(int pid, int sig)
1272 /* it is a pseudo-forked child */
1273 child = find_pseudo_pid(-pid);
1275 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1276 HANDLE hProcess = w32_pseudo_child_handles[child];
1279 /* "Does process exist?" use of kill */
1283 /* kill -9 style un-graceful exit */
1284 if (TerminateThread(hProcess, sig)) {
1285 /* Allow the scheduler to finish cleaning up the other thread.
1286 * Otherwise, if we ExitProcess() before another context switch
1287 * happens we will end up with a process exit code of "sig" instead
1288 * of our own exit status.
1289 * See also: https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1292 remove_dead_pseudo_process(child);
1299 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1300 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1301 /* Yield and wait for the other thread to send us its message_hwnd */
1303 win32_async_check(aTHX);
1304 hwnd = w32_pseudo_child_message_hwnds[child];
1307 if (hwnd != INVALID_HANDLE_VALUE) {
1308 /* We fake signals to pseudo-processes using Win32
1309 * message queue. In Win9X the pids are negative already. */
1310 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1311 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1313 /* Don't wait for child process to terminate after we send a SIGTERM
1314 * because the child may be blocked in a system call and never receive
1317 if (sig == SIGTERM) {
1319 remove_dead_pseudo_process(child);
1321 /* It might be us ... */
1334 child = find_pid(pid);
1336 if (my_kill(pid, sig)) {
1338 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1339 exitcode != STILL_ACTIVE)
1341 remove_dead_process(child);
1347 if (my_kill(pid, sig))
1356 win32_stat(const char *path, Stat_t *sbuf)
1359 char buffer[MAX_PATH+1];
1360 int l = strlen(path);
1363 BOOL expect_dir = FALSE;
1365 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1366 GV_NOTQUAL, SVt_PV);
1367 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1370 switch(path[l - 1]) {
1371 /* FindFirstFile() and stat() are buggy with a trailing
1372 * slashes, except for the root directory of a drive */
1375 if (l > sizeof(buffer)) {
1376 errno = ENAMETOOLONG;
1380 strncpy(buffer, path, l);
1381 /* remove additional trailing slashes */
1382 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1384 /* add back slash if we otherwise end up with just a drive letter */
1385 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1392 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1394 if (l == 2 && isALPHA(path[0])) {
1395 buffer[0] = path[0];
1406 path = PerlDir_mapA(path);
1410 /* We must open & close the file once; otherwise file attribute changes */
1411 /* might not yet have propagated to "other" hard links of the same file. */
1412 /* This also gives us an opportunity to determine the number of links. */
1413 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1414 if (handle != INVALID_HANDLE_VALUE) {
1415 BY_HANDLE_FILE_INFORMATION bhi;
1416 if (GetFileInformationByHandle(handle, &bhi))
1417 nlink = bhi.nNumberOfLinks;
1418 CloseHandle(handle);
1422 /* path will be mapped correctly above */
1423 #if defined(WIN64) || defined(USE_LARGE_FILES)
1424 res = _stati64(path, sbuf);
1426 res = stat(path, sbuf);
1428 sbuf->st_nlink = nlink;
1431 /* CRT is buggy on sharenames, so make sure it really isn't.
1432 * XXX using GetFileAttributesEx() will enable us to set
1433 * sbuf->st_*time (but note that's not available on the
1434 * Windows of 1995) */
1435 DWORD r = GetFileAttributesA(path);
1436 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1437 /* sbuf may still contain old garbage since stat() failed */
1438 Zero(sbuf, 1, Stat_t);
1439 sbuf->st_mode = S_IFDIR | S_IREAD;
1441 if (!(r & FILE_ATTRIBUTE_READONLY))
1442 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1447 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1448 && (path[2] == '\\' || path[2] == '/'))
1450 /* The drive can be inaccessible, some _stat()s are buggy */
1451 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1456 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1460 if (S_ISDIR(sbuf->st_mode)) {
1461 /* Ensure the "write" bit is switched off in the mode for
1462 * directories with the read-only attribute set. Borland (at least)
1463 * switches it on for directories, which is technically correct
1464 * (directories are indeed always writable unless denied by DACLs),
1465 * but we want stat() and -w to reflect the state of the read-only
1466 * attribute for symmetry with chmod(). */
1467 DWORD r = GetFileAttributesA(path);
1468 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1469 sbuf->st_mode &= ~S_IWRITE;
1473 if (S_ISDIR(sbuf->st_mode)) {
1474 sbuf->st_mode |= S_IEXEC;
1476 else if (S_ISREG(sbuf->st_mode)) {
1478 if (l >= 4 && path[l-4] == '.') {
1479 const char *e = path + l - 3;
1480 if (strnicmp(e,"exe",3)
1481 && strnicmp(e,"bat",3)
1482 && strnicmp(e,"com",3)
1483 && strnicmp(e,"cmd",3))
1484 sbuf->st_mode &= ~S_IEXEC;
1486 sbuf->st_mode |= S_IEXEC;
1489 sbuf->st_mode &= ~S_IEXEC;
1490 /* Propagate permissions to _group_ and _others_ */
1491 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1492 sbuf->st_mode |= (perms>>3) | (perms>>6);
1499 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1500 #define SKIP_SLASHES(s) \
1502 while (*(s) && isSLASH(*(s))) \
1505 #define COPY_NONSLASHES(d,s) \
1507 while (*(s) && !isSLASH(*(s))) \
1511 /* Find the longname of a given path. path is destructively modified.
1512 * It should have space for at least MAX_PATH characters. */
1514 win32_longpath(char *path)
1516 WIN32_FIND_DATA fdata;
1518 char tmpbuf[MAX_PATH+1];
1519 char *tmpstart = tmpbuf;
1526 if (isALPHA(path[0]) && path[1] == ':') {
1528 *tmpstart++ = path[0];
1532 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1534 *tmpstart++ = path[0];
1535 *tmpstart++ = path[1];
1536 SKIP_SLASHES(start);
1537 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1539 *tmpstart++ = *start++;
1540 SKIP_SLASHES(start);
1541 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1546 /* copy initial slash, if any */
1547 if (isSLASH(*start)) {
1548 *tmpstart++ = *start++;
1550 SKIP_SLASHES(start);
1553 /* FindFirstFile() expands "." and "..", so we need to pass
1554 * those through unmolested */
1556 && (!start[1] || isSLASH(start[1])
1557 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1559 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1564 /* if this is the end, bust outta here */
1568 /* now we're at a non-slash; walk up to next slash */
1569 while (*start && !isSLASH(*start))
1572 /* stop and find full name of component */
1575 fhand = FindFirstFile(path,&fdata);
1577 if (fhand != INVALID_HANDLE_VALUE) {
1578 STRLEN len = strlen(fdata.cFileName);
1579 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1580 strcpy(tmpstart, fdata.cFileName);
1591 /* failed a step, just return without side effects */
1592 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1597 strcpy(path,tmpbuf);
1606 /* Can't use PerlIO to write as it allocates memory */
1607 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1608 PL_no_mem, strlen(PL_no_mem));
1614 /* The win32_ansipath() function takes a Unicode filename and converts it
1615 * into the current Windows codepage. If some characters cannot be mapped,
1616 * then it will convert the short name instead.
1618 * The buffer to the ansi pathname must be freed with win32_free() when it
1619 * it no longer needed.
1621 * The argument to win32_ansipath() must exist before this function is
1622 * called; otherwise there is no way to determine the short path name.
1624 * Ideas for future refinement:
1625 * - Only convert those segments of the path that are not in the current
1626 * codepage, but leave the other segments in their long form.
1627 * - If the resulting name is longer than MAX_PATH, start converting
1628 * additional path segments into short names until the full name
1629 * is shorter than MAX_PATH. Shorten the filename part last!
1632 win32_ansipath(const WCHAR *widename)
1635 BOOL use_default = FALSE;
1636 size_t widelen = wcslen(widename)+1;
1637 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1638 NULL, 0, NULL, NULL);
1639 name = win32_malloc(len);
1643 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1644 name, len, NULL, &use_default);
1646 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1648 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1651 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1653 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1654 NULL, 0, NULL, NULL);
1655 name = win32_realloc(name, len);
1658 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1659 name, len, NULL, NULL);
1660 win32_free(shortname);
1667 win32_getenv(const char *name)
1673 needlen = GetEnvironmentVariableA(name,NULL,0);
1675 curitem = sv_2mortal(newSVpvn("", 0));
1677 SvGROW(curitem, needlen+1);
1678 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1680 } while (needlen >= SvLEN(curitem));
1681 SvCUR_set(curitem, needlen);
1684 /* allow any environment variables that begin with 'PERL'
1685 to be stored in the registry */
1686 if (strncmp(name, "PERL", 4) == 0)
1687 (void)get_regstr(name, &curitem);
1689 if (curitem && SvCUR(curitem))
1690 return SvPVX(curitem);
1696 win32_putenv(const char *name)
1704 Newx(curitem,strlen(name)+1,char);
1705 strcpy(curitem, name);
1706 val = strchr(curitem, '=');
1708 /* The sane way to deal with the environment.
1709 * Has these advantages over putenv() & co.:
1710 * * enables us to store a truly empty value in the
1711 * environment (like in UNIX).
1712 * * we don't have to deal with RTL globals, bugs and leaks
1713 * (specifically, see http://support.microsoft.com/kb/235601).
1715 * Why you may want to use the RTL environment handling
1716 * (previously enabled by USE_WIN32_RTL_ENV):
1717 * * environ[] and RTL functions will not reflect changes,
1718 * which might be an issue if extensions want to access
1719 * the env. via RTL. This cuts both ways, since RTL will
1720 * not see changes made by extensions that call the Win32
1721 * functions directly, either.
1725 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1734 filetime_to_clock(PFILETIME ft)
1736 __int64 qw = ft->dwHighDateTime;
1738 qw |= ft->dwLowDateTime;
1739 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1744 win32_times(struct tms *timebuf)
1749 clock_t process_time_so_far = clock();
1750 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1752 timebuf->tms_utime = filetime_to_clock(&user);
1753 timebuf->tms_stime = filetime_to_clock(&kernel);
1754 timebuf->tms_cutime = 0;
1755 timebuf->tms_cstime = 0;
1757 /* That failed - e.g. Win95 fallback to clock() */
1758 timebuf->tms_utime = process_time_so_far;
1759 timebuf->tms_stime = 0;
1760 timebuf->tms_cutime = 0;
1761 timebuf->tms_cstime = 0;
1763 return process_time_so_far;
1766 /* fix utime() so it works on directories in NT */
1768 filetime_from_time(PFILETIME pFileTime, time_t Time)
1770 struct tm *pTM = localtime(&Time);
1771 SYSTEMTIME SystemTime;
1777 SystemTime.wYear = pTM->tm_year + 1900;
1778 SystemTime.wMonth = pTM->tm_mon + 1;
1779 SystemTime.wDay = pTM->tm_mday;
1780 SystemTime.wHour = pTM->tm_hour;
1781 SystemTime.wMinute = pTM->tm_min;
1782 SystemTime.wSecond = pTM->tm_sec;
1783 SystemTime.wMilliseconds = 0;
1785 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1786 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1790 win32_unlink(const char *filename)
1796 filename = PerlDir_mapA(filename);
1797 attrs = GetFileAttributesA(filename);
1798 if (attrs == 0xFFFFFFFF) {
1802 if (attrs & FILE_ATTRIBUTE_READONLY) {
1803 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1804 ret = unlink(filename);
1806 (void)SetFileAttributesA(filename, attrs);
1809 ret = unlink(filename);
1814 win32_utime(const char *filename, struct utimbuf *times)
1821 struct utimbuf TimeBuffer;
1824 filename = PerlDir_mapA(filename);
1825 rc = utime(filename, times);
1827 /* EACCES: path specifies directory or readonly file */
1828 if (rc == 0 || errno != EACCES)
1831 if (times == NULL) {
1832 times = &TimeBuffer;
1833 time(×->actime);
1834 times->modtime = times->actime;
1837 /* This will (and should) still fail on readonly files */
1838 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1839 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1840 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1841 if (handle == INVALID_HANDLE_VALUE)
1844 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1845 filetime_from_time(&ftAccess, times->actime) &&
1846 filetime_from_time(&ftWrite, times->modtime) &&
1847 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1852 CloseHandle(handle);
1857 unsigned __int64 ft_i64;
1862 #define Const64(x) x##LL
1864 #define Const64(x) x##i64
1866 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1867 #define EPOCH_BIAS Const64(116444736000000000)
1869 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1870 * and appears to be unsupported even by glibc) */
1872 win32_gettimeofday(struct timeval *tp, void *not_used)
1876 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1877 GetSystemTimeAsFileTime(&ft.ft_val);
1879 /* seconds since epoch */
1880 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1882 /* microseconds remaining */
1883 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1889 win32_uname(struct utsname *name)
1891 struct hostent *hep;
1892 STRLEN nodemax = sizeof(name->nodename)-1;
1895 switch (g_osver.dwPlatformId) {
1896 case VER_PLATFORM_WIN32_WINDOWS:
1897 strcpy(name->sysname, "Windows");
1899 case VER_PLATFORM_WIN32_NT:
1900 strcpy(name->sysname, "Windows NT");
1902 case VER_PLATFORM_WIN32s:
1903 strcpy(name->sysname, "Win32s");
1906 strcpy(name->sysname, "Win32 Unknown");
1911 sprintf(name->release, "%d.%d",
1912 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1915 sprintf(name->version, "Build %d",
1916 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1917 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1918 if (g_osver.szCSDVersion[0]) {
1919 char *buf = name->version + strlen(name->version);
1920 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1924 hep = win32_gethostbyname("localhost");
1926 STRLEN len = strlen(hep->h_name);
1927 if (len <= nodemax) {
1928 strcpy(name->nodename, hep->h_name);
1931 strncpy(name->nodename, hep->h_name, nodemax);
1932 name->nodename[nodemax] = '\0';
1937 if (!GetComputerName(name->nodename, &sz))
1938 *name->nodename = '\0';
1941 /* machine (architecture) */
1946 GetSystemInfo(&info);
1948 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1949 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
1950 procarch = info.u.s.wProcessorArchitecture;
1952 procarch = info.wProcessorArchitecture;
1955 case PROCESSOR_ARCHITECTURE_INTEL:
1956 arch = "x86"; break;
1957 case PROCESSOR_ARCHITECTURE_IA64:
1958 arch = "ia64"; break;
1959 case PROCESSOR_ARCHITECTURE_AMD64:
1960 arch = "amd64"; break;
1961 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1962 arch = "unknown"; break;
1964 sprintf(name->machine, "unknown(0x%x)", procarch);
1965 arch = name->machine;
1968 if (name->machine != arch)
1969 strcpy(name->machine, arch);
1974 /* Timing related stuff */
1977 do_raise(pTHX_ int sig)
1979 if (sig < SIG_SIZE) {
1980 Sighandler_t handler = w32_sighandler[sig];
1981 if (handler == SIG_IGN) {
1984 else if (handler != SIG_DFL) {
1989 /* Choose correct default behaviour */
2005 /* Tell caller to exit thread/process as approriate */
2010 sig_terminate(pTHX_ int sig)
2012 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2013 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2020 win32_async_check(pTHX)
2023 HWND hwnd = w32_message_hwnd;
2025 /* Reset w32_poll_count before doing anything else, incase we dispatch
2026 * messages that end up calling back into perl */
2029 if (hwnd != INVALID_HANDLE_VALUE) {
2030 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2031 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2036 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2037 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2039 /* re-post a WM_QUIT message (we'll mark it as read later) */
2040 if(msg.message == WM_QUIT) {
2041 PostQuitMessage((int)msg.wParam);
2045 if(!CallMsgFilter(&msg, MSGF_USER))
2047 TranslateMessage(&msg);
2048 DispatchMessage(&msg);
2053 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2054 * This is necessary when we are being called by win32_msgwait() to
2055 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2056 * message over and over. An example how this can happen is when
2057 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2058 * is generating messages before the process terminated.
2060 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2062 /* Above or other stuff may have set a signal flag */
2069 /* This function will not return until the timeout has elapsed, or until
2070 * one of the handles is ready. */
2072 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2074 /* We may need several goes at this - so compute when we stop */
2076 if (timeout != INFINITE) {
2077 ticks = GetTickCount();
2081 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2084 if (result == WAIT_TIMEOUT) {
2085 /* Ran out of time - explicit return of zero to avoid -ve if we
2086 have scheduling issues
2090 if (timeout != INFINITE) {
2091 ticks = GetTickCount();
2093 if (result == WAIT_OBJECT_0 + count) {
2094 /* Message has arrived - check it */
2095 (void)win32_async_check(aTHX);
2098 /* Not timeout or message - one of handles is ready */
2102 /* compute time left to wait */
2103 ticks = timeout - ticks;
2104 /* If we are past the end say zero */
2105 return (ticks > 0) ? ticks : 0;
2109 win32_internal_wait(int *status, DWORD timeout)
2111 /* XXX this wait emulation only knows about processes
2112 * spawned via win32_spawnvp(P_NOWAIT, ...).
2116 DWORD exitcode, waitcode;
2119 if (w32_num_pseudo_children) {
2120 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2121 timeout, &waitcode);
2122 /* Time out here if there are no other children to wait for. */
2123 if (waitcode == WAIT_TIMEOUT) {
2124 if (!w32_num_children) {
2128 else if (waitcode != WAIT_FAILED) {
2129 if (waitcode >= WAIT_ABANDONED_0
2130 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2131 i = waitcode - WAIT_ABANDONED_0;
2133 i = waitcode - WAIT_OBJECT_0;
2134 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2135 *status = (int)((exitcode & 0xff) << 8);
2136 retval = (int)w32_pseudo_child_pids[i];
2137 remove_dead_pseudo_process(i);
2144 if (!w32_num_children) {
2149 /* if a child exists, wait for it to die */
2150 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2151 if (waitcode == WAIT_TIMEOUT) {
2154 if (waitcode != WAIT_FAILED) {
2155 if (waitcode >= WAIT_ABANDONED_0
2156 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2157 i = waitcode - WAIT_ABANDONED_0;
2159 i = waitcode - WAIT_OBJECT_0;
2160 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2161 *status = (int)((exitcode & 0xff) << 8);
2162 retval = (int)w32_child_pids[i];
2163 remove_dead_process(i);
2168 errno = GetLastError();
2173 win32_waitpid(int pid, int *status, int flags)
2176 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2179 if (pid == -1) /* XXX threadid == 1 ? */
2180 return win32_internal_wait(status, timeout);
2183 child = find_pseudo_pid(-pid);
2185 HANDLE hThread = w32_pseudo_child_handles[child];
2187 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2188 if (waitcode == WAIT_TIMEOUT) {
2191 else if (waitcode == WAIT_OBJECT_0) {
2192 if (GetExitCodeThread(hThread, &waitcode)) {
2193 *status = (int)((waitcode & 0xff) << 8);
2194 retval = (int)w32_pseudo_child_pids[child];
2195 remove_dead_pseudo_process(child);
2207 child = find_pid(pid);
2209 hProcess = w32_child_handles[child];
2210 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2211 if (waitcode == WAIT_TIMEOUT) {
2214 else if (waitcode == WAIT_OBJECT_0) {
2215 if (GetExitCodeProcess(hProcess, &waitcode)) {
2216 *status = (int)((waitcode & 0xff) << 8);
2217 retval = (int)w32_child_pids[child];
2218 remove_dead_process(child);
2226 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2228 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2229 if (waitcode == WAIT_TIMEOUT) {
2230 CloseHandle(hProcess);
2233 else if (waitcode == WAIT_OBJECT_0) {
2234 if (GetExitCodeProcess(hProcess, &waitcode)) {
2235 *status = (int)((waitcode & 0xff) << 8);
2236 CloseHandle(hProcess);
2240 CloseHandle(hProcess);
2246 return retval >= 0 ? pid : retval;
2250 win32_wait(int *status)
2252 return win32_internal_wait(status, INFINITE);
2255 DllExport unsigned int
2256 win32_sleep(unsigned int t)
2259 /* Win32 times are in ms so *1000 in and /1000 out */
2260 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2263 DllExport unsigned int
2264 win32_alarm(unsigned int sec)
2267 * the 'obvious' implentation is SetTimer() with a callback
2268 * which does whatever receiving SIGALRM would do
2269 * we cannot use SIGALRM even via raise() as it is not
2270 * one of the supported codes in <signal.h>
2274 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2275 w32_message_hwnd = win32_create_message_window();
2278 if (w32_message_hwnd == NULL)
2279 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2282 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2287 KillTimer(w32_message_hwnd, w32_timerid);
2294 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2297 win32_crypt(const char *txt, const char *salt)
2300 return des_fcrypt(txt, salt, w32_crypt_buffer);
2303 /* simulate flock by locking a range on the file */
2305 #define LK_LEN 0xffff0000
2308 win32_flock(int fd, int oper)
2314 fh = (HANDLE)_get_osfhandle(fd);
2315 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2318 memset(&o, 0, sizeof(o));
2321 case LOCK_SH: /* shared lock */
2322 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2325 case LOCK_EX: /* exclusive lock */
2326 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2329 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2330 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2333 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2334 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2338 case LOCK_UN: /* unlock lock */
2339 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2342 default: /* unknown */
2347 if (GetLastError() == ERROR_LOCK_VIOLATION)
2348 errno = WSAEWOULDBLOCK;
2358 * redirected io subsystem for all XS modules
2371 return (&(_environ));
2374 /* the rest are the remapped stdio routines */
2394 win32_ferror(FILE *fp)
2396 return (ferror(fp));
2401 win32_feof(FILE *fp)
2407 * Since the errors returned by the socket error function
2408 * WSAGetLastError() are not known by the library routine strerror
2409 * we have to roll our own.
2413 win32_strerror(int e)
2415 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2416 extern int sys_nerr;
2419 if (e < 0 || e > sys_nerr) {
2424 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2425 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2426 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2429 strcpy(w32_strerror_buffer, "Unknown Error");
2431 return w32_strerror_buffer;
2435 #define strerror win32_strerror
2439 win32_str_os_error(void *sv, DWORD dwErr)
2443 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2444 |FORMAT_MESSAGE_IGNORE_INSERTS
2445 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2446 dwErr, 0, (char *)&sMsg, 1, NULL);
2447 /* strip trailing whitespace and period */
2450 --dwLen; /* dwLen doesn't include trailing null */
2451 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2452 if ('.' != sMsg[dwLen])
2457 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2459 dwLen = sprintf(sMsg,
2460 "Unknown error #0x%lX (lookup 0x%lX)",
2461 dwErr, GetLastError());
2465 sv_setpvn((SV*)sv, sMsg, dwLen);
2471 win32_fprintf(FILE *fp, const char *format, ...)
2474 va_start(marker, format); /* Initialize variable arguments. */
2476 return (vfprintf(fp, format, marker));
2480 win32_printf(const char *format, ...)
2483 va_start(marker, format); /* Initialize variable arguments. */
2485 return (vprintf(format, marker));
2489 win32_vfprintf(FILE *fp, const char *format, va_list args)
2491 return (vfprintf(fp, format, args));
2495 win32_vprintf(const char *format, va_list args)
2497 return (vprintf(format, args));
2501 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2503 return fread(buf, size, count, fp);
2507 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2509 return fwrite(buf, size, count, fp);
2512 #define MODE_SIZE 10
2515 win32_fopen(const char *filename, const char *mode)
2523 if (stricmp(filename, "/dev/null")==0)
2526 f = fopen(PerlDir_mapA(filename), mode);
2527 /* avoid buffering headaches for child processes */
2528 if (f && *mode == 'a')
2529 win32_fseek(f, 0, SEEK_END);
2533 #ifndef USE_SOCKETS_AS_HANDLES
2535 #define fdopen my_fdopen
2539 win32_fdopen(int handle, const char *mode)
2543 f = fdopen(handle, (char *) mode);
2544 /* avoid buffering headaches for child processes */
2545 if (f && *mode == 'a')
2546 win32_fseek(f, 0, SEEK_END);
2551 win32_freopen(const char *path, const char *mode, FILE *stream)
2554 if (stricmp(path, "/dev/null")==0)
2557 return freopen(PerlDir_mapA(path), mode, stream);
2561 win32_fclose(FILE *pf)
2563 return my_fclose(pf); /* defined in win32sck.c */
2567 win32_fputs(const char *s,FILE *pf)
2569 return fputs(s, pf);
2573 win32_fputc(int c,FILE *pf)
2579 win32_ungetc(int c,FILE *pf)
2581 return ungetc(c,pf);
2585 win32_getc(FILE *pf)
2591 win32_fileno(FILE *pf)
2597 win32_clearerr(FILE *pf)
2604 win32_fflush(FILE *pf)
2610 win32_ftell(FILE *pf)
2612 #if defined(WIN64) || defined(USE_LARGE_FILES)
2613 #if defined(__BORLANDC__) /* buk */
2614 return win32_tell( fileno( pf ) );
2617 if (fgetpos(pf, &pos))
2627 win32_fseek(FILE *pf, Off_t offset,int origin)
2629 #if defined(WIN64) || defined(USE_LARGE_FILES)
2630 #if defined(__BORLANDC__) /* buk */
2640 if (fgetpos(pf, &pos))
2645 fseek(pf, 0, SEEK_END);
2646 pos = _telli64(fileno(pf));
2655 return fsetpos(pf, &offset);
2658 return fseek(pf, (long)offset, origin);
2663 win32_fgetpos(FILE *pf,fpos_t *p)
2665 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2666 if( win32_tell(fileno(pf)) == -1L ) {
2672 return fgetpos(pf, p);
2677 win32_fsetpos(FILE *pf,const fpos_t *p)
2679 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2680 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2682 return fsetpos(pf, p);
2687 win32_rewind(FILE *pf)
2697 char prefix[MAX_PATH+1];
2698 char filename[MAX_PATH+1];
2699 DWORD len = GetTempPath(MAX_PATH, prefix);
2700 if (len && len < MAX_PATH) {
2701 if (GetTempFileName(prefix, "plx", 0, filename)) {
2702 HANDLE fh = CreateFile(filename,
2703 DELETE | GENERIC_READ | GENERIC_WRITE,
2707 FILE_ATTRIBUTE_NORMAL
2708 | FILE_FLAG_DELETE_ON_CLOSE,
2710 if (fh != INVALID_HANDLE_VALUE) {
2711 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2713 #if defined(__BORLANDC__)
2714 setmode(fd,O_BINARY);
2716 DEBUG_p(PerlIO_printf(Perl_debug_log,
2717 "Created tmpfile=%s\n",filename));
2729 int fd = win32_tmpfd();
2731 return win32_fdopen(fd, "w+b");
2743 win32_fstat(int fd, Stat_t *sbufptr)
2746 /* A file designated by filehandle is not shown as accessible
2747 * for write operations, probably because it is opened for reading.
2750 BY_HANDLE_FILE_INFORMATION bhfi;
2751 # if defined(WIN64) || defined(USE_LARGE_FILES)
2752 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2754 int rc = fstat(fd,&tmp);
2756 sbufptr->st_dev = tmp.st_dev;
2757 sbufptr->st_ino = tmp.st_ino;
2758 sbufptr->st_mode = tmp.st_mode;
2759 sbufptr->st_nlink = tmp.st_nlink;
2760 sbufptr->st_uid = tmp.st_uid;
2761 sbufptr->st_gid = tmp.st_gid;
2762 sbufptr->st_rdev = tmp.st_rdev;
2763 sbufptr->st_size = tmp.st_size;
2764 sbufptr->st_atime = tmp.st_atime;
2765 sbufptr->st_mtime = tmp.st_mtime;
2766 sbufptr->st_ctime = tmp.st_ctime;
2768 int rc = fstat(fd,sbufptr);
2771 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2772 # if defined(WIN64) || defined(USE_LARGE_FILES)
2773 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2775 sbufptr->st_mode &= 0xFE00;
2776 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2777 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2779 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2780 + ((S_IREAD|S_IWRITE) >> 6));
2784 # if defined(WIN64) || defined(USE_LARGE_FILES)
2785 return _fstati64(fd, sbufptr);
2787 return fstat(fd, sbufptr);
2793 win32_pipe(int *pfd, unsigned int size, int mode)
2795 return _pipe(pfd, size, mode);
2799 win32_popenlist(const char *mode, IV narg, SV **args)
2802 Perl_croak(aTHX_ "List form of pipe open not implemented");
2807 * a popen() clone that respects PERL5SHELL
2809 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2813 win32_popen(const char *command, const char *mode)
2815 #ifdef USE_RTL_POPEN
2816 return _popen(command, mode);
2828 /* establish which ends read and write */
2829 if (strchr(mode,'w')) {
2830 stdfd = 0; /* stdin */
2833 nhandle = STD_INPUT_HANDLE;
2835 else if (strchr(mode,'r')) {
2836 stdfd = 1; /* stdout */
2839 nhandle = STD_OUTPUT_HANDLE;
2844 /* set the correct mode */
2845 if (strchr(mode,'b'))
2847 else if (strchr(mode,'t'))
2850 ourmode = _fmode & (O_TEXT | O_BINARY);
2852 /* the child doesn't inherit handles */
2853 ourmode |= O_NOINHERIT;
2855 if (win32_pipe(p, 512, ourmode) == -1)
2858 /* save the old std handle (this needs to happen before the
2859 * dup2(), since that might call SetStdHandle() too) */
2862 old_h = GetStdHandle(nhandle);
2864 /* save current stdfd */
2865 if ((oldfd = win32_dup(stdfd)) == -1)
2868 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2869 /* stdfd will be inherited by the child */
2870 if (win32_dup2(p[child], stdfd) == -1)
2873 /* close the child end in parent */
2874 win32_close(p[child]);
2876 /* set the new std handle (in case dup2() above didn't) */
2877 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2879 /* start the child */
2882 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2885 /* revert stdfd to whatever it was before */
2886 if (win32_dup2(oldfd, stdfd) == -1)
2889 /* close saved handle */
2892 /* restore the old std handle (this needs to happen after the
2893 * dup2(), since that might call SetStdHandle() too */
2895 SetStdHandle(nhandle, old_h);
2900 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2902 /* set process id so that it can be returned by perl's open() */
2903 PL_forkprocess = childpid;
2906 /* we have an fd, return a file stream */
2907 return (PerlIO_fdopen(p[parent], (char *)mode));
2910 /* we don't need to check for errors here */
2914 win32_dup2(oldfd, stdfd);
2918 SetStdHandle(nhandle, old_h);
2924 #endif /* USE_RTL_POPEN */
2932 win32_pclose(PerlIO *pf)
2934 #ifdef USE_RTL_POPEN
2938 int childpid, status;
2941 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2944 childpid = SvIVX(sv);
2960 if (win32_waitpid(childpid, &status, 0) == -1)
2965 #endif /* USE_RTL_POPEN */
2969 win32_link(const char *oldname, const char *newname)
2972 WCHAR wOldName[MAX_PATH+1];
2973 WCHAR wNewName[MAX_PATH+1];
2975 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2976 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2977 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2978 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2982 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2987 win32_rename(const char *oname, const char *newname)
2989 char szOldName[MAX_PATH+1];
2991 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2994 if (stricmp(newname, oname))
2995 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2996 strcpy(szOldName, PerlDir_mapA(oname));
2998 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3000 DWORD err = GetLastError();
3002 case ERROR_BAD_NET_NAME:
3003 case ERROR_BAD_NETPATH:
3004 case ERROR_BAD_PATHNAME:
3005 case ERROR_FILE_NOT_FOUND:
3006 case ERROR_FILENAME_EXCED_RANGE:
3007 case ERROR_INVALID_DRIVE:
3008 case ERROR_NO_MORE_FILES:
3009 case ERROR_PATH_NOT_FOUND:
3022 win32_setmode(int fd, int mode)
3024 return setmode(fd, mode);
3028 win32_chsize(int fd, Off_t size)
3030 #if defined(WIN64) || defined(USE_LARGE_FILES)
3032 Off_t cur, end, extend;
3034 cur = win32_tell(fd);
3037 end = win32_lseek(fd, 0, SEEK_END);
3040 extend = size - end;
3044 else if (extend > 0) {
3045 /* must grow the file, padding with nulls */
3047 int oldmode = win32_setmode(fd, O_BINARY);
3049 memset(b, '\0', sizeof(b));
3051 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3052 count = win32_write(fd, b, count);
3053 if ((int)count < 0) {
3057 } while ((extend -= count) > 0);
3058 win32_setmode(fd, oldmode);
3061 /* shrink the file */
3062 win32_lseek(fd, size, SEEK_SET);
3063 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3069 win32_lseek(fd, cur, SEEK_SET);
3072 return chsize(fd, (long)size);
3077 win32_lseek(int fd, Off_t offset, int origin)
3079 #if defined(WIN64) || defined(USE_LARGE_FILES)
3080 #if defined(__BORLANDC__) /* buk */
3082 pos.QuadPart = offset;
3083 pos.LowPart = SetFilePointer(
3084 (HANDLE)_get_osfhandle(fd),
3089 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3093 return pos.QuadPart;
3095 return _lseeki64(fd, offset, origin);
3098 return lseek(fd, (long)offset, origin);
3105 #if defined(WIN64) || defined(USE_LARGE_FILES)
3106 #if defined(__BORLANDC__) /* buk */
3109 pos.LowPart = SetFilePointer(
3110 (HANDLE)_get_osfhandle(fd),
3115 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3119 return pos.QuadPart;
3120 /* return tell(fd); */
3122 return _telli64(fd);
3130 win32_open(const char *path, int flag, ...)
3137 pmode = va_arg(ap, int);
3140 if (stricmp(path, "/dev/null")==0)
3143 return open(PerlDir_mapA(path), flag, pmode);
3146 /* close() that understands socket */
3147 extern int my_close(int); /* in win32sck.c */
3152 return my_close(fd);
3162 win32_isatty(int fd)
3164 /* The Microsoft isatty() function returns true for *all*
3165 * character mode devices, including "nul". Our implementation
3166 * should only return true if the handle has a console buffer.
3169 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3170 if (fh == (HANDLE)-1) {
3171 /* errno is already set to EBADF */
3175 if (GetConsoleMode(fh, &mode))
3189 win32_dup2(int fd1,int fd2)
3191 return dup2(fd1,fd2);
3195 win32_read(int fd, void *buf, unsigned int cnt)
3197 return read(fd, buf, cnt);
3201 win32_write(int fd, const void *buf, unsigned int cnt)
3203 return write(fd, buf, cnt);
3207 win32_mkdir(const char *dir, int mode)
3210 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3214 win32_rmdir(const char *dir)
3217 return rmdir(PerlDir_mapA(dir));
3221 win32_chdir(const char *dir)
3232 win32_access(const char *path, int mode)
3235 return access(PerlDir_mapA(path), mode);
3239 win32_chmod(const char *path, int mode)
3242 return chmod(PerlDir_mapA(path), mode);
3247 create_command_line(char *cname, STRLEN clen, const char * const *args)
3254 bool bat_file = FALSE;
3255 bool cmd_shell = FALSE;
3256 bool dumb_shell = FALSE;
3257 bool extra_quotes = FALSE;
3258 bool quote_next = FALSE;
3261 cname = (char*)args[0];
3263 /* The NT cmd.exe shell has the following peculiarity that needs to be
3264 * worked around. It strips a leading and trailing dquote when any
3265 * of the following is true:
3266 * 1. the /S switch was used
3267 * 2. there are more than two dquotes
3268 * 3. there is a special character from this set: &<>()@^|
3269 * 4. no whitespace characters within the two dquotes
3270 * 5. string between two dquotes isn't an executable file
3271 * To work around this, we always add a leading and trailing dquote
3272 * to the string, if the first argument is either "cmd.exe" or "cmd",
3273 * and there were at least two or more arguments passed to cmd.exe
3274 * (not including switches).
3275 * XXX the above rules (from "cmd /?") don't seem to be applied
3276 * always, making for the convolutions below :-(
3280 clen = strlen(cname);
3283 && (stricmp(&cname[clen-4], ".bat") == 0
3284 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3290 char *exe = strrchr(cname, '/');
3291 char *exe2 = strrchr(cname, '\\');
3298 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3302 else if (stricmp(exe, "command.com") == 0
3303 || stricmp(exe, "command") == 0)
3310 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3311 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3312 STRLEN curlen = strlen(arg);
3313 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3314 len += 2; /* assume quoting needed (worst case) */
3316 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3318 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3321 Newx(cmd, len, char);
3326 extra_quotes = TRUE;
3329 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3331 STRLEN curlen = strlen(arg);
3333 /* we want to protect empty arguments and ones with spaces with
3334 * dquotes, but only if they aren't already there */
3339 else if (quote_next) {
3340 /* see if it really is multiple arguments pretending to
3341 * be one and force a set of quotes around it */
3342 if (*find_next_space(arg))
3345 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3347 while (i < curlen) {
3348 if (isSPACE(arg[i])) {
3351 else if (arg[i] == '"') {
3375 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3376 && stricmp(arg+curlen-2, "/c") == 0)
3378 /* is there a next argument? */
3379 if (args[index+1]) {
3380 /* are there two or more next arguments? */
3381 if (args[index+2]) {
3383 extra_quotes = TRUE;
3386 /* single argument, force quoting if it has spaces */
3402 qualified_path(const char *cmd)
3406 char *fullcmd, *curfullcmd;
3412 fullcmd = (char*)cmd;
3414 if (*fullcmd == '/' || *fullcmd == '\\')
3421 pathstr = PerlEnv_getenv("PATH");
3423 /* worst case: PATH is a single directory; we need additional space
3424 * to append "/", ".exe" and trailing "\0" */
3425 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3426 curfullcmd = fullcmd;
3431 /* start by appending the name to the current prefix */
3432 strcpy(curfullcmd, cmd);
3433 curfullcmd += cmdlen;
3435 /* if it doesn't end with '.', or has no extension, try adding
3436 * a trailing .exe first */
3437 if (cmd[cmdlen-1] != '.'
3438 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3440 strcpy(curfullcmd, ".exe");
3441 res = GetFileAttributes(fullcmd);
3442 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3447 /* that failed, try the bare name */
3448 res = GetFileAttributes(fullcmd);
3449 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3452 /* quit if no other path exists, or if cmd already has path */
3453 if (!pathstr || !*pathstr || has_slash)
3456 /* skip leading semis */
3457 while (*pathstr == ';')
3460 /* build a new prefix from scratch */
3461 curfullcmd = fullcmd;
3462 while (*pathstr && *pathstr != ';') {
3463 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3464 pathstr++; /* skip initial '"' */
3465 while (*pathstr && *pathstr != '"') {
3466 *curfullcmd++ = *pathstr++;
3469 pathstr++; /* skip trailing '"' */
3472 *curfullcmd++ = *pathstr++;
3476 pathstr++; /* skip trailing semi */
3477 if (curfullcmd > fullcmd /* append a dir separator */
3478 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3480 *curfullcmd++ = '\\';
3488 /* The following are just place holders.
3489 * Some hosts may provide and environment that the OS is
3490 * not tracking, therefore, these host must provide that
3491 * environment and the current directory to CreateProcess
3495 win32_get_childenv(void)
3501 win32_free_childenv(void* d)
3506 win32_clearenv(void)
3508 char *envv = GetEnvironmentStrings();
3512 char *end = strchr(cur,'=');
3513 if (end && end != cur) {
3515 SetEnvironmentVariable(cur, NULL);
3517 cur = end + strlen(end+1)+2;
3519 else if ((len = strlen(cur)))
3522 FreeEnvironmentStrings(envv);
3526 win32_get_childdir(void)
3530 char szfilename[MAX_PATH+1];
3532 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3533 Newx(ptr, strlen(szfilename)+1, char);
3534 strcpy(ptr, szfilename);
3539 win32_free_childdir(char* d)
3546 /* XXX this needs to be made more compatible with the spawnvp()
3547 * provided by the various RTLs. In particular, searching for
3548 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3549 * This doesn't significantly affect perl itself, because we
3550 * always invoke things using PERL5SHELL if a direct attempt to
3551 * spawn the executable fails.
3553 * XXX splitting and rejoining the commandline between do_aspawn()
3554 * and win32_spawnvp() could also be avoided.
3558 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3560 #ifdef USE_RTL_SPAWNVP
3561 return spawnvp(mode, cmdname, (char * const *)argv);
3568 STARTUPINFO StartupInfo;
3569 PROCESS_INFORMATION ProcessInformation;
3572 char *fullcmd = NULL;
3573 char *cname = (char *)cmdname;
3577 clen = strlen(cname);
3578 /* if command name contains dquotes, must remove them */
3579 if (strchr(cname, '"')) {
3581 Newx(cname,clen+1,char);
3594 cmd = create_command_line(cname, clen, argv);
3596 env = PerlEnv_get_childenv();
3597 dir = PerlEnv_get_childdir();
3600 case P_NOWAIT: /* asynch + remember result */
3601 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3606 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3609 create |= CREATE_NEW_PROCESS_GROUP;
3612 case P_WAIT: /* synchronous execution */
3614 default: /* invalid mode */
3619 memset(&StartupInfo,0,sizeof(StartupInfo));
3620 StartupInfo.cb = sizeof(StartupInfo);
3621 memset(&tbl,0,sizeof(tbl));
3622 PerlEnv_get_child_IO(&tbl);
3623 StartupInfo.dwFlags = tbl.dwFlags;
3624 StartupInfo.dwX = tbl.dwX;
3625 StartupInfo.dwY = tbl.dwY;
3626 StartupInfo.dwXSize = tbl.dwXSize;
3627 StartupInfo.dwYSize = tbl.dwYSize;
3628 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3629 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3630 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3631 StartupInfo.wShowWindow = tbl.wShowWindow;
3632 StartupInfo.hStdInput = tbl.childStdIn;
3633 StartupInfo.hStdOutput = tbl.childStdOut;
3634 StartupInfo.hStdError = tbl.childStdErr;
3635 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3636 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3637 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3639 create |= CREATE_NEW_CONSOLE;
3642 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3644 if (w32_use_showwindow) {
3645 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3646 StartupInfo.wShowWindow = w32_showwindow;
3649 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3652 if (!CreateProcess(cname, /* search PATH to find executable */
3653 cmd, /* executable, and its arguments */
3654 NULL, /* process attributes */
3655 NULL, /* thread attributes */
3656 TRUE, /* inherit handles */
3657 create, /* creation flags */
3658 (LPVOID)env, /* inherit environment */
3659 dir, /* inherit cwd */
3661 &ProcessInformation))
3663 /* initial NULL argument to CreateProcess() does a PATH
3664 * search, but it always first looks in the directory
3665 * where the current process was started, which behavior
3666 * is undesirable for backward compatibility. So we
3667 * jump through our own hoops by picking out the path
3668 * we really want it to use. */
3670 fullcmd = qualified_path(cname);
3672 if (cname != cmdname)
3675 DEBUG_p(PerlIO_printf(Perl_debug_log,
3676 "Retrying [%s] with same args\n",
3686 if (mode == P_NOWAIT) {
3687 /* asynchronous spawn -- store handle, return PID */
3688 ret = (int)ProcessInformation.dwProcessId;
3690 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3691 w32_child_pids[w32_num_children] = (DWORD)ret;
3696 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3697 /* FIXME: if msgwait returned due to message perhaps forward the
3698 "signal" to the process
3700 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3702 CloseHandle(ProcessInformation.hProcess);
3705 CloseHandle(ProcessInformation.hThread);
3708 PerlEnv_free_childenv(env);
3709 PerlEnv_free_childdir(dir);
3711 if (cname != cmdname)
3718 win32_execv(const char *cmdname, const char *const *argv)
3722 /* if this is a pseudo-forked child, we just want to spawn
3723 * the new program, and return */
3725 # ifdef __BORLANDC__
3726 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3728 return spawnv(P_WAIT, cmdname, argv);
3732 return execv(cmdname, (char *const *)argv);
3734 return execv(cmdname, argv);
3739 win32_execvp(const char *cmdname, const char *const *argv)
3743 /* if this is a pseudo-forked child, we just want to spawn
3744 * the new program, and return */
3745 if (w32_pseudo_id) {
3746 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3756 return execvp(cmdname, (char *const *)argv);
3758 return execvp(cmdname, argv);
3763 win32_perror(const char *str)
3769 win32_setbuf(FILE *pf, char *buf)
3775 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3777 return setvbuf(pf, buf, type, size);
3781 win32_flushall(void)
3787 win32_fcloseall(void)
3793 win32_fgets(char *s, int n, FILE *pf)
3795 return fgets(s, n, pf);
3805 win32_fgetc(FILE *pf)
3811 win32_putc(int c, FILE *pf)
3817 win32_puts(const char *s)
3829 win32_putchar(int c)
3836 #ifndef USE_PERL_SBRK
3838 static char *committed = NULL; /* XXX threadead */
3839 static char *base = NULL; /* XXX threadead */
3840 static char *reserved = NULL; /* XXX threadead */
3841 static char *brk = NULL; /* XXX threadead */
3842 static DWORD pagesize = 0; /* XXX threadead */
3845 sbrk(ptrdiff_t need)
3850 GetSystemInfo(&info);
3851 /* Pretend page size is larger so we don't perpetually
3852 * call the OS to commit just one page ...
3854 pagesize = info.dwPageSize << 3;
3856 if (brk+need >= reserved)
3858 DWORD size = brk+need-reserved;
3860 char *prev_committed = NULL;
3861 if (committed && reserved && committed < reserved)
3863 /* Commit last of previous chunk cannot span allocations */
3864 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3867 /* Remember where we committed from in case we want to decommit later */
3868 prev_committed = committed;
3869 committed = reserved;
3872 /* Reserve some (more) space
3873 * Contiguous blocks give us greater efficiency, so reserve big blocks -
3874 * this is only address space not memory...
3875 * Note this is a little sneaky, 1st call passes NULL as reserved
3876 * so lets system choose where we start, subsequent calls pass
3877 * the old end address so ask for a contiguous block
3880 if (size < 64*1024*1024)
3881 size = 64*1024*1024;
3882 size = ((size + pagesize - 1) / pagesize) * pagesize;
3883 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3886 reserved = addr+size;
3896 /* The existing block could not be extended far enough, so decommit
3897 * anything that was just committed above and start anew */
3900 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
3903 reserved = base = committed = brk = NULL;
3914 if (brk > committed)
3916 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3918 if (committed+size > reserved)
3919 size = reserved-committed;
3920 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3933 win32_malloc(size_t size)
3935 return malloc(size);
3939 win32_calloc(size_t numitems, size_t size)
3941 return calloc(numitems,size);
3945 win32_realloc(void *block, size_t size)
3947 return realloc(block,size);
3951 win32_free(void *block)
3958 win32_open_osfhandle(intptr_t handle, int flags)
3960 return _open_osfhandle(handle, flags);
3964 win32_get_osfhandle(int fd)
3966 return (intptr_t)_get_osfhandle(fd);
3970 win32_fdupopen(FILE *pf)
3975 int fileno = win32_dup(win32_fileno(pf));
3977 /* open the file in the same mode */
3979 if((pf)->flags & _F_READ) {
3983 else if((pf)->flags & _F_WRIT) {
3987 else if((pf)->flags & _F_RDWR) {
3993 if((pf)->_flag & _IOREAD) {
3997 else if((pf)->_flag & _IOWRT) {
4001 else if((pf)->_flag & _IORW) {
4008 /* it appears that the binmode is attached to the
4009 * file descriptor so binmode files will be handled
4012 pfdup = win32_fdopen(fileno, mode);
4014 /* move the file pointer to the same position */
4015 if (!fgetpos(pf, &pos)) {
4016 fsetpos(pfdup, &pos);
4022 win32_dynaload(const char* filename)
4025 char buf[MAX_PATH+1];
4028 /* LoadLibrary() doesn't recognize forward slashes correctly,
4029 * so turn 'em back. */
4030 first = strchr(filename, '/');
4032 STRLEN len = strlen(filename);
4033 if (len <= MAX_PATH) {
4034 strcpy(buf, filename);
4035 filename = &buf[first - filename];
4037 if (*filename == '/')
4038 *(char*)filename = '\\';
4044 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4047 XS(w32_SetChildShowWindow)
4050 BOOL use_showwindow = w32_use_showwindow;
4051 /* use "unsigned short" because Perl has redefined "WORD" */
4052 unsigned short showwindow = w32_showwindow;
4055 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4057 if (items == 0 || !SvOK(ST(0)))
4058 w32_use_showwindow = FALSE;
4060 w32_use_showwindow = TRUE;
4061 w32_showwindow = (unsigned short)SvIV(ST(0));
4066 ST(0) = sv_2mortal(newSViv(showwindow));
4068 ST(0) = &PL_sv_undef;
4073 Perl_init_os_extras(void)
4076 char *file = __FILE__;
4078 /* Initialize Win32CORE if it has been statically linked. */
4079 void (*pfn_init)(pTHX);
4080 #if defined(__BORLANDC__)
4081 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4082 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4084 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4089 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4093 win32_signal_context(void)
4098 my_perl = PL_curinterp;
4099 PERL_SET_THX(my_perl);
4103 return PL_curinterp;
4109 win32_ctrlhandler(DWORD dwCtrlType)
4112 dTHXa(PERL_GET_SIG_CONTEXT);
4118 switch(dwCtrlType) {
4119 case CTRL_CLOSE_EVENT:
4120 /* A signal that the system sends to all processes attached to a console when
4121 the user closes the console (either by choosing the Close command from the
4122 console window's System menu, or by choosing the End Task command from the
4125 if (do_raise(aTHX_ 1)) /* SIGHUP */
4126 sig_terminate(aTHX_ 1);
4130 /* A CTRL+c signal was received */
4131 if (do_raise(aTHX_ SIGINT))
4132 sig_terminate(aTHX_ SIGINT);
4135 case CTRL_BREAK_EVENT:
4136 /* A CTRL+BREAK signal was received */
4137 if (do_raise(aTHX_ SIGBREAK))
4138 sig_terminate(aTHX_ SIGBREAK);
4141 case CTRL_LOGOFF_EVENT:
4142 /* A signal that the system sends to all console processes when a user is logging
4143 off. This signal does not indicate which user is logging off, so no
4144 assumptions can be made.
4147 case CTRL_SHUTDOWN_EVENT:
4148 /* A signal that the system sends to all console processes when the system is
4151 if (do_raise(aTHX_ SIGTERM))
4152 sig_terminate(aTHX_ SIGTERM);
4161 #ifdef SET_INVALID_PARAMETER_HANDLER
4162 # include <crtdbg.h>
4173 /* fetch Unicode version of PATH */
4175 wide_path = win32_malloc(len*sizeof(WCHAR));
4177 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4181 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4186 /* convert to ANSI pathnames */
4187 wide_dir = wide_path;
4190 WCHAR *sep = wcschr(wide_dir, ';');
4198 /* remove quotes around pathname */
4199 if (*wide_dir == '"')
4201 wide_len = wcslen(wide_dir);
4202 if (wide_len && wide_dir[wide_len-1] == '"')
4203 wide_dir[wide_len-1] = '\0';
4205 /* append ansi_dir to ansi_path */
4206 ansi_dir = win32_ansipath(wide_dir);
4207 ansi_len = strlen(ansi_dir);
4209 size_t newlen = len + 1 + ansi_len;
4210 ansi_path = win32_realloc(ansi_path, newlen+1);
4213 ansi_path[len] = ';';
4214 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4219 ansi_path = win32_malloc(5+len+1);
4222 memcpy(ansi_path, "PATH=", 5);
4223 memcpy(ansi_path+5, ansi_dir, len+1);
4226 win32_free(ansi_dir);
4231 /* Update C RTL environ array. This will only have full effect if
4232 * perl_parse() is later called with `environ` as the `env` argument.
4233 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4235 * We do have to ansify() the PATH before Perl has been fully
4236 * initialized because S_find_script() uses the PATH when perl
4237 * is being invoked with the -S option. This happens before %ENV
4238 * is initialized in S_init_postdump_symbols().
4240 * XXX Is this a bug? Should S_find_script() use the environment
4241 * XXX passed in the `env` arg to parse_perl()?
4244 /* Keep system environment in sync because S_init_postdump_symbols()
4245 * will not call mg_set() if it initializes %ENV from `environ`.
4247 SetEnvironmentVariableA("PATH", ansi_path+5);
4248 /* We are intentionally leaking the ansi_path string here because
4249 * the Borland runtime library puts it directly into the environ
4250 * array. The Microsoft runtime library seems to make a copy,
4251 * but will leak the copy should it be replaced again later.
4252 * Since this code is only called once during PERL_SYS_INIT this
4253 * shouldn't really matter.
4256 win32_free(wide_path);
4260 Perl_win32_init(int *argcp, char ***argvp)
4262 #ifdef SET_INVALID_PARAMETER_HANDLER
4263 _invalid_parameter_handler oldHandler, newHandler;
4264 newHandler = my_invalid_parameter_handler;
4265 oldHandler = _set_invalid_parameter_handler(newHandler);
4266 _CrtSetReportMode(_CRT_ASSERT, 0);
4268 /* Disable floating point errors, Perl will trap the ones we
4269 * care about. VC++ RTL defaults to switching these off
4270 * already, but the Borland RTL doesn't. Since we don't
4271 * want to be at the vendor's whim on the default, we set
4272 * it explicitly here.
4274 #if !defined(__GNUC__)
4275 _control87(MCW_EM, MCW_EM);
4279 /* When the manifest resource requests Common-Controls v6 then
4280 * user32.dll no longer registers all the Windows classes used for
4281 * standard controls but leaves some of them to be registered by
4282 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4283 * it makes sure comctl32.dll gets loaded into the process and registers
4284 * the standard control classes. Without this even normal Windows APIs
4285 * like MessageBox() can fail under some versions of Windows XP.
4287 InitCommonControls();
4289 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4290 GetVersionEx(&g_osver);
4296 Perl_win32_term(void)
4306 win32_get_child_IO(child_IO_table* ptbl)
4308 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4309 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4310 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4314 win32_signal(int sig, Sighandler_t subcode)
4317 if (sig < SIG_SIZE) {
4318 int save_errno = errno;
4319 Sighandler_t result = signal(sig, subcode);
4320 if (result == SIG_ERR) {
4321 result = w32_sighandler[sig];
4324 w32_sighandler[sig] = subcode;
4333 /* The PerlMessageWindowClass's WindowProc */
4335 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4337 return win32_process_message(hwnd, msg, wParam, lParam) ?
4338 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4341 /* The real message handler. Can be called with
4342 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4343 * that it processes */
4345 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4347 /* BEWARE. The context retrieved using dTHX; is the context of the
4348 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4349 * up to and including WM_CREATE. If it ever happens that you need the
4350 * 'child' context before this, then it needs to be passed into
4351 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4352 * from the lparam of CreateWindow(). It could then be stored/retrieved
4353 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4354 * the dTHX calls here. */
4355 /* XXX For now it is assumed that the overhead of the dTHX; for what
4356 * are relativley infrequent code-paths, is better than the added
4357 * complexity of getting the correct context passed into
4358 * win32_create_message_window() */
4363 case WM_USER_MESSAGE: {
4364 long child = find_pseudo_pid((int)wParam);
4367 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4374 case WM_USER_KILL: {
4376 /* We use WM_USER_KILL to fake kill() with other signals */
4377 int sig = (int)wParam;
4378 if (do_raise(aTHX_ sig))
4379 sig_terminate(aTHX_ sig);
4386 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4387 if (w32_timerid && w32_timerid==(UINT)wParam) {
4388 KillTimer(w32_message_hwnd, w32_timerid);
4391 /* Now fake a call to signal handler */
4392 if (do_raise(aTHX_ 14))
4393 sig_terminate(aTHX_ 14);
4405 /* Above or other stuff may have set a signal flag, and we may not have
4406 * been called from win32_async_check() (e.g. some other GUI's message
4407 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4408 * handler that die's, and the message loop that calls here is wrapped
4409 * in an eval, then you may well end up with orphaned windows - signals
4410 * are dispatched by win32_async_check() */
4416 win32_create_message_window_class(void)
4418 /* create the window class for "message only" windows */
4422 wc.lpfnWndProc = win32_message_window_proc;
4423 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4424 wc.lpszClassName = "PerlMessageWindowClass";
4426 /* second and subsequent calls will fail, but class
4427 * will already be registered */
4432 win32_create_message_window(void)
4434 win32_create_message_window_class();
4435 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4436 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4439 #ifdef HAVE_INTERP_INTERN
4442 win32_csighandler(int sig)
4445 dTHXa(PERL_GET_SIG_CONTEXT);
4446 Perl_warn(aTHX_ "Got signal %d",sig);
4451 #if defined(__MINGW32__) && defined(__cplusplus)
4452 #define CAST_HWND__(x) (HWND__*)(x)
4454 #define CAST_HWND__(x) x
4458 Perl_sys_intern_init(pTHX)
4462 w32_perlshell_tokens = NULL;
4463 w32_perlshell_vec = (char**)NULL;
4464 w32_perlshell_items = 0;
4465 w32_fdpid = newAV();
4466 Newx(w32_children, 1, child_tab);
4467 w32_num_children = 0;
4468 # ifdef USE_ITHREADS
4470 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4471 w32_num_pseudo_children = 0;
4474 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4476 for (i=0; i < SIG_SIZE; i++) {
4477 w32_sighandler[i] = SIG_DFL;
4479 # ifdef MULTIPLICITY
4480 if (my_perl == PL_curinterp) {
4484 /* Force C runtime signal stuff to set its console handler */
4485 signal(SIGINT,win32_csighandler);
4486 signal(SIGBREAK,win32_csighandler);
4488 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4489 * flag. This has the side-effect of disabling Ctrl-C events in all
4490 * processes in this group.
4491 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4492 * with a NULL handler.
4494 SetConsoleCtrlHandler(NULL,FALSE);
4496 /* Push our handler on top */
4497 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4502 Perl_sys_intern_clear(pTHX)
4504 Safefree(w32_perlshell_tokens);
4505 Safefree(w32_perlshell_vec);
4506 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4507 Safefree(w32_children);
4509 KillTimer(w32_message_hwnd, w32_timerid);
4512 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4513 DestroyWindow(w32_message_hwnd);
4514 # ifdef MULTIPLICITY
4515 if (my_perl == PL_curinterp) {
4519 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4521 # ifdef USE_ITHREADS
4522 Safefree(w32_pseudo_children);
4526 # ifdef USE_ITHREADS
4529 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4531 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4533 dst->perlshell_tokens = NULL;
4534 dst->perlshell_vec = (char**)NULL;
4535 dst->perlshell_items = 0;
4536 dst->fdpid = newAV();
4537 Newxz(dst->children, 1, child_tab);
4539 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4541 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4542 dst->poll_count = 0;
4543 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4545 # endif /* USE_ITHREADS */
4546 #endif /* HAVE_INTERP_INTERN */