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);
1695 win32_croak_not_implemented(const char * fname)
1697 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1699 Perl_croak_nocontext("%s not implemented!\n", fname);
1702 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1703 * potentially using the system's default replacement character for any
1704 * unrepresentable characters. The caller must free() the returned string. */
1706 wstr_to_str(const wchar_t* wstr)
1708 BOOL used_default = FALSE;
1709 size_t wlen = wcslen(wstr) + 1;
1710 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1711 NULL, 0, NULL, NULL);
1712 char* str = (char*)malloc(len);
1715 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1716 str, len, NULL, &used_default);
1720 /* The win32_ansipath() function takes a Unicode filename and converts it
1721 * into the current Windows codepage. If some characters cannot be mapped,
1722 * then it will convert the short name instead.
1724 * The buffer to the ansi pathname must be freed with win32_free() when it
1725 * it no longer needed.
1727 * The argument to win32_ansipath() must exist before this function is
1728 * called; otherwise there is no way to determine the short path name.
1730 * Ideas for future refinement:
1731 * - Only convert those segments of the path that are not in the current
1732 * codepage, but leave the other segments in their long form.
1733 * - If the resulting name is longer than MAX_PATH, start converting
1734 * additional path segments into short names until the full name
1735 * is shorter than MAX_PATH. Shorten the filename part last!
1738 win32_ansipath(const WCHAR *widename)
1741 BOOL use_default = FALSE;
1742 size_t widelen = wcslen(widename)+1;
1743 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1744 NULL, 0, NULL, NULL);
1745 name = (char*)win32_malloc(len);
1749 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1750 name, len, NULL, &use_default);
1752 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1754 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1757 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1759 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1760 NULL, 0, NULL, NULL);
1761 name = (char*)win32_realloc(name, len);
1764 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1765 name, len, NULL, NULL);
1766 win32_free(shortname);
1772 /* the returned string must be freed with win32_freeenvironmentstrings which is
1773 * implemented as a macro
1774 * void win32_freeenvironmentstrings(void* block)
1777 win32_getenvironmentstrings(void)
1779 LPWSTR lpWStr, lpWTmp;
1781 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1783 /* Get the process environment strings */
1784 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1785 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1786 env_len = wcslen(lpWTmp);
1787 /* calculate the size of the environment strings */
1788 wenvstrings_len += env_len + 1;
1791 /* Get the number of bytes required to store the ACP encoded string */
1792 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1793 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1794 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1798 /* Convert the string from UTF-16 encoding to ACP encoding */
1799 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1800 aenvstrings_len, NULL, NULL);
1802 FreeEnvironmentStringsW(lpWStr);
1808 win32_getenv(const char *name)
1815 needlen = GetEnvironmentVariableA(name,NULL,0);
1817 curitem = sv_2mortal(newSVpvs(""));
1819 SvGROW(curitem, needlen+1);
1820 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1822 } while (needlen >= SvLEN(curitem));
1823 SvCUR_set(curitem, needlen);
1826 last_err = GetLastError();
1827 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1828 /* It appears the variable is in the env, but the Win32 API
1829 doesn't have a canned way of getting it. So we fall back to
1830 grabbing the whole env and pulling this value out if possible */
1831 char *envv = GetEnvironmentStrings();
1835 char *end = strchr(cur,'=');
1836 if (end && end != cur) {
1838 if (strEQ(cur,name)) {
1839 curitem = sv_2mortal(newSVpv(end+1,0));
1844 cur = end + strlen(end+1)+2;
1846 else if ((len = strlen(cur)))
1849 FreeEnvironmentStrings(envv);
1851 #ifndef WIN32_NO_REGISTRY
1853 /* last ditch: allow any environment variables that begin with 'PERL'
1854 to be obtained from the registry, if found there */
1855 if (strBEGINs(name, "PERL"))
1856 (void)get_regstr(name, &curitem);
1860 if (curitem && SvCUR(curitem))
1861 return SvPVX(curitem);
1867 win32_putenv(const char *name)
1874 curitem = (char *) win32_malloc(strlen(name)+1);
1875 strcpy(curitem, name);
1876 val = strchr(curitem, '=');
1878 /* The sane way to deal with the environment.
1879 * Has these advantages over putenv() & co.:
1880 * * enables us to store a truly empty value in the
1881 * environment (like in UNIX).
1882 * * we don't have to deal with RTL globals, bugs and leaks
1883 * (specifically, see http://support.microsoft.com/kb/235601).
1885 * Why you may want to use the RTL environment handling
1886 * (previously enabled by USE_WIN32_RTL_ENV):
1887 * * environ[] and RTL functions will not reflect changes,
1888 * which might be an issue if extensions want to access
1889 * the env. via RTL. This cuts both ways, since RTL will
1890 * not see changes made by extensions that call the Win32
1891 * functions directly, either.
1895 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1898 win32_free(curitem);
1904 filetime_to_clock(PFILETIME ft)
1906 __int64 qw = ft->dwHighDateTime;
1908 qw |= ft->dwLowDateTime;
1909 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1914 win32_times(struct tms *timebuf)
1919 clock_t process_time_so_far = clock();
1920 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1922 timebuf->tms_utime = filetime_to_clock(&user);
1923 timebuf->tms_stime = filetime_to_clock(&kernel);
1924 timebuf->tms_cutime = 0;
1925 timebuf->tms_cstime = 0;
1927 /* That failed - e.g. Win95 fallback to clock() */
1928 timebuf->tms_utime = process_time_so_far;
1929 timebuf->tms_stime = 0;
1930 timebuf->tms_cutime = 0;
1931 timebuf->tms_cstime = 0;
1933 return process_time_so_far;
1936 /* fix utime() so it works on directories in NT */
1938 filetime_from_time(PFILETIME pFileTime, time_t Time)
1940 struct tm *pTM = localtime(&Time);
1941 SYSTEMTIME SystemTime;
1947 SystemTime.wYear = pTM->tm_year + 1900;
1948 SystemTime.wMonth = pTM->tm_mon + 1;
1949 SystemTime.wDay = pTM->tm_mday;
1950 SystemTime.wHour = pTM->tm_hour;
1951 SystemTime.wMinute = pTM->tm_min;
1952 SystemTime.wSecond = pTM->tm_sec;
1953 SystemTime.wMilliseconds = 0;
1955 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1956 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1960 win32_unlink(const char *filename)
1966 filename = PerlDir_mapA(filename);
1967 attrs = GetFileAttributesA(filename);
1968 if (attrs == 0xFFFFFFFF) {
1972 if (attrs & FILE_ATTRIBUTE_READONLY) {
1973 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1974 ret = unlink(filename);
1976 (void)SetFileAttributesA(filename, attrs);
1979 ret = unlink(filename);
1984 win32_utime(const char *filename, struct utimbuf *times)
1991 struct utimbuf TimeBuffer;
1994 filename = PerlDir_mapA(filename);
1995 rc = utime(filename, times);
1997 /* EACCES: path specifies directory or readonly file */
1998 if (rc == 0 || errno != EACCES)
2001 if (times == NULL) {
2002 times = &TimeBuffer;
2003 time(×->actime);
2004 times->modtime = times->actime;
2007 /* This will (and should) still fail on readonly files */
2008 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2009 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
2010 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2011 if (handle == INVALID_HANDLE_VALUE)
2014 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
2015 filetime_from_time(&ftAccess, times->actime) &&
2016 filetime_from_time(&ftWrite, times->modtime) &&
2017 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
2022 CloseHandle(handle);
2027 unsigned __int64 ft_i64;
2032 #define Const64(x) x##LL
2034 #define Const64(x) x##i64
2036 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2037 #define EPOCH_BIAS Const64(116444736000000000)
2039 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2040 * and appears to be unsupported even by glibc) */
2042 win32_gettimeofday(struct timeval *tp, void *not_used)
2046 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2047 GetSystemTimeAsFileTime(&ft.ft_val);
2049 /* seconds since epoch */
2050 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2052 /* microseconds remaining */
2053 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2059 win32_uname(struct utsname *name)
2061 struct hostent *hep;
2062 STRLEN nodemax = sizeof(name->nodename)-1;
2065 switch (g_osver.dwPlatformId) {
2066 case VER_PLATFORM_WIN32_WINDOWS:
2067 strcpy(name->sysname, "Windows");
2069 case VER_PLATFORM_WIN32_NT:
2070 strcpy(name->sysname, "Windows NT");
2072 case VER_PLATFORM_WIN32s:
2073 strcpy(name->sysname, "Win32s");
2076 strcpy(name->sysname, "Win32 Unknown");
2081 sprintf(name->release, "%d.%d",
2082 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2085 sprintf(name->version, "Build %d",
2086 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2087 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2088 if (g_osver.szCSDVersion[0]) {
2089 char *buf = name->version + strlen(name->version);
2090 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2094 hep = win32_gethostbyname("localhost");
2096 STRLEN len = strlen(hep->h_name);
2097 if (len <= nodemax) {
2098 strcpy(name->nodename, hep->h_name);
2101 strncpy(name->nodename, hep->h_name, nodemax);
2102 name->nodename[nodemax] = '\0';
2107 if (!GetComputerName(name->nodename, &sz))
2108 *name->nodename = '\0';
2111 /* machine (architecture) */
2116 GetSystemInfo(&info);
2118 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2119 procarch = info.u.s.wProcessorArchitecture;
2121 procarch = info.wProcessorArchitecture;
2124 case PROCESSOR_ARCHITECTURE_INTEL:
2125 arch = "x86"; break;
2126 case PROCESSOR_ARCHITECTURE_IA64:
2127 arch = "ia64"; break;
2128 case PROCESSOR_ARCHITECTURE_AMD64:
2129 arch = "amd64"; break;
2130 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2131 arch = "unknown"; break;
2133 sprintf(name->machine, "unknown(0x%x)", procarch);
2134 arch = name->machine;
2137 if (name->machine != arch)
2138 strcpy(name->machine, arch);
2143 /* Timing related stuff */
2146 do_raise(pTHX_ int sig)
2148 if (sig < SIG_SIZE) {
2149 Sighandler_t handler = w32_sighandler[sig];
2150 if (handler == SIG_IGN) {
2153 else if (handler != SIG_DFL) {
2158 /* Choose correct default behaviour */
2174 /* Tell caller to exit thread/process as appropriate */
2179 sig_terminate(pTHX_ int sig)
2181 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2182 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2189 win32_async_check(pTHX)
2192 HWND hwnd = w32_message_hwnd;
2194 /* Reset w32_poll_count before doing anything else, incase we dispatch
2195 * messages that end up calling back into perl */
2198 if (hwnd != INVALID_HANDLE_VALUE) {
2199 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2200 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2205 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2206 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2208 /* re-post a WM_QUIT message (we'll mark it as read later) */
2209 if(msg.message == WM_QUIT) {
2210 PostQuitMessage((int)msg.wParam);
2214 if(!CallMsgFilter(&msg, MSGF_USER))
2216 TranslateMessage(&msg);
2217 DispatchMessage(&msg);
2222 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2223 * This is necessary when we are being called by win32_msgwait() to
2224 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2225 * message over and over. An example how this can happen is when
2226 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2227 * is generating messages before the process terminated.
2229 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2231 /* Above or other stuff may have set a signal flag */
2238 /* This function will not return until the timeout has elapsed, or until
2239 * one of the handles is ready. */
2241 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2243 /* We may need several goes at this - so compute when we stop */
2245 unsigned __int64 endtime = timeout;
2246 if (timeout != INFINITE) {
2247 GetSystemTimeAsFileTime(&ticks.ft_val);
2248 ticks.ft_i64 /= 10000;
2249 endtime += ticks.ft_i64;
2251 /* This was a race condition. Do not let a non INFINITE timeout to
2252 * MsgWaitForMultipleObjects roll under 0 creating a near
2253 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2254 * user who did a CORE perl function with a non infinity timeout,
2255 * sleep for example. This is 64 to 32 truncation minefield.
2257 * This scenario can only be created if the timespan from the return of
2258 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2259 * generate the scenario, manual breakpoints in a C debugger are required,
2260 * or a context switch occurred in win32_async_check in PeekMessage, or random
2261 * messages are delivered to the *thread* message queue of the Perl thread
2262 * from another process (msctf.dll doing IPC among its instances, VS debugger
2263 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2265 while (ticks.ft_i64 <= endtime) {
2266 /* if timeout's type is lengthened, remember to split 64b timeout
2267 * into multiple non-infinity runs of MWFMO */
2268 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2269 (DWORD)(endtime - ticks.ft_i64),
2270 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2273 if (result == WAIT_TIMEOUT) {
2274 /* Ran out of time - explicit return of zero to avoid -ve if we
2275 have scheduling issues
2279 if (timeout != INFINITE) {
2280 GetSystemTimeAsFileTime(&ticks.ft_val);
2281 ticks.ft_i64 /= 10000;
2283 if (result == WAIT_OBJECT_0 + count) {
2284 /* Message has arrived - check it */
2285 (void)win32_async_check(aTHX);
2288 /* Not timeout or message - one of handles is ready */
2292 /* If we are past the end say zero */
2293 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2295 /* compute time left to wait */
2296 ticks.ft_i64 = endtime - ticks.ft_i64;
2297 /* if more ms than DWORD, then return max DWORD */
2298 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2302 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2304 /* XXX this wait emulation only knows about processes
2305 * spawned via win32_spawnvp(P_NOWAIT, ...).
2308 DWORD exitcode, waitcode;
2311 if (w32_num_pseudo_children) {
2312 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2313 timeout, &waitcode);
2314 /* Time out here if there are no other children to wait for. */
2315 if (waitcode == WAIT_TIMEOUT) {
2316 if (!w32_num_children) {
2320 else if (waitcode != WAIT_FAILED) {
2321 if (waitcode >= WAIT_ABANDONED_0
2322 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2323 i = waitcode - WAIT_ABANDONED_0;
2325 i = waitcode - WAIT_OBJECT_0;
2326 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2327 *status = (int)((exitcode & 0xff) << 8);
2328 retval = (int)w32_pseudo_child_pids[i];
2329 remove_dead_pseudo_process(i);
2336 if (!w32_num_children) {
2341 /* if a child exists, wait for it to die */
2342 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2343 if (waitcode == WAIT_TIMEOUT) {
2346 if (waitcode != WAIT_FAILED) {
2347 if (waitcode >= WAIT_ABANDONED_0
2348 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2349 i = waitcode - WAIT_ABANDONED_0;
2351 i = waitcode - WAIT_OBJECT_0;
2352 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2353 *status = (int)((exitcode & 0xff) << 8);
2354 retval = (int)w32_child_pids[i];
2355 remove_dead_process(i);
2360 errno = GetLastError();
2365 win32_waitpid(int pid, int *status, int flags)
2368 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2371 if (pid == -1) /* XXX threadid == 1 ? */
2372 return win32_internal_wait(aTHX_ status, timeout);
2375 child = find_pseudo_pid(aTHX_ -pid);
2377 HANDLE hThread = w32_pseudo_child_handles[child];
2379 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2380 if (waitcode == WAIT_TIMEOUT) {
2383 else if (waitcode == WAIT_OBJECT_0) {
2384 if (GetExitCodeThread(hThread, &waitcode)) {
2385 *status = (int)((waitcode & 0xff) << 8);
2386 retval = (int)w32_pseudo_child_pids[child];
2387 remove_dead_pseudo_process(child);
2399 child = find_pid(aTHX_ pid);
2401 hProcess = w32_child_handles[child];
2402 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2403 if (waitcode == WAIT_TIMEOUT) {
2406 else if (waitcode == WAIT_OBJECT_0) {
2407 if (GetExitCodeProcess(hProcess, &waitcode)) {
2408 *status = (int)((waitcode & 0xff) << 8);
2409 retval = (int)w32_child_pids[child];
2410 remove_dead_process(child);
2418 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2420 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2421 if (waitcode == WAIT_TIMEOUT) {
2422 CloseHandle(hProcess);
2425 else if (waitcode == WAIT_OBJECT_0) {
2426 if (GetExitCodeProcess(hProcess, &waitcode)) {
2427 *status = (int)((waitcode & 0xff) << 8);
2428 CloseHandle(hProcess);
2432 CloseHandle(hProcess);
2438 return retval >= 0 ? pid : retval;
2442 win32_wait(int *status)
2445 return win32_internal_wait(aTHX_ status, INFINITE);
2448 DllExport unsigned int
2449 win32_sleep(unsigned int t)
2452 /* Win32 times are in ms so *1000 in and /1000 out */
2453 if (t > UINT_MAX / 1000) {
2454 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2455 "sleep(%lu) too large", t);
2457 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2464 win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
2468 DllExport unsigned int
2469 win32_alarm(unsigned int sec)
2472 * the 'obvious' implentation is SetTimer() with a callback
2473 * which does whatever receiving SIGALRM would do
2474 * we cannot use SIGALRM even via raise() as it is not
2475 * one of the supported codes in <signal.h>
2479 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2480 w32_message_hwnd = win32_create_message_window();
2483 if (w32_message_hwnd == NULL)
2484 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2487 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2492 KillTimer(w32_message_hwnd, w32_timerid);
2499 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2502 win32_crypt(const char *txt, const char *salt)
2505 return des_fcrypt(txt, salt, w32_crypt_buffer);
2508 /* simulate flock by locking a range on the file */
2510 #define LK_LEN 0xffff0000
2513 win32_flock(int fd, int oper)
2519 fh = (HANDLE)_get_osfhandle(fd);
2520 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2523 memset(&o, 0, sizeof(o));
2526 case LOCK_SH: /* shared lock */
2527 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2530 case LOCK_EX: /* exclusive lock */
2531 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2534 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2535 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2538 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2539 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2543 case LOCK_UN: /* unlock lock */
2544 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2547 default: /* unknown */
2552 if (GetLastError() == ERROR_LOCK_VIOLATION)
2553 errno = EWOULDBLOCK;
2562 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2564 /* Get the errno value corresponding to the given err. This function is not
2565 * intended to handle conversion of general GetLastError() codes. It only exists
2566 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2567 * used to be assigned to errno/$! in earlier versions of perl; this function is
2568 * used to catch any old Perl code which is still trying to assign such values
2569 * to $! and convert them to errno values instead.
2572 win32_get_errno(int err)
2574 return convert_wsa_error_to_errno(err);
2578 * redirected io subsystem for all XS modules
2591 return (&(_environ));
2594 /* the rest are the remapped stdio routines */
2614 win32_ferror(FILE *fp)
2616 return (ferror(fp));
2621 win32_feof(FILE *fp)
2626 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2627 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2631 * Since the errors returned by the socket error function
2632 * WSAGetLastError() are not known by the library routine strerror
2633 * we have to roll our own to cover the case of socket errors
2634 * that could not be converted to regular errno values by
2635 * get_last_socket_error() in win32/win32sck.c.
2639 win32_strerror(int e)
2641 #if !defined __MINGW32__ /* compiler intolerance */
2642 extern int sys_nerr;
2645 if (e < 0 || e > sys_nerr) {
2649 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2650 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2651 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2652 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2653 * We must therefore still roll our own messages for these codes, and
2654 * additionally map them to corresponding Windows (sockets) error codes
2655 * first to avoid getting the wrong system message.
2657 else if (e >= EADDRINUSE && e <= EWOULDBLOCK) {
2658 e = convert_errno_to_wsa_error(e);
2662 aTHXa(PERL_GET_THX);
2663 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2664 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2665 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2668 strcpy(w32_strerror_buffer, "Unknown Error");
2670 return w32_strerror_buffer;
2674 #define strerror win32_strerror
2678 win32_str_os_error(void *sv, DWORD dwErr)
2682 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2683 |FORMAT_MESSAGE_IGNORE_INSERTS
2684 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2685 dwErr, 0, (char *)&sMsg, 1, NULL);
2686 /* strip trailing whitespace and period */
2689 --dwLen; /* dwLen doesn't include trailing null */
2690 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2691 if ('.' != sMsg[dwLen])
2696 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2698 dwLen = sprintf(sMsg,
2699 "Unknown error #0x%lX (lookup 0x%lX)",
2700 dwErr, GetLastError());
2704 sv_setpvn((SV*)sv, sMsg, dwLen);
2710 win32_fprintf(FILE *fp, const char *format, ...)
2713 va_start(marker, format); /* Initialize variable arguments. */
2715 return (vfprintf(fp, format, marker));
2719 win32_printf(const char *format, ...)
2722 va_start(marker, format); /* Initialize variable arguments. */
2724 return (vprintf(format, marker));
2728 win32_vfprintf(FILE *fp, const char *format, va_list args)
2730 return (vfprintf(fp, format, args));
2734 win32_vprintf(const char *format, va_list args)
2736 return (vprintf(format, args));
2740 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2742 return fread(buf, size, count, fp);
2746 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2748 return fwrite(buf, size, count, fp);
2751 #define MODE_SIZE 10
2754 win32_fopen(const char *filename, const char *mode)
2762 if (stricmp(filename, "/dev/null")==0)
2765 aTHXa(PERL_GET_THX);
2766 f = fopen(PerlDir_mapA(filename), mode);
2767 /* avoid buffering headaches for child processes */
2768 if (f && *mode == 'a')
2769 win32_fseek(f, 0, SEEK_END);
2774 win32_fdopen(int handle, const char *mode)
2777 f = fdopen(handle, (char *) mode);
2778 /* avoid buffering headaches for child processes */
2779 if (f && *mode == 'a')
2780 win32_fseek(f, 0, SEEK_END);
2785 win32_freopen(const char *path, const char *mode, FILE *stream)
2788 if (stricmp(path, "/dev/null")==0)
2791 aTHXa(PERL_GET_THX);
2792 return freopen(PerlDir_mapA(path), mode, stream);
2796 win32_fclose(FILE *pf)
2798 #ifdef WIN32_NO_SOCKETS
2801 return my_fclose(pf); /* defined in win32sck.c */
2806 win32_fputs(const char *s,FILE *pf)
2808 return fputs(s, pf);
2812 win32_fputc(int c,FILE *pf)
2818 win32_ungetc(int c,FILE *pf)
2820 return ungetc(c,pf);
2824 win32_getc(FILE *pf)
2830 win32_fileno(FILE *pf)
2836 win32_clearerr(FILE *pf)
2843 win32_fflush(FILE *pf)
2849 win32_ftell(FILE *pf)
2851 #if defined(WIN64) || defined(USE_LARGE_FILES)
2853 if (fgetpos(pf, &pos))
2862 win32_fseek(FILE *pf, Off_t offset,int origin)
2864 #if defined(WIN64) || defined(USE_LARGE_FILES)
2868 if (fgetpos(pf, &pos))
2873 fseek(pf, 0, SEEK_END);
2874 pos = _telli64(fileno(pf));
2883 return fsetpos(pf, &offset);
2885 return fseek(pf, (long)offset, origin);
2890 win32_fgetpos(FILE *pf,fpos_t *p)
2892 return fgetpos(pf, p);
2896 win32_fsetpos(FILE *pf,const fpos_t *p)
2898 return fsetpos(pf, p);
2902 win32_rewind(FILE *pf)
2911 return win32_tmpfd_mode(0);
2915 win32_tmpfd_mode(int mode)
2917 char prefix[MAX_PATH+1];
2918 char filename[MAX_PATH+1];
2919 DWORD len = GetTempPath(MAX_PATH, prefix);
2920 mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
2922 if (len && len < MAX_PATH) {
2923 if (GetTempFileName(prefix, "plx", 0, filename)) {
2924 HANDLE fh = CreateFile(filename,
2925 DELETE | GENERIC_READ | GENERIC_WRITE,
2929 FILE_ATTRIBUTE_NORMAL
2930 | FILE_FLAG_DELETE_ON_CLOSE,
2932 if (fh != INVALID_HANDLE_VALUE) {
2933 int fd = win32_open_osfhandle((intptr_t)fh, mode);
2936 DEBUG_p(PerlIO_printf(Perl_debug_log,
2937 "Created tmpfile=%s\n",filename));
2949 int fd = win32_tmpfd();
2951 return win32_fdopen(fd, "w+b");
2963 win32_fstat(int fd, Stat_t *sbufptr)
2965 #if defined(WIN64) || defined(USE_LARGE_FILES)
2966 return _fstati64(fd, sbufptr);
2968 return fstat(fd, sbufptr);
2973 win32_pipe(int *pfd, unsigned int size, int mode)
2975 return _pipe(pfd, size, mode);
2979 win32_popenlist(const char *mode, IV narg, SV **args)
2983 return do_popen(mode, NULL, narg, args);
2987 do_popen(const char *mode, const char *command, IV narg, SV **args) {
2996 const char **args_pvs = NULL;
2998 /* establish which ends read and write */
2999 if (strchr(mode,'w')) {
3000 stdfd = 0; /* stdin */
3003 nhandle = STD_INPUT_HANDLE;
3005 else if (strchr(mode,'r')) {
3006 stdfd = 1; /* stdout */
3009 nhandle = STD_OUTPUT_HANDLE;
3014 /* set the correct mode */
3015 if (strchr(mode,'b'))
3017 else if (strchr(mode,'t'))
3020 ourmode = _fmode & (O_TEXT | O_BINARY);
3022 /* the child doesn't inherit handles */
3023 ourmode |= O_NOINHERIT;
3025 if (win32_pipe(p, 512, ourmode) == -1)
3028 /* Previously this code redirected stdin/out temporarily so the
3029 child process inherited those handles, this caused race
3030 conditions when another thread was writing/reading those
3033 To avoid that we just feed the handles to CreateProcess() so
3034 the handles are redirected only in the child.
3036 handles[child] = p[child];
3037 handles[parent] = -1;
3040 /* CreateProcess() requires inheritable handles */
3041 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3042 HANDLE_FLAG_INHERIT)) {
3046 /* start the child */
3051 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3057 const char *exe_name;
3059 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3060 SAVEFREEPV(args_pvs);
3061 for (i = 0; i < narg; ++i)
3062 args_pvs[i] = SvPV_nolen(args[i]);
3064 exe_name = qualified_path(args_pvs[0], TRUE);
3066 /* let CreateProcess() try to find it instead */
3067 exe_name = args_pvs[0];
3069 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3074 win32_close(p[child]);
3076 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3078 /* set process id so that it can be returned by perl's open() */
3079 PL_forkprocess = childpid;
3082 /* we have an fd, return a file stream */
3083 return (PerlIO_fdopen(p[parent], (char *)mode));
3086 /* we don't need to check for errors here */
3094 * a popen() clone that respects PERL5SHELL
3096 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3100 win32_popen(const char *command, const char *mode)
3102 #ifdef USE_RTL_POPEN
3103 return _popen(command, mode);
3105 return do_popen(mode, command, 0, NULL);
3106 #endif /* USE_RTL_POPEN */
3114 win32_pclose(PerlIO *pf)
3116 #ifdef USE_RTL_POPEN
3120 int childpid, status;
3123 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3126 childpid = SvIVX(sv);
3142 if (win32_waitpid(childpid, &status, 0) == -1)
3147 #endif /* USE_RTL_POPEN */
3151 win32_link(const char *oldname, const char *newname)
3154 WCHAR wOldName[MAX_PATH+1];
3155 WCHAR wNewName[MAX_PATH+1];
3157 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3158 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3159 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3160 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3164 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3165 both permissions errors and if the source is a directory, while
3166 POSIX wants EACCES and EPERM respectively.
3168 Determined by experimentation on Windows 7 x64 SP1, since MS
3169 don't document what error codes are returned.
3171 switch (GetLastError()) {
3172 case ERROR_BAD_NET_NAME:
3173 case ERROR_BAD_NETPATH:
3174 case ERROR_BAD_PATHNAME:
3175 case ERROR_FILE_NOT_FOUND:
3176 case ERROR_FILENAME_EXCED_RANGE:
3177 case ERROR_INVALID_DRIVE:
3178 case ERROR_PATH_NOT_FOUND:
3181 case ERROR_ALREADY_EXISTS:
3184 case ERROR_ACCESS_DENIED:
3187 case ERROR_NOT_SAME_DEVICE:
3190 case ERROR_DISK_FULL:
3193 case ERROR_NOT_ENOUGH_QUOTA:
3197 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3205 win32_rename(const char *oname, const char *newname)
3207 char szOldName[MAX_PATH+1];
3209 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3212 if (stricmp(newname, oname))
3213 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3214 strcpy(szOldName, PerlDir_mapA(oname));
3216 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3218 DWORD err = GetLastError();
3220 case ERROR_BAD_NET_NAME:
3221 case ERROR_BAD_NETPATH:
3222 case ERROR_BAD_PATHNAME:
3223 case ERROR_FILE_NOT_FOUND:
3224 case ERROR_FILENAME_EXCED_RANGE:
3225 case ERROR_INVALID_DRIVE:
3226 case ERROR_NO_MORE_FILES:
3227 case ERROR_PATH_NOT_FOUND:
3230 case ERROR_DISK_FULL:
3233 case ERROR_NOT_ENOUGH_QUOTA:
3246 win32_setmode(int fd, int mode)
3248 return setmode(fd, mode);
3252 win32_chsize(int fd, Off_t size)
3254 #if defined(WIN64) || defined(USE_LARGE_FILES)
3256 Off_t cur, end, extend;
3258 cur = win32_tell(fd);
3261 end = win32_lseek(fd, 0, SEEK_END);
3264 extend = size - end;
3268 else if (extend > 0) {
3269 /* must grow the file, padding with nulls */
3271 int oldmode = win32_setmode(fd, O_BINARY);
3273 memset(b, '\0', sizeof(b));
3275 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3276 count = win32_write(fd, b, count);
3277 if ((int)count < 0) {
3281 } while ((extend -= count) > 0);
3282 win32_setmode(fd, oldmode);
3285 /* shrink the file */
3286 win32_lseek(fd, size, SEEK_SET);
3287 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3292 win32_lseek(fd, cur, SEEK_SET);
3295 return chsize(fd, (long)size);
3300 win32_lseek(int fd, Off_t offset, int origin)
3302 #if defined(WIN64) || defined(USE_LARGE_FILES)
3303 return _lseeki64(fd, offset, origin);
3305 return lseek(fd, (long)offset, origin);
3312 #if defined(WIN64) || defined(USE_LARGE_FILES)
3313 return _telli64(fd);
3320 win32_open(const char *path, int flag, ...)
3327 pmode = va_arg(ap, int);
3330 if (stricmp(path, "/dev/null")==0)
3333 aTHXa(PERL_GET_THX);
3334 return open(PerlDir_mapA(path), flag, pmode);
3337 /* close() that understands socket */
3338 extern int my_close(int); /* in win32sck.c */
3343 #ifdef WIN32_NO_SOCKETS
3346 return my_close(fd);
3357 win32_isatty(int fd)
3359 /* The Microsoft isatty() function returns true for *all*
3360 * character mode devices, including "nul". Our implementation
3361 * should only return true if the handle has a console buffer.
3364 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3365 if (fh == (HANDLE)-1) {
3366 /* errno is already set to EBADF */
3370 if (GetConsoleMode(fh, &mode))
3384 win32_dup2(int fd1,int fd2)
3386 return dup2(fd1,fd2);
3390 win32_read(int fd, void *buf, unsigned int cnt)
3392 return read(fd, buf, cnt);
3396 win32_write(int fd, const void *buf, unsigned int cnt)
3398 return write(fd, buf, cnt);
3402 win32_mkdir(const char *dir, int mode)
3405 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3409 win32_rmdir(const char *dir)
3412 return rmdir(PerlDir_mapA(dir));
3416 win32_chdir(const char *dir)
3418 if (!dir || !*dir) {
3426 win32_access(const char *path, int mode)
3429 return access(PerlDir_mapA(path), mode);
3433 win32_chmod(const char *path, int mode)
3436 return chmod(PerlDir_mapA(path), mode);
3441 create_command_line(char *cname, STRLEN clen, const char * const *args)
3448 bool bat_file = FALSE;
3449 bool cmd_shell = FALSE;
3450 bool dumb_shell = FALSE;
3451 bool extra_quotes = FALSE;
3452 bool quote_next = FALSE;
3455 cname = (char*)args[0];
3457 /* The NT cmd.exe shell has the following peculiarity that needs to be
3458 * worked around. It strips a leading and trailing dquote when any
3459 * of the following is true:
3460 * 1. the /S switch was used
3461 * 2. there are more than two dquotes
3462 * 3. there is a special character from this set: &<>()@^|
3463 * 4. no whitespace characters within the two dquotes
3464 * 5. string between two dquotes isn't an executable file
3465 * To work around this, we always add a leading and trailing dquote
3466 * to the string, if the first argument is either "cmd.exe" or "cmd",
3467 * and there were at least two or more arguments passed to cmd.exe
3468 * (not including switches).
3469 * XXX the above rules (from "cmd /?") don't seem to be applied
3470 * always, making for the convolutions below :-(
3474 clen = strlen(cname);
3477 && (stricmp(&cname[clen-4], ".bat") == 0
3478 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3484 char *exe = strrchr(cname, '/');
3485 char *exe2 = strrchr(cname, '\\');
3492 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3496 else if (stricmp(exe, "command.com") == 0
3497 || stricmp(exe, "command") == 0)
3504 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3505 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3506 STRLEN curlen = strlen(arg);
3507 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3508 len += 2; /* assume quoting needed (worst case) */
3510 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3512 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3515 Newx(cmd, len, char);
3520 extra_quotes = TRUE;
3523 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3525 STRLEN curlen = strlen(arg);
3527 /* we want to protect empty arguments and ones with spaces with
3528 * dquotes, but only if they aren't already there */
3533 else if (quote_next) {
3534 /* see if it really is multiple arguments pretending to
3535 * be one and force a set of quotes around it */
3536 if (*find_next_space(arg))
3539 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3541 while (i < curlen) {
3542 if (isSPACE(arg[i])) {
3545 else if (arg[i] == '"') {
3569 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3570 && stricmp(arg+curlen-2, "/c") == 0)
3572 /* is there a next argument? */
3573 if (args[index+1]) {
3574 /* are there two or more next arguments? */
3575 if (args[index+2]) {
3577 extra_quotes = TRUE;
3580 /* single argument, force quoting if it has spaces */
3595 static const char *exe_extensions[] =
3597 ".exe", /* this must be first */
3603 qualified_path(const char *cmd, bool other_exts)
3606 char *fullcmd, *curfullcmd;
3612 fullcmd = (char*)cmd;
3614 if (*fullcmd == '/' || *fullcmd == '\\')
3623 pathstr = PerlEnv_getenv("PATH");
3625 /* worst case: PATH is a single directory; we need additional space
3626 * to append "/", ".exe" and trailing "\0" */
3627 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3628 curfullcmd = fullcmd;
3633 /* start by appending the name to the current prefix */
3634 strcpy(curfullcmd, cmd);
3635 curfullcmd += cmdlen;
3637 /* if it doesn't end with '.', or has no extension, try adding
3638 * a trailing .exe first */
3639 if (cmd[cmdlen-1] != '.'
3640 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3643 /* first extension is .exe */
3644 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3645 for (i = 0; i < ext_limit; ++i) {
3646 strcpy(curfullcmd, exe_extensions[i]);
3647 res = GetFileAttributes(fullcmd);
3648 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3655 /* that failed, try the bare name */
3656 res = GetFileAttributes(fullcmd);
3657 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3660 /* quit if no other path exists, or if cmd already has path */
3661 if (!pathstr || !*pathstr || has_slash)
3664 /* skip leading semis */
3665 while (*pathstr == ';')
3668 /* build a new prefix from scratch */
3669 curfullcmd = fullcmd;
3670 while (*pathstr && *pathstr != ';') {
3671 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3672 pathstr++; /* skip initial '"' */
3673 while (*pathstr && *pathstr != '"') {
3674 *curfullcmd++ = *pathstr++;
3677 pathstr++; /* skip trailing '"' */
3680 *curfullcmd++ = *pathstr++;
3684 pathstr++; /* skip trailing semi */
3685 if (curfullcmd > fullcmd /* append a dir separator */
3686 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3688 *curfullcmd++ = '\\';
3696 /* The following are just place holders.
3697 * Some hosts may provide and environment that the OS is
3698 * not tracking, therefore, these host must provide that
3699 * environment and the current directory to CreateProcess
3703 win32_get_childenv(void)
3709 win32_free_childenv(void* d)
3714 win32_clearenv(void)
3716 char *envv = GetEnvironmentStrings();
3720 char *end = strchr(cur,'=');
3721 if (end && end != cur) {
3723 SetEnvironmentVariable(cur, NULL);
3725 cur = end + strlen(end+1)+2;
3727 else if ((len = strlen(cur)))
3730 FreeEnvironmentStrings(envv);
3734 win32_get_childdir(void)
3737 char szfilename[MAX_PATH+1];
3739 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3740 Newx(ptr, strlen(szfilename)+1, char);
3741 strcpy(ptr, szfilename);
3746 win32_free_childdir(char* d)
3752 /* XXX this needs to be made more compatible with the spawnvp()
3753 * provided by the various RTLs. In particular, searching for
3754 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3755 * This doesn't significantly affect perl itself, because we
3756 * always invoke things using PERL5SHELL if a direct attempt to
3757 * spawn the executable fails.
3759 * XXX splitting and rejoining the commandline between do_aspawn()
3760 * and win32_spawnvp() could also be avoided.
3764 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3766 #ifdef USE_RTL_SPAWNVP
3767 return _spawnvp(mode, cmdname, (char * const *)argv);
3769 return do_spawnvp_handles(mode, cmdname, argv, NULL);
3774 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3775 const int *handles) {
3781 STARTUPINFO StartupInfo;
3782 PROCESS_INFORMATION ProcessInformation;
3785 char *fullcmd = NULL;
3786 char *cname = (char *)cmdname;
3790 clen = strlen(cname);
3791 /* if command name contains dquotes, must remove them */
3792 if (strchr(cname, '"')) {
3794 Newx(cname,clen+1,char);
3807 cmd = create_command_line(cname, clen, argv);
3809 aTHXa(PERL_GET_THX);
3810 env = PerlEnv_get_childenv();
3811 dir = PerlEnv_get_childdir();
3814 case P_NOWAIT: /* asynch + remember result */
3815 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3820 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3823 create |= CREATE_NEW_PROCESS_GROUP;
3826 case P_WAIT: /* synchronous execution */
3828 default: /* invalid mode */
3834 memset(&StartupInfo,0,sizeof(StartupInfo));
3835 StartupInfo.cb = sizeof(StartupInfo);
3836 memset(&tbl,0,sizeof(tbl));
3837 PerlEnv_get_child_IO(&tbl);
3838 StartupInfo.dwFlags = tbl.dwFlags;
3839 StartupInfo.dwX = tbl.dwX;
3840 StartupInfo.dwY = tbl.dwY;
3841 StartupInfo.dwXSize = tbl.dwXSize;
3842 StartupInfo.dwYSize = tbl.dwYSize;
3843 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3844 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3845 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3846 StartupInfo.wShowWindow = tbl.wShowWindow;
3847 StartupInfo.hStdInput = handles && handles[0] != -1 ?
3848 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3849 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
3850 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3851 StartupInfo.hStdError = handles && handles[2] != -1 ?
3852 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3853 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3854 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3855 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3857 create |= CREATE_NEW_CONSOLE;
3860 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3862 if (w32_use_showwindow) {
3863 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3864 StartupInfo.wShowWindow = w32_showwindow;
3867 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3870 if (!CreateProcess(cname, /* search PATH to find executable */
3871 cmd, /* executable, and its arguments */
3872 NULL, /* process attributes */
3873 NULL, /* thread attributes */
3874 TRUE, /* inherit handles */
3875 create, /* creation flags */
3876 (LPVOID)env, /* inherit environment */
3877 dir, /* inherit cwd */
3879 &ProcessInformation))
3881 /* initial NULL argument to CreateProcess() does a PATH
3882 * search, but it always first looks in the directory
3883 * where the current process was started, which behavior
3884 * is undesirable for backward compatibility. So we
3885 * jump through our own hoops by picking out the path
3886 * we really want it to use. */
3888 fullcmd = qualified_path(cname, FALSE);
3890 if (cname != cmdname)
3893 DEBUG_p(PerlIO_printf(Perl_debug_log,
3894 "Retrying [%s] with same args\n",
3904 if (mode == P_NOWAIT) {
3905 /* asynchronous spawn -- store handle, return PID */
3906 ret = (int)ProcessInformation.dwProcessId;
3908 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3909 w32_child_pids[w32_num_children] = (DWORD)ret;
3914 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3915 /* FIXME: if msgwait returned due to message perhaps forward the
3916 "signal" to the process
3918 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3920 CloseHandle(ProcessInformation.hProcess);
3923 CloseHandle(ProcessInformation.hThread);
3926 PerlEnv_free_childenv(env);
3927 PerlEnv_free_childdir(dir);
3929 if (cname != cmdname)
3935 win32_execv(const char *cmdname, const char *const *argv)
3939 /* if this is a pseudo-forked child, we just want to spawn
3940 * the new program, and return */
3942 return _spawnv(P_WAIT, cmdname, argv);
3944 return _execv(cmdname, argv);
3948 win32_execvp(const char *cmdname, const char *const *argv)
3952 /* if this is a pseudo-forked child, we just want to spawn
3953 * the new program, and return */
3954 if (w32_pseudo_id) {
3955 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3964 return _execvp(cmdname, argv);
3968 win32_perror(const char *str)
3974 win32_setbuf(FILE *pf, char *buf)
3980 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3982 return setvbuf(pf, buf, type, size);
3986 win32_flushall(void)
3992 win32_fcloseall(void)
3998 win32_fgets(char *s, int n, FILE *pf)
4000 return fgets(s, n, pf);
4010 win32_fgetc(FILE *pf)
4016 win32_putc(int c, FILE *pf)
4022 win32_puts(const char *s)
4034 win32_putchar(int c)
4041 #ifndef USE_PERL_SBRK
4043 static char *committed = NULL; /* XXX threadead */
4044 static char *base = NULL; /* XXX threadead */
4045 static char *reserved = NULL; /* XXX threadead */
4046 static char *brk = NULL; /* XXX threadead */
4047 static DWORD pagesize = 0; /* XXX threadead */
4050 sbrk(ptrdiff_t need)
4055 GetSystemInfo(&info);
4056 /* Pretend page size is larger so we don't perpetually
4057 * call the OS to commit just one page ...
4059 pagesize = info.dwPageSize << 3;
4061 if (brk+need >= reserved)
4063 DWORD size = brk+need-reserved;
4065 char *prev_committed = NULL;
4066 if (committed && reserved && committed < reserved)
4068 /* Commit last of previous chunk cannot span allocations */
4069 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4072 /* Remember where we committed from in case we want to decommit later */
4073 prev_committed = committed;
4074 committed = reserved;
4077 /* Reserve some (more) space
4078 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4079 * this is only address space not memory...
4080 * Note this is a little sneaky, 1st call passes NULL as reserved
4081 * so lets system choose where we start, subsequent calls pass
4082 * the old end address so ask for a contiguous block
4085 if (size < 64*1024*1024)
4086 size = 64*1024*1024;
4087 size = ((size + pagesize - 1) / pagesize) * pagesize;
4088 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4091 reserved = addr+size;
4101 /* The existing block could not be extended far enough, so decommit
4102 * anything that was just committed above and start anew */
4105 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4108 reserved = base = committed = brk = NULL;
4119 if (brk > committed)
4121 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4123 if (committed+size > reserved)
4124 size = reserved-committed;
4125 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4138 win32_malloc(size_t size)
4140 return malloc(size);
4144 win32_calloc(size_t numitems, size_t size)
4146 return calloc(numitems,size);
4150 win32_realloc(void *block, size_t size)
4152 return realloc(block,size);
4156 win32_free(void *block)
4163 win32_open_osfhandle(intptr_t handle, int flags)
4165 return _open_osfhandle(handle, flags);
4169 win32_get_osfhandle(int fd)
4171 return (intptr_t)_get_osfhandle(fd);
4175 win32_fdupopen(FILE *pf)
4180 int fileno = win32_dup(win32_fileno(pf));
4182 /* open the file in the same mode */
4183 if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
4187 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
4191 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
4197 /* it appears that the binmode is attached to the
4198 * file descriptor so binmode files will be handled
4201 pfdup = win32_fdopen(fileno, mode);
4203 /* move the file pointer to the same position */
4204 if (!fgetpos(pf, &pos)) {
4205 fsetpos(pfdup, &pos);
4211 win32_dynaload(const char* filename)
4214 char buf[MAX_PATH+1];
4217 /* LoadLibrary() doesn't recognize forward slashes correctly,
4218 * so turn 'em back. */
4219 first = strchr(filename, '/');
4221 STRLEN len = strlen(filename);
4222 if (len <= MAX_PATH) {
4223 strcpy(buf, filename);
4224 filename = &buf[first - filename];
4226 if (*filename == '/')
4227 *(char*)filename = '\\';
4233 aTHXa(PERL_GET_THX);
4234 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4237 XS(w32_SetChildShowWindow)
4240 BOOL use_showwindow = w32_use_showwindow;
4241 /* use "unsigned short" because Perl has redefined "WORD" */
4242 unsigned short showwindow = w32_showwindow;
4245 croak_xs_usage(cv, "[showwindow]");
4247 if (items == 0 || !SvOK(ST(0)))
4248 w32_use_showwindow = FALSE;
4250 w32_use_showwindow = TRUE;
4251 w32_showwindow = (unsigned short)SvIV(ST(0));
4256 ST(0) = sv_2mortal(newSViv(showwindow));
4258 ST(0) = &PL_sv_undef;
4263 #ifdef PERL_IS_MINIPERL
4264 /* shelling out is much slower, full perl uses Win32.pm */
4268 /* Make the host for current directory */
4269 char* ptr = PerlEnv_get_childdir();
4272 * then it worked, set PV valid,
4273 * else return 'undef'
4276 SV *sv = sv_newmortal();
4278 PerlEnv_free_childdir(ptr);
4280 #ifndef INCOMPLETE_TAINTS
4292 Perl_init_os_extras(void)
4295 char *file = __FILE__;
4297 /* Initialize Win32CORE if it has been statically linked. */
4298 #ifndef PERL_IS_MINIPERL
4299 void (*pfn_init)(pTHX);
4300 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4301 ? GetModuleHandle(NULL)
4302 : w32_perldll_handle);
4303 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4304 aTHXa(PERL_GET_THX);
4308 aTHXa(PERL_GET_THX);
4311 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4312 #ifdef PERL_IS_MINIPERL
4313 newXS("Win32::GetCwd", w32_GetCwd, file);
4318 win32_signal_context(void)
4323 my_perl = PL_curinterp;
4324 PERL_SET_THX(my_perl);
4328 return PL_curinterp;
4334 win32_ctrlhandler(DWORD dwCtrlType)
4337 dTHXa(PERL_GET_SIG_CONTEXT);
4343 switch(dwCtrlType) {
4344 case CTRL_CLOSE_EVENT:
4345 /* A signal that the system sends to all processes attached to a console when
4346 the user closes the console (either by choosing the Close command from the
4347 console window's System menu, or by choosing the End Task command from the
4350 if (do_raise(aTHX_ 1)) /* SIGHUP */
4351 sig_terminate(aTHX_ 1);
4355 /* A CTRL+c signal was received */
4356 if (do_raise(aTHX_ SIGINT))
4357 sig_terminate(aTHX_ SIGINT);
4360 case CTRL_BREAK_EVENT:
4361 /* A CTRL+BREAK signal was received */
4362 if (do_raise(aTHX_ SIGBREAK))
4363 sig_terminate(aTHX_ SIGBREAK);
4366 case CTRL_LOGOFF_EVENT:
4367 /* A signal that the system sends to all console processes when a user is logging
4368 off. This signal does not indicate which user is logging off, so no
4369 assumptions can be made.
4372 case CTRL_SHUTDOWN_EVENT:
4373 /* A signal that the system sends to all console processes when the system is
4376 if (do_raise(aTHX_ SIGTERM))
4377 sig_terminate(aTHX_ SIGTERM);
4386 #ifdef SET_INVALID_PARAMETER_HANDLER
4387 # include <crtdbg.h>
4398 /* fetch Unicode version of PATH */
4400 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4402 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4404 win32_free(wide_path);
4410 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4415 /* convert to ANSI pathnames */
4416 wide_dir = wide_path;
4419 WCHAR *sep = wcschr(wide_dir, ';');
4427 /* remove quotes around pathname */
4428 if (*wide_dir == '"')
4430 wide_len = wcslen(wide_dir);
4431 if (wide_len && wide_dir[wide_len-1] == '"')
4432 wide_dir[wide_len-1] = '\0';
4434 /* append ansi_dir to ansi_path */
4435 ansi_dir = win32_ansipath(wide_dir);
4436 ansi_len = strlen(ansi_dir);
4438 size_t newlen = len + 1 + ansi_len;
4439 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4442 ansi_path[len] = ';';
4443 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4448 ansi_path = (char*)win32_malloc(5+len+1);
4451 memcpy(ansi_path, "PATH=", 5);
4452 memcpy(ansi_path+5, ansi_dir, len+1);
4455 win32_free(ansi_dir);
4460 /* Update C RTL environ array. This will only have full effect if
4461 * perl_parse() is later called with `environ` as the `env` argument.
4462 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4464 * We do have to ansify() the PATH before Perl has been fully
4465 * initialized because S_find_script() uses the PATH when perl
4466 * is being invoked with the -S option. This happens before %ENV
4467 * is initialized in S_init_postdump_symbols().
4469 * XXX Is this a bug? Should S_find_script() use the environment
4470 * XXX passed in the `env` arg to parse_perl()?
4473 /* Keep system environment in sync because S_init_postdump_symbols()
4474 * will not call mg_set() if it initializes %ENV from `environ`.
4476 SetEnvironmentVariableA("PATH", ansi_path+5);
4477 win32_free(ansi_path);
4479 win32_free(wide_path);
4483 Perl_win32_init(int *argcp, char ***argvp)
4485 #ifdef SET_INVALID_PARAMETER_HANDLER
4486 _invalid_parameter_handler oldHandler, newHandler;
4487 newHandler = my_invalid_parameter_handler;
4488 oldHandler = _set_invalid_parameter_handler(newHandler);
4489 _CrtSetReportMode(_CRT_ASSERT, 0);
4491 /* Disable floating point errors, Perl will trap the ones we
4492 * care about. VC++ RTL defaults to switching these off
4493 * already, but some RTLs don't. Since we don't
4494 * want to be at the vendor's whim on the default, we set
4495 * it explicitly here.
4497 #if !defined(__GNUC__)
4498 _control87(MCW_EM, MCW_EM);
4502 /* When the manifest resource requests Common-Controls v6 then
4503 * user32.dll no longer registers all the Windows classes used for
4504 * standard controls but leaves some of them to be registered by
4505 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4506 * it makes sure comctl32.dll gets loaded into the process and registers
4507 * the standard control classes. Without this even normal Windows APIs
4508 * like MessageBox() can fail under some versions of Windows XP.
4510 InitCommonControls();
4512 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4513 GetVersionEx(&g_osver);
4515 #ifdef WIN32_DYN_IOINFO_SIZE
4517 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4518 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4519 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4522 ioinfo_size /= IOINFO_ARRAY_ELTS;
4523 w32_ioinfo_size = ioinfo_size;
4529 #ifndef WIN32_NO_REGISTRY
4532 retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
4533 if (retval != ERROR_SUCCESS) {
4534 HKCU_Perl_hnd = NULL;
4536 retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
4537 if (retval != ERROR_SUCCESS) {
4538 HKLM_Perl_hnd = NULL;
4545 Perl_win32_term(void)
4552 #ifndef WIN32_NO_REGISTRY
4553 /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
4554 but no point of checking and we can't die() at this point */
4555 RegCloseKey(HKLM_Perl_hnd);
4556 RegCloseKey(HKCU_Perl_hnd);
4557 /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
4562 win32_get_child_IO(child_IO_table* ptbl)
4564 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4565 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4566 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4570 win32_signal(int sig, Sighandler_t subcode)
4573 if (sig < SIG_SIZE) {
4574 int save_errno = errno;
4575 Sighandler_t result;
4576 #ifdef SET_INVALID_PARAMETER_HANDLER
4577 /* Silence our invalid parameter handler since we expect to make some
4578 * calls with invalid signal numbers giving a SIG_ERR result. */
4579 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4581 result = signal(sig, subcode);
4582 #ifdef SET_INVALID_PARAMETER_HANDLER
4583 set_silent_invalid_parameter_handler(oldvalue);
4585 aTHXa(PERL_GET_THX);
4586 if (result == SIG_ERR) {
4587 result = w32_sighandler[sig];
4590 w32_sighandler[sig] = subcode;
4599 /* The PerlMessageWindowClass's WindowProc */
4601 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4603 return win32_process_message(hwnd, msg, wParam, lParam) ?
4604 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4607 /* The real message handler. Can be called with
4608 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4609 * that it processes */
4611 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4613 /* BEWARE. The context retrieved using dTHX; is the context of the
4614 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4615 * up to and including WM_CREATE. If it ever happens that you need the
4616 * 'child' context before this, then it needs to be passed into
4617 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4618 * from the lparam of CreateWindow(). It could then be stored/retrieved
4619 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4620 * the dTHX calls here. */
4621 /* XXX For now it is assumed that the overhead of the dTHX; for what
4622 * are relativley infrequent code-paths, is better than the added
4623 * complexity of getting the correct context passed into
4624 * win32_create_message_window() */
4630 case WM_USER_MESSAGE: {
4631 long child = find_pseudo_pid(aTHX_ (int)wParam);
4633 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4640 case WM_USER_KILL: {
4641 /* We use WM_USER_KILL to fake kill() with other signals */
4642 int sig = (int)wParam;
4643 if (do_raise(aTHX_ sig))
4644 sig_terminate(aTHX_ sig);
4650 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4651 if (w32_timerid && w32_timerid==(UINT)wParam) {
4652 KillTimer(w32_message_hwnd, w32_timerid);
4655 /* Now fake a call to signal handler */
4656 if (do_raise(aTHX_ 14))
4657 sig_terminate(aTHX_ 14);
4669 /* Above or other stuff may have set a signal flag, and we may not have
4670 * been called from win32_async_check() (e.g. some other GUI's message
4671 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4672 * handler that die's, and the message loop that calls here is wrapped
4673 * in an eval, then you may well end up with orphaned windows - signals
4674 * are dispatched by win32_async_check() */
4680 win32_create_message_window_class(void)
4682 /* create the window class for "message only" windows */
4686 wc.lpfnWndProc = win32_message_window_proc;
4687 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4688 wc.lpszClassName = "PerlMessageWindowClass";
4690 /* second and subsequent calls will fail, but class
4691 * will already be registered */
4696 win32_create_message_window(void)
4698 win32_create_message_window_class();
4699 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4700 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4703 #ifdef HAVE_INTERP_INTERN
4706 win32_csighandler(int sig)
4709 dTHXa(PERL_GET_SIG_CONTEXT);
4710 Perl_warn(aTHX_ "Got signal %d",sig);
4715 #if defined(__MINGW32__) && defined(__cplusplus)
4716 #define CAST_HWND__(x) (HWND__*)(x)
4718 #define CAST_HWND__(x) x
4722 Perl_sys_intern_init(pTHX)
4727 w32_perlshell_tokens = NULL;
4728 w32_perlshell_vec = (char**)NULL;
4729 w32_perlshell_items = 0;
4730 w32_fdpid = newAV();
4731 Newx(w32_children, 1, child_tab);
4732 w32_num_children = 0;
4733 # ifdef USE_ITHREADS
4735 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4736 w32_num_pseudo_children = 0;
4739 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4741 #ifdef PERL_IS_MINIPERL
4742 w32_sloppystat = TRUE;
4744 w32_sloppystat = FALSE;
4746 for (i=0; i < SIG_SIZE; i++) {
4747 w32_sighandler[i] = SIG_DFL;
4749 # ifdef MULTIPLICITY
4750 if (my_perl == PL_curinterp) {
4754 /* Force C runtime signal stuff to set its console handler */
4755 signal(SIGINT,win32_csighandler);
4756 signal(SIGBREAK,win32_csighandler);
4758 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4759 * flag. This has the side-effect of disabling Ctrl-C events in all
4760 * processes in this group.
4761 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4762 * with a NULL handler.
4764 SetConsoleCtrlHandler(NULL,FALSE);
4766 /* Push our handler on top */
4767 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4772 Perl_sys_intern_clear(pTHX)
4776 Safefree(w32_perlshell_tokens);
4777 Safefree(w32_perlshell_vec);
4778 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4779 Safefree(w32_children);
4781 KillTimer(w32_message_hwnd, w32_timerid);
4784 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4785 DestroyWindow(w32_message_hwnd);
4786 # ifdef MULTIPLICITY
4787 if (my_perl == PL_curinterp) {
4791 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4793 # ifdef USE_ITHREADS
4794 Safefree(w32_pseudo_children);
4798 # ifdef USE_ITHREADS
4801 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4803 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4805 dst->perlshell_tokens = NULL;
4806 dst->perlshell_vec = (char**)NULL;
4807 dst->perlshell_items = 0;
4808 dst->fdpid = newAV();
4809 Newxz(dst->children, 1, child_tab);
4811 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4813 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4814 dst->poll_count = 0;
4815 dst->sloppystat = src->sloppystat;
4816 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4818 # endif /* USE_ITHREADS */
4819 #endif /* HAVE_INTERP_INTERN */