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" */
53 #define PERL_NO_GET_CONTEXT
58 /* assert.h conflicts with #define of assert in perl.h */
66 #include <sys/utime.h>
69 /* Mingw32 defaults to globing command line
70 * So we turn it off like this:
75 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
76 /* Mingw32-1.1 is missing some prototypes */
78 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
79 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
80 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
88 #define EXECF_SPAWN_NOWAIT 3
90 #if defined(PERL_IMPLICIT_SYS)
92 # define getlogin g_getlogin
95 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
96 * parameter handler. This functionality is not available in the
97 * 64-bit compiler from the Platform SDK, which unfortunately also
98 * believes itself to be MSC version 14.
100 * There is no #define related to _set_invalid_parameter_handler(),
101 * but we can check for one of the constants defined for
102 * _set_abort_behavior(), which was introduced into stdlib.h at
106 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
107 # define SET_INVALID_PARAMETER_HANDLER
110 #ifdef SET_INVALID_PARAMETER_HANDLER
111 static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
112 static void my_invalid_parameter_handler(const wchar_t* expression,
113 const wchar_t* function, const wchar_t* file,
114 unsigned int line, uintptr_t pReserved);
117 #ifndef WIN32_NO_REGISTRY
118 static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
119 static char* get_regstr(const char *valuename, SV **svp);
122 static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
123 char *trailing, ...);
124 static char* win32_get_xlib(const char *pl,
125 WIN32_NO_REGISTRY_M_(const char *xlib)
126 const char *libname, STRLEN *const len);
128 static BOOL has_shell_metachars(const char *ptr);
129 static long tokenize(const char *str, char **dest, char ***destv);
130 static void get_shell(void);
131 static char* find_next_space(const char *s);
132 static int do_spawn2(pTHX_ const char *cmd, int exectype);
133 static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
135 static int do_spawnvp_handles(int mode, const char *cmdname,
136 const char * const *argv, const int *handles);
137 static PerlIO * do_popen(const char *mode, const char *command, IV narg,
139 static long find_pid(pTHX_ int pid);
140 static void remove_dead_process(long child);
141 static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
142 static int my_killpg(int pid, int sig);
143 static int my_kill(int pid, int sig);
144 static void out_of_memory(void);
145 static char* wstr_to_str(const wchar_t* wstr);
146 static long filetime_to_clock(PFILETIME ft);
147 static BOOL filetime_from_time(PFILETIME ft, time_t t);
148 static char* create_command_line(char *cname, STRLEN clen,
149 const char * const *args);
150 static char* qualified_path(const char *cmd, bool other_exts);
151 static void ansify_path(void);
152 static LRESULT win32_process_message(HWND hwnd, UINT msg,
153 WPARAM wParam, LPARAM lParam);
156 static long find_pseudo_pid(pTHX_ int pid);
157 static void remove_dead_pseudo_process(long child);
158 static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
161 #ifdef HAVE_INTERP_INTERN
162 static void win32_csighandler(int sig);
166 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
167 char w32_module_name[MAX_PATH+1];
168 #ifdef WIN32_DYN_IOINFO_SIZE
169 Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
173 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
175 #ifndef WIN32_NO_REGISTRY
176 /* initialized by Perl_win32_init/PERL_SYS_INIT */
177 static HKEY HKCU_Perl_hnd;
178 static HKEY HKLM_Perl_hnd;
181 #ifdef SET_INVALID_PARAMETER_HANDLER
182 static BOOL silent_invalid_parameter_handler = FALSE;
185 set_silent_invalid_parameter_handler(BOOL newvalue)
187 BOOL oldvalue = silent_invalid_parameter_handler;
189 silent_invalid_parameter_handler = newvalue;
195 my_invalid_parameter_handler(const wchar_t* expression,
196 const wchar_t* function,
202 char* ansi_expression;
205 if (silent_invalid_parameter_handler)
207 ansi_expression = wstr_to_str(expression);
208 ansi_function = wstr_to_str(function);
209 ansi_file = wstr_to_str(file);
210 fprintf(stderr, "Invalid parameter detected in function %s. "
211 "File: %s, line: %d\n", ansi_function, ansi_file, line);
212 fprintf(stderr, "Expression: %s\n", ansi_expression);
213 free(ansi_expression);
221 set_w32_module_name(void)
223 /* this function may be called at DLL_PROCESS_ATTACH time */
225 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
226 ? GetModuleHandle(NULL)
227 : w32_perldll_handle);
229 WCHAR modulename[MAX_PATH];
230 WCHAR fullname[MAX_PATH];
233 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
234 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
235 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
237 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
239 /* Make sure we get an absolute pathname in case the module was loaded
240 * explicitly by LoadLibrary() with a relative path. */
241 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
243 /* Make sure we start with the long path name of the module because we
244 * later scan for pathname components to match "5.xx" to locate
245 * compatible sitelib directories, and the short pathname might mangle
246 * this path segment (e.g. by removing the dot on NTFS to something
247 * like "5xx~1.yy") */
248 if (pfnGetLongPathNameW)
249 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
251 /* remove \\?\ prefix */
252 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
253 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
255 ansi = win32_ansipath(fullname);
256 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
259 /* normalize to forward slashes */
260 ptr = w32_module_name;
268 #ifndef WIN32_NO_REGISTRY
269 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
271 get_regstr_from(HKEY handle, const char *valuename, SV **svp)
273 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
279 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
280 if (retval == ERROR_SUCCESS
281 && (type == REG_SZ || type == REG_EXPAND_SZ))
285 *svp = sv_2mortal(newSVpvs(""));
286 SvGROW(*svp, datalen);
287 retval = RegQueryValueEx(handle, valuename, 0, NULL,
288 (PBYTE)SvPVX(*svp), &datalen);
289 if (retval == ERROR_SUCCESS) {
291 SvCUR_set(*svp,datalen-1);
297 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
299 get_regstr(const char *valuename, SV **svp)
303 str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
310 str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
316 #endif /* ifndef WIN32_NO_REGISTRY */
318 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
320 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
324 char mod_name[MAX_PATH+1];
330 va_start(ap, trailing_path);
331 strip = va_arg(ap, char *);
333 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
334 baselen = strlen(base);
336 if (!*w32_module_name) {
337 set_w32_module_name();
339 strcpy(mod_name, w32_module_name);
340 ptr = strrchr(mod_name, '/');
341 while (ptr && strip) {
342 /* look for directories to skip back */
345 ptr = strrchr(mod_name, '/');
346 /* avoid stripping component if there is no slash,
347 * or it doesn't match ... */
348 if (!ptr || stricmp(ptr+1, strip) != 0) {
349 /* ... but not if component matches m|5\.$patchlevel.*| */
350 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
351 && strnEQ(strip, base, baselen)
352 && strnEQ(ptr+1, base, baselen)))
358 strip = va_arg(ap, char *);
366 strcpy(++ptr, trailing_path);
368 /* only add directory if it exists */
369 if (GetFileAttributes(mod_name) != (DWORD) -1) {
370 /* directory exists */
373 *prev_pathp = sv_2mortal(newSVpvs(""));
374 else if (SvPVX(*prev_pathp))
375 sv_catpvs(*prev_pathp, ";");
376 sv_catpv(*prev_pathp, mod_name);
378 *len = SvCUR(*prev_pathp);
379 return SvPVX(*prev_pathp);
386 win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
388 char *stdlib = "lib";
390 #ifndef WIN32_NO_REGISTRY
391 char buffer[MAX_PATH+1];
393 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
394 sprintf(buffer, "%s-%s", stdlib, pl);
395 if (!get_regstr(buffer, &sv))
396 (void)get_regstr(stdlib, &sv);
399 /* $stdlib .= ";$EMD/../../lib" */
400 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
404 win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib)
405 const char *libname, STRLEN *const len)
407 #ifndef WIN32_NO_REGISTRY
410 char pathstr[MAX_PATH+1];
414 #ifndef WIN32_NO_REGISTRY
415 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
416 sprintf(regstr, "%s-%s", xlib, pl);
417 (void)get_regstr(regstr, &sv1);
421 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
422 sprintf(pathstr, "%s/%s/lib", libname, pl);
423 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
425 #ifndef WIN32_NO_REGISTRY
426 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
427 (void)get_regstr(xlib, &sv2);
431 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
432 sprintf(pathstr, "%s/lib", libname);
433 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
451 win32_get_sitelib(const char *pl, STRLEN *const len)
453 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len);
456 #ifndef PERL_VENDORLIB_NAME
457 # define PERL_VENDORLIB_NAME "vendor"
461 win32_get_vendorlib(const char *pl, STRLEN *const len)
463 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len);
467 has_shell_metachars(const char *ptr)
473 * Scan string looking for redirection (< or >) or pipe
474 * characters (|) that are not in a quoted string.
475 * Shell variable interpolation (%VAR%) can also happen inside strings.
507 #if !defined(PERL_IMPLICIT_SYS)
508 /* since the current process environment is being updated in util.c
509 * the library functions will get the correct environment
512 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
514 PERL_FLUSHALL_FOR_CHILD;
515 return win32_popen(cmd, mode);
519 Perl_my_pclose(pTHX_ PerlIO *fp)
521 return win32_pclose(fp);
525 DllExport unsigned long
528 return (unsigned long)g_osver.dwPlatformId;
537 return -((int)w32_pseudo_id);
542 /* Tokenize a string. Words are null-separated, and the list
543 * ends with a doubled null. Any character (except null and
544 * including backslash) may be escaped by preceding it with a
545 * backslash (the backslash will be stripped).
546 * Returns number of words in result buffer.
549 tokenize(const char *str, char **dest, char ***destv)
551 char *retstart = NULL;
552 char **retvstart = 0;
555 int slen = strlen(str);
558 Newx(ret, slen+2, char);
559 Newx(retv, (slen+3)/2, char*);
567 if (*ret == '\\' && *str)
569 else if (*ret == ' ') {
585 retvstart[items] = NULL;
598 if (!w32_perlshell_tokens) {
599 /* we don't use COMSPEC here for two reasons:
600 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
601 * uncontrolled unportability of the ensuing scripts.
602 * 2. PERL5SHELL could be set to a shell that may not be fit for
603 * interactive use (which is what most programs look in COMSPEC
606 const char* defaultshell = "cmd.exe /x/d/c";
607 const char *usershell = PerlEnv_getenv("PERL5SHELL");
608 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
609 &w32_perlshell_tokens,
615 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
624 PERL_ARGS_ASSERT_DO_ASPAWN;
630 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
632 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
637 while (++mark <= sp) {
638 if (*mark && (str = SvPV_nolen(*mark)))
645 status = win32_spawnvp(flag,
646 (const char*)(really ? SvPV_nolen(really) : argv[0]),
647 (const char* const*)argv);
649 if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) {
650 /* possible shell-builtin, invoke with shell */
652 sh_items = w32_perlshell_items;
654 argv[index+sh_items] = argv[index];
655 while (--sh_items >= 0)
656 argv[sh_items] = w32_perlshell_vec[sh_items];
658 status = win32_spawnvp(flag,
659 (const char*)(really ? SvPV_nolen(really) : argv[0]),
660 (const char* const*)argv);
663 if (flag == P_NOWAIT) {
664 PL_statusvalue = -1; /* >16bits hint for pp_system() */
668 if (ckWARN(WARN_EXEC))
669 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
674 PL_statusvalue = status;
680 /* returns pointer to the next unquoted space or the end of the string */
682 find_next_space(const char *s)
684 bool in_quotes = FALSE;
686 /* ignore doubled backslashes, or backslash+quote */
687 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
690 /* keep track of when we're within quotes */
691 else if (*s == '"') {
693 in_quotes = !in_quotes;
695 /* break it up only at spaces that aren't in quotes */
696 else if (!in_quotes && isSPACE(*s))
705 do_spawn2(pTHX_ const char *cmd, int exectype) {
706 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
710 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
716 BOOL needToTry = TRUE;
719 /* Save an extra exec if possible. See if there are shell
720 * metacharacters in it */
721 if (!has_shell_metachars(cmd)) {
722 Newx(argv, strlen(cmd) / 2 + 2, char*);
723 Newx(cmd2, strlen(cmd) + 1, char);
726 for (s = cmd2; *s;) {
727 while (*s && isSPACE(*s))
731 s = find_next_space(s);
739 status = win32_spawnvp(P_WAIT, argv[0],
740 (const char* const*)argv);
742 case EXECF_SPAWN_NOWAIT:
743 status = do_spawnvp_handles(P_NOWAIT, argv[0],
744 (const char* const*)argv, handles);
747 status = win32_execvp(argv[0], (const char* const*)argv);
750 if (status != -1 || errno == 0)
760 Newx(argv, w32_perlshell_items + 2, char*);
761 while (++i < w32_perlshell_items)
762 argv[i] = w32_perlshell_vec[i];
763 argv[i++] = (char *)cmd;
767 status = win32_spawnvp(P_WAIT, argv[0],
768 (const char* const*)argv);
770 case EXECF_SPAWN_NOWAIT:
771 status = do_spawnvp_handles(P_NOWAIT, argv[0],
772 (const char* const*)argv, handles);
775 status = win32_execvp(argv[0], (const char* const*)argv);
781 if (exectype == EXECF_SPAWN_NOWAIT) {
782 PL_statusvalue = -1; /* >16bits hint for pp_system() */
786 if (ckWARN(WARN_EXEC))
787 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
788 (exectype == EXECF_EXEC ? "exec" : "spawn"),
789 cmd, strerror(errno));
794 PL_statusvalue = status;
800 Perl_do_spawn(pTHX_ char *cmd)
802 PERL_ARGS_ASSERT_DO_SPAWN;
804 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
808 Perl_do_spawn_nowait(pTHX_ char *cmd)
810 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
812 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
816 Perl_do_exec(pTHX_ const char *cmd)
818 PERL_ARGS_ASSERT_DO_EXEC;
820 do_spawn2(aTHX_ cmd, EXECF_EXEC);
824 /* The idea here is to read all the directory names into a string table
825 * (separated by nulls) and when one of the other dir functions is called
826 * return the pointer to the current file name.
829 win32_opendir(const char *filename)
835 char scanname[MAX_PATH+3];
836 WCHAR wscanname[sizeof(scanname)];
837 WIN32_FIND_DATAW wFindData;
838 char buffer[MAX_PATH*2];
841 len = strlen(filename);
846 if (len > MAX_PATH) {
847 errno = ENAMETOOLONG;
851 /* Get us a DIR structure */
854 /* Create the search pattern */
855 strcpy(scanname, filename);
857 /* bare drive name means look in cwd for drive */
858 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
859 scanname[len++] = '.';
860 scanname[len++] = '/';
862 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
863 scanname[len++] = '/';
865 scanname[len++] = '*';
866 scanname[len] = '\0';
868 /* do the FindFirstFile call */
869 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
871 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
873 if (dirp->handle == INVALID_HANDLE_VALUE) {
874 DWORD err = GetLastError();
875 /* FindFirstFile() fails on empty drives! */
877 case ERROR_FILE_NOT_FOUND:
879 case ERROR_NO_MORE_FILES:
880 case ERROR_PATH_NOT_FOUND:
883 case ERROR_NOT_ENOUGH_MEMORY:
895 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
896 wFindData.cFileName, -1,
897 buffer, sizeof(buffer), NULL, &use_default);
898 if (use_default && *wFindData.cAlternateFileName) {
899 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
900 wFindData.cAlternateFileName, -1,
901 buffer, sizeof(buffer), NULL, NULL);
904 /* now allocate the first part of the string table for
905 * the filenames that we find.
907 idx = strlen(buffer)+1;
912 Newx(dirp->start, dirp->size, char);
913 strcpy(dirp->start, buffer);
915 dirp->end = dirp->curr = dirp->start;
921 /* Readdir just returns the current string pointer and bumps the
922 * string pointer to the nDllExport entry.
924 DllExport struct direct *
925 win32_readdir(DIR *dirp)
930 /* first set up the structure to return */
931 len = strlen(dirp->curr);
932 strcpy(dirp->dirstr.d_name, dirp->curr);
933 dirp->dirstr.d_namlen = len;
936 dirp->dirstr.d_ino = dirp->curr - dirp->start;
938 /* Now set up for the next call to readdir */
939 dirp->curr += len + 1;
940 if (dirp->curr >= dirp->end) {
942 char buffer[MAX_PATH*2];
944 if (dirp->handle == INVALID_HANDLE_VALUE) {
947 /* finding the next file that matches the wildcard
948 * (which should be all of them in this directory!).
951 WIN32_FIND_DATAW wFindData;
952 res = FindNextFileW(dirp->handle, &wFindData);
954 BOOL use_default = FALSE;
955 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
956 wFindData.cFileName, -1,
957 buffer, sizeof(buffer), NULL, &use_default);
958 if (use_default && *wFindData.cAlternateFileName) {
959 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
960 wFindData.cAlternateFileName, -1,
961 buffer, sizeof(buffer), NULL, NULL);
966 long endpos = dirp->end - dirp->start;
967 long newsize = endpos + strlen(buffer) + 1;
968 /* bump the string table size by enough for the
969 * new name and its null terminator */
970 while (newsize > dirp->size) {
971 long curpos = dirp->curr - dirp->start;
972 Renew(dirp->start, dirp->size * 2, char);
974 dirp->curr = dirp->start + curpos;
976 strcpy(dirp->start + endpos, buffer);
977 dirp->end = dirp->start + newsize;
982 if (dirp->handle != INVALID_HANDLE_VALUE) {
983 FindClose(dirp->handle);
984 dirp->handle = INVALID_HANDLE_VALUE;
988 return &(dirp->dirstr);
994 /* Telldir returns the current string pointer position */
996 win32_telldir(DIR *dirp)
998 return dirp->curr ? (dirp->curr - dirp->start) : -1;
1002 /* Seekdir moves the string pointer to a previously saved position
1003 * (returned by telldir).
1006 win32_seekdir(DIR *dirp, long loc)
1008 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
1011 /* Rewinddir resets the string pointer to the start */
1013 win32_rewinddir(DIR *dirp)
1015 dirp->curr = dirp->start;
1018 /* free the memory allocated by opendir */
1020 win32_closedir(DIR *dirp)
1022 if (dirp->handle != INVALID_HANDLE_VALUE)
1023 FindClose(dirp->handle);
1024 Safefree(dirp->start);
1029 /* duplicate a open DIR* for interpreter cloning */
1031 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1034 PerlInterpreter *const from = param->proto_perl;
1035 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1040 /* switch back to original interpreter because win32_readdir()
1041 * might Renew(dirp->start).
1047 /* mark current position; read all remaining entries into the
1048 * cache, and then restore to current position.
1050 pos = win32_telldir(dirp);
1051 while (win32_readdir(dirp)) {
1052 /* read all entries into cache */
1054 win32_seekdir(dirp, pos);
1056 /* switch back to new interpreter to allocate new DIR structure */
1062 memcpy(dup, dirp, sizeof(DIR));
1064 Newx(dup->start, dirp->size, char);
1065 memcpy(dup->start, dirp->start, dirp->size);
1067 dup->end = dup->start + (dirp->end - dirp->start);
1069 dup->curr = dup->start + (dirp->curr - dirp->start);
1081 * Just pretend that everyone is a superuser. NT will let us know if
1082 * we don\'t really have permission to do something.
1085 #define ROOT_UID ((uid_t)0)
1086 #define ROOT_GID ((gid_t)0)
1115 return (auid == ROOT_UID ? 0 : -1);
1121 return (agid == ROOT_GID ? 0 : -1);
1128 char *buf = w32_getlogin_buffer;
1129 DWORD size = sizeof(w32_getlogin_buffer);
1130 if (GetUserName(buf,&size))
1136 chown(const char *path, uid_t owner, gid_t group)
1143 * XXX this needs strengthening (for PerlIO)
1146 #if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
1147 int mkstemp(const char *path)
1150 char buf[MAX_PATH+1];
1154 if (i++ > 10) { /* give up */
1158 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1162 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1170 find_pid(pTHX_ int pid)
1172 long child = w32_num_children;
1173 while (--child >= 0) {
1174 if ((int)w32_child_pids[child] == pid)
1181 remove_dead_process(long child)
1185 CloseHandle(w32_child_handles[child]);
1186 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1187 (w32_num_children-child-1), HANDLE);
1188 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1189 (w32_num_children-child-1), DWORD);
1196 find_pseudo_pid(pTHX_ int pid)
1198 long child = w32_num_pseudo_children;
1199 while (--child >= 0) {
1200 if ((int)w32_pseudo_child_pids[child] == pid)
1207 remove_dead_pseudo_process(long child)
1211 CloseHandle(w32_pseudo_child_handles[child]);
1212 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1213 (w32_num_pseudo_children-child-1), HANDLE);
1214 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1215 (w32_num_pseudo_children-child-1), DWORD);
1216 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1217 (w32_num_pseudo_children-child-1), HWND);
1218 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1219 (w32_num_pseudo_children-child-1), char);
1220 w32_num_pseudo_children--;
1225 win32_wait_for_children(pTHX)
1227 if (w32_pseudo_children && w32_num_pseudo_children) {
1230 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1232 for (child = 0; child < w32_num_pseudo_children; ++child) {
1233 if (!w32_pseudo_child_sigterm[child])
1234 handles[count++] = w32_pseudo_child_handles[child];
1236 /* XXX should use MsgWaitForMultipleObjects() to continue
1237 * XXX processing messages while we wait.
1239 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1241 while (w32_num_pseudo_children)
1242 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1248 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1252 /* "Does process exist?" use of kill */
1255 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1260 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1263 default: /* For now be backwards compatible with perl 5.6 */
1265 /* Note that we will only be able to kill processes owned by the
1266 * current process owner, even when we are running as an administrator.
1267 * To kill processes of other owners we would need to set the
1268 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1270 if (TerminateProcess(process_handle, sig))
1277 /* returns number of processes killed */
1279 my_killpg(int pid, int sig)
1281 HANDLE process_handle;
1282 HANDLE snapshot_handle;
1285 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1286 if (process_handle == NULL)
1289 killed += terminate_process(pid, process_handle, sig);
1291 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1292 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1293 PROCESSENTRY32 entry;
1295 entry.dwSize = sizeof(entry);
1296 if (Process32First(snapshot_handle, &entry)) {
1298 if (entry.th32ParentProcessID == (DWORD)pid)
1299 killed += my_killpg(entry.th32ProcessID, sig);
1300 entry.dwSize = sizeof(entry);
1302 while (Process32Next(snapshot_handle, &entry));
1304 CloseHandle(snapshot_handle);
1306 CloseHandle(process_handle);
1310 /* returns number of processes killed */
1312 my_kill(int pid, int sig)
1315 HANDLE process_handle;
1318 return my_killpg(pid, -sig);
1320 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1321 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1322 if (process_handle != NULL) {
1323 retval = terminate_process(pid, process_handle, sig);
1324 CloseHandle(process_handle);
1330 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1331 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1332 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1333 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1335 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1336 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1337 * a HWND in the time period allowed.
1340 get_hwnd_delay(pTHX, long child, DWORD tries)
1342 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1343 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1345 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1346 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1347 * thread 100% of the time since threads are attached to a CPU for NUMA and
1348 * caching reasons, and the child thread was attached to a different CPU
1349 * therefore there is no workload on that CPU and Sleep(0) returns control
1350 * without yielding the time slot.
1351 * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
1354 win32_async_check(aTHX);
1355 hwnd = w32_pseudo_child_message_hwnds[child];
1356 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1359 unsigned int count = 0;
1360 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1361 while (count++ < tries) {
1363 win32_async_check(aTHX);
1364 hwnd = w32_pseudo_child_message_hwnds[child];
1365 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1369 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1374 win32_kill(int pid, int sig)
1380 /* it is a pseudo-forked child */
1381 child = find_pseudo_pid(aTHX_ -pid);
1383 HANDLE hProcess = w32_pseudo_child_handles[child];
1386 /* "Does process exist?" use of kill */
1390 /* kill -9 style un-graceful exit */
1391 /* Do a wait to make sure child starts and isn't in DLL
1393 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1394 if (TerminateThread(hProcess, sig)) {
1395 /* Allow the scheduler to finish cleaning up the other
1397 * Otherwise, if we ExitProcess() before another context
1398 * switch happens we will end up with a process exit
1399 * code of "sig" instead of our own exit status.
1400 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1403 remove_dead_pseudo_process(child);
1410 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1411 /* We fake signals to pseudo-processes using Win32
1413 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1414 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1416 /* Don't wait for child process to terminate after we send a
1417 * SIGTERM because the child may be blocked in a system call
1418 * and never receive the signal.
1420 if (sig == SIGTERM) {
1422 w32_pseudo_child_sigterm[child] = 1;
1424 /* It might be us ... */
1436 child = find_pid(aTHX_ pid);
1438 if (my_kill(pid, sig)) {
1440 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1441 exitcode != STILL_ACTIVE)
1443 remove_dead_process(child);
1449 if (my_kill(pid, sig))
1458 win32_stat(const char *path, Stat_t *sbuf)
1460 char buffer[MAX_PATH+1];
1461 int l = strlen(path);
1465 BOOL expect_dir = FALSE;
1468 switch(path[l - 1]) {
1469 /* FindFirstFile() and stat() are buggy with a trailing
1470 * slashes, except for the root directory of a drive */
1473 if (l > sizeof(buffer)) {
1474 errno = ENAMETOOLONG;
1478 strncpy(buffer, path, l);
1479 /* remove additional trailing slashes */
1480 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1482 /* add back slash if we otherwise end up with just a drive letter */
1483 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1490 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1492 if (l == 2 && isALPHA(path[0])) {
1493 buffer[0] = path[0];
1504 path = PerlDir_mapA(path);
1507 if (!w32_sloppystat) {
1508 /* We must open & close the file once; otherwise file attribute changes */
1509 /* might not yet have propagated to "other" hard links of the same file. */
1510 /* This also gives us an opportunity to determine the number of links. */
1511 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1512 if (handle != INVALID_HANDLE_VALUE) {
1513 BY_HANDLE_FILE_INFORMATION bhi;
1514 if (GetFileInformationByHandle(handle, &bhi))
1515 nlink = bhi.nNumberOfLinks;
1516 CloseHandle(handle);
1519 DWORD err = GetLastError();
1520 /* very common case, skip CRT stat and its also failing syscalls */
1521 if(err == ERROR_FILE_NOT_FOUND) {
1528 /* path will be mapped correctly above */
1529 #if defined(WIN64) || defined(USE_LARGE_FILES)
1530 res = _stati64(path, sbuf);
1532 res = stat(path, sbuf);
1534 sbuf->st_nlink = nlink;
1537 /* CRT is buggy on sharenames, so make sure it really isn't.
1538 * XXX using GetFileAttributesEx() will enable us to set
1539 * sbuf->st_*time (but note that's not available on the
1540 * Windows of 1995) */
1541 DWORD r = GetFileAttributesA(path);
1542 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1543 /* sbuf may still contain old garbage since stat() failed */
1544 Zero(sbuf, 1, Stat_t);
1545 sbuf->st_mode = S_IFDIR | S_IREAD;
1547 if (!(r & FILE_ATTRIBUTE_READONLY))
1548 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1553 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1554 && (path[2] == '\\' || path[2] == '/'))
1556 /* The drive can be inaccessible, some _stat()s are buggy */
1557 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1562 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1566 if (S_ISDIR(sbuf->st_mode)) {
1567 /* Ensure the "write" bit is switched off in the mode for
1568 * directories with the read-only attribute set. Some compilers
1569 * switch it on for directories, which is technically correct
1570 * (directories are indeed always writable unless denied by DACLs),
1571 * but we want stat() and -w to reflect the state of the read-only
1572 * attribute for symmetry with chmod(). */
1573 DWORD r = GetFileAttributesA(path);
1574 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1575 sbuf->st_mode &= ~S_IWRITE;
1582 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1583 #define SKIP_SLASHES(s) \
1585 while (*(s) && isSLASH(*(s))) \
1588 #define COPY_NONSLASHES(d,s) \
1590 while (*(s) && !isSLASH(*(s))) \
1594 /* Find the longname of a given path. path is destructively modified.
1595 * It should have space for at least MAX_PATH characters. */
1597 win32_longpath(char *path)
1599 WIN32_FIND_DATA fdata;
1601 char tmpbuf[MAX_PATH+1];
1602 char *tmpstart = tmpbuf;
1609 if (isALPHA(path[0]) && path[1] == ':') {
1611 *tmpstart++ = path[0];
1615 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1617 *tmpstart++ = path[0];
1618 *tmpstart++ = path[1];
1619 SKIP_SLASHES(start);
1620 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1622 *tmpstart++ = *start++;
1623 SKIP_SLASHES(start);
1624 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1629 /* copy initial slash, if any */
1630 if (isSLASH(*start)) {
1631 *tmpstart++ = *start++;
1633 SKIP_SLASHES(start);
1636 /* FindFirstFile() expands "." and "..", so we need to pass
1637 * those through unmolested */
1639 && (!start[1] || isSLASH(start[1])
1640 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1642 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1647 /* if this is the end, bust outta here */
1651 /* now we're at a non-slash; walk up to next slash */
1652 while (*start && !isSLASH(*start))
1655 /* stop and find full name of component */
1658 fhand = FindFirstFile(path,&fdata);
1660 if (fhand != INVALID_HANDLE_VALUE) {
1661 STRLEN len = strlen(fdata.cFileName);
1662 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1663 strcpy(tmpstart, fdata.cFileName);
1674 /* failed a step, just return without side effects */
1675 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1680 strcpy(path,tmpbuf);
1693 win32_croak_not_implemented(const char * fname)
1695 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1697 Perl_croak_nocontext("%s not implemented!\n", fname);
1700 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1701 * potentially using the system's default replacement character for any
1702 * unrepresentable characters. The caller must free() the returned string. */
1704 wstr_to_str(const wchar_t* wstr)
1706 BOOL used_default = FALSE;
1707 size_t wlen = wcslen(wstr) + 1;
1708 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1709 NULL, 0, NULL, NULL);
1710 char* str = (char*)malloc(len);
1713 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1714 str, len, NULL, &used_default);
1718 /* The win32_ansipath() function takes a Unicode filename and converts it
1719 * into the current Windows codepage. If some characters cannot be mapped,
1720 * then it will convert the short name instead.
1722 * The buffer to the ansi pathname must be freed with win32_free() when it
1723 * it no longer needed.
1725 * The argument to win32_ansipath() must exist before this function is
1726 * called; otherwise there is no way to determine the short path name.
1728 * Ideas for future refinement:
1729 * - Only convert those segments of the path that are not in the current
1730 * codepage, but leave the other segments in their long form.
1731 * - If the resulting name is longer than MAX_PATH, start converting
1732 * additional path segments into short names until the full name
1733 * is shorter than MAX_PATH. Shorten the filename part last!
1736 win32_ansipath(const WCHAR *widename)
1739 BOOL use_default = FALSE;
1740 size_t widelen = wcslen(widename)+1;
1741 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1742 NULL, 0, NULL, NULL);
1743 name = (char*)win32_malloc(len);
1747 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1748 name, len, NULL, &use_default);
1750 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1752 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1755 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1757 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1758 NULL, 0, NULL, NULL);
1759 name = (char*)win32_realloc(name, len);
1762 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1763 name, len, NULL, NULL);
1764 win32_free(shortname);
1770 /* the returned string must be freed with win32_freeenvironmentstrings which is
1771 * implemented as a macro
1772 * void win32_freeenvironmentstrings(void* block)
1775 win32_getenvironmentstrings(void)
1777 LPWSTR lpWStr, lpWTmp;
1779 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1781 /* Get the process environment strings */
1782 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1783 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1784 env_len = wcslen(lpWTmp);
1785 /* calculate the size of the environment strings */
1786 wenvstrings_len += env_len + 1;
1789 /* Get the number of bytes required to store the ACP encoded string */
1790 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1791 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1792 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1796 /* Convert the string from UTF-16 encoding to ACP encoding */
1797 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1798 aenvstrings_len, NULL, NULL);
1800 FreeEnvironmentStringsW(lpWStr);
1806 win32_getenv(const char *name)
1813 needlen = GetEnvironmentVariableA(name,NULL,0);
1815 curitem = sv_2mortal(newSVpvs(""));
1817 SvGROW(curitem, needlen+1);
1818 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1820 } while (needlen >= SvLEN(curitem));
1821 SvCUR_set(curitem, needlen);
1824 last_err = GetLastError();
1825 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1826 /* It appears the variable is in the env, but the Win32 API
1827 doesn't have a canned way of getting it. So we fall back to
1828 grabbing the whole env and pulling this value out if possible */
1829 char *envv = GetEnvironmentStrings();
1833 char *end = strchr(cur,'=');
1834 if (end && end != cur) {
1836 if (strEQ(cur,name)) {
1837 curitem = sv_2mortal(newSVpv(end+1,0));
1842 cur = end + strlen(end+1)+2;
1844 else if ((len = strlen(cur)))
1847 FreeEnvironmentStrings(envv);
1849 #ifndef WIN32_NO_REGISTRY
1851 /* last ditch: allow any environment variables that begin with 'PERL'
1852 to be obtained from the registry, if found there */
1853 if (strBEGINs(name, "PERL"))
1854 (void)get_regstr(name, &curitem);
1858 if (curitem && SvCUR(curitem))
1859 return SvPVX(curitem);
1865 win32_putenv(const char *name)
1872 curitem = (char *) win32_malloc(strlen(name)+1);
1873 strcpy(curitem, name);
1874 val = strchr(curitem, '=');
1876 /* The sane way to deal with the environment.
1877 * Has these advantages over putenv() & co.:
1878 * * enables us to store a truly empty value in the
1879 * environment (like in UNIX).
1880 * * we don't have to deal with RTL globals, bugs and leaks
1881 * (specifically, see http://support.microsoft.com/kb/235601).
1883 * Why you may want to use the RTL environment handling
1884 * (previously enabled by USE_WIN32_RTL_ENV):
1885 * * environ[] and RTL functions will not reflect changes,
1886 * which might be an issue if extensions want to access
1887 * the env. via RTL. This cuts both ways, since RTL will
1888 * not see changes made by extensions that call the Win32
1889 * functions directly, either.
1893 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1896 win32_free(curitem);
1902 filetime_to_clock(PFILETIME ft)
1904 __int64 qw = ft->dwHighDateTime;
1906 qw |= ft->dwLowDateTime;
1907 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1912 win32_times(struct tms *timebuf)
1917 clock_t process_time_so_far = clock();
1918 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1920 timebuf->tms_utime = filetime_to_clock(&user);
1921 timebuf->tms_stime = filetime_to_clock(&kernel);
1922 timebuf->tms_cutime = 0;
1923 timebuf->tms_cstime = 0;
1925 /* That failed - e.g. Win95 fallback to clock() */
1926 timebuf->tms_utime = process_time_so_far;
1927 timebuf->tms_stime = 0;
1928 timebuf->tms_cutime = 0;
1929 timebuf->tms_cstime = 0;
1931 return process_time_so_far;
1934 /* fix utime() so it works on directories in NT */
1936 filetime_from_time(PFILETIME pFileTime, time_t Time)
1938 struct tm *pTM = localtime(&Time);
1939 SYSTEMTIME SystemTime;
1945 SystemTime.wYear = pTM->tm_year + 1900;
1946 SystemTime.wMonth = pTM->tm_mon + 1;
1947 SystemTime.wDay = pTM->tm_mday;
1948 SystemTime.wHour = pTM->tm_hour;
1949 SystemTime.wMinute = pTM->tm_min;
1950 SystemTime.wSecond = pTM->tm_sec;
1951 SystemTime.wMilliseconds = 0;
1953 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1954 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1958 win32_unlink(const char *filename)
1964 filename = PerlDir_mapA(filename);
1965 attrs = GetFileAttributesA(filename);
1966 if (attrs == 0xFFFFFFFF) {
1970 if (attrs & FILE_ATTRIBUTE_READONLY) {
1971 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1972 ret = unlink(filename);
1974 (void)SetFileAttributesA(filename, attrs);
1977 ret = unlink(filename);
1982 win32_utime(const char *filename, struct utimbuf *times)
1989 struct utimbuf TimeBuffer;
1992 filename = PerlDir_mapA(filename);
1993 rc = utime(filename, times);
1995 /* EACCES: path specifies directory or readonly file */
1996 if (rc == 0 || errno != EACCES)
1999 if (times == NULL) {
2000 times = &TimeBuffer;
2001 time(×->actime);
2002 times->modtime = times->actime;
2005 /* This will (and should) still fail on readonly files */
2006 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2007 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
2008 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2009 if (handle == INVALID_HANDLE_VALUE)
2012 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
2013 filetime_from_time(&ftAccess, times->actime) &&
2014 filetime_from_time(&ftWrite, times->modtime) &&
2015 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
2020 CloseHandle(handle);
2025 unsigned __int64 ft_i64;
2030 #define Const64(x) x##LL
2032 #define Const64(x) x##i64
2034 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2035 #define EPOCH_BIAS Const64(116444736000000000)
2037 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2038 * and appears to be unsupported even by glibc) */
2040 win32_gettimeofday(struct timeval *tp, void *not_used)
2044 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2045 GetSystemTimeAsFileTime(&ft.ft_val);
2047 /* seconds since epoch */
2048 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2050 /* microseconds remaining */
2051 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2057 win32_uname(struct utsname *name)
2059 struct hostent *hep;
2060 STRLEN nodemax = sizeof(name->nodename)-1;
2063 switch (g_osver.dwPlatformId) {
2064 case VER_PLATFORM_WIN32_WINDOWS:
2065 strcpy(name->sysname, "Windows");
2067 case VER_PLATFORM_WIN32_NT:
2068 strcpy(name->sysname, "Windows NT");
2070 case VER_PLATFORM_WIN32s:
2071 strcpy(name->sysname, "Win32s");
2074 strcpy(name->sysname, "Win32 Unknown");
2079 sprintf(name->release, "%d.%d",
2080 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2083 sprintf(name->version, "Build %d",
2084 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2085 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2086 if (g_osver.szCSDVersion[0]) {
2087 char *buf = name->version + strlen(name->version);
2088 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2092 hep = win32_gethostbyname("localhost");
2094 STRLEN len = strlen(hep->h_name);
2095 if (len <= nodemax) {
2096 strcpy(name->nodename, hep->h_name);
2099 strncpy(name->nodename, hep->h_name, nodemax);
2100 name->nodename[nodemax] = '\0';
2105 if (!GetComputerName(name->nodename, &sz))
2106 *name->nodename = '\0';
2109 /* machine (architecture) */
2114 GetSystemInfo(&info);
2116 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2117 procarch = info.u.s.wProcessorArchitecture;
2119 procarch = info.wProcessorArchitecture;
2122 case PROCESSOR_ARCHITECTURE_INTEL:
2123 arch = "x86"; break;
2124 case PROCESSOR_ARCHITECTURE_IA64:
2125 arch = "ia64"; break;
2126 case PROCESSOR_ARCHITECTURE_AMD64:
2127 arch = "amd64"; break;
2128 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2129 arch = "unknown"; break;
2131 sprintf(name->machine, "unknown(0x%x)", procarch);
2132 arch = name->machine;
2135 if (name->machine != arch)
2136 strcpy(name->machine, arch);
2141 /* Timing related stuff */
2144 do_raise(pTHX_ int sig)
2146 if (sig < SIG_SIZE) {
2147 Sighandler_t handler = w32_sighandler[sig];
2148 if (handler == SIG_IGN) {
2151 else if (handler != SIG_DFL) {
2156 /* Choose correct default behaviour */
2172 /* Tell caller to exit thread/process as appropriate */
2177 sig_terminate(pTHX_ int sig)
2179 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2180 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2187 win32_async_check(pTHX)
2190 HWND hwnd = w32_message_hwnd;
2192 /* Reset w32_poll_count before doing anything else, incase we dispatch
2193 * messages that end up calling back into perl */
2196 if (hwnd != INVALID_HANDLE_VALUE) {
2197 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2198 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2203 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2204 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2206 /* re-post a WM_QUIT message (we'll mark it as read later) */
2207 if(msg.message == WM_QUIT) {
2208 PostQuitMessage((int)msg.wParam);
2212 if(!CallMsgFilter(&msg, MSGF_USER))
2214 TranslateMessage(&msg);
2215 DispatchMessage(&msg);
2220 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2221 * This is necessary when we are being called by win32_msgwait() to
2222 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2223 * message over and over. An example how this can happen is when
2224 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2225 * is generating messages before the process terminated.
2227 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2229 /* Above or other stuff may have set a signal flag */
2236 /* This function will not return until the timeout has elapsed, or until
2237 * one of the handles is ready. */
2239 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2241 /* We may need several goes at this - so compute when we stop */
2243 unsigned __int64 endtime = timeout;
2244 if (timeout != INFINITE) {
2245 GetSystemTimeAsFileTime(&ticks.ft_val);
2246 ticks.ft_i64 /= 10000;
2247 endtime += ticks.ft_i64;
2249 /* This was a race condition. Do not let a non INFINITE timeout to
2250 * MsgWaitForMultipleObjects roll under 0 creating a near
2251 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2252 * user who did a CORE perl function with a non infinity timeout,
2253 * sleep for example. This is 64 to 32 truncation minefield.
2255 * This scenario can only be created if the timespan from the return of
2256 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2257 * generate the scenario, manual breakpoints in a C debugger are required,
2258 * or a context switch occurred in win32_async_check in PeekMessage, or random
2259 * messages are delivered to the *thread* message queue of the Perl thread
2260 * from another process (msctf.dll doing IPC among its instances, VS debugger
2261 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2263 while (ticks.ft_i64 <= endtime) {
2264 /* if timeout's type is lengthened, remember to split 64b timeout
2265 * into multiple non-infinity runs of MWFMO */
2266 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2267 (DWORD)(endtime - ticks.ft_i64),
2268 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2271 if (result == WAIT_TIMEOUT) {
2272 /* Ran out of time - explicit return of zero to avoid -ve if we
2273 have scheduling issues
2277 if (timeout != INFINITE) {
2278 GetSystemTimeAsFileTime(&ticks.ft_val);
2279 ticks.ft_i64 /= 10000;
2281 if (result == WAIT_OBJECT_0 + count) {
2282 /* Message has arrived - check it */
2283 (void)win32_async_check(aTHX);
2286 /* Not timeout or message - one of handles is ready */
2290 /* If we are past the end say zero */
2291 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2293 /* compute time left to wait */
2294 ticks.ft_i64 = endtime - ticks.ft_i64;
2295 /* if more ms than DWORD, then return max DWORD */
2296 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2300 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2302 /* XXX this wait emulation only knows about processes
2303 * spawned via win32_spawnvp(P_NOWAIT, ...).
2306 DWORD exitcode, waitcode;
2309 if (w32_num_pseudo_children) {
2310 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2311 timeout, &waitcode);
2312 /* Time out here if there are no other children to wait for. */
2313 if (waitcode == WAIT_TIMEOUT) {
2314 if (!w32_num_children) {
2318 else if (waitcode != WAIT_FAILED) {
2319 if (waitcode >= WAIT_ABANDONED_0
2320 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2321 i = waitcode - WAIT_ABANDONED_0;
2323 i = waitcode - WAIT_OBJECT_0;
2324 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2325 *status = (int)((exitcode & 0xff) << 8);
2326 retval = (int)w32_pseudo_child_pids[i];
2327 remove_dead_pseudo_process(i);
2334 if (!w32_num_children) {
2339 /* if a child exists, wait for it to die */
2340 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2341 if (waitcode == WAIT_TIMEOUT) {
2344 if (waitcode != WAIT_FAILED) {
2345 if (waitcode >= WAIT_ABANDONED_0
2346 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2347 i = waitcode - WAIT_ABANDONED_0;
2349 i = waitcode - WAIT_OBJECT_0;
2350 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2351 *status = (int)((exitcode & 0xff) << 8);
2352 retval = (int)w32_child_pids[i];
2353 remove_dead_process(i);
2358 errno = GetLastError();
2363 win32_waitpid(int pid, int *status, int flags)
2366 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2369 if (pid == -1) /* XXX threadid == 1 ? */
2370 return win32_internal_wait(aTHX_ status, timeout);
2373 child = find_pseudo_pid(aTHX_ -pid);
2375 HANDLE hThread = w32_pseudo_child_handles[child];
2377 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2378 if (waitcode == WAIT_TIMEOUT) {
2381 else if (waitcode == WAIT_OBJECT_0) {
2382 if (GetExitCodeThread(hThread, &waitcode)) {
2383 *status = (int)((waitcode & 0xff) << 8);
2384 retval = (int)w32_pseudo_child_pids[child];
2385 remove_dead_pseudo_process(child);
2397 child = find_pid(aTHX_ pid);
2399 hProcess = w32_child_handles[child];
2400 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2401 if (waitcode == WAIT_TIMEOUT) {
2404 else if (waitcode == WAIT_OBJECT_0) {
2405 if (GetExitCodeProcess(hProcess, &waitcode)) {
2406 *status = (int)((waitcode & 0xff) << 8);
2407 retval = (int)w32_child_pids[child];
2408 remove_dead_process(child);
2416 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2418 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2419 if (waitcode == WAIT_TIMEOUT) {
2420 CloseHandle(hProcess);
2423 else if (waitcode == WAIT_OBJECT_0) {
2424 if (GetExitCodeProcess(hProcess, &waitcode)) {
2425 *status = (int)((waitcode & 0xff) << 8);
2426 CloseHandle(hProcess);
2430 CloseHandle(hProcess);
2436 return retval >= 0 ? pid : retval;
2440 win32_wait(int *status)
2443 return win32_internal_wait(aTHX_ status, INFINITE);
2446 DllExport unsigned int
2447 win32_sleep(unsigned int t)
2450 /* Win32 times are in ms so *1000 in and /1000 out */
2451 if (t > UINT_MAX / 1000) {
2452 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2453 "sleep(%lu) too large", t);
2455 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2462 win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
2466 DllExport unsigned int
2467 win32_alarm(unsigned int sec)
2470 * the 'obvious' implentation is SetTimer() with a callback
2471 * which does whatever receiving SIGALRM would do
2472 * we cannot use SIGALRM even via raise() as it is not
2473 * one of the supported codes in <signal.h>
2477 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2478 w32_message_hwnd = win32_create_message_window();
2481 if (w32_message_hwnd == NULL)
2482 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2485 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2490 KillTimer(w32_message_hwnd, w32_timerid);
2497 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2500 win32_crypt(const char *txt, const char *salt)
2503 return des_fcrypt(txt, salt, w32_crypt_buffer);
2506 /* simulate flock by locking a range on the file */
2508 #define LK_LEN 0xffff0000
2511 win32_flock(int fd, int oper)
2517 fh = (HANDLE)_get_osfhandle(fd);
2518 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2521 memset(&o, 0, sizeof(o));
2524 case LOCK_SH: /* shared lock */
2525 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2528 case LOCK_EX: /* exclusive lock */
2529 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2532 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2533 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2536 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2537 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2541 case LOCK_UN: /* unlock lock */
2542 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2545 default: /* unknown */
2550 if (GetLastError() == ERROR_LOCK_VIOLATION)
2551 errno = EWOULDBLOCK;
2560 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2562 /* Get the errno value corresponding to the given err. This function is not
2563 * intended to handle conversion of general GetLastError() codes. It only exists
2564 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2565 * used to be assigned to errno/$! in earlier versions of perl; this function is
2566 * used to catch any old Perl code which is still trying to assign such values
2567 * to $! and convert them to errno values instead.
2570 win32_get_errno(int err)
2572 return convert_wsa_error_to_errno(err);
2576 * redirected io subsystem for all XS modules
2589 return (&(_environ));
2592 /* the rest are the remapped stdio routines */
2612 win32_ferror(FILE *fp)
2614 return (ferror(fp));
2619 win32_feof(FILE *fp)
2624 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2625 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2629 * Since the errors returned by the socket error function
2630 * WSAGetLastError() are not known by the library routine strerror
2631 * we have to roll our own to cover the case of socket errors
2632 * that could not be converted to regular errno values by
2633 * get_last_socket_error() in win32/win32sck.c.
2637 win32_strerror(int e)
2639 #if !defined __MINGW32__ /* compiler intolerance */
2640 extern int sys_nerr;
2643 if (e < 0 || e > sys_nerr) {
2647 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2648 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2649 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2650 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2651 * We must therefore still roll our own messages for these codes, and
2652 * additionally map them to corresponding Windows (sockets) error codes
2653 * first to avoid getting the wrong system message.
2655 else if (e >= EADDRINUSE && e <= EWOULDBLOCK) {
2656 e = convert_errno_to_wsa_error(e);
2660 aTHXa(PERL_GET_THX);
2661 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2662 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2663 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2666 strcpy(w32_strerror_buffer, "Unknown Error");
2668 return w32_strerror_buffer;
2672 #define strerror win32_strerror
2676 win32_str_os_error(void *sv, DWORD dwErr)
2680 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2681 |FORMAT_MESSAGE_IGNORE_INSERTS
2682 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2683 dwErr, 0, (char *)&sMsg, 1, NULL);
2684 /* strip trailing whitespace and period */
2687 --dwLen; /* dwLen doesn't include trailing null */
2688 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2689 if ('.' != sMsg[dwLen])
2694 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2696 dwLen = sprintf(sMsg,
2697 "Unknown error #0x%lX (lookup 0x%lX)",
2698 dwErr, GetLastError());
2702 sv_setpvn((SV*)sv, sMsg, dwLen);
2708 win32_fprintf(FILE *fp, const char *format, ...)
2711 va_start(marker, format); /* Initialize variable arguments. */
2713 return (vfprintf(fp, format, marker));
2717 win32_printf(const char *format, ...)
2720 va_start(marker, format); /* Initialize variable arguments. */
2722 return (vprintf(format, marker));
2726 win32_vfprintf(FILE *fp, const char *format, va_list args)
2728 return (vfprintf(fp, format, args));
2732 win32_vprintf(const char *format, va_list args)
2734 return (vprintf(format, args));
2738 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2740 return fread(buf, size, count, fp);
2744 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2746 return fwrite(buf, size, count, fp);
2749 #define MODE_SIZE 10
2752 win32_fopen(const char *filename, const char *mode)
2760 if (stricmp(filename, "/dev/null")==0)
2763 aTHXa(PERL_GET_THX);
2764 f = fopen(PerlDir_mapA(filename), mode);
2765 /* avoid buffering headaches for child processes */
2766 if (f && *mode == 'a')
2767 win32_fseek(f, 0, SEEK_END);
2772 win32_fdopen(int handle, const char *mode)
2775 f = fdopen(handle, (char *) mode);
2776 /* avoid buffering headaches for child processes */
2777 if (f && *mode == 'a')
2778 win32_fseek(f, 0, SEEK_END);
2783 win32_freopen(const char *path, const char *mode, FILE *stream)
2786 if (stricmp(path, "/dev/null")==0)
2789 aTHXa(PERL_GET_THX);
2790 return freopen(PerlDir_mapA(path), mode, stream);
2794 win32_fclose(FILE *pf)
2796 #ifdef WIN32_NO_SOCKETS
2799 return my_fclose(pf); /* defined in win32sck.c */
2804 win32_fputs(const char *s,FILE *pf)
2806 return fputs(s, pf);
2810 win32_fputc(int c,FILE *pf)
2816 win32_ungetc(int c,FILE *pf)
2818 return ungetc(c,pf);
2822 win32_getc(FILE *pf)
2828 win32_fileno(FILE *pf)
2834 win32_clearerr(FILE *pf)
2841 win32_fflush(FILE *pf)
2847 win32_ftell(FILE *pf)
2849 #if defined(WIN64) || defined(USE_LARGE_FILES)
2851 if (fgetpos(pf, &pos))
2860 win32_fseek(FILE *pf, Off_t offset,int origin)
2862 #if defined(WIN64) || defined(USE_LARGE_FILES)
2866 if (fgetpos(pf, &pos))
2871 fseek(pf, 0, SEEK_END);
2872 pos = _telli64(fileno(pf));
2881 return fsetpos(pf, &offset);
2883 return fseek(pf, (long)offset, origin);
2888 win32_fgetpos(FILE *pf,fpos_t *p)
2890 return fgetpos(pf, p);
2894 win32_fsetpos(FILE *pf,const fpos_t *p)
2896 return fsetpos(pf, p);
2900 win32_rewind(FILE *pf)
2909 char prefix[MAX_PATH+1];
2910 char filename[MAX_PATH+1];
2911 DWORD len = GetTempPath(MAX_PATH, prefix);
2912 if (len && len < MAX_PATH) {
2913 if (GetTempFileName(prefix, "plx", 0, filename)) {
2914 HANDLE fh = CreateFile(filename,
2915 DELETE | GENERIC_READ | GENERIC_WRITE,
2919 FILE_ATTRIBUTE_NORMAL
2920 | FILE_FLAG_DELETE_ON_CLOSE,
2922 if (fh != INVALID_HANDLE_VALUE) {
2923 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2926 DEBUG_p(PerlIO_printf(Perl_debug_log,
2927 "Created tmpfile=%s\n",filename));
2939 int fd = win32_tmpfd();
2941 return win32_fdopen(fd, "w+b");
2953 win32_fstat(int fd, Stat_t *sbufptr)
2955 #if defined(WIN64) || defined(USE_LARGE_FILES)
2956 return _fstati64(fd, sbufptr);
2958 return fstat(fd, sbufptr);
2963 win32_pipe(int *pfd, unsigned int size, int mode)
2965 return _pipe(pfd, size, mode);
2969 win32_popenlist(const char *mode, IV narg, SV **args)
2973 return do_popen(mode, NULL, narg, args);
2977 do_popen(const char *mode, const char *command, IV narg, SV **args) {
2986 const char **args_pvs = NULL;
2988 /* establish which ends read and write */
2989 if (strchr(mode,'w')) {
2990 stdfd = 0; /* stdin */
2993 nhandle = STD_INPUT_HANDLE;
2995 else if (strchr(mode,'r')) {
2996 stdfd = 1; /* stdout */
2999 nhandle = STD_OUTPUT_HANDLE;
3004 /* set the correct mode */
3005 if (strchr(mode,'b'))
3007 else if (strchr(mode,'t'))
3010 ourmode = _fmode & (O_TEXT | O_BINARY);
3012 /* the child doesn't inherit handles */
3013 ourmode |= O_NOINHERIT;
3015 if (win32_pipe(p, 512, ourmode) == -1)
3018 /* Previously this code redirected stdin/out temporarily so the
3019 child process inherited those handles, this caused race
3020 conditions when another thread was writing/reading those
3023 To avoid that we just feed the handles to CreateProcess() so
3024 the handles are redirected only in the child.
3026 handles[child] = p[child];
3027 handles[parent] = -1;
3030 /* CreateProcess() requires inheritable handles */
3031 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3032 HANDLE_FLAG_INHERIT)) {
3036 /* start the child */
3041 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3047 const char *exe_name;
3049 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3050 SAVEFREEPV(args_pvs);
3051 for (i = 0; i < narg; ++i)
3052 args_pvs[i] = SvPV_nolen(args[i]);
3054 exe_name = qualified_path(args_pvs[0], TRUE);
3056 /* let CreateProcess() try to find it instead */
3057 exe_name = args_pvs[0];
3059 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3064 win32_close(p[child]);
3066 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3068 /* set process id so that it can be returned by perl's open() */
3069 PL_forkprocess = childpid;
3072 /* we have an fd, return a file stream */
3073 return (PerlIO_fdopen(p[parent], (char *)mode));
3076 /* we don't need to check for errors here */
3084 * a popen() clone that respects PERL5SHELL
3086 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3090 win32_popen(const char *command, const char *mode)
3092 #ifdef USE_RTL_POPEN
3093 return _popen(command, mode);
3095 return do_popen(mode, command, 0, NULL);
3096 #endif /* USE_RTL_POPEN */
3104 win32_pclose(PerlIO *pf)
3106 #ifdef USE_RTL_POPEN
3110 int childpid, status;
3113 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3116 childpid = SvIVX(sv);
3132 if (win32_waitpid(childpid, &status, 0) == -1)
3137 #endif /* USE_RTL_POPEN */
3141 win32_link(const char *oldname, const char *newname)
3144 WCHAR wOldName[MAX_PATH+1];
3145 WCHAR wNewName[MAX_PATH+1];
3147 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3148 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3149 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3150 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3154 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3155 both permissions errors and if the source is a directory, while
3156 POSIX wants EACCES and EPERM respectively.
3158 Determined by experimentation on Windows 7 x64 SP1, since MS
3159 don't document what error codes are returned.
3161 switch (GetLastError()) {
3162 case ERROR_BAD_NET_NAME:
3163 case ERROR_BAD_NETPATH:
3164 case ERROR_BAD_PATHNAME:
3165 case ERROR_FILE_NOT_FOUND:
3166 case ERROR_FILENAME_EXCED_RANGE:
3167 case ERROR_INVALID_DRIVE:
3168 case ERROR_PATH_NOT_FOUND:
3171 case ERROR_ALREADY_EXISTS:
3174 case ERROR_ACCESS_DENIED:
3177 case ERROR_NOT_SAME_DEVICE:
3180 case ERROR_DISK_FULL:
3183 case ERROR_NOT_ENOUGH_QUOTA:
3187 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3195 win32_rename(const char *oname, const char *newname)
3197 char szOldName[MAX_PATH+1];
3199 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3202 if (stricmp(newname, oname))
3203 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3204 strcpy(szOldName, PerlDir_mapA(oname));
3206 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3208 DWORD err = GetLastError();
3210 case ERROR_BAD_NET_NAME:
3211 case ERROR_BAD_NETPATH:
3212 case ERROR_BAD_PATHNAME:
3213 case ERROR_FILE_NOT_FOUND:
3214 case ERROR_FILENAME_EXCED_RANGE:
3215 case ERROR_INVALID_DRIVE:
3216 case ERROR_NO_MORE_FILES:
3217 case ERROR_PATH_NOT_FOUND:
3220 case ERROR_DISK_FULL:
3223 case ERROR_NOT_ENOUGH_QUOTA:
3236 win32_setmode(int fd, int mode)
3238 return setmode(fd, mode);
3242 win32_chsize(int fd, Off_t size)
3244 #if defined(WIN64) || defined(USE_LARGE_FILES)
3246 Off_t cur, end, extend;
3248 cur = win32_tell(fd);
3251 end = win32_lseek(fd, 0, SEEK_END);
3254 extend = size - end;
3258 else if (extend > 0) {
3259 /* must grow the file, padding with nulls */
3261 int oldmode = win32_setmode(fd, O_BINARY);
3263 memset(b, '\0', sizeof(b));
3265 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3266 count = win32_write(fd, b, count);
3267 if ((int)count < 0) {
3271 } while ((extend -= count) > 0);
3272 win32_setmode(fd, oldmode);
3275 /* shrink the file */
3276 win32_lseek(fd, size, SEEK_SET);
3277 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3282 win32_lseek(fd, cur, SEEK_SET);
3285 return chsize(fd, (long)size);
3290 win32_lseek(int fd, Off_t offset, int origin)
3292 #if defined(WIN64) || defined(USE_LARGE_FILES)
3293 return _lseeki64(fd, offset, origin);
3295 return lseek(fd, (long)offset, origin);
3302 #if defined(WIN64) || defined(USE_LARGE_FILES)
3303 return _telli64(fd);
3310 win32_open(const char *path, int flag, ...)
3317 pmode = va_arg(ap, int);
3320 if (stricmp(path, "/dev/null")==0)
3323 aTHXa(PERL_GET_THX);
3324 return open(PerlDir_mapA(path), flag, pmode);
3327 /* close() that understands socket */
3328 extern int my_close(int); /* in win32sck.c */
3333 #ifdef WIN32_NO_SOCKETS
3336 return my_close(fd);
3347 win32_isatty(int fd)
3349 /* The Microsoft isatty() function returns true for *all*
3350 * character mode devices, including "nul". Our implementation
3351 * should only return true if the handle has a console buffer.
3354 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3355 if (fh == (HANDLE)-1) {
3356 /* errno is already set to EBADF */
3360 if (GetConsoleMode(fh, &mode))
3374 win32_dup2(int fd1,int fd2)
3376 return dup2(fd1,fd2);
3380 win32_read(int fd, void *buf, unsigned int cnt)
3382 return read(fd, buf, cnt);
3386 win32_write(int fd, const void *buf, unsigned int cnt)
3388 return write(fd, buf, cnt);
3392 win32_mkdir(const char *dir, int mode)
3395 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3399 win32_rmdir(const char *dir)
3402 return rmdir(PerlDir_mapA(dir));
3406 win32_chdir(const char *dir)
3408 if (!dir || !*dir) {
3416 win32_access(const char *path, int mode)
3419 return access(PerlDir_mapA(path), mode);
3423 win32_chmod(const char *path, int mode)
3426 return chmod(PerlDir_mapA(path), mode);
3431 create_command_line(char *cname, STRLEN clen, const char * const *args)
3438 bool bat_file = FALSE;
3439 bool cmd_shell = FALSE;
3440 bool dumb_shell = FALSE;
3441 bool extra_quotes = FALSE;
3442 bool quote_next = FALSE;
3445 cname = (char*)args[0];
3447 /* The NT cmd.exe shell has the following peculiarity that needs to be
3448 * worked around. It strips a leading and trailing dquote when any
3449 * of the following is true:
3450 * 1. the /S switch was used
3451 * 2. there are more than two dquotes
3452 * 3. there is a special character from this set: &<>()@^|
3453 * 4. no whitespace characters within the two dquotes
3454 * 5. string between two dquotes isn't an executable file
3455 * To work around this, we always add a leading and trailing dquote
3456 * to the string, if the first argument is either "cmd.exe" or "cmd",
3457 * and there were at least two or more arguments passed to cmd.exe
3458 * (not including switches).
3459 * XXX the above rules (from "cmd /?") don't seem to be applied
3460 * always, making for the convolutions below :-(
3464 clen = strlen(cname);
3467 && (stricmp(&cname[clen-4], ".bat") == 0
3468 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3474 char *exe = strrchr(cname, '/');
3475 char *exe2 = strrchr(cname, '\\');
3482 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3486 else if (stricmp(exe, "command.com") == 0
3487 || stricmp(exe, "command") == 0)
3494 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3495 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3496 STRLEN curlen = strlen(arg);
3497 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3498 len += 2; /* assume quoting needed (worst case) */
3500 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3502 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3505 Newx(cmd, len, char);
3510 extra_quotes = TRUE;
3513 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3515 STRLEN curlen = strlen(arg);
3517 /* we want to protect empty arguments and ones with spaces with
3518 * dquotes, but only if they aren't already there */
3523 else if (quote_next) {
3524 /* see if it really is multiple arguments pretending to
3525 * be one and force a set of quotes around it */
3526 if (*find_next_space(arg))
3529 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3531 while (i < curlen) {
3532 if (isSPACE(arg[i])) {
3535 else if (arg[i] == '"') {
3559 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3560 && stricmp(arg+curlen-2, "/c") == 0)
3562 /* is there a next argument? */
3563 if (args[index+1]) {
3564 /* are there two or more next arguments? */
3565 if (args[index+2]) {
3567 extra_quotes = TRUE;
3570 /* single argument, force quoting if it has spaces */
3585 static const char *exe_extensions[] =
3587 ".exe", /* this must be first */
3593 qualified_path(const char *cmd, bool other_exts)
3596 char *fullcmd, *curfullcmd;
3602 fullcmd = (char*)cmd;
3604 if (*fullcmd == '/' || *fullcmd == '\\')
3613 pathstr = PerlEnv_getenv("PATH");
3615 /* worst case: PATH is a single directory; we need additional space
3616 * to append "/", ".exe" and trailing "\0" */
3617 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3618 curfullcmd = fullcmd;
3623 /* start by appending the name to the current prefix */
3624 strcpy(curfullcmd, cmd);
3625 curfullcmd += cmdlen;
3627 /* if it doesn't end with '.', or has no extension, try adding
3628 * a trailing .exe first */
3629 if (cmd[cmdlen-1] != '.'
3630 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3633 /* first extension is .exe */
3634 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3635 for (i = 0; i < ext_limit; ++i) {
3636 strcpy(curfullcmd, exe_extensions[i]);
3637 res = GetFileAttributes(fullcmd);
3638 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3645 /* that failed, try the bare name */
3646 res = GetFileAttributes(fullcmd);
3647 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3650 /* quit if no other path exists, or if cmd already has path */
3651 if (!pathstr || !*pathstr || has_slash)
3654 /* skip leading semis */
3655 while (*pathstr == ';')
3658 /* build a new prefix from scratch */
3659 curfullcmd = fullcmd;
3660 while (*pathstr && *pathstr != ';') {
3661 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3662 pathstr++; /* skip initial '"' */
3663 while (*pathstr && *pathstr != '"') {
3664 *curfullcmd++ = *pathstr++;
3667 pathstr++; /* skip trailing '"' */
3670 *curfullcmd++ = *pathstr++;
3674 pathstr++; /* skip trailing semi */
3675 if (curfullcmd > fullcmd /* append a dir separator */
3676 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3678 *curfullcmd++ = '\\';
3686 /* The following are just place holders.
3687 * Some hosts may provide and environment that the OS is
3688 * not tracking, therefore, these host must provide that
3689 * environment and the current directory to CreateProcess
3693 win32_get_childenv(void)
3699 win32_free_childenv(void* d)
3704 win32_clearenv(void)
3706 char *envv = GetEnvironmentStrings();
3710 char *end = strchr(cur,'=');
3711 if (end && end != cur) {
3713 SetEnvironmentVariable(cur, NULL);
3715 cur = end + strlen(end+1)+2;
3717 else if ((len = strlen(cur)))
3720 FreeEnvironmentStrings(envv);
3724 win32_get_childdir(void)
3727 char szfilename[MAX_PATH+1];
3729 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3730 Newx(ptr, strlen(szfilename)+1, char);
3731 strcpy(ptr, szfilename);
3736 win32_free_childdir(char* d)
3742 /* XXX this needs to be made more compatible with the spawnvp()
3743 * provided by the various RTLs. In particular, searching for
3744 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3745 * This doesn't significantly affect perl itself, because we
3746 * always invoke things using PERL5SHELL if a direct attempt to
3747 * spawn the executable fails.
3749 * XXX splitting and rejoining the commandline between do_aspawn()
3750 * and win32_spawnvp() could also be avoided.
3754 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3756 #ifdef USE_RTL_SPAWNVP
3757 return _spawnvp(mode, cmdname, (char * const *)argv);
3759 return do_spawnvp_handles(mode, cmdname, argv, NULL);
3764 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3765 const int *handles) {
3771 STARTUPINFO StartupInfo;
3772 PROCESS_INFORMATION ProcessInformation;
3775 char *fullcmd = NULL;
3776 char *cname = (char *)cmdname;
3780 clen = strlen(cname);
3781 /* if command name contains dquotes, must remove them */
3782 if (strchr(cname, '"')) {
3784 Newx(cname,clen+1,char);
3797 cmd = create_command_line(cname, clen, argv);
3799 aTHXa(PERL_GET_THX);
3800 env = PerlEnv_get_childenv();
3801 dir = PerlEnv_get_childdir();
3804 case P_NOWAIT: /* asynch + remember result */
3805 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3810 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3813 create |= CREATE_NEW_PROCESS_GROUP;
3816 case P_WAIT: /* synchronous execution */
3818 default: /* invalid mode */
3824 memset(&StartupInfo,0,sizeof(StartupInfo));
3825 StartupInfo.cb = sizeof(StartupInfo);
3826 memset(&tbl,0,sizeof(tbl));
3827 PerlEnv_get_child_IO(&tbl);
3828 StartupInfo.dwFlags = tbl.dwFlags;
3829 StartupInfo.dwX = tbl.dwX;
3830 StartupInfo.dwY = tbl.dwY;
3831 StartupInfo.dwXSize = tbl.dwXSize;
3832 StartupInfo.dwYSize = tbl.dwYSize;
3833 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3834 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3835 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3836 StartupInfo.wShowWindow = tbl.wShowWindow;
3837 StartupInfo.hStdInput = handles && handles[0] != -1 ?
3838 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3839 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
3840 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3841 StartupInfo.hStdError = handles && handles[2] != -1 ?
3842 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3843 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3844 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3845 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3847 create |= CREATE_NEW_CONSOLE;
3850 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3852 if (w32_use_showwindow) {
3853 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3854 StartupInfo.wShowWindow = w32_showwindow;
3857 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3860 if (!CreateProcess(cname, /* search PATH to find executable */
3861 cmd, /* executable, and its arguments */
3862 NULL, /* process attributes */
3863 NULL, /* thread attributes */
3864 TRUE, /* inherit handles */
3865 create, /* creation flags */
3866 (LPVOID)env, /* inherit environment */
3867 dir, /* inherit cwd */
3869 &ProcessInformation))
3871 /* initial NULL argument to CreateProcess() does a PATH
3872 * search, but it always first looks in the directory
3873 * where the current process was started, which behavior
3874 * is undesirable for backward compatibility. So we
3875 * jump through our own hoops by picking out the path
3876 * we really want it to use. */
3878 fullcmd = qualified_path(cname, FALSE);
3880 if (cname != cmdname)
3883 DEBUG_p(PerlIO_printf(Perl_debug_log,
3884 "Retrying [%s] with same args\n",
3894 if (mode == P_NOWAIT) {
3895 /* asynchronous spawn -- store handle, return PID */
3896 ret = (int)ProcessInformation.dwProcessId;
3898 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3899 w32_child_pids[w32_num_children] = (DWORD)ret;
3904 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3905 /* FIXME: if msgwait returned due to message perhaps forward the
3906 "signal" to the process
3908 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3910 CloseHandle(ProcessInformation.hProcess);
3913 CloseHandle(ProcessInformation.hThread);
3916 PerlEnv_free_childenv(env);
3917 PerlEnv_free_childdir(dir);
3919 if (cname != cmdname)
3925 win32_execv(const char *cmdname, const char *const *argv)
3929 /* if this is a pseudo-forked child, we just want to spawn
3930 * the new program, and return */
3932 return _spawnv(P_WAIT, cmdname, argv);
3934 return _execv(cmdname, argv);
3938 win32_execvp(const char *cmdname, const char *const *argv)
3942 /* if this is a pseudo-forked child, we just want to spawn
3943 * the new program, and return */
3944 if (w32_pseudo_id) {
3945 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3954 return _execvp(cmdname, argv);
3958 win32_perror(const char *str)
3964 win32_setbuf(FILE *pf, char *buf)
3970 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3972 return setvbuf(pf, buf, type, size);
3976 win32_flushall(void)
3982 win32_fcloseall(void)
3988 win32_fgets(char *s, int n, FILE *pf)
3990 return fgets(s, n, pf);
4000 win32_fgetc(FILE *pf)
4006 win32_putc(int c, FILE *pf)
4012 win32_puts(const char *s)
4024 win32_putchar(int c)
4031 #ifndef USE_PERL_SBRK
4033 static char *committed = NULL; /* XXX threadead */
4034 static char *base = NULL; /* XXX threadead */
4035 static char *reserved = NULL; /* XXX threadead */
4036 static char *brk = NULL; /* XXX threadead */
4037 static DWORD pagesize = 0; /* XXX threadead */
4040 sbrk(ptrdiff_t need)
4045 GetSystemInfo(&info);
4046 /* Pretend page size is larger so we don't perpetually
4047 * call the OS to commit just one page ...
4049 pagesize = info.dwPageSize << 3;
4051 if (brk+need >= reserved)
4053 DWORD size = brk+need-reserved;
4055 char *prev_committed = NULL;
4056 if (committed && reserved && committed < reserved)
4058 /* Commit last of previous chunk cannot span allocations */
4059 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4062 /* Remember where we committed from in case we want to decommit later */
4063 prev_committed = committed;
4064 committed = reserved;
4067 /* Reserve some (more) space
4068 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4069 * this is only address space not memory...
4070 * Note this is a little sneaky, 1st call passes NULL as reserved
4071 * so lets system choose where we start, subsequent calls pass
4072 * the old end address so ask for a contiguous block
4075 if (size < 64*1024*1024)
4076 size = 64*1024*1024;
4077 size = ((size + pagesize - 1) / pagesize) * pagesize;
4078 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4081 reserved = addr+size;
4091 /* The existing block could not be extended far enough, so decommit
4092 * anything that was just committed above and start anew */
4095 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4098 reserved = base = committed = brk = NULL;
4109 if (brk > committed)
4111 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4113 if (committed+size > reserved)
4114 size = reserved-committed;
4115 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4128 win32_malloc(size_t size)
4130 return malloc(size);
4134 win32_calloc(size_t numitems, size_t size)
4136 return calloc(numitems,size);
4140 win32_realloc(void *block, size_t size)
4142 return realloc(block,size);
4146 win32_free(void *block)
4153 win32_open_osfhandle(intptr_t handle, int flags)
4155 return _open_osfhandle(handle, flags);
4159 win32_get_osfhandle(int fd)
4161 return (intptr_t)_get_osfhandle(fd);
4165 win32_fdupopen(FILE *pf)
4170 int fileno = win32_dup(win32_fileno(pf));
4172 /* open the file in the same mode */
4173 if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
4177 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
4181 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
4187 /* it appears that the binmode is attached to the
4188 * file descriptor so binmode files will be handled
4191 pfdup = win32_fdopen(fileno, mode);
4193 /* move the file pointer to the same position */
4194 if (!fgetpos(pf, &pos)) {
4195 fsetpos(pfdup, &pos);
4201 win32_dynaload(const char* filename)
4204 char buf[MAX_PATH+1];
4207 /* LoadLibrary() doesn't recognize forward slashes correctly,
4208 * so turn 'em back. */
4209 first = strchr(filename, '/');
4211 STRLEN len = strlen(filename);
4212 if (len <= MAX_PATH) {
4213 strcpy(buf, filename);
4214 filename = &buf[first - filename];
4216 if (*filename == '/')
4217 *(char*)filename = '\\';
4223 aTHXa(PERL_GET_THX);
4224 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4227 XS(w32_SetChildShowWindow)
4230 BOOL use_showwindow = w32_use_showwindow;
4231 /* use "unsigned short" because Perl has redefined "WORD" */
4232 unsigned short showwindow = w32_showwindow;
4235 croak_xs_usage(cv, "[showwindow]");
4237 if (items == 0 || !SvOK(ST(0)))
4238 w32_use_showwindow = FALSE;
4240 w32_use_showwindow = TRUE;
4241 w32_showwindow = (unsigned short)SvIV(ST(0));
4246 ST(0) = sv_2mortal(newSViv(showwindow));
4248 ST(0) = &PL_sv_undef;
4253 #ifdef PERL_IS_MINIPERL
4254 /* shelling out is much slower, full perl uses Win32.pm */
4258 /* Make the host for current directory */
4259 char* ptr = PerlEnv_get_childdir();
4262 * then it worked, set PV valid,
4263 * else return 'undef'
4266 SV *sv = sv_newmortal();
4268 PerlEnv_free_childdir(ptr);
4270 #ifndef INCOMPLETE_TAINTS
4282 Perl_init_os_extras(void)
4285 char *file = __FILE__;
4287 /* Initialize Win32CORE if it has been statically linked. */
4288 #ifndef PERL_IS_MINIPERL
4289 void (*pfn_init)(pTHX);
4290 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4291 ? GetModuleHandle(NULL)
4292 : w32_perldll_handle);
4293 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4294 aTHXa(PERL_GET_THX);
4298 aTHXa(PERL_GET_THX);
4301 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4302 #ifdef PERL_IS_MINIPERL
4303 newXS("Win32::GetCwd", w32_GetCwd, file);
4308 win32_signal_context(void)
4313 my_perl = PL_curinterp;
4314 PERL_SET_THX(my_perl);
4318 return PL_curinterp;
4324 win32_ctrlhandler(DWORD dwCtrlType)
4327 dTHXa(PERL_GET_SIG_CONTEXT);
4333 switch(dwCtrlType) {
4334 case CTRL_CLOSE_EVENT:
4335 /* A signal that the system sends to all processes attached to a console when
4336 the user closes the console (either by choosing the Close command from the
4337 console window's System menu, or by choosing the End Task command from the
4340 if (do_raise(aTHX_ 1)) /* SIGHUP */
4341 sig_terminate(aTHX_ 1);
4345 /* A CTRL+c signal was received */
4346 if (do_raise(aTHX_ SIGINT))
4347 sig_terminate(aTHX_ SIGINT);
4350 case CTRL_BREAK_EVENT:
4351 /* A CTRL+BREAK signal was received */
4352 if (do_raise(aTHX_ SIGBREAK))
4353 sig_terminate(aTHX_ SIGBREAK);
4356 case CTRL_LOGOFF_EVENT:
4357 /* A signal that the system sends to all console processes when a user is logging
4358 off. This signal does not indicate which user is logging off, so no
4359 assumptions can be made.
4362 case CTRL_SHUTDOWN_EVENT:
4363 /* A signal that the system sends to all console processes when the system is
4366 if (do_raise(aTHX_ SIGTERM))
4367 sig_terminate(aTHX_ SIGTERM);
4376 #ifdef SET_INVALID_PARAMETER_HANDLER
4377 # include <crtdbg.h>
4388 /* fetch Unicode version of PATH */
4390 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4392 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4394 win32_free(wide_path);
4400 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4405 /* convert to ANSI pathnames */
4406 wide_dir = wide_path;
4409 WCHAR *sep = wcschr(wide_dir, ';');
4417 /* remove quotes around pathname */
4418 if (*wide_dir == '"')
4420 wide_len = wcslen(wide_dir);
4421 if (wide_len && wide_dir[wide_len-1] == '"')
4422 wide_dir[wide_len-1] = '\0';
4424 /* append ansi_dir to ansi_path */
4425 ansi_dir = win32_ansipath(wide_dir);
4426 ansi_len = strlen(ansi_dir);
4428 size_t newlen = len + 1 + ansi_len;
4429 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4432 ansi_path[len] = ';';
4433 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4438 ansi_path = (char*)win32_malloc(5+len+1);
4441 memcpy(ansi_path, "PATH=", 5);
4442 memcpy(ansi_path+5, ansi_dir, len+1);
4445 win32_free(ansi_dir);
4450 /* Update C RTL environ array. This will only have full effect if
4451 * perl_parse() is later called with `environ` as the `env` argument.
4452 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4454 * We do have to ansify() the PATH before Perl has been fully
4455 * initialized because S_find_script() uses the PATH when perl
4456 * is being invoked with the -S option. This happens before %ENV
4457 * is initialized in S_init_postdump_symbols().
4459 * XXX Is this a bug? Should S_find_script() use the environment
4460 * XXX passed in the `env` arg to parse_perl()?
4463 /* Keep system environment in sync because S_init_postdump_symbols()
4464 * will not call mg_set() if it initializes %ENV from `environ`.
4466 SetEnvironmentVariableA("PATH", ansi_path+5);
4467 win32_free(ansi_path);
4469 win32_free(wide_path);
4473 Perl_win32_init(int *argcp, char ***argvp)
4475 #ifdef SET_INVALID_PARAMETER_HANDLER
4476 _invalid_parameter_handler oldHandler, newHandler;
4477 newHandler = my_invalid_parameter_handler;
4478 oldHandler = _set_invalid_parameter_handler(newHandler);
4479 _CrtSetReportMode(_CRT_ASSERT, 0);
4481 /* Disable floating point errors, Perl will trap the ones we
4482 * care about. VC++ RTL defaults to switching these off
4483 * already, but some RTLs don't. Since we don't
4484 * want to be at the vendor's whim on the default, we set
4485 * it explicitly here.
4487 #if !defined(__GNUC__)
4488 _control87(MCW_EM, MCW_EM);
4492 /* When the manifest resource requests Common-Controls v6 then
4493 * user32.dll no longer registers all the Windows classes used for
4494 * standard controls but leaves some of them to be registered by
4495 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4496 * it makes sure comctl32.dll gets loaded into the process and registers
4497 * the standard control classes. Without this even normal Windows APIs
4498 * like MessageBox() can fail under some versions of Windows XP.
4500 InitCommonControls();
4502 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4503 GetVersionEx(&g_osver);
4505 #ifdef WIN32_DYN_IOINFO_SIZE
4507 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4508 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4509 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4512 ioinfo_size /= IOINFO_ARRAY_ELTS;
4513 w32_ioinfo_size = ioinfo_size;
4519 #ifndef WIN32_NO_REGISTRY
4522 retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
4523 if (retval != ERROR_SUCCESS) {
4524 HKCU_Perl_hnd = NULL;
4526 retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
4527 if (retval != ERROR_SUCCESS) {
4528 HKLM_Perl_hnd = NULL;
4535 Perl_win32_term(void)
4542 #ifndef WIN32_NO_REGISTRY
4543 /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
4544 but no point of checking and we can't die() at this point */
4545 RegCloseKey(HKLM_Perl_hnd);
4546 RegCloseKey(HKCU_Perl_hnd);
4547 /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
4552 win32_get_child_IO(child_IO_table* ptbl)
4554 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4555 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4556 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4560 win32_signal(int sig, Sighandler_t subcode)
4563 if (sig < SIG_SIZE) {
4564 int save_errno = errno;
4565 Sighandler_t result;
4566 #ifdef SET_INVALID_PARAMETER_HANDLER
4567 /* Silence our invalid parameter handler since we expect to make some
4568 * calls with invalid signal numbers giving a SIG_ERR result. */
4569 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4571 result = signal(sig, subcode);
4572 #ifdef SET_INVALID_PARAMETER_HANDLER
4573 set_silent_invalid_parameter_handler(oldvalue);
4575 aTHXa(PERL_GET_THX);
4576 if (result == SIG_ERR) {
4577 result = w32_sighandler[sig];
4580 w32_sighandler[sig] = subcode;
4589 /* The PerlMessageWindowClass's WindowProc */
4591 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4593 return win32_process_message(hwnd, msg, wParam, lParam) ?
4594 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4597 /* The real message handler. Can be called with
4598 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4599 * that it processes */
4601 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4603 /* BEWARE. The context retrieved using dTHX; is the context of the
4604 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4605 * up to and including WM_CREATE. If it ever happens that you need the
4606 * 'child' context before this, then it needs to be passed into
4607 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4608 * from the lparam of CreateWindow(). It could then be stored/retrieved
4609 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4610 * the dTHX calls here. */
4611 /* XXX For now it is assumed that the overhead of the dTHX; for what
4612 * are relativley infrequent code-paths, is better than the added
4613 * complexity of getting the correct context passed into
4614 * win32_create_message_window() */
4620 case WM_USER_MESSAGE: {
4621 long child = find_pseudo_pid(aTHX_ (int)wParam);
4623 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4630 case WM_USER_KILL: {
4631 /* We use WM_USER_KILL to fake kill() with other signals */
4632 int sig = (int)wParam;
4633 if (do_raise(aTHX_ sig))
4634 sig_terminate(aTHX_ sig);
4640 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4641 if (w32_timerid && w32_timerid==(UINT)wParam) {
4642 KillTimer(w32_message_hwnd, w32_timerid);
4645 /* Now fake a call to signal handler */
4646 if (do_raise(aTHX_ 14))
4647 sig_terminate(aTHX_ 14);
4659 /* Above or other stuff may have set a signal flag, and we may not have
4660 * been called from win32_async_check() (e.g. some other GUI's message
4661 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4662 * handler that die's, and the message loop that calls here is wrapped
4663 * in an eval, then you may well end up with orphaned windows - signals
4664 * are dispatched by win32_async_check() */
4670 win32_create_message_window_class(void)
4672 /* create the window class for "message only" windows */
4676 wc.lpfnWndProc = win32_message_window_proc;
4677 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4678 wc.lpszClassName = "PerlMessageWindowClass";
4680 /* second and subsequent calls will fail, but class
4681 * will already be registered */
4686 win32_create_message_window(void)
4688 win32_create_message_window_class();
4689 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4690 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4693 #ifdef HAVE_INTERP_INTERN
4696 win32_csighandler(int sig)
4699 dTHXa(PERL_GET_SIG_CONTEXT);
4700 Perl_warn(aTHX_ "Got signal %d",sig);
4705 #if defined(__MINGW32__) && defined(__cplusplus)
4706 #define CAST_HWND__(x) (HWND__*)(x)
4708 #define CAST_HWND__(x) x
4712 Perl_sys_intern_init(pTHX)
4716 w32_perlshell_tokens = NULL;
4717 w32_perlshell_vec = (char**)NULL;
4718 w32_perlshell_items = 0;
4719 w32_fdpid = newAV();
4720 Newx(w32_children, 1, child_tab);
4721 w32_num_children = 0;
4722 # ifdef USE_ITHREADS
4724 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4725 w32_num_pseudo_children = 0;
4728 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4730 #ifdef PERL_IS_MINIPERL
4731 w32_sloppystat = TRUE;
4733 w32_sloppystat = FALSE;
4735 for (i=0; i < SIG_SIZE; i++) {
4736 w32_sighandler[i] = SIG_DFL;
4738 # ifdef MULTIPLICITY
4739 if (my_perl == PL_curinterp) {
4743 /* Force C runtime signal stuff to set its console handler */
4744 signal(SIGINT,win32_csighandler);
4745 signal(SIGBREAK,win32_csighandler);
4747 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4748 * flag. This has the side-effect of disabling Ctrl-C events in all
4749 * processes in this group.
4750 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4751 * with a NULL handler.
4753 SetConsoleCtrlHandler(NULL,FALSE);
4755 /* Push our handler on top */
4756 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4761 Perl_sys_intern_clear(pTHX)
4763 Safefree(w32_perlshell_tokens);
4764 Safefree(w32_perlshell_vec);
4765 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4766 Safefree(w32_children);
4768 KillTimer(w32_message_hwnd, w32_timerid);
4771 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4772 DestroyWindow(w32_message_hwnd);
4773 # ifdef MULTIPLICITY
4774 if (my_perl == PL_curinterp) {
4778 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4780 # ifdef USE_ITHREADS
4781 Safefree(w32_pseudo_children);
4785 # ifdef USE_ITHREADS
4788 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4790 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4792 dst->perlshell_tokens = NULL;
4793 dst->perlshell_vec = (char**)NULL;
4794 dst->perlshell_items = 0;
4795 dst->fdpid = newAV();
4796 Newxz(dst->children, 1, child_tab);
4798 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4800 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4801 dst->poll_count = 0;
4802 dst->sloppystat = src->sloppystat;
4803 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4805 # endif /* USE_ITHREADS */
4806 #endif /* HAVE_INTERP_INTERN */