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);
2862 DEBUG_p(PerlIO_printf(Perl_debug_log,
2863 "Created tmpfile=%s\n",filename));
2875 int fd = win32_tmpfd();
2877 return win32_fdopen(fd, "w+b");
2889 win32_fstat(int fd, Stat_t *sbufptr)
2891 #if defined(WIN64) || defined(USE_LARGE_FILES)
2892 return _fstati64(fd, sbufptr);
2894 return fstat(fd, sbufptr);
2899 win32_pipe(int *pfd, unsigned int size, int mode)
2901 return _pipe(pfd, size, mode);
2905 win32_popenlist(const char *mode, IV narg, SV **args)
2907 Perl_croak_nocontext("List form of pipe open not implemented");
2912 * a popen() clone that respects PERL5SHELL
2914 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2918 win32_popen(const char *command, const char *mode)
2920 #ifdef USE_RTL_POPEN
2921 return _popen(command, mode);
2932 /* establish which ends read and write */
2933 if (strchr(mode,'w')) {
2934 stdfd = 0; /* stdin */
2937 nhandle = STD_INPUT_HANDLE;
2939 else if (strchr(mode,'r')) {
2940 stdfd = 1; /* stdout */
2943 nhandle = STD_OUTPUT_HANDLE;
2948 /* set the correct mode */
2949 if (strchr(mode,'b'))
2951 else if (strchr(mode,'t'))
2954 ourmode = _fmode & (O_TEXT | O_BINARY);
2956 /* the child doesn't inherit handles */
2957 ourmode |= O_NOINHERIT;
2959 if (win32_pipe(p, 512, ourmode) == -1)
2962 /* save the old std handle (this needs to happen before the
2963 * dup2(), since that might call SetStdHandle() too) */
2966 old_h = GetStdHandle(nhandle);
2968 /* save current stdfd */
2969 if ((oldfd = win32_dup(stdfd)) == -1)
2972 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2973 /* stdfd will be inherited by the child */
2974 if (win32_dup2(p[child], stdfd) == -1)
2977 /* close the child end in parent */
2978 win32_close(p[child]);
2980 /* set the new std handle (in case dup2() above didn't) */
2981 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2983 /* start the child */
2986 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2989 /* revert stdfd to whatever it was before */
2990 if (win32_dup2(oldfd, stdfd) == -1)
2993 /* close saved handle */
2996 /* restore the old std handle (this needs to happen after the
2997 * dup2(), since that might call SetStdHandle() too */
2999 SetStdHandle(nhandle, old_h);
3004 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3006 /* set process id so that it can be returned by perl's open() */
3007 PL_forkprocess = childpid;
3010 /* we have an fd, return a file stream */
3011 return (PerlIO_fdopen(p[parent], (char *)mode));
3014 /* we don't need to check for errors here */
3018 win32_dup2(oldfd, stdfd);
3022 SetStdHandle(nhandle, old_h);
3028 #endif /* USE_RTL_POPEN */
3036 win32_pclose(PerlIO *pf)
3038 #ifdef USE_RTL_POPEN
3042 int childpid, status;
3045 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3048 childpid = SvIVX(sv);
3064 if (win32_waitpid(childpid, &status, 0) == -1)
3069 #endif /* USE_RTL_POPEN */
3073 win32_link(const char *oldname, const char *newname)
3076 WCHAR wOldName[MAX_PATH+1];
3077 WCHAR wNewName[MAX_PATH+1];
3079 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3080 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3081 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3082 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3086 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3087 both permissions errors and if the source is a directory, while
3088 POSIX wants EACCES and EPERM respectively.
3090 Determined by experimentation on Windows 7 x64 SP1, since MS
3091 don't document what error codes are returned.
3093 switch (GetLastError()) {
3094 case ERROR_BAD_NET_NAME:
3095 case ERROR_BAD_NETPATH:
3096 case ERROR_BAD_PATHNAME:
3097 case ERROR_FILE_NOT_FOUND:
3098 case ERROR_FILENAME_EXCED_RANGE:
3099 case ERROR_INVALID_DRIVE:
3100 case ERROR_PATH_NOT_FOUND:
3103 case ERROR_ALREADY_EXISTS:
3106 case ERROR_ACCESS_DENIED:
3109 case ERROR_NOT_SAME_DEVICE:
3113 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3121 win32_rename(const char *oname, const char *newname)
3123 char szOldName[MAX_PATH+1];
3125 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3128 if (stricmp(newname, oname))
3129 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3130 strcpy(szOldName, PerlDir_mapA(oname));
3132 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3134 DWORD err = GetLastError();
3136 case ERROR_BAD_NET_NAME:
3137 case ERROR_BAD_NETPATH:
3138 case ERROR_BAD_PATHNAME:
3139 case ERROR_FILE_NOT_FOUND:
3140 case ERROR_FILENAME_EXCED_RANGE:
3141 case ERROR_INVALID_DRIVE:
3142 case ERROR_NO_MORE_FILES:
3143 case ERROR_PATH_NOT_FOUND:
3156 win32_setmode(int fd, int mode)
3158 return setmode(fd, mode);
3162 win32_chsize(int fd, Off_t size)
3164 #if defined(WIN64) || defined(USE_LARGE_FILES)
3166 Off_t cur, end, extend;
3168 cur = win32_tell(fd);
3171 end = win32_lseek(fd, 0, SEEK_END);
3174 extend = size - end;
3178 else if (extend > 0) {
3179 /* must grow the file, padding with nulls */
3181 int oldmode = win32_setmode(fd, O_BINARY);
3183 memset(b, '\0', sizeof(b));
3185 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3186 count = win32_write(fd, b, count);
3187 if ((int)count < 0) {
3191 } while ((extend -= count) > 0);
3192 win32_setmode(fd, oldmode);
3195 /* shrink the file */
3196 win32_lseek(fd, size, SEEK_SET);
3197 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3203 win32_lseek(fd, cur, SEEK_SET);
3206 return chsize(fd, (long)size);
3211 win32_lseek(int fd, Off_t offset, int origin)
3213 #if defined(WIN64) || defined(USE_LARGE_FILES)
3214 return _lseeki64(fd, offset, origin);
3216 return lseek(fd, (long)offset, origin);
3223 #if defined(WIN64) || defined(USE_LARGE_FILES)
3224 return _telli64(fd);
3231 win32_open(const char *path, int flag, ...)
3238 pmode = va_arg(ap, int);
3241 if (stricmp(path, "/dev/null")==0)
3244 return open(PerlDir_mapA(path), flag, pmode);
3247 /* close() that understands socket */
3248 extern int my_close(int); /* in win32sck.c */
3253 #ifdef WIN32_NO_SOCKETS
3256 return my_close(fd);
3267 win32_isatty(int fd)
3269 /* The Microsoft isatty() function returns true for *all*
3270 * character mode devices, including "nul". Our implementation
3271 * should only return true if the handle has a console buffer.
3274 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3275 if (fh == (HANDLE)-1) {
3276 /* errno is already set to EBADF */
3280 if (GetConsoleMode(fh, &mode))
3294 win32_dup2(int fd1,int fd2)
3296 return dup2(fd1,fd2);
3300 win32_read(int fd, void *buf, unsigned int cnt)
3302 return read(fd, buf, cnt);
3306 win32_write(int fd, const void *buf, unsigned int cnt)
3308 return write(fd, buf, cnt);
3312 win32_mkdir(const char *dir, int mode)
3315 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3319 win32_rmdir(const char *dir)
3322 return rmdir(PerlDir_mapA(dir));
3326 win32_chdir(const char *dir)
3336 win32_access(const char *path, int mode)
3339 return access(PerlDir_mapA(path), mode);
3343 win32_chmod(const char *path, int mode)
3346 return chmod(PerlDir_mapA(path), mode);
3351 create_command_line(char *cname, STRLEN clen, const char * const *args)
3358 bool bat_file = FALSE;
3359 bool cmd_shell = FALSE;
3360 bool dumb_shell = FALSE;
3361 bool extra_quotes = FALSE;
3362 bool quote_next = FALSE;
3365 cname = (char*)args[0];
3367 /* The NT cmd.exe shell has the following peculiarity that needs to be
3368 * worked around. It strips a leading and trailing dquote when any
3369 * of the following is true:
3370 * 1. the /S switch was used
3371 * 2. there are more than two dquotes
3372 * 3. there is a special character from this set: &<>()@^|
3373 * 4. no whitespace characters within the two dquotes
3374 * 5. string between two dquotes isn't an executable file
3375 * To work around this, we always add a leading and trailing dquote
3376 * to the string, if the first argument is either "cmd.exe" or "cmd",
3377 * and there were at least two or more arguments passed to cmd.exe
3378 * (not including switches).
3379 * XXX the above rules (from "cmd /?") don't seem to be applied
3380 * always, making for the convolutions below :-(
3384 clen = strlen(cname);
3387 && (stricmp(&cname[clen-4], ".bat") == 0
3388 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3394 char *exe = strrchr(cname, '/');
3395 char *exe2 = strrchr(cname, '\\');
3402 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3406 else if (stricmp(exe, "command.com") == 0
3407 || stricmp(exe, "command") == 0)
3414 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3415 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3416 STRLEN curlen = strlen(arg);
3417 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3418 len += 2; /* assume quoting needed (worst case) */
3420 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3422 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3425 Newx(cmd, len, char);
3430 extra_quotes = TRUE;
3433 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3435 STRLEN curlen = strlen(arg);
3437 /* we want to protect empty arguments and ones with spaces with
3438 * dquotes, but only if they aren't already there */
3443 else if (quote_next) {
3444 /* see if it really is multiple arguments pretending to
3445 * be one and force a set of quotes around it */
3446 if (*find_next_space(arg))
3449 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3451 while (i < curlen) {
3452 if (isSPACE(arg[i])) {
3455 else if (arg[i] == '"') {
3479 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3480 && stricmp(arg+curlen-2, "/c") == 0)
3482 /* is there a next argument? */
3483 if (args[index+1]) {
3484 /* are there two or more next arguments? */
3485 if (args[index+2]) {
3487 extra_quotes = TRUE;
3490 /* single argument, force quoting if it has spaces */
3506 qualified_path(const char *cmd)
3510 char *fullcmd, *curfullcmd;
3516 fullcmd = (char*)cmd;
3518 if (*fullcmd == '/' || *fullcmd == '\\')
3525 pathstr = PerlEnv_getenv("PATH");
3527 /* worst case: PATH is a single directory; we need additional space
3528 * to append "/", ".exe" and trailing "\0" */
3529 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3530 curfullcmd = fullcmd;
3535 /* start by appending the name to the current prefix */
3536 strcpy(curfullcmd, cmd);
3537 curfullcmd += cmdlen;
3539 /* if it doesn't end with '.', or has no extension, try adding
3540 * a trailing .exe first */
3541 if (cmd[cmdlen-1] != '.'
3542 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3544 strcpy(curfullcmd, ".exe");
3545 res = GetFileAttributes(fullcmd);
3546 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3551 /* that failed, try the bare name */
3552 res = GetFileAttributes(fullcmd);
3553 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3556 /* quit if no other path exists, or if cmd already has path */
3557 if (!pathstr || !*pathstr || has_slash)
3560 /* skip leading semis */
3561 while (*pathstr == ';')
3564 /* build a new prefix from scratch */
3565 curfullcmd = fullcmd;
3566 while (*pathstr && *pathstr != ';') {
3567 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3568 pathstr++; /* skip initial '"' */
3569 while (*pathstr && *pathstr != '"') {
3570 *curfullcmd++ = *pathstr++;
3573 pathstr++; /* skip trailing '"' */
3576 *curfullcmd++ = *pathstr++;
3580 pathstr++; /* skip trailing semi */
3581 if (curfullcmd > fullcmd /* append a dir separator */
3582 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3584 *curfullcmd++ = '\\';
3592 /* The following are just place holders.
3593 * Some hosts may provide and environment that the OS is
3594 * not tracking, therefore, these host must provide that
3595 * environment and the current directory to CreateProcess
3599 win32_get_childenv(void)
3605 win32_free_childenv(void* d)
3610 win32_clearenv(void)
3612 char *envv = GetEnvironmentStrings();
3616 char *end = strchr(cur,'=');
3617 if (end && end != cur) {
3619 SetEnvironmentVariable(cur, NULL);
3621 cur = end + strlen(end+1)+2;
3623 else if ((len = strlen(cur)))
3626 FreeEnvironmentStrings(envv);
3630 win32_get_childdir(void)
3633 char szfilename[MAX_PATH+1];
3635 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3636 Newx(ptr, strlen(szfilename)+1, char);
3637 strcpy(ptr, szfilename);
3642 win32_free_childdir(char* d)
3648 /* XXX this needs to be made more compatible with the spawnvp()
3649 * provided by the various RTLs. In particular, searching for
3650 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3651 * This doesn't significantly affect perl itself, because we
3652 * always invoke things using PERL5SHELL if a direct attempt to
3653 * spawn the executable fails.
3655 * XXX splitting and rejoining the commandline between do_aspawn()
3656 * and win32_spawnvp() could also be avoided.
3660 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3662 #ifdef USE_RTL_SPAWNVP
3663 return spawnvp(mode, cmdname, (char * const *)argv);
3670 STARTUPINFO StartupInfo;
3671 PROCESS_INFORMATION ProcessInformation;
3674 char *fullcmd = NULL;
3675 char *cname = (char *)cmdname;
3679 clen = strlen(cname);
3680 /* if command name contains dquotes, must remove them */
3681 if (strchr(cname, '"')) {
3683 Newx(cname,clen+1,char);
3696 cmd = create_command_line(cname, clen, argv);
3698 aTHXa(PERL_GET_THX);
3699 env = PerlEnv_get_childenv();
3700 dir = PerlEnv_get_childdir();
3703 case P_NOWAIT: /* asynch + remember result */
3704 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3709 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3712 create |= CREATE_NEW_PROCESS_GROUP;
3715 case P_WAIT: /* synchronous execution */
3717 default: /* invalid mode */
3722 memset(&StartupInfo,0,sizeof(StartupInfo));
3723 StartupInfo.cb = sizeof(StartupInfo);
3724 memset(&tbl,0,sizeof(tbl));
3725 PerlEnv_get_child_IO(&tbl);
3726 StartupInfo.dwFlags = tbl.dwFlags;
3727 StartupInfo.dwX = tbl.dwX;
3728 StartupInfo.dwY = tbl.dwY;
3729 StartupInfo.dwXSize = tbl.dwXSize;
3730 StartupInfo.dwYSize = tbl.dwYSize;
3731 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3732 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3733 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3734 StartupInfo.wShowWindow = tbl.wShowWindow;
3735 StartupInfo.hStdInput = tbl.childStdIn;
3736 StartupInfo.hStdOutput = tbl.childStdOut;
3737 StartupInfo.hStdError = tbl.childStdErr;
3738 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3739 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3740 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3742 create |= CREATE_NEW_CONSOLE;
3745 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3747 if (w32_use_showwindow) {
3748 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3749 StartupInfo.wShowWindow = w32_showwindow;
3752 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3755 if (!CreateProcess(cname, /* search PATH to find executable */
3756 cmd, /* executable, and its arguments */
3757 NULL, /* process attributes */
3758 NULL, /* thread attributes */
3759 TRUE, /* inherit handles */
3760 create, /* creation flags */
3761 (LPVOID)env, /* inherit environment */
3762 dir, /* inherit cwd */
3764 &ProcessInformation))
3766 /* initial NULL argument to CreateProcess() does a PATH
3767 * search, but it always first looks in the directory
3768 * where the current process was started, which behavior
3769 * is undesirable for backward compatibility. So we
3770 * jump through our own hoops by picking out the path
3771 * we really want it to use. */
3773 fullcmd = qualified_path(cname);
3775 if (cname != cmdname)
3778 DEBUG_p(PerlIO_printf(Perl_debug_log,
3779 "Retrying [%s] with same args\n",
3789 if (mode == P_NOWAIT) {
3790 /* asynchronous spawn -- store handle, return PID */
3791 ret = (int)ProcessInformation.dwProcessId;
3793 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3794 w32_child_pids[w32_num_children] = (DWORD)ret;
3799 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3800 /* FIXME: if msgwait returned due to message perhaps forward the
3801 "signal" to the process
3803 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3805 CloseHandle(ProcessInformation.hProcess);
3808 CloseHandle(ProcessInformation.hThread);
3811 PerlEnv_free_childenv(env);
3812 PerlEnv_free_childdir(dir);
3814 if (cname != cmdname)
3821 win32_execv(const char *cmdname, const char *const *argv)
3825 /* if this is a pseudo-forked child, we just want to spawn
3826 * the new program, and return */
3828 return spawnv(P_WAIT, cmdname, argv);
3830 return execv(cmdname, argv);
3834 win32_execvp(const char *cmdname, const char *const *argv)
3838 /* if this is a pseudo-forked child, we just want to spawn
3839 * the new program, and return */
3840 if (w32_pseudo_id) {
3841 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3850 return execvp(cmdname, argv);
3854 win32_perror(const char *str)
3860 win32_setbuf(FILE *pf, char *buf)
3866 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3868 return setvbuf(pf, buf, type, size);
3872 win32_flushall(void)
3878 win32_fcloseall(void)
3884 win32_fgets(char *s, int n, FILE *pf)
3886 return fgets(s, n, pf);
3896 win32_fgetc(FILE *pf)
3902 win32_putc(int c, FILE *pf)
3908 win32_puts(const char *s)
3920 win32_putchar(int c)
3927 #ifndef USE_PERL_SBRK
3929 static char *committed = NULL; /* XXX threadead */
3930 static char *base = NULL; /* XXX threadead */
3931 static char *reserved = NULL; /* XXX threadead */
3932 static char *brk = NULL; /* XXX threadead */
3933 static DWORD pagesize = 0; /* XXX threadead */
3936 sbrk(ptrdiff_t need)
3941 GetSystemInfo(&info);
3942 /* Pretend page size is larger so we don't perpetually
3943 * call the OS to commit just one page ...
3945 pagesize = info.dwPageSize << 3;
3947 if (brk+need >= reserved)
3949 DWORD size = brk+need-reserved;
3951 char *prev_committed = NULL;
3952 if (committed && reserved && committed < reserved)
3954 /* Commit last of previous chunk cannot span allocations */
3955 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3958 /* Remember where we committed from in case we want to decommit later */
3959 prev_committed = committed;
3960 committed = reserved;
3963 /* Reserve some (more) space
3964 * Contiguous blocks give us greater efficiency, so reserve big blocks -
3965 * this is only address space not memory...
3966 * Note this is a little sneaky, 1st call passes NULL as reserved
3967 * so lets system choose where we start, subsequent calls pass
3968 * the old end address so ask for a contiguous block
3971 if (size < 64*1024*1024)
3972 size = 64*1024*1024;
3973 size = ((size + pagesize - 1) / pagesize) * pagesize;
3974 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3977 reserved = addr+size;
3987 /* The existing block could not be extended far enough, so decommit
3988 * anything that was just committed above and start anew */
3991 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
3994 reserved = base = committed = brk = NULL;
4005 if (brk > committed)
4007 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4009 if (committed+size > reserved)
4010 size = reserved-committed;
4011 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4024 win32_malloc(size_t size)
4026 return malloc(size);
4030 win32_calloc(size_t numitems, size_t size)
4032 return calloc(numitems,size);
4036 win32_realloc(void *block, size_t size)
4038 return realloc(block,size);
4042 win32_free(void *block)
4049 win32_open_osfhandle(intptr_t handle, int flags)
4051 return _open_osfhandle(handle, flags);
4055 win32_get_osfhandle(int fd)
4057 return (intptr_t)_get_osfhandle(fd);
4061 win32_fdupopen(FILE *pf)
4066 int fileno = win32_dup(win32_fileno(pf));
4068 /* open the file in the same mode */
4069 if((pf)->_flag & _IOREAD) {
4073 else if((pf)->_flag & _IOWRT) {
4077 else if((pf)->_flag & _IORW) {
4083 /* it appears that the binmode is attached to the
4084 * file descriptor so binmode files will be handled
4087 pfdup = win32_fdopen(fileno, mode);
4089 /* move the file pointer to the same position */
4090 if (!fgetpos(pf, &pos)) {
4091 fsetpos(pfdup, &pos);
4097 win32_dynaload(const char* filename)
4100 char buf[MAX_PATH+1];
4103 /* LoadLibrary() doesn't recognize forward slashes correctly,
4104 * so turn 'em back. */
4105 first = strchr(filename, '/');
4107 STRLEN len = strlen(filename);
4108 if (len <= MAX_PATH) {
4109 strcpy(buf, filename);
4110 filename = &buf[first - filename];
4112 if (*filename == '/')
4113 *(char*)filename = '\\';
4119 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4122 XS(w32_SetChildShowWindow)
4125 BOOL use_showwindow = w32_use_showwindow;
4126 /* use "unsigned short" because Perl has redefined "WORD" */
4127 unsigned short showwindow = w32_showwindow;
4130 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4132 if (items == 0 || !SvOK(ST(0)))
4133 w32_use_showwindow = FALSE;
4135 w32_use_showwindow = TRUE;
4136 w32_showwindow = (unsigned short)SvIV(ST(0));
4141 ST(0) = sv_2mortal(newSViv(showwindow));
4143 ST(0) = &PL_sv_undef;
4148 Perl_init_os_extras(void)
4151 char *file = __FILE__;
4153 /* Initialize Win32CORE if it has been statically linked. */
4154 #ifndef PERL_IS_MINIPERL
4155 void (*pfn_init)(pTHX);
4156 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4161 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4165 win32_signal_context(void)
4170 my_perl = PL_curinterp;
4171 PERL_SET_THX(my_perl);
4175 return PL_curinterp;
4181 win32_ctrlhandler(DWORD dwCtrlType)
4184 dTHXa(PERL_GET_SIG_CONTEXT);
4190 switch(dwCtrlType) {
4191 case CTRL_CLOSE_EVENT:
4192 /* A signal that the system sends to all processes attached to a console when
4193 the user closes the console (either by choosing the Close command from the
4194 console window's System menu, or by choosing the End Task command from the
4197 if (do_raise(aTHX_ 1)) /* SIGHUP */
4198 sig_terminate(aTHX_ 1);
4202 /* A CTRL+c signal was received */
4203 if (do_raise(aTHX_ SIGINT))
4204 sig_terminate(aTHX_ SIGINT);
4207 case CTRL_BREAK_EVENT:
4208 /* A CTRL+BREAK signal was received */
4209 if (do_raise(aTHX_ SIGBREAK))
4210 sig_terminate(aTHX_ SIGBREAK);
4213 case CTRL_LOGOFF_EVENT:
4214 /* A signal that the system sends to all console processes when a user is logging
4215 off. This signal does not indicate which user is logging off, so no
4216 assumptions can be made.
4219 case CTRL_SHUTDOWN_EVENT:
4220 /* A signal that the system sends to all console processes when the system is
4223 if (do_raise(aTHX_ SIGTERM))
4224 sig_terminate(aTHX_ SIGTERM);
4233 #ifdef SET_INVALID_PARAMETER_HANDLER
4234 # include <crtdbg.h>
4245 /* fetch Unicode version of PATH */
4247 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4249 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4253 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4258 /* convert to ANSI pathnames */
4259 wide_dir = wide_path;
4262 WCHAR *sep = wcschr(wide_dir, ';');
4270 /* remove quotes around pathname */
4271 if (*wide_dir == '"')
4273 wide_len = wcslen(wide_dir);
4274 if (wide_len && wide_dir[wide_len-1] == '"')
4275 wide_dir[wide_len-1] = '\0';
4277 /* append ansi_dir to ansi_path */
4278 ansi_dir = win32_ansipath(wide_dir);
4279 ansi_len = strlen(ansi_dir);
4281 size_t newlen = len + 1 + ansi_len;
4282 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4285 ansi_path[len] = ';';
4286 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4291 ansi_path = (char*)win32_malloc(5+len+1);
4294 memcpy(ansi_path, "PATH=", 5);
4295 memcpy(ansi_path+5, ansi_dir, len+1);
4298 win32_free(ansi_dir);
4303 /* Update C RTL environ array. This will only have full effect if
4304 * perl_parse() is later called with `environ` as the `env` argument.
4305 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4307 * We do have to ansify() the PATH before Perl has been fully
4308 * initialized because S_find_script() uses the PATH when perl
4309 * is being invoked with the -S option. This happens before %ENV
4310 * is initialized in S_init_postdump_symbols().
4312 * XXX Is this a bug? Should S_find_script() use the environment
4313 * XXX passed in the `env` arg to parse_perl()?
4316 /* Keep system environment in sync because S_init_postdump_symbols()
4317 * will not call mg_set() if it initializes %ENV from `environ`.
4319 SetEnvironmentVariableA("PATH", ansi_path+5);
4320 /* We are intentionally leaking the ansi_path string here because
4321 * the some runtime libraries puts it directly into the environ
4322 * array. The Microsoft runtime library seems to make a copy,
4323 * but will leak the copy should it be replaced again later.
4324 * Since this code is only called once during PERL_SYS_INIT this
4325 * shouldn't really matter.
4328 win32_free(wide_path);
4332 Perl_win32_init(int *argcp, char ***argvp)
4334 #ifdef SET_INVALID_PARAMETER_HANDLER
4335 _invalid_parameter_handler oldHandler, newHandler;
4336 newHandler = my_invalid_parameter_handler;
4337 oldHandler = _set_invalid_parameter_handler(newHandler);
4338 _CrtSetReportMode(_CRT_ASSERT, 0);
4340 /* Disable floating point errors, Perl will trap the ones we
4341 * care about. VC++ RTL defaults to switching these off
4342 * already, but some RTLs don't. Since we don't
4343 * want to be at the vendor's whim on the default, we set
4344 * it explicitly here.
4346 #if !defined(__GNUC__)
4347 _control87(MCW_EM, MCW_EM);
4351 /* When the manifest resource requests Common-Controls v6 then
4352 * user32.dll no longer registers all the Windows classes used for
4353 * standard controls but leaves some of them to be registered by
4354 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4355 * it makes sure comctl32.dll gets loaded into the process and registers
4356 * the standard control classes. Without this even normal Windows APIs
4357 * like MessageBox() can fail under some versions of Windows XP.
4359 InitCommonControls();
4361 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4362 GetVersionEx(&g_osver);
4368 Perl_win32_term(void)
4377 win32_get_child_IO(child_IO_table* ptbl)
4379 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4380 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4381 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4385 win32_signal(int sig, Sighandler_t subcode)
4388 if (sig < SIG_SIZE) {
4389 int save_errno = errno;
4390 Sighandler_t result;
4391 #ifdef SET_INVALID_PARAMETER_HANDLER
4392 /* Silence our invalid parameter handler since we expect to make some
4393 * calls with invalid signal numbers giving a SIG_ERR result. */
4394 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4396 result = signal(sig, subcode);
4397 #ifdef SET_INVALID_PARAMETER_HANDLER
4398 set_silent_invalid_parameter_handler(oldvalue);
4400 if (result == SIG_ERR) {
4401 result = w32_sighandler[sig];
4404 w32_sighandler[sig] = subcode;
4413 /* The PerlMessageWindowClass's WindowProc */
4415 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4417 return win32_process_message(hwnd, msg, wParam, lParam) ?
4418 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4421 /* The real message handler. Can be called with
4422 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4423 * that it processes */
4425 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4427 /* BEWARE. The context retrieved using dTHX; is the context of the
4428 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4429 * up to and including WM_CREATE. If it ever happens that you need the
4430 * 'child' context before this, then it needs to be passed into
4431 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4432 * from the lparam of CreateWindow(). It could then be stored/retrieved
4433 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4434 * the dTHX calls here. */
4435 /* XXX For now it is assumed that the overhead of the dTHX; for what
4436 * are relativley infrequent code-paths, is better than the added
4437 * complexity of getting the correct context passed into
4438 * win32_create_message_window() */
4443 case WM_USER_MESSAGE: {
4444 long child = find_pseudo_pid((int)wParam);
4447 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4454 case WM_USER_KILL: {
4456 /* We use WM_USER_KILL to fake kill() with other signals */
4457 int sig = (int)wParam;
4458 if (do_raise(aTHX_ sig))
4459 sig_terminate(aTHX_ sig);
4466 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4467 if (w32_timerid && w32_timerid==(UINT)wParam) {
4468 KillTimer(w32_message_hwnd, w32_timerid);
4471 /* Now fake a call to signal handler */
4472 if (do_raise(aTHX_ 14))
4473 sig_terminate(aTHX_ 14);
4485 /* Above or other stuff may have set a signal flag, and we may not have
4486 * been called from win32_async_check() (e.g. some other GUI's message
4487 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4488 * handler that die's, and the message loop that calls here is wrapped
4489 * in an eval, then you may well end up with orphaned windows - signals
4490 * are dispatched by win32_async_check() */
4496 win32_create_message_window_class(void)
4498 /* create the window class for "message only" windows */
4502 wc.lpfnWndProc = win32_message_window_proc;
4503 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4504 wc.lpszClassName = "PerlMessageWindowClass";
4506 /* second and subsequent calls will fail, but class
4507 * will already be registered */
4512 win32_create_message_window(void)
4514 win32_create_message_window_class();
4515 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4516 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4519 #ifdef HAVE_INTERP_INTERN
4522 win32_csighandler(int sig)
4525 dTHXa(PERL_GET_SIG_CONTEXT);
4526 Perl_warn(aTHX_ "Got signal %d",sig);
4531 #if defined(__MINGW32__) && defined(__cplusplus)
4532 #define CAST_HWND__(x) (HWND__*)(x)
4534 #define CAST_HWND__(x) x
4538 Perl_sys_intern_init(pTHX)
4542 w32_perlshell_tokens = NULL;
4543 w32_perlshell_vec = (char**)NULL;
4544 w32_perlshell_items = 0;
4545 w32_fdpid = newAV();
4546 Newx(w32_children, 1, child_tab);
4547 w32_num_children = 0;
4548 # ifdef USE_ITHREADS
4550 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4551 w32_num_pseudo_children = 0;
4554 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4556 for (i=0; i < SIG_SIZE; i++) {
4557 w32_sighandler[i] = SIG_DFL;
4559 # ifdef MULTIPLICITY
4560 if (my_perl == PL_curinterp) {
4564 /* Force C runtime signal stuff to set its console handler */
4565 signal(SIGINT,win32_csighandler);
4566 signal(SIGBREAK,win32_csighandler);
4568 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4569 * flag. This has the side-effect of disabling Ctrl-C events in all
4570 * processes in this group.
4571 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4572 * with a NULL handler.
4574 SetConsoleCtrlHandler(NULL,FALSE);
4576 /* Push our handler on top */
4577 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4582 Perl_sys_intern_clear(pTHX)
4584 Safefree(w32_perlshell_tokens);
4585 Safefree(w32_perlshell_vec);
4586 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4587 Safefree(w32_children);
4589 KillTimer(w32_message_hwnd, w32_timerid);
4592 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4593 DestroyWindow(w32_message_hwnd);
4594 # ifdef MULTIPLICITY
4595 if (my_perl == PL_curinterp) {
4599 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4601 # ifdef USE_ITHREADS
4602 Safefree(w32_pseudo_children);
4606 # ifdef USE_ITHREADS
4609 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4611 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4613 dst->perlshell_tokens = NULL;
4614 dst->perlshell_vec = (char**)NULL;
4615 dst->perlshell_items = 0;
4616 dst->fdpid = newAV();
4617 Newxz(dst->children, 1, child_tab);
4619 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4621 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4622 dst->poll_count = 0;
4623 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4625 # endif /* USE_ITHREADS */
4626 #endif /* HAVE_INTERP_INTERN */