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 */
67 #include <sys/utime.h>
70 /* Mingw32 defaults to globing command line
71 * So we turn it off like this:
76 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
77 /* Mingw32-1.1 is missing some prototypes */
79 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
89 #define EXECF_SPAWN_NOWAIT 3
91 #if defined(PERL_IMPLICIT_SYS)
92 # undef win32_get_privlib
93 # define win32_get_privlib g_win32_get_privlib
94 # undef win32_get_sitelib
95 # define win32_get_sitelib g_win32_get_sitelib
96 # undef win32_get_vendorlib
97 # define win32_get_vendorlib g_win32_get_vendorlib
99 # define getlogin g_getlogin
102 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
103 * parameter handler. This functionality is not available in the
104 * 64-bit compiler from the Platform SDK, which unfortunately also
105 * believes itself to be MSC version 14.
107 * There is no #define related to _set_invalid_parameter_handler(),
108 * but we can check for one of the constants defined for
109 * _set_abort_behavior(), which was introduced into stdlib.h at
113 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
114 # define SET_INVALID_PARAMETER_HANDLER
117 #ifdef SET_INVALID_PARAMETER_HANDLER
118 static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
119 static void my_invalid_parameter_handler(const wchar_t* expression,
120 const wchar_t* function, const wchar_t* file,
121 unsigned int line, uintptr_t pReserved);
124 static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
125 static char* get_regstr(const char *valuename, SV **svp);
126 static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
127 char *trailing, ...);
128 static char* win32_get_xlib(const char *pl, const char *xlib,
129 const char *libname, STRLEN *const len);
130 static BOOL has_shell_metachars(const char *ptr);
131 static long tokenize(const char *str, char **dest, char ***destv);
132 static void get_shell(void);
133 static char* find_next_space(const char *s);
134 static int do_spawn2(pTHX_ const char *cmd, int exectype);
135 static long find_pid(int pid);
136 static void remove_dead_process(long child);
137 static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
138 static int my_kill(int pid, int sig);
139 static void out_of_memory(void);
140 static char* wstr_to_str(const wchar_t* wstr);
141 static long filetime_to_clock(PFILETIME ft);
142 static BOOL filetime_from_time(PFILETIME ft, time_t t);
143 static char* create_command_line(char *cname, STRLEN clen,
144 const char * const *args);
145 static char* qualified_path(const char *cmd);
146 static void ansify_path(void);
147 static LRESULT win32_process_message(HWND hwnd, UINT msg,
148 WPARAM wParam, LPARAM lParam);
151 static long find_pseudo_pid(int pid);
152 static void remove_dead_pseudo_process(long child);
153 static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
156 #ifdef HAVE_INTERP_INTERN
157 static void win32_csighandler(int sig);
161 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
162 char w32_module_name[MAX_PATH+1];
165 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
167 #ifdef SET_INVALID_PARAMETER_HANDLER
168 static BOOL silent_invalid_parameter_handler = FALSE;
171 set_silent_invalid_parameter_handler(BOOL newvalue)
173 BOOL oldvalue = silent_invalid_parameter_handler;
175 silent_invalid_parameter_handler = newvalue;
181 my_invalid_parameter_handler(const wchar_t* expression,
182 const wchar_t* function,
188 char* ansi_expression;
191 if (silent_invalid_parameter_handler)
193 ansi_expression = wstr_to_str(expression);
194 ansi_function = wstr_to_str(function);
195 ansi_file = wstr_to_str(file);
196 fprintf(stderr, "Invalid parameter detected in function %s. "
197 "File: %s, line: %d\n", ansi_function, ansi_file, line);
198 fprintf(stderr, "Expression: %s\n", ansi_expression);
199 free(ansi_expression);
207 set_w32_module_name(void)
209 /* this function may be called at DLL_PROCESS_ATTACH time */
211 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
212 ? GetModuleHandle(NULL)
213 : w32_perldll_handle);
215 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
216 osver.dwOSVersionInfoSize = sizeof(osver);
217 GetVersionEx(&osver);
219 if (osver.dwMajorVersion > 4) {
220 WCHAR modulename[MAX_PATH];
221 WCHAR fullname[MAX_PATH];
224 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
225 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
226 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
228 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
230 /* Make sure we get an absolute pathname in case the module was loaded
231 * explicitly by LoadLibrary() with a relative path. */
232 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
234 /* Make sure we start with the long path name of the module because we
235 * later scan for pathname components to match "5.xx" to locate
236 * compatible sitelib directories, and the short pathname might mangle
237 * this path segment (e.g. by removing the dot on NTFS to something
238 * like "5xx~1.yy") */
239 if (pfnGetLongPathNameW)
240 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
242 /* remove \\?\ prefix */
243 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
244 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
246 ansi = win32_ansipath(fullname);
247 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
251 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
253 /* remove \\?\ prefix */
254 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
255 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
257 /* try to get full path to binary (which may be mangled when perl is
258 * run from a 16-bit app) */
259 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
260 win32_longpath(w32_module_name);
261 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
264 /* normalize to forward slashes */
265 ptr = w32_module_name;
273 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
275 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
277 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
280 const char *subkey = "Software\\Perl";
284 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
285 if (retval == ERROR_SUCCESS) {
287 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
288 if (retval == ERROR_SUCCESS
289 && (type == REG_SZ || type == REG_EXPAND_SZ))
293 *svp = sv_2mortal(newSVpvn("",0));
294 SvGROW(*svp, datalen);
295 retval = RegQueryValueEx(handle, valuename, 0, NULL,
296 (PBYTE)SvPVX(*svp), &datalen);
297 if (retval == ERROR_SUCCESS) {
299 SvCUR_set(*svp,datalen-1);
307 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
309 get_regstr(const char *valuename, SV **svp)
311 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
313 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
317 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
319 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
323 char mod_name[MAX_PATH+1];
329 va_start(ap, trailing_path);
330 strip = va_arg(ap, char *);
332 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
333 baselen = strlen(base);
335 if (!*w32_module_name) {
336 set_w32_module_name();
338 strcpy(mod_name, w32_module_name);
339 ptr = strrchr(mod_name, '/');
340 while (ptr && strip) {
341 /* look for directories to skip back */
344 ptr = strrchr(mod_name, '/');
345 /* avoid stripping component if there is no slash,
346 * or it doesn't match ... */
347 if (!ptr || stricmp(ptr+1, strip) != 0) {
348 /* ... but not if component matches m|5\.$patchlevel.*| */
349 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
350 && strncmp(strip, base, baselen) == 0
351 && strncmp(ptr+1, base, baselen) == 0))
357 strip = va_arg(ap, char *);
365 strcpy(++ptr, trailing_path);
367 /* only add directory if it exists */
368 if (GetFileAttributes(mod_name) != (DWORD) -1) {
369 /* directory exists */
372 *prev_pathp = sv_2mortal(newSVpvn("",0));
373 else if (SvPVX(*prev_pathp))
374 sv_catpvn(*prev_pathp, ";", 1);
375 sv_catpv(*prev_pathp, mod_name);
377 *len = SvCUR(*prev_pathp);
378 return SvPVX(*prev_pathp);
385 win32_get_privlib(const char *pl, STRLEN *const len)
387 char *stdlib = "lib";
388 char buffer[MAX_PATH+1];
391 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
392 sprintf(buffer, "%s-%s", stdlib, pl);
393 if (!get_regstr(buffer, &sv))
394 (void)get_regstr(stdlib, &sv);
396 /* $stdlib .= ";$EMD/../../lib" */
397 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
401 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
406 char pathstr[MAX_PATH+1];
410 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
411 sprintf(regstr, "%s-%s", xlib, pl);
412 (void)get_regstr(regstr, &sv1);
415 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
416 sprintf(pathstr, "%s/%s/lib", libname, pl);
417 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
419 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
420 (void)get_regstr(xlib, &sv2);
423 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
424 sprintf(pathstr, "%s/lib", libname);
425 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
432 sv_catpvn(sv1, ";", 1);
442 win32_get_sitelib(const char *pl, STRLEN *const len)
444 return win32_get_xlib(pl, "sitelib", "site", len);
447 #ifndef PERL_VENDORLIB_NAME
448 # define PERL_VENDORLIB_NAME "vendor"
452 win32_get_vendorlib(const char *pl, STRLEN *const len)
454 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
458 has_shell_metachars(const char *ptr)
464 * Scan string looking for redirection (< or >) or pipe
465 * characters (|) that are not in a quoted string.
466 * Shell variable interpolation (%VAR%) can also happen inside strings.
498 #if !defined(PERL_IMPLICIT_SYS)
499 /* since the current process environment is being updated in util.c
500 * the library functions will get the correct environment
503 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
505 PERL_FLUSHALL_FOR_CHILD;
506 return win32_popen(cmd, mode);
510 Perl_my_pclose(pTHX_ PerlIO *fp)
512 return win32_pclose(fp);
516 DllExport unsigned long
519 return (unsigned long)g_osver.dwPlatformId;
528 return -((int)w32_pseudo_id);
533 /* Tokenize a string. Words are null-separated, and the list
534 * ends with a doubled null. Any character (except null and
535 * including backslash) may be escaped by preceding it with a
536 * backslash (the backslash will be stripped).
537 * Returns number of words in result buffer.
540 tokenize(const char *str, char **dest, char ***destv)
542 char *retstart = NULL;
543 char **retvstart = 0;
546 int slen = strlen(str);
549 Newx(ret, slen+2, char);
550 Newx(retv, (slen+3)/2, char*);
558 if (*ret == '\\' && *str)
560 else if (*ret == ' ') {
576 retvstart[items] = NULL;
589 if (!w32_perlshell_tokens) {
590 /* we don't use COMSPEC here for two reasons:
591 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
592 * uncontrolled unportability of the ensuing scripts.
593 * 2. PERL5SHELL could be set to a shell that may not be fit for
594 * interactive use (which is what most programs look in COMSPEC
597 const char* defaultshell = "cmd.exe /x/d/c";
598 const char *usershell = PerlEnv_getenv("PERL5SHELL");
599 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
600 &w32_perlshell_tokens,
606 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
614 PERL_ARGS_ASSERT_DO_ASPAWN;
620 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
622 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
627 while (++mark <= sp) {
628 if (*mark && (str = SvPV_nolen(*mark)))
635 status = win32_spawnvp(flag,
636 (const char*)(really ? SvPV_nolen(really) : argv[0]),
637 (const char* const*)argv);
639 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
640 /* possible shell-builtin, invoke with shell */
642 sh_items = w32_perlshell_items;
644 argv[index+sh_items] = argv[index];
645 while (--sh_items >= 0)
646 argv[sh_items] = w32_perlshell_vec[sh_items];
648 status = win32_spawnvp(flag,
649 (const char*)(really ? SvPV_nolen(really) : argv[0]),
650 (const char* const*)argv);
653 if (flag == P_NOWAIT) {
654 PL_statusvalue = -1; /* >16bits hint for pp_system() */
658 if (ckWARN(WARN_EXEC))
659 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
664 PL_statusvalue = status;
670 /* returns pointer to the next unquoted space or the end of the string */
672 find_next_space(const char *s)
674 bool in_quotes = FALSE;
676 /* ignore doubled backslashes, or backslash+quote */
677 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
680 /* keep track of when we're within quotes */
681 else if (*s == '"') {
683 in_quotes = !in_quotes;
685 /* break it up only at spaces that aren't in quotes */
686 else if (!in_quotes && isSPACE(*s))
695 do_spawn2(pTHX_ const char *cmd, int exectype)
701 BOOL needToTry = TRUE;
704 /* Save an extra exec if possible. See if there are shell
705 * metacharacters in it */
706 if (!has_shell_metachars(cmd)) {
707 Newx(argv, strlen(cmd) / 2 + 2, char*);
708 Newx(cmd2, strlen(cmd) + 1, char);
711 for (s = cmd2; *s;) {
712 while (*s && isSPACE(*s))
716 s = find_next_space(s);
724 status = win32_spawnvp(P_WAIT, argv[0],
725 (const char* const*)argv);
727 case EXECF_SPAWN_NOWAIT:
728 status = win32_spawnvp(P_NOWAIT, argv[0],
729 (const char* const*)argv);
732 status = win32_execvp(argv[0], (const char* const*)argv);
735 if (status != -1 || errno == 0)
745 Newx(argv, w32_perlshell_items + 2, char*);
746 while (++i < w32_perlshell_items)
747 argv[i] = w32_perlshell_vec[i];
748 argv[i++] = (char *)cmd;
752 status = win32_spawnvp(P_WAIT, argv[0],
753 (const char* const*)argv);
755 case EXECF_SPAWN_NOWAIT:
756 status = win32_spawnvp(P_NOWAIT, argv[0],
757 (const char* const*)argv);
760 status = win32_execvp(argv[0], (const char* const*)argv);
766 if (exectype == EXECF_SPAWN_NOWAIT) {
767 PL_statusvalue = -1; /* >16bits hint for pp_system() */
771 if (ckWARN(WARN_EXEC))
772 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
773 (exectype == EXECF_EXEC ? "exec" : "spawn"),
774 cmd, strerror(errno));
779 PL_statusvalue = status;
785 Perl_do_spawn(pTHX_ char *cmd)
787 PERL_ARGS_ASSERT_DO_SPAWN;
789 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
793 Perl_do_spawn_nowait(pTHX_ char *cmd)
795 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
797 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
801 Perl_do_exec(pTHX_ const char *cmd)
803 PERL_ARGS_ASSERT_DO_EXEC;
805 do_spawn2(aTHX_ cmd, EXECF_EXEC);
809 /* The idea here is to read all the directory names into a string table
810 * (separated by nulls) and when one of the other dir functions is called
811 * return the pointer to the current file name.
814 win32_opendir(const char *filename)
820 char scanname[MAX_PATH+3];
821 WCHAR wscanname[sizeof(scanname)];
822 WIN32_FIND_DATAW wFindData;
823 char buffer[MAX_PATH*2];
826 len = strlen(filename);
831 if (len > MAX_PATH) {
832 errno = ENAMETOOLONG;
836 /* Get us a DIR structure */
839 /* Create the search pattern */
840 strcpy(scanname, filename);
842 /* bare drive name means look in cwd for drive */
843 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
844 scanname[len++] = '.';
845 scanname[len++] = '/';
847 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
848 scanname[len++] = '/';
850 scanname[len++] = '*';
851 scanname[len] = '\0';
853 /* do the FindFirstFile call */
854 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
855 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
857 if (dirp->handle == INVALID_HANDLE_VALUE) {
858 DWORD err = GetLastError();
859 /* FindFirstFile() fails on empty drives! */
861 case ERROR_FILE_NOT_FOUND:
863 case ERROR_NO_MORE_FILES:
864 case ERROR_PATH_NOT_FOUND:
867 case ERROR_NOT_ENOUGH_MEMORY:
879 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
880 wFindData.cFileName, -1,
881 buffer, sizeof(buffer), NULL, &use_default);
882 if (use_default && *wFindData.cAlternateFileName) {
883 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
884 wFindData.cAlternateFileName, -1,
885 buffer, sizeof(buffer), NULL, NULL);
888 /* now allocate the first part of the string table for
889 * the filenames that we find.
891 idx = strlen(buffer)+1;
896 Newx(dirp->start, dirp->size, char);
897 strcpy(dirp->start, buffer);
899 dirp->end = dirp->curr = dirp->start;
905 /* Readdir just returns the current string pointer and bumps the
906 * string pointer to the nDllExport entry.
908 DllExport struct direct *
909 win32_readdir(DIR *dirp)
914 /* first set up the structure to return */
915 len = strlen(dirp->curr);
916 strcpy(dirp->dirstr.d_name, dirp->curr);
917 dirp->dirstr.d_namlen = len;
920 dirp->dirstr.d_ino = dirp->curr - dirp->start;
922 /* Now set up for the next call to readdir */
923 dirp->curr += len + 1;
924 if (dirp->curr >= dirp->end) {
926 char buffer[MAX_PATH*2];
928 if (dirp->handle == INVALID_HANDLE_VALUE) {
931 /* finding the next file that matches the wildcard
932 * (which should be all of them in this directory!).
935 WIN32_FIND_DATAW wFindData;
936 res = FindNextFileW(dirp->handle, &wFindData);
938 BOOL use_default = FALSE;
939 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
940 wFindData.cFileName, -1,
941 buffer, sizeof(buffer), NULL, &use_default);
942 if (use_default && *wFindData.cAlternateFileName) {
943 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
944 wFindData.cAlternateFileName, -1,
945 buffer, sizeof(buffer), NULL, NULL);
950 long endpos = dirp->end - dirp->start;
951 long newsize = endpos + strlen(buffer) + 1;
952 /* bump the string table size by enough for the
953 * new name and its null terminator */
954 while (newsize > dirp->size) {
955 long curpos = dirp->curr - dirp->start;
957 Renew(dirp->start, dirp->size, char);
958 dirp->curr = dirp->start + curpos;
960 strcpy(dirp->start + endpos, buffer);
961 dirp->end = dirp->start + newsize;
966 if (dirp->handle != INVALID_HANDLE_VALUE) {
967 FindClose(dirp->handle);
968 dirp->handle = INVALID_HANDLE_VALUE;
972 return &(dirp->dirstr);
978 /* Telldir returns the current string pointer position */
980 win32_telldir(DIR *dirp)
982 return dirp->curr ? (dirp->curr - dirp->start) : -1;
986 /* Seekdir moves the string pointer to a previously saved position
987 * (returned by telldir).
990 win32_seekdir(DIR *dirp, long loc)
992 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
995 /* Rewinddir resets the string pointer to the start */
997 win32_rewinddir(DIR *dirp)
999 dirp->curr = dirp->start;
1002 /* free the memory allocated by opendir */
1004 win32_closedir(DIR *dirp)
1006 if (dirp->handle != INVALID_HANDLE_VALUE)
1007 FindClose(dirp->handle);
1008 Safefree(dirp->start);
1013 /* duplicate a open DIR* for interpreter cloning */
1015 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1018 PerlInterpreter *const from = param->proto_perl;
1019 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1024 /* switch back to original interpreter because win32_readdir()
1025 * might Renew(dirp->start).
1031 /* mark current position; read all remaining entries into the
1032 * cache, and then restore to current position.
1034 pos = win32_telldir(dirp);
1035 while (win32_readdir(dirp)) {
1036 /* read all entries into cache */
1038 win32_seekdir(dirp, pos);
1040 /* switch back to new interpreter to allocate new DIR structure */
1046 memcpy(dup, dirp, sizeof(DIR));
1048 Newx(dup->start, dirp->size, char);
1049 memcpy(dup->start, dirp->start, dirp->size);
1051 dup->end = dup->start + (dirp->end - dirp->start);
1053 dup->curr = dup->start + (dirp->curr - dirp->start);
1065 * Just pretend that everyone is a superuser. NT will let us know if
1066 * we don\'t really have permission to do something.
1069 #define ROOT_UID ((uid_t)0)
1070 #define ROOT_GID ((gid_t)0)
1099 return (auid == ROOT_UID ? 0 : -1);
1105 return (agid == ROOT_GID ? 0 : -1);
1112 char *buf = w32_getlogin_buffer;
1113 DWORD size = sizeof(w32_getlogin_buffer);
1114 if (GetUserName(buf,&size))
1120 chown(const char *path, uid_t owner, gid_t group)
1127 * XXX this needs strengthening (for PerlIO)
1130 int mkstemp(const char *path)
1133 char buf[MAX_PATH+1];
1137 if (i++ > 10) { /* give up */
1141 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1145 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1155 long child = w32_num_children;
1156 while (--child >= 0) {
1157 if ((int)w32_child_pids[child] == pid)
1164 remove_dead_process(long child)
1168 CloseHandle(w32_child_handles[child]);
1169 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1170 (w32_num_children-child-1), HANDLE);
1171 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1172 (w32_num_children-child-1), DWORD);
1179 find_pseudo_pid(int pid)
1182 long child = w32_num_pseudo_children;
1183 while (--child >= 0) {
1184 if ((int)w32_pseudo_child_pids[child] == pid)
1191 remove_dead_pseudo_process(long child)
1195 CloseHandle(w32_pseudo_child_handles[child]);
1196 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1197 (w32_num_pseudo_children-child-1), HANDLE);
1198 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1199 (w32_num_pseudo_children-child-1), DWORD);
1200 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1201 (w32_num_pseudo_children-child-1), HWND);
1202 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1203 (w32_num_pseudo_children-child-1), char);
1204 w32_num_pseudo_children--;
1209 win32_wait_for_children(pTHX)
1211 if (w32_pseudo_children && w32_num_pseudo_children) {
1214 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1216 for (child = 0; child < w32_num_pseudo_children; ++child) {
1217 if (!w32_pseudo_child_sigterm[child])
1218 handles[count++] = w32_pseudo_child_handles[child];
1220 /* XXX should use MsgWaitForMultipleObjects() to continue
1221 * XXX processing messages while we wait.
1223 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1225 while (w32_num_pseudo_children)
1226 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1232 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1236 /* "Does process exist?" use of kill */
1239 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1244 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1247 default: /* For now be backwards compatible with perl 5.6 */
1249 /* Note that we will only be able to kill processes owned by the
1250 * current process owner, even when we are running as an administrator.
1251 * To kill processes of other owners we would need to set the
1252 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1254 if (TerminateProcess(process_handle, sig))
1262 killpg(int pid, int sig)
1264 HANDLE process_handle;
1265 HANDLE snapshot_handle;
1268 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1269 if (process_handle == NULL)
1272 killed += terminate_process(pid, process_handle, sig);
1274 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1275 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1276 PROCESSENTRY32 entry;
1278 entry.dwSize = sizeof(entry);
1279 if (Process32First(snapshot_handle, &entry)) {
1281 if (entry.th32ParentProcessID == (DWORD)pid)
1282 killed += killpg(entry.th32ProcessID, sig);
1283 entry.dwSize = sizeof(entry);
1285 while (Process32Next(snapshot_handle, &entry));
1287 CloseHandle(snapshot_handle);
1289 CloseHandle(process_handle);
1294 my_kill(int pid, int sig)
1297 HANDLE process_handle;
1300 return killpg(pid, -sig);
1302 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1303 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1304 if (process_handle != NULL) {
1305 retval = terminate_process(pid, process_handle, sig);
1306 CloseHandle(process_handle);
1312 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1313 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1314 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1315 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1317 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1318 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1319 * a HWND in the time period allowed.
1322 get_hwnd_delay(pTHX, long child, DWORD tries)
1324 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1325 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1327 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1328 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1329 * thread 100% of the time since threads are attached to a CPU for NUMA and
1330 * caching reasons, and the child thread was attached to a different CPU
1331 * therefore there is no workload on that CPU and Sleep(0) returns control
1332 * without yielding the time slot.
1333 * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
1336 win32_async_check(aTHX);
1337 hwnd = w32_pseudo_child_message_hwnds[child];
1338 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1341 unsigned int count = 0;
1342 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1343 while (count++ < tries) {
1345 win32_async_check(aTHX);
1346 hwnd = w32_pseudo_child_message_hwnds[child];
1347 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1351 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1356 win32_kill(int pid, int sig)
1362 /* it is a pseudo-forked child */
1363 child = find_pseudo_pid(-pid);
1365 HANDLE hProcess = w32_pseudo_child_handles[child];
1368 /* "Does process exist?" use of kill */
1372 /* kill -9 style un-graceful exit */
1373 /* Do a wait to make sure child starts and isn't in DLL
1375 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1376 if (TerminateThread(hProcess, sig)) {
1377 /* Allow the scheduler to finish cleaning up the other
1379 * Otherwise, if we ExitProcess() before another context
1380 * switch happens we will end up with a process exit
1381 * code of "sig" instead of our own exit status.
1382 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1385 remove_dead_pseudo_process(child);
1392 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1393 /* We fake signals to pseudo-processes using Win32
1395 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1396 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1398 /* Don't wait for child process to terminate after we send a
1399 * SIGTERM because the child may be blocked in a system call
1400 * and never receive the signal.
1402 if (sig == SIGTERM) {
1404 w32_pseudo_child_sigterm[child] = 1;
1406 /* It might be us ... */
1418 child = find_pid(pid);
1420 if (my_kill(pid, sig)) {
1422 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1423 exitcode != STILL_ACTIVE)
1425 remove_dead_process(child);
1431 if (my_kill(pid, sig))
1440 win32_stat(const char *path, Stat_t *sbuf)
1443 char buffer[MAX_PATH+1];
1444 int l = strlen(path);
1447 BOOL expect_dir = FALSE;
1449 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1450 GV_NOTQUAL, SVt_PV);
1451 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1454 switch(path[l - 1]) {
1455 /* FindFirstFile() and stat() are buggy with a trailing
1456 * slashes, except for the root directory of a drive */
1459 if (l > sizeof(buffer)) {
1460 errno = ENAMETOOLONG;
1464 strncpy(buffer, path, l);
1465 /* remove additional trailing slashes */
1466 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1468 /* add back slash if we otherwise end up with just a drive letter */
1469 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1476 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1478 if (l == 2 && isALPHA(path[0])) {
1479 buffer[0] = path[0];
1490 path = PerlDir_mapA(path);
1494 /* We must open & close the file once; otherwise file attribute changes */
1495 /* might not yet have propagated to "other" hard links of the same file. */
1496 /* This also gives us an opportunity to determine the number of links. */
1497 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1498 if (handle != INVALID_HANDLE_VALUE) {
1499 BY_HANDLE_FILE_INFORMATION bhi;
1500 if (GetFileInformationByHandle(handle, &bhi))
1501 nlink = bhi.nNumberOfLinks;
1502 CloseHandle(handle);
1506 /* path will be mapped correctly above */
1507 #if defined(WIN64) || defined(USE_LARGE_FILES)
1508 res = _stati64(path, sbuf);
1510 res = stat(path, sbuf);
1512 sbuf->st_nlink = nlink;
1515 /* CRT is buggy on sharenames, so make sure it really isn't.
1516 * XXX using GetFileAttributesEx() will enable us to set
1517 * sbuf->st_*time (but note that's not available on the
1518 * Windows of 1995) */
1519 DWORD r = GetFileAttributesA(path);
1520 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1521 /* sbuf may still contain old garbage since stat() failed */
1522 Zero(sbuf, 1, Stat_t);
1523 sbuf->st_mode = S_IFDIR | S_IREAD;
1525 if (!(r & FILE_ATTRIBUTE_READONLY))
1526 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1531 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1532 && (path[2] == '\\' || path[2] == '/'))
1534 /* The drive can be inaccessible, some _stat()s are buggy */
1535 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1540 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1544 if (S_ISDIR(sbuf->st_mode)) {
1545 /* Ensure the "write" bit is switched off in the mode for
1546 * directories with the read-only attribute set. Some compilers
1547 * switch it on for directories, which is technically correct
1548 * (directories are indeed always writable unless denied by DACLs),
1549 * but we want stat() and -w to reflect the state of the read-only
1550 * attribute for symmetry with chmod(). */
1551 DWORD r = GetFileAttributesA(path);
1552 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1553 sbuf->st_mode &= ~S_IWRITE;
1560 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1561 #define SKIP_SLASHES(s) \
1563 while (*(s) && isSLASH(*(s))) \
1566 #define COPY_NONSLASHES(d,s) \
1568 while (*(s) && !isSLASH(*(s))) \
1572 /* Find the longname of a given path. path is destructively modified.
1573 * It should have space for at least MAX_PATH characters. */
1575 win32_longpath(char *path)
1577 WIN32_FIND_DATA fdata;
1579 char tmpbuf[MAX_PATH+1];
1580 char *tmpstart = tmpbuf;
1587 if (isALPHA(path[0]) && path[1] == ':') {
1589 *tmpstart++ = path[0];
1593 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1595 *tmpstart++ = path[0];
1596 *tmpstart++ = path[1];
1597 SKIP_SLASHES(start);
1598 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1600 *tmpstart++ = *start++;
1601 SKIP_SLASHES(start);
1602 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1607 /* copy initial slash, if any */
1608 if (isSLASH(*start)) {
1609 *tmpstart++ = *start++;
1611 SKIP_SLASHES(start);
1614 /* FindFirstFile() expands "." and "..", so we need to pass
1615 * those through unmolested */
1617 && (!start[1] || isSLASH(start[1])
1618 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1620 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1625 /* if this is the end, bust outta here */
1629 /* now we're at a non-slash; walk up to next slash */
1630 while (*start && !isSLASH(*start))
1633 /* stop and find full name of component */
1636 fhand = FindFirstFile(path,&fdata);
1638 if (fhand != INVALID_HANDLE_VALUE) {
1639 STRLEN len = strlen(fdata.cFileName);
1640 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1641 strcpy(tmpstart, fdata.cFileName);
1652 /* failed a step, just return without side effects */
1653 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1658 strcpy(path,tmpbuf);
1667 /* Can't use PerlIO to write as it allocates memory */
1668 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1669 PL_no_mem, strlen(PL_no_mem));
1676 win32_croak_not_implemented(const char * fname)
1678 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1680 Perl_croak_nocontext("%s not implemented!\n", fname);
1683 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1684 * potentially using the system's default replacement character for any
1685 * unrepresentable characters. The caller must free() the returned string. */
1687 wstr_to_str(const wchar_t* wstr)
1689 BOOL used_default = FALSE;
1690 size_t wlen = wcslen(wstr) + 1;
1691 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1692 NULL, 0, NULL, NULL);
1693 char* str = (char*)malloc(len);
1696 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1697 str, len, NULL, &used_default);
1701 /* The win32_ansipath() function takes a Unicode filename and converts it
1702 * into the current Windows codepage. If some characters cannot be mapped,
1703 * then it will convert the short name instead.
1705 * The buffer to the ansi pathname must be freed with win32_free() when it
1706 * it no longer needed.
1708 * The argument to win32_ansipath() must exist before this function is
1709 * called; otherwise there is no way to determine the short path name.
1711 * Ideas for future refinement:
1712 * - Only convert those segments of the path that are not in the current
1713 * codepage, but leave the other segments in their long form.
1714 * - If the resulting name is longer than MAX_PATH, start converting
1715 * additional path segments into short names until the full name
1716 * is shorter than MAX_PATH. Shorten the filename part last!
1719 win32_ansipath(const WCHAR *widename)
1722 BOOL use_default = FALSE;
1723 size_t widelen = wcslen(widename)+1;
1724 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1725 NULL, 0, NULL, NULL);
1726 name = (char*)win32_malloc(len);
1730 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1731 name, len, NULL, &use_default);
1733 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1735 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1738 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1740 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1741 NULL, 0, NULL, NULL);
1742 name = (char*)win32_realloc(name, len);
1745 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1746 name, len, NULL, NULL);
1747 win32_free(shortname);
1753 /* the returned string must be freed with win32_freeenvironmentstrings which is
1754 * implemented as a macro
1755 * void win32_freeenvironmentstrings(void* block)
1758 win32_getenvironmentstrings(void)
1760 LPWSTR lpWStr, lpWTmp;
1762 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1764 /* Get the process environment strings */
1765 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1766 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1767 env_len = wcslen(lpWTmp);
1768 /* calculate the size of the environment strings */
1769 wenvstrings_len += env_len + 1;
1772 /* Get the number of bytes required to store the ACP encoded string */
1773 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1774 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1775 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1779 /* Convert the string from UTF-16 encoding to ACP encoding */
1780 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1781 aenvstrings_len, NULL, NULL);
1787 win32_getenv(const char *name)
1794 needlen = GetEnvironmentVariableA(name,NULL,0);
1796 curitem = sv_2mortal(newSVpvn("", 0));
1798 SvGROW(curitem, needlen+1);
1799 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1801 } while (needlen >= SvLEN(curitem));
1802 SvCUR_set(curitem, needlen);
1805 last_err = GetLastError();
1806 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1807 /* It appears the variable is in the env, but the Win32 API
1808 doesn't have a canned way of getting it. So we fall back to
1809 grabbing the whole env and pulling this value out if possible */
1810 char *envv = GetEnvironmentStrings();
1814 char *end = strchr(cur,'=');
1815 if (end && end != cur) {
1817 if (!strcmp(cur,name)) {
1818 curitem = sv_2mortal(newSVpv(end+1,0));
1823 cur = end + strlen(end+1)+2;
1825 else if ((len = strlen(cur)))
1828 FreeEnvironmentStrings(envv);
1831 /* last ditch: allow any environment variables that begin with 'PERL'
1832 to be obtained from the registry, if found there */
1833 if (strncmp(name, "PERL", 4) == 0)
1834 (void)get_regstr(name, &curitem);
1837 if (curitem && SvCUR(curitem))
1838 return SvPVX(curitem);
1844 win32_putenv(const char *name)
1851 curitem = (char *) win32_malloc(strlen(name)+1);
1852 strcpy(curitem, name);
1853 val = strchr(curitem, '=');
1855 /* The sane way to deal with the environment.
1856 * Has these advantages over putenv() & co.:
1857 * * enables us to store a truly empty value in the
1858 * environment (like in UNIX).
1859 * * we don't have to deal with RTL globals, bugs and leaks
1860 * (specifically, see http://support.microsoft.com/kb/235601).
1862 * Why you may want to use the RTL environment handling
1863 * (previously enabled by USE_WIN32_RTL_ENV):
1864 * * environ[] and RTL functions will not reflect changes,
1865 * which might be an issue if extensions want to access
1866 * the env. via RTL. This cuts both ways, since RTL will
1867 * not see changes made by extensions that call the Win32
1868 * functions directly, either.
1872 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1875 win32_free(curitem);
1881 filetime_to_clock(PFILETIME ft)
1883 __int64 qw = ft->dwHighDateTime;
1885 qw |= ft->dwLowDateTime;
1886 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1891 win32_times(struct tms *timebuf)
1896 clock_t process_time_so_far = clock();
1897 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1899 timebuf->tms_utime = filetime_to_clock(&user);
1900 timebuf->tms_stime = filetime_to_clock(&kernel);
1901 timebuf->tms_cutime = 0;
1902 timebuf->tms_cstime = 0;
1904 /* That failed - e.g. Win95 fallback to clock() */
1905 timebuf->tms_utime = process_time_so_far;
1906 timebuf->tms_stime = 0;
1907 timebuf->tms_cutime = 0;
1908 timebuf->tms_cstime = 0;
1910 return process_time_so_far;
1913 /* fix utime() so it works on directories in NT */
1915 filetime_from_time(PFILETIME pFileTime, time_t Time)
1917 struct tm *pTM = localtime(&Time);
1918 SYSTEMTIME SystemTime;
1924 SystemTime.wYear = pTM->tm_year + 1900;
1925 SystemTime.wMonth = pTM->tm_mon + 1;
1926 SystemTime.wDay = pTM->tm_mday;
1927 SystemTime.wHour = pTM->tm_hour;
1928 SystemTime.wMinute = pTM->tm_min;
1929 SystemTime.wSecond = pTM->tm_sec;
1930 SystemTime.wMilliseconds = 0;
1932 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1933 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1937 win32_unlink(const char *filename)
1943 filename = PerlDir_mapA(filename);
1944 attrs = GetFileAttributesA(filename);
1945 if (attrs == 0xFFFFFFFF) {
1949 if (attrs & FILE_ATTRIBUTE_READONLY) {
1950 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1951 ret = unlink(filename);
1953 (void)SetFileAttributesA(filename, attrs);
1956 ret = unlink(filename);
1961 win32_utime(const char *filename, struct utimbuf *times)
1968 struct utimbuf TimeBuffer;
1971 filename = PerlDir_mapA(filename);
1972 rc = utime(filename, times);
1974 /* EACCES: path specifies directory or readonly file */
1975 if (rc == 0 || errno != EACCES)
1978 if (times == NULL) {
1979 times = &TimeBuffer;
1980 time(×->actime);
1981 times->modtime = times->actime;
1984 /* This will (and should) still fail on readonly files */
1985 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1986 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1987 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1988 if (handle == INVALID_HANDLE_VALUE)
1991 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1992 filetime_from_time(&ftAccess, times->actime) &&
1993 filetime_from_time(&ftWrite, times->modtime) &&
1994 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1999 CloseHandle(handle);
2004 unsigned __int64 ft_i64;
2009 #define Const64(x) x##LL
2011 #define Const64(x) x##i64
2013 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2014 #define EPOCH_BIAS Const64(116444736000000000)
2016 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2017 * and appears to be unsupported even by glibc) */
2019 win32_gettimeofday(struct timeval *tp, void *not_used)
2023 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2024 GetSystemTimeAsFileTime(&ft.ft_val);
2026 /* seconds since epoch */
2027 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2029 /* microseconds remaining */
2030 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2036 win32_uname(struct utsname *name)
2038 struct hostent *hep;
2039 STRLEN nodemax = sizeof(name->nodename)-1;
2042 switch (g_osver.dwPlatformId) {
2043 case VER_PLATFORM_WIN32_WINDOWS:
2044 strcpy(name->sysname, "Windows");
2046 case VER_PLATFORM_WIN32_NT:
2047 strcpy(name->sysname, "Windows NT");
2049 case VER_PLATFORM_WIN32s:
2050 strcpy(name->sysname, "Win32s");
2053 strcpy(name->sysname, "Win32 Unknown");
2058 sprintf(name->release, "%d.%d",
2059 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2062 sprintf(name->version, "Build %d",
2063 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2064 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2065 if (g_osver.szCSDVersion[0]) {
2066 char *buf = name->version + strlen(name->version);
2067 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2071 hep = win32_gethostbyname("localhost");
2073 STRLEN len = strlen(hep->h_name);
2074 if (len <= nodemax) {
2075 strcpy(name->nodename, hep->h_name);
2078 strncpy(name->nodename, hep->h_name, nodemax);
2079 name->nodename[nodemax] = '\0';
2084 if (!GetComputerName(name->nodename, &sz))
2085 *name->nodename = '\0';
2088 /* machine (architecture) */
2093 GetSystemInfo(&info);
2095 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2096 procarch = info.u.s.wProcessorArchitecture;
2098 procarch = info.wProcessorArchitecture;
2101 case PROCESSOR_ARCHITECTURE_INTEL:
2102 arch = "x86"; break;
2103 case PROCESSOR_ARCHITECTURE_IA64:
2104 arch = "ia64"; break;
2105 case PROCESSOR_ARCHITECTURE_AMD64:
2106 arch = "amd64"; break;
2107 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2108 arch = "unknown"; break;
2110 sprintf(name->machine, "unknown(0x%x)", procarch);
2111 arch = name->machine;
2114 if (name->machine != arch)
2115 strcpy(name->machine, arch);
2120 /* Timing related stuff */
2123 do_raise(pTHX_ int sig)
2125 if (sig < SIG_SIZE) {
2126 Sighandler_t handler = w32_sighandler[sig];
2127 if (handler == SIG_IGN) {
2130 else if (handler != SIG_DFL) {
2135 /* Choose correct default behaviour */
2151 /* Tell caller to exit thread/process as approriate */
2156 sig_terminate(pTHX_ int sig)
2158 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2159 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2166 win32_async_check(pTHX)
2169 HWND hwnd = w32_message_hwnd;
2171 /* Reset w32_poll_count before doing anything else, incase we dispatch
2172 * messages that end up calling back into perl */
2175 if (hwnd != INVALID_HANDLE_VALUE) {
2176 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2177 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2182 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2183 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2185 /* re-post a WM_QUIT message (we'll mark it as read later) */
2186 if(msg.message == WM_QUIT) {
2187 PostQuitMessage((int)msg.wParam);
2191 if(!CallMsgFilter(&msg, MSGF_USER))
2193 TranslateMessage(&msg);
2194 DispatchMessage(&msg);
2199 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2200 * This is necessary when we are being called by win32_msgwait() to
2201 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2202 * message over and over. An example how this can happen is when
2203 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2204 * is generating messages before the process terminated.
2206 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2208 /* Above or other stuff may have set a signal flag */
2215 /* This function will not return until the timeout has elapsed, or until
2216 * one of the handles is ready. */
2218 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2220 /* We may need several goes at this - so compute when we stop */
2222 unsigned __int64 endtime = timeout;
2223 if (timeout != INFINITE) {
2224 GetSystemTimeAsFileTime(&ticks.ft_val);
2225 ticks.ft_i64 /= 10000;
2226 endtime += ticks.ft_i64;
2228 /* This was a race condition. Do not let a non INFINITE timeout to
2229 * MsgWaitForMultipleObjects roll under 0 creating a near
2230 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2231 * user who did a CORE perl function with a non infinity timeout,
2232 * sleep for example. This is 64 to 32 truncation minefield.
2234 * This scenario can only be created if the timespan from the return of
2235 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2236 * generate the scenario, manual breakpoints in a C debugger are required,
2237 * or a context switch occured in win32_async_check in PeekMessage, or random
2238 * messages are delivered to the *thread* message queue of the Perl thread
2239 * from another process (msctf.dll doing IPC among its instances, VS debugger
2240 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2242 while (ticks.ft_i64 <= endtime) {
2243 /* if timeout's type is lengthened, remember to split 64b timeout
2244 * into multiple non-infinity runs of MWFMO */
2245 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2246 (DWORD)(endtime - ticks.ft_i64),
2247 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2250 if (result == WAIT_TIMEOUT) {
2251 /* Ran out of time - explicit return of zero to avoid -ve if we
2252 have scheduling issues
2256 if (timeout != INFINITE) {
2257 GetSystemTimeAsFileTime(&ticks.ft_val);
2258 ticks.ft_i64 /= 10000;
2260 if (result == WAIT_OBJECT_0 + count) {
2261 /* Message has arrived - check it */
2262 (void)win32_async_check(aTHX);
2265 /* Not timeout or message - one of handles is ready */
2269 /* If we are past the end say zero */
2270 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2272 /* compute time left to wait */
2273 ticks.ft_i64 = endtime - ticks.ft_i64;
2274 /* if more ms than DWORD, then return max DWORD */
2275 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2279 win32_internal_wait(int *status, DWORD timeout)
2281 /* XXX this wait emulation only knows about processes
2282 * spawned via win32_spawnvp(P_NOWAIT, ...).
2286 DWORD exitcode, waitcode;
2289 if (w32_num_pseudo_children) {
2290 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2291 timeout, &waitcode);
2292 /* Time out here if there are no other children to wait for. */
2293 if (waitcode == WAIT_TIMEOUT) {
2294 if (!w32_num_children) {
2298 else if (waitcode != WAIT_FAILED) {
2299 if (waitcode >= WAIT_ABANDONED_0
2300 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2301 i = waitcode - WAIT_ABANDONED_0;
2303 i = waitcode - WAIT_OBJECT_0;
2304 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2305 *status = (int)((exitcode & 0xff) << 8);
2306 retval = (int)w32_pseudo_child_pids[i];
2307 remove_dead_pseudo_process(i);
2314 if (!w32_num_children) {
2319 /* if a child exists, wait for it to die */
2320 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2321 if (waitcode == WAIT_TIMEOUT) {
2324 if (waitcode != WAIT_FAILED) {
2325 if (waitcode >= WAIT_ABANDONED_0
2326 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2327 i = waitcode - WAIT_ABANDONED_0;
2329 i = waitcode - WAIT_OBJECT_0;
2330 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2331 *status = (int)((exitcode & 0xff) << 8);
2332 retval = (int)w32_child_pids[i];
2333 remove_dead_process(i);
2338 errno = GetLastError();
2343 win32_waitpid(int pid, int *status, int flags)
2346 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2349 if (pid == -1) /* XXX threadid == 1 ? */
2350 return win32_internal_wait(status, timeout);
2353 child = find_pseudo_pid(-pid);
2355 HANDLE hThread = w32_pseudo_child_handles[child];
2357 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2358 if (waitcode == WAIT_TIMEOUT) {
2361 else if (waitcode == WAIT_OBJECT_0) {
2362 if (GetExitCodeThread(hThread, &waitcode)) {
2363 *status = (int)((waitcode & 0xff) << 8);
2364 retval = (int)w32_pseudo_child_pids[child];
2365 remove_dead_pseudo_process(child);
2377 child = find_pid(pid);
2379 hProcess = w32_child_handles[child];
2380 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2381 if (waitcode == WAIT_TIMEOUT) {
2384 else if (waitcode == WAIT_OBJECT_0) {
2385 if (GetExitCodeProcess(hProcess, &waitcode)) {
2386 *status = (int)((waitcode & 0xff) << 8);
2387 retval = (int)w32_child_pids[child];
2388 remove_dead_process(child);
2396 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2398 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2399 if (waitcode == WAIT_TIMEOUT) {
2400 CloseHandle(hProcess);
2403 else if (waitcode == WAIT_OBJECT_0) {
2404 if (GetExitCodeProcess(hProcess, &waitcode)) {
2405 *status = (int)((waitcode & 0xff) << 8);
2406 CloseHandle(hProcess);
2410 CloseHandle(hProcess);
2416 return retval >= 0 ? pid : retval;
2420 win32_wait(int *status)
2422 return win32_internal_wait(status, INFINITE);
2425 DllExport unsigned int
2426 win32_sleep(unsigned int t)
2429 /* Win32 times are in ms so *1000 in and /1000 out */
2430 if (t > UINT_MAX / 1000) {
2431 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2432 "sleep(%lu) too large", t);
2434 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2437 DllExport unsigned int
2438 win32_alarm(unsigned int sec)
2441 * the 'obvious' implentation is SetTimer() with a callback
2442 * which does whatever receiving SIGALRM would do
2443 * we cannot use SIGALRM even via raise() as it is not
2444 * one of the supported codes in <signal.h>
2448 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2449 w32_message_hwnd = win32_create_message_window();
2452 if (w32_message_hwnd == NULL)
2453 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2456 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2461 KillTimer(w32_message_hwnd, w32_timerid);
2468 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2471 win32_crypt(const char *txt, const char *salt)
2474 return des_fcrypt(txt, salt, w32_crypt_buffer);
2477 /* simulate flock by locking a range on the file */
2479 #define LK_LEN 0xffff0000
2482 win32_flock(int fd, int oper)
2488 fh = (HANDLE)_get_osfhandle(fd);
2489 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2492 memset(&o, 0, sizeof(o));
2495 case LOCK_SH: /* shared lock */
2496 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2499 case LOCK_EX: /* exclusive lock */
2500 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2503 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2504 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2507 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2508 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2512 case LOCK_UN: /* unlock lock */
2513 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2516 default: /* unknown */
2521 if (GetLastError() == ERROR_LOCK_VIOLATION)
2522 errno = WSAEWOULDBLOCK;
2532 * redirected io subsystem for all XS modules
2545 return (&(_environ));
2548 /* the rest are the remapped stdio routines */
2568 win32_ferror(FILE *fp)
2570 return (ferror(fp));
2575 win32_feof(FILE *fp)
2581 * Since the errors returned by the socket error function
2582 * WSAGetLastError() are not known by the library routine strerror
2583 * we have to roll our own.
2587 win32_strerror(int e)
2589 #if !defined __MINGW32__ /* compiler intolerance */
2590 extern int sys_nerr;
2593 if (e < 0 || e > sys_nerr) {
2598 aTHXa(PERL_GET_THX);
2599 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2600 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2601 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2604 strcpy(w32_strerror_buffer, "Unknown Error");
2606 return w32_strerror_buffer;
2610 #define strerror win32_strerror
2614 win32_str_os_error(void *sv, DWORD dwErr)
2618 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2619 |FORMAT_MESSAGE_IGNORE_INSERTS
2620 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2621 dwErr, 0, (char *)&sMsg, 1, NULL);
2622 /* strip trailing whitespace and period */
2625 --dwLen; /* dwLen doesn't include trailing null */
2626 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2627 if ('.' != sMsg[dwLen])
2632 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2634 dwLen = sprintf(sMsg,
2635 "Unknown error #0x%lX (lookup 0x%lX)",
2636 dwErr, GetLastError());
2640 sv_setpvn((SV*)sv, sMsg, dwLen);
2646 win32_fprintf(FILE *fp, const char *format, ...)
2649 va_start(marker, format); /* Initialize variable arguments. */
2651 return (vfprintf(fp, format, marker));
2655 win32_printf(const char *format, ...)
2658 va_start(marker, format); /* Initialize variable arguments. */
2660 return (vprintf(format, marker));
2664 win32_vfprintf(FILE *fp, const char *format, va_list args)
2666 return (vfprintf(fp, format, args));
2670 win32_vprintf(const char *format, va_list args)
2672 return (vprintf(format, args));
2676 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2678 return fread(buf, size, count, fp);
2682 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2684 return fwrite(buf, size, count, fp);
2687 #define MODE_SIZE 10
2690 win32_fopen(const char *filename, const char *mode)
2698 if (stricmp(filename, "/dev/null")==0)
2701 f = fopen(PerlDir_mapA(filename), mode);
2702 /* avoid buffering headaches for child processes */
2703 if (f && *mode == 'a')
2704 win32_fseek(f, 0, SEEK_END);
2709 win32_fdopen(int handle, const char *mode)
2712 f = fdopen(handle, (char *) mode);
2713 /* avoid buffering headaches for child processes */
2714 if (f && *mode == 'a')
2715 win32_fseek(f, 0, SEEK_END);
2720 win32_freopen(const char *path, const char *mode, FILE *stream)
2723 if (stricmp(path, "/dev/null")==0)
2726 return freopen(PerlDir_mapA(path), mode, stream);
2730 win32_fclose(FILE *pf)
2732 #ifdef WIN32_NO_SOCKETS
2735 return my_fclose(pf); /* defined in win32sck.c */
2740 win32_fputs(const char *s,FILE *pf)
2742 return fputs(s, pf);
2746 win32_fputc(int c,FILE *pf)
2752 win32_ungetc(int c,FILE *pf)
2754 return ungetc(c,pf);
2758 win32_getc(FILE *pf)
2764 win32_fileno(FILE *pf)
2770 win32_clearerr(FILE *pf)
2777 win32_fflush(FILE *pf)
2783 win32_ftell(FILE *pf)
2785 #if defined(WIN64) || defined(USE_LARGE_FILES)
2787 if (fgetpos(pf, &pos))
2796 win32_fseek(FILE *pf, Off_t offset,int origin)
2798 #if defined(WIN64) || defined(USE_LARGE_FILES)
2802 if (fgetpos(pf, &pos))
2807 fseek(pf, 0, SEEK_END);
2808 pos = _telli64(fileno(pf));
2817 return fsetpos(pf, &offset);
2819 return fseek(pf, (long)offset, origin);
2824 win32_fgetpos(FILE *pf,fpos_t *p)
2826 return fgetpos(pf, p);
2830 win32_fsetpos(FILE *pf,const fpos_t *p)
2832 return fsetpos(pf, p);
2836 win32_rewind(FILE *pf)
2845 char prefix[MAX_PATH+1];
2846 char filename[MAX_PATH+1];
2847 DWORD len = GetTempPath(MAX_PATH, prefix);
2848 if (len && len < MAX_PATH) {
2849 if (GetTempFileName(prefix, "plx", 0, filename)) {
2850 HANDLE fh = CreateFile(filename,
2851 DELETE | GENERIC_READ | GENERIC_WRITE,
2855 FILE_ATTRIBUTE_NORMAL
2856 | FILE_FLAG_DELETE_ON_CLOSE,
2858 if (fh != INVALID_HANDLE_VALUE) {
2859 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2861 DEBUG_p(PerlIO_printf(Perl_debug_log,
2862 "Created tmpfile=%s\n",filename));
2874 int fd = win32_tmpfd();
2876 return win32_fdopen(fd, "w+b");
2888 win32_fstat(int fd, Stat_t *sbufptr)
2890 #if defined(WIN64) || defined(USE_LARGE_FILES)
2891 return _fstati64(fd, sbufptr);
2893 return fstat(fd, sbufptr);
2898 win32_pipe(int *pfd, unsigned int size, int mode)
2900 return _pipe(pfd, size, mode);
2904 win32_popenlist(const char *mode, IV narg, SV **args)
2906 Perl_croak_nocontext("List form of pipe open not implemented");
2911 * a popen() clone that respects PERL5SHELL
2913 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2917 win32_popen(const char *command, const char *mode)
2919 #ifdef USE_RTL_POPEN
2920 return _popen(command, mode);
2931 /* establish which ends read and write */
2932 if (strchr(mode,'w')) {
2933 stdfd = 0; /* stdin */
2936 nhandle = STD_INPUT_HANDLE;
2938 else if (strchr(mode,'r')) {
2939 stdfd = 1; /* stdout */
2942 nhandle = STD_OUTPUT_HANDLE;
2947 /* set the correct mode */
2948 if (strchr(mode,'b'))
2950 else if (strchr(mode,'t'))
2953 ourmode = _fmode & (O_TEXT | O_BINARY);
2955 /* the child doesn't inherit handles */
2956 ourmode |= O_NOINHERIT;
2958 if (win32_pipe(p, 512, ourmode) == -1)
2961 /* save the old std handle (this needs to happen before the
2962 * dup2(), since that might call SetStdHandle() too) */
2965 old_h = GetStdHandle(nhandle);
2967 /* save current stdfd */
2968 if ((oldfd = win32_dup(stdfd)) == -1)
2971 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2972 /* stdfd will be inherited by the child */
2973 if (win32_dup2(p[child], stdfd) == -1)
2976 /* close the child end in parent */
2977 win32_close(p[child]);
2979 /* set the new std handle (in case dup2() above didn't) */
2980 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2982 /* start the child */
2985 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2988 /* revert stdfd to whatever it was before */
2989 if (win32_dup2(oldfd, stdfd) == -1)
2992 /* close saved handle */
2995 /* restore the old std handle (this needs to happen after the
2996 * dup2(), since that might call SetStdHandle() too */
2998 SetStdHandle(nhandle, old_h);
3003 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3005 /* set process id so that it can be returned by perl's open() */
3006 PL_forkprocess = childpid;
3009 /* we have an fd, return a file stream */
3010 return (PerlIO_fdopen(p[parent], (char *)mode));
3013 /* we don't need to check for errors here */
3017 win32_dup2(oldfd, stdfd);
3021 SetStdHandle(nhandle, old_h);
3027 #endif /* USE_RTL_POPEN */
3035 win32_pclose(PerlIO *pf)
3037 #ifdef USE_RTL_POPEN
3041 int childpid, status;
3044 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3047 childpid = SvIVX(sv);
3063 if (win32_waitpid(childpid, &status, 0) == -1)
3068 #endif /* USE_RTL_POPEN */
3072 win32_link(const char *oldname, const char *newname)
3075 WCHAR wOldName[MAX_PATH+1];
3076 WCHAR wNewName[MAX_PATH+1];
3078 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3079 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3080 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3081 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3085 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3086 both permissions errors and if the source is a directory, while
3087 POSIX wants EACCES and EPERM respectively.
3089 Determined by experimentation on Windows 7 x64 SP1, since MS
3090 don't document what error codes are returned.
3092 switch (GetLastError()) {
3093 case ERROR_BAD_NET_NAME:
3094 case ERROR_BAD_NETPATH:
3095 case ERROR_BAD_PATHNAME:
3096 case ERROR_FILE_NOT_FOUND:
3097 case ERROR_FILENAME_EXCED_RANGE:
3098 case ERROR_INVALID_DRIVE:
3099 case ERROR_PATH_NOT_FOUND:
3102 case ERROR_ALREADY_EXISTS:
3105 case ERROR_ACCESS_DENIED:
3108 case ERROR_NOT_SAME_DEVICE:
3112 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3120 win32_rename(const char *oname, const char *newname)
3122 char szOldName[MAX_PATH+1];
3124 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3127 if (stricmp(newname, oname))
3128 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3129 strcpy(szOldName, PerlDir_mapA(oname));
3131 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3133 DWORD err = GetLastError();
3135 case ERROR_BAD_NET_NAME:
3136 case ERROR_BAD_NETPATH:
3137 case ERROR_BAD_PATHNAME:
3138 case ERROR_FILE_NOT_FOUND:
3139 case ERROR_FILENAME_EXCED_RANGE:
3140 case ERROR_INVALID_DRIVE:
3141 case ERROR_NO_MORE_FILES:
3142 case ERROR_PATH_NOT_FOUND:
3155 win32_setmode(int fd, int mode)
3157 return setmode(fd, mode);
3161 win32_chsize(int fd, Off_t size)
3163 #if defined(WIN64) || defined(USE_LARGE_FILES)
3165 Off_t cur, end, extend;
3167 cur = win32_tell(fd);
3170 end = win32_lseek(fd, 0, SEEK_END);
3173 extend = size - end;
3177 else if (extend > 0) {
3178 /* must grow the file, padding with nulls */
3180 int oldmode = win32_setmode(fd, O_BINARY);
3182 memset(b, '\0', sizeof(b));
3184 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3185 count = win32_write(fd, b, count);
3186 if ((int)count < 0) {
3190 } while ((extend -= count) > 0);
3191 win32_setmode(fd, oldmode);
3194 /* shrink the file */
3195 win32_lseek(fd, size, SEEK_SET);
3196 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3202 win32_lseek(fd, cur, SEEK_SET);
3205 return chsize(fd, (long)size);
3210 win32_lseek(int fd, Off_t offset, int origin)
3212 #if defined(WIN64) || defined(USE_LARGE_FILES)
3213 return _lseeki64(fd, offset, origin);
3215 return lseek(fd, (long)offset, origin);
3222 #if defined(WIN64) || defined(USE_LARGE_FILES)
3223 return _telli64(fd);
3230 win32_open(const char *path, int flag, ...)
3237 pmode = va_arg(ap, int);
3240 if (stricmp(path, "/dev/null")==0)
3243 return open(PerlDir_mapA(path), flag, pmode);
3246 /* close() that understands socket */
3247 extern int my_close(int); /* in win32sck.c */
3252 #ifdef WIN32_NO_SOCKETS
3255 return my_close(fd);
3266 win32_isatty(int fd)
3268 /* The Microsoft isatty() function returns true for *all*
3269 * character mode devices, including "nul". Our implementation
3270 * should only return true if the handle has a console buffer.
3273 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3274 if (fh == (HANDLE)-1) {
3275 /* errno is already set to EBADF */
3279 if (GetConsoleMode(fh, &mode))
3293 win32_dup2(int fd1,int fd2)
3295 return dup2(fd1,fd2);
3299 win32_read(int fd, void *buf, unsigned int cnt)
3301 return read(fd, buf, cnt);
3305 win32_write(int fd, const void *buf, unsigned int cnt)
3307 return write(fd, buf, cnt);
3311 win32_mkdir(const char *dir, int mode)
3314 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3318 win32_rmdir(const char *dir)
3321 return rmdir(PerlDir_mapA(dir));
3325 win32_chdir(const char *dir)
3335 win32_access(const char *path, int mode)
3338 return access(PerlDir_mapA(path), mode);
3342 win32_chmod(const char *path, int mode)
3345 return chmod(PerlDir_mapA(path), mode);
3350 create_command_line(char *cname, STRLEN clen, const char * const *args)
3356 bool bat_file = FALSE;
3357 bool cmd_shell = FALSE;
3358 bool dumb_shell = FALSE;
3359 bool extra_quotes = FALSE;
3360 bool quote_next = FALSE;
3363 cname = (char*)args[0];
3365 /* The NT cmd.exe shell has the following peculiarity that needs to be
3366 * worked around. It strips a leading and trailing dquote when any
3367 * of the following is true:
3368 * 1. the /S switch was used
3369 * 2. there are more than two dquotes
3370 * 3. there is a special character from this set: &<>()@^|
3371 * 4. no whitespace characters within the two dquotes
3372 * 5. string between two dquotes isn't an executable file
3373 * To work around this, we always add a leading and trailing dquote
3374 * to the string, if the first argument is either "cmd.exe" or "cmd",
3375 * and there were at least two or more arguments passed to cmd.exe
3376 * (not including switches).
3377 * XXX the above rules (from "cmd /?") don't seem to be applied
3378 * always, making for the convolutions below :-(
3382 clen = strlen(cname);
3385 && (stricmp(&cname[clen-4], ".bat") == 0
3386 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3392 char *exe = strrchr(cname, '/');
3393 char *exe2 = strrchr(cname, '\\');
3400 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3404 else if (stricmp(exe, "command.com") == 0
3405 || stricmp(exe, "command") == 0)
3412 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3413 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3414 STRLEN curlen = strlen(arg);
3415 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3416 len += 2; /* assume quoting needed (worst case) */
3418 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3420 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3423 Newx(cmd, len, char);
3428 extra_quotes = TRUE;
3431 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3433 STRLEN curlen = strlen(arg);
3435 /* we want to protect empty arguments and ones with spaces with
3436 * dquotes, but only if they aren't already there */
3441 else if (quote_next) {
3442 /* see if it really is multiple arguments pretending to
3443 * be one and force a set of quotes around it */
3444 if (*find_next_space(arg))
3447 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3449 while (i < curlen) {
3450 if (isSPACE(arg[i])) {
3453 else if (arg[i] == '"') {
3477 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3478 && stricmp(arg+curlen-2, "/c") == 0)
3480 /* is there a next argument? */
3481 if (args[index+1]) {
3482 /* are there two or more next arguments? */
3483 if (args[index+2]) {
3485 extra_quotes = TRUE;
3488 /* single argument, force quoting if it has spaces */
3504 qualified_path(const char *cmd)
3508 char *fullcmd, *curfullcmd;
3514 fullcmd = (char*)cmd;
3516 if (*fullcmd == '/' || *fullcmd == '\\')
3523 pathstr = PerlEnv_getenv("PATH");
3525 /* worst case: PATH is a single directory; we need additional space
3526 * to append "/", ".exe" and trailing "\0" */
3527 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3528 curfullcmd = fullcmd;
3533 /* start by appending the name to the current prefix */
3534 strcpy(curfullcmd, cmd);
3535 curfullcmd += cmdlen;
3537 /* if it doesn't end with '.', or has no extension, try adding
3538 * a trailing .exe first */
3539 if (cmd[cmdlen-1] != '.'
3540 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3542 strcpy(curfullcmd, ".exe");
3543 res = GetFileAttributes(fullcmd);
3544 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3549 /* that failed, try the bare name */
3550 res = GetFileAttributes(fullcmd);
3551 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3554 /* quit if no other path exists, or if cmd already has path */
3555 if (!pathstr || !*pathstr || has_slash)
3558 /* skip leading semis */
3559 while (*pathstr == ';')
3562 /* build a new prefix from scratch */
3563 curfullcmd = fullcmd;
3564 while (*pathstr && *pathstr != ';') {
3565 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3566 pathstr++; /* skip initial '"' */
3567 while (*pathstr && *pathstr != '"') {
3568 *curfullcmd++ = *pathstr++;
3571 pathstr++; /* skip trailing '"' */
3574 *curfullcmd++ = *pathstr++;
3578 pathstr++; /* skip trailing semi */
3579 if (curfullcmd > fullcmd /* append a dir separator */
3580 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3582 *curfullcmd++ = '\\';
3590 /* The following are just place holders.
3591 * Some hosts may provide and environment that the OS is
3592 * not tracking, therefore, these host must provide that
3593 * environment and the current directory to CreateProcess
3597 win32_get_childenv(void)
3603 win32_free_childenv(void* d)
3608 win32_clearenv(void)
3610 char *envv = GetEnvironmentStrings();
3614 char *end = strchr(cur,'=');
3615 if (end && end != cur) {
3617 SetEnvironmentVariable(cur, NULL);
3619 cur = end + strlen(end+1)+2;
3621 else if ((len = strlen(cur)))
3624 FreeEnvironmentStrings(envv);
3628 win32_get_childdir(void)
3631 char szfilename[MAX_PATH+1];
3633 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3634 Newx(ptr, strlen(szfilename)+1, char);
3635 strcpy(ptr, szfilename);
3640 win32_free_childdir(char* d)
3646 /* XXX this needs to be made more compatible with the spawnvp()
3647 * provided by the various RTLs. In particular, searching for
3648 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3649 * This doesn't significantly affect perl itself, because we
3650 * always invoke things using PERL5SHELL if a direct attempt to
3651 * spawn the executable fails.
3653 * XXX splitting and rejoining the commandline between do_aspawn()
3654 * and win32_spawnvp() could also be avoided.
3658 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3660 #ifdef USE_RTL_SPAWNVP
3661 return spawnvp(mode, cmdname, (char * const *)argv);
3668 STARTUPINFO StartupInfo;
3669 PROCESS_INFORMATION ProcessInformation;
3672 char *fullcmd = NULL;
3673 char *cname = (char *)cmdname;
3677 clen = strlen(cname);
3678 /* if command name contains dquotes, must remove them */
3679 if (strchr(cname, '"')) {
3681 Newx(cname,clen+1,char);
3694 cmd = create_command_line(cname, clen, argv);
3696 aTHXa(PERL_GET_THX);
3697 env = PerlEnv_get_childenv();
3698 dir = PerlEnv_get_childdir();
3701 case P_NOWAIT: /* asynch + remember result */
3702 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3707 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3710 create |= CREATE_NEW_PROCESS_GROUP;
3713 case P_WAIT: /* synchronous execution */
3715 default: /* invalid mode */
3720 memset(&StartupInfo,0,sizeof(StartupInfo));
3721 StartupInfo.cb = sizeof(StartupInfo);
3722 memset(&tbl,0,sizeof(tbl));
3723 PerlEnv_get_child_IO(&tbl);
3724 StartupInfo.dwFlags = tbl.dwFlags;
3725 StartupInfo.dwX = tbl.dwX;
3726 StartupInfo.dwY = tbl.dwY;
3727 StartupInfo.dwXSize = tbl.dwXSize;
3728 StartupInfo.dwYSize = tbl.dwYSize;
3729 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3730 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3731 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3732 StartupInfo.wShowWindow = tbl.wShowWindow;
3733 StartupInfo.hStdInput = tbl.childStdIn;
3734 StartupInfo.hStdOutput = tbl.childStdOut;
3735 StartupInfo.hStdError = tbl.childStdErr;
3736 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3737 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3738 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3740 create |= CREATE_NEW_CONSOLE;
3743 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3745 if (w32_use_showwindow) {
3746 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3747 StartupInfo.wShowWindow = w32_showwindow;
3750 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3753 if (!CreateProcess(cname, /* search PATH to find executable */
3754 cmd, /* executable, and its arguments */
3755 NULL, /* process attributes */
3756 NULL, /* thread attributes */
3757 TRUE, /* inherit handles */
3758 create, /* creation flags */
3759 (LPVOID)env, /* inherit environment */
3760 dir, /* inherit cwd */
3762 &ProcessInformation))
3764 /* initial NULL argument to CreateProcess() does a PATH
3765 * search, but it always first looks in the directory
3766 * where the current process was started, which behavior
3767 * is undesirable for backward compatibility. So we
3768 * jump through our own hoops by picking out the path
3769 * we really want it to use. */
3771 fullcmd = qualified_path(cname);
3773 if (cname != cmdname)
3776 DEBUG_p(PerlIO_printf(Perl_debug_log,
3777 "Retrying [%s] with same args\n",
3787 if (mode == P_NOWAIT) {
3788 /* asynchronous spawn -- store handle, return PID */
3789 ret = (int)ProcessInformation.dwProcessId;
3791 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3792 w32_child_pids[w32_num_children] = (DWORD)ret;
3797 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3798 /* FIXME: if msgwait returned due to message perhaps forward the
3799 "signal" to the process
3801 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3803 CloseHandle(ProcessInformation.hProcess);
3806 CloseHandle(ProcessInformation.hThread);
3809 PerlEnv_free_childenv(env);
3810 PerlEnv_free_childdir(dir);
3812 if (cname != cmdname)
3819 win32_execv(const char *cmdname, const char *const *argv)
3823 /* if this is a pseudo-forked child, we just want to spawn
3824 * the new program, and return */
3826 return spawnv(P_WAIT, cmdname, argv);
3828 return execv(cmdname, argv);
3832 win32_execvp(const char *cmdname, const char *const *argv)
3836 /* if this is a pseudo-forked child, we just want to spawn
3837 * the new program, and return */
3838 if (w32_pseudo_id) {
3839 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3848 return execvp(cmdname, argv);
3852 win32_perror(const char *str)
3858 win32_setbuf(FILE *pf, char *buf)
3864 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3866 return setvbuf(pf, buf, type, size);
3870 win32_flushall(void)
3876 win32_fcloseall(void)
3882 win32_fgets(char *s, int n, FILE *pf)
3884 return fgets(s, n, pf);
3894 win32_fgetc(FILE *pf)
3900 win32_putc(int c, FILE *pf)
3906 win32_puts(const char *s)
3918 win32_putchar(int c)
3925 #ifndef USE_PERL_SBRK
3927 static char *committed = NULL; /* XXX threadead */
3928 static char *base = NULL; /* XXX threadead */
3929 static char *reserved = NULL; /* XXX threadead */
3930 static char *brk = NULL; /* XXX threadead */
3931 static DWORD pagesize = 0; /* XXX threadead */
3934 sbrk(ptrdiff_t need)
3939 GetSystemInfo(&info);
3940 /* Pretend page size is larger so we don't perpetually
3941 * call the OS to commit just one page ...
3943 pagesize = info.dwPageSize << 3;
3945 if (brk+need >= reserved)
3947 DWORD size = brk+need-reserved;
3949 char *prev_committed = NULL;
3950 if (committed && reserved && committed < reserved)
3952 /* Commit last of previous chunk cannot span allocations */
3953 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3956 /* Remember where we committed from in case we want to decommit later */
3957 prev_committed = committed;
3958 committed = reserved;
3961 /* Reserve some (more) space
3962 * Contiguous blocks give us greater efficiency, so reserve big blocks -
3963 * this is only address space not memory...
3964 * Note this is a little sneaky, 1st call passes NULL as reserved
3965 * so lets system choose where we start, subsequent calls pass
3966 * the old end address so ask for a contiguous block
3969 if (size < 64*1024*1024)
3970 size = 64*1024*1024;
3971 size = ((size + pagesize - 1) / pagesize) * pagesize;
3972 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3975 reserved = addr+size;
3985 /* The existing block could not be extended far enough, so decommit
3986 * anything that was just committed above and start anew */
3989 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
3992 reserved = base = committed = brk = NULL;
4003 if (brk > committed)
4005 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4007 if (committed+size > reserved)
4008 size = reserved-committed;
4009 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4022 win32_malloc(size_t size)
4024 return malloc(size);
4028 win32_calloc(size_t numitems, size_t size)
4030 return calloc(numitems,size);
4034 win32_realloc(void *block, size_t size)
4036 return realloc(block,size);
4040 win32_free(void *block)
4047 win32_open_osfhandle(intptr_t handle, int flags)
4049 return _open_osfhandle(handle, flags);
4053 win32_get_osfhandle(int fd)
4055 return (intptr_t)_get_osfhandle(fd);
4059 win32_fdupopen(FILE *pf)
4064 int fileno = win32_dup(win32_fileno(pf));
4066 /* open the file in the same mode */
4067 if((pf)->_flag & _IOREAD) {
4071 else if((pf)->_flag & _IOWRT) {
4075 else if((pf)->_flag & _IORW) {
4081 /* it appears that the binmode is attached to the
4082 * file descriptor so binmode files will be handled
4085 pfdup = win32_fdopen(fileno, mode);
4087 /* move the file pointer to the same position */
4088 if (!fgetpos(pf, &pos)) {
4089 fsetpos(pfdup, &pos);
4095 win32_dynaload(const char* filename)
4098 char buf[MAX_PATH+1];
4101 /* LoadLibrary() doesn't recognize forward slashes correctly,
4102 * so turn 'em back. */
4103 first = strchr(filename, '/');
4105 STRLEN len = strlen(filename);
4106 if (len <= MAX_PATH) {
4107 strcpy(buf, filename);
4108 filename = &buf[first - filename];
4110 if (*filename == '/')
4111 *(char*)filename = '\\';
4117 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4120 XS(w32_SetChildShowWindow)
4123 BOOL use_showwindow = w32_use_showwindow;
4124 /* use "unsigned short" because Perl has redefined "WORD" */
4125 unsigned short showwindow = w32_showwindow;
4128 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4130 if (items == 0 || !SvOK(ST(0)))
4131 w32_use_showwindow = FALSE;
4133 w32_use_showwindow = TRUE;
4134 w32_showwindow = (unsigned short)SvIV(ST(0));
4139 ST(0) = sv_2mortal(newSViv(showwindow));
4141 ST(0) = &PL_sv_undef;
4146 Perl_init_os_extras(void)
4149 char *file = __FILE__;
4151 /* Initialize Win32CORE if it has been statically linked. */
4152 #ifndef PERL_IS_MINIPERL
4153 void (*pfn_init)(pTHX);
4154 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4159 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4163 win32_signal_context(void)
4168 my_perl = PL_curinterp;
4169 PERL_SET_THX(my_perl);
4173 return PL_curinterp;
4179 win32_ctrlhandler(DWORD dwCtrlType)
4182 dTHXa(PERL_GET_SIG_CONTEXT);
4188 switch(dwCtrlType) {
4189 case CTRL_CLOSE_EVENT:
4190 /* A signal that the system sends to all processes attached to a console when
4191 the user closes the console (either by choosing the Close command from the
4192 console window's System menu, or by choosing the End Task command from the
4195 if (do_raise(aTHX_ 1)) /* SIGHUP */
4196 sig_terminate(aTHX_ 1);
4200 /* A CTRL+c signal was received */
4201 if (do_raise(aTHX_ SIGINT))
4202 sig_terminate(aTHX_ SIGINT);
4205 case CTRL_BREAK_EVENT:
4206 /* A CTRL+BREAK signal was received */
4207 if (do_raise(aTHX_ SIGBREAK))
4208 sig_terminate(aTHX_ SIGBREAK);
4211 case CTRL_LOGOFF_EVENT:
4212 /* A signal that the system sends to all console processes when a user is logging
4213 off. This signal does not indicate which user is logging off, so no
4214 assumptions can be made.
4217 case CTRL_SHUTDOWN_EVENT:
4218 /* A signal that the system sends to all console processes when the system is
4221 if (do_raise(aTHX_ SIGTERM))
4222 sig_terminate(aTHX_ SIGTERM);
4231 #ifdef SET_INVALID_PARAMETER_HANDLER
4232 # include <crtdbg.h>
4243 /* fetch Unicode version of PATH */
4245 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4247 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4251 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4256 /* convert to ANSI pathnames */
4257 wide_dir = wide_path;
4260 WCHAR *sep = wcschr(wide_dir, ';');
4268 /* remove quotes around pathname */
4269 if (*wide_dir == '"')
4271 wide_len = wcslen(wide_dir);
4272 if (wide_len && wide_dir[wide_len-1] == '"')
4273 wide_dir[wide_len-1] = '\0';
4275 /* append ansi_dir to ansi_path */
4276 ansi_dir = win32_ansipath(wide_dir);
4277 ansi_len = strlen(ansi_dir);
4279 size_t newlen = len + 1 + ansi_len;
4280 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4283 ansi_path[len] = ';';
4284 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4289 ansi_path = (char*)win32_malloc(5+len+1);
4292 memcpy(ansi_path, "PATH=", 5);
4293 memcpy(ansi_path+5, ansi_dir, len+1);
4296 win32_free(ansi_dir);
4301 /* Update C RTL environ array. This will only have full effect if
4302 * perl_parse() is later called with `environ` as the `env` argument.
4303 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4305 * We do have to ansify() the PATH before Perl has been fully
4306 * initialized because S_find_script() uses the PATH when perl
4307 * is being invoked with the -S option. This happens before %ENV
4308 * is initialized in S_init_postdump_symbols().
4310 * XXX Is this a bug? Should S_find_script() use the environment
4311 * XXX passed in the `env` arg to parse_perl()?
4314 /* Keep system environment in sync because S_init_postdump_symbols()
4315 * will not call mg_set() if it initializes %ENV from `environ`.
4317 SetEnvironmentVariableA("PATH", ansi_path+5);
4318 /* We are intentionally leaking the ansi_path string here because
4319 * the some runtime libraries puts it directly into the environ
4320 * array. The Microsoft runtime library seems to make a copy,
4321 * but will leak the copy should it be replaced again later.
4322 * Since this code is only called once during PERL_SYS_INIT this
4323 * shouldn't really matter.
4326 win32_free(wide_path);
4330 Perl_win32_init(int *argcp, char ***argvp)
4332 #ifdef SET_INVALID_PARAMETER_HANDLER
4333 _invalid_parameter_handler oldHandler, newHandler;
4334 newHandler = my_invalid_parameter_handler;
4335 oldHandler = _set_invalid_parameter_handler(newHandler);
4336 _CrtSetReportMode(_CRT_ASSERT, 0);
4338 /* Disable floating point errors, Perl will trap the ones we
4339 * care about. VC++ RTL defaults to switching these off
4340 * already, but some RTLs don't. Since we don't
4341 * want to be at the vendor's whim on the default, we set
4342 * it explicitly here.
4344 #if !defined(__GNUC__)
4345 _control87(MCW_EM, MCW_EM);
4349 /* When the manifest resource requests Common-Controls v6 then
4350 * user32.dll no longer registers all the Windows classes used for
4351 * standard controls but leaves some of them to be registered by
4352 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4353 * it makes sure comctl32.dll gets loaded into the process and registers
4354 * the standard control classes. Without this even normal Windows APIs
4355 * like MessageBox() can fail under some versions of Windows XP.
4357 InitCommonControls();
4359 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4360 GetVersionEx(&g_osver);
4366 Perl_win32_term(void)
4375 win32_get_child_IO(child_IO_table* ptbl)
4377 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4378 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4379 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4383 win32_signal(int sig, Sighandler_t subcode)
4386 if (sig < SIG_SIZE) {
4387 int save_errno = errno;
4388 Sighandler_t result;
4389 #ifdef SET_INVALID_PARAMETER_HANDLER
4390 /* Silence our invalid parameter handler since we expect to make some
4391 * calls with invalid signal numbers giving a SIG_ERR result. */
4392 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4394 result = signal(sig, subcode);
4395 #ifdef SET_INVALID_PARAMETER_HANDLER
4396 set_silent_invalid_parameter_handler(oldvalue);
4398 if (result == SIG_ERR) {
4399 result = w32_sighandler[sig];
4402 w32_sighandler[sig] = subcode;
4411 /* The PerlMessageWindowClass's WindowProc */
4413 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4415 return win32_process_message(hwnd, msg, wParam, lParam) ?
4416 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4419 /* The real message handler. Can be called with
4420 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4421 * that it processes */
4423 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4425 /* BEWARE. The context retrieved using dTHX; is the context of the
4426 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4427 * up to and including WM_CREATE. If it ever happens that you need the
4428 * 'child' context before this, then it needs to be passed into
4429 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4430 * from the lparam of CreateWindow(). It could then be stored/retrieved
4431 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4432 * the dTHX calls here. */
4433 /* XXX For now it is assumed that the overhead of the dTHX; for what
4434 * are relativley infrequent code-paths, is better than the added
4435 * complexity of getting the correct context passed into
4436 * win32_create_message_window() */
4441 case WM_USER_MESSAGE: {
4442 long child = find_pseudo_pid((int)wParam);
4445 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4452 case WM_USER_KILL: {
4454 /* We use WM_USER_KILL to fake kill() with other signals */
4455 int sig = (int)wParam;
4456 if (do_raise(aTHX_ sig))
4457 sig_terminate(aTHX_ sig);
4464 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4465 if (w32_timerid && w32_timerid==(UINT)wParam) {
4466 KillTimer(w32_message_hwnd, w32_timerid);
4469 /* Now fake a call to signal handler */
4470 if (do_raise(aTHX_ 14))
4471 sig_terminate(aTHX_ 14);
4483 /* Above or other stuff may have set a signal flag, and we may not have
4484 * been called from win32_async_check() (e.g. some other GUI's message
4485 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4486 * handler that die's, and the message loop that calls here is wrapped
4487 * in an eval, then you may well end up with orphaned windows - signals
4488 * are dispatched by win32_async_check() */
4494 win32_create_message_window_class(void)
4496 /* create the window class for "message only" windows */
4500 wc.lpfnWndProc = win32_message_window_proc;
4501 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4502 wc.lpszClassName = "PerlMessageWindowClass";
4504 /* second and subsequent calls will fail, but class
4505 * will already be registered */
4510 win32_create_message_window(void)
4512 win32_create_message_window_class();
4513 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4514 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4517 #ifdef HAVE_INTERP_INTERN
4520 win32_csighandler(int sig)
4523 dTHXa(PERL_GET_SIG_CONTEXT);
4524 Perl_warn(aTHX_ "Got signal %d",sig);
4529 #if defined(__MINGW32__) && defined(__cplusplus)
4530 #define CAST_HWND__(x) (HWND__*)(x)
4532 #define CAST_HWND__(x) x
4536 Perl_sys_intern_init(pTHX)
4540 w32_perlshell_tokens = NULL;
4541 w32_perlshell_vec = (char**)NULL;
4542 w32_perlshell_items = 0;
4543 w32_fdpid = newAV();
4544 Newx(w32_children, 1, child_tab);
4545 w32_num_children = 0;
4546 # ifdef USE_ITHREADS
4548 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4549 w32_num_pseudo_children = 0;
4552 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4554 for (i=0; i < SIG_SIZE; i++) {
4555 w32_sighandler[i] = SIG_DFL;
4557 # ifdef MULTIPLICITY
4558 if (my_perl == PL_curinterp) {
4562 /* Force C runtime signal stuff to set its console handler */
4563 signal(SIGINT,win32_csighandler);
4564 signal(SIGBREAK,win32_csighandler);
4566 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4567 * flag. This has the side-effect of disabling Ctrl-C events in all
4568 * processes in this group.
4569 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4570 * with a NULL handler.
4572 SetConsoleCtrlHandler(NULL,FALSE);
4574 /* Push our handler on top */
4575 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4580 Perl_sys_intern_clear(pTHX)
4582 Safefree(w32_perlshell_tokens);
4583 Safefree(w32_perlshell_vec);
4584 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4585 Safefree(w32_children);
4587 KillTimer(w32_message_hwnd, w32_timerid);
4590 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4591 DestroyWindow(w32_message_hwnd);
4592 # ifdef MULTIPLICITY
4593 if (my_perl == PL_curinterp) {
4597 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4599 # ifdef USE_ITHREADS
4600 Safefree(w32_pseudo_children);
4604 # ifdef USE_ITHREADS
4607 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4609 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4611 dst->perlshell_tokens = NULL;
4612 dst->perlshell_vec = (char**)NULL;
4613 dst->perlshell_items = 0;
4614 dst->fdpid = newAV();
4615 Newxz(dst->children, 1, child_tab);
4617 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4619 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4620 dst->poll_count = 0;
4621 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4623 # endif /* USE_ITHREADS */
4624 #endif /* HAVE_INTERP_INTERN */