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 && strncmp(strip, base, baselen) == 0
352 && strncmp(ptr+1, base, baselen) == 0))
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)
623 PERL_ARGS_ASSERT_DO_ASPAWN;
629 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
631 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
636 while (++mark <= sp) {
637 if (*mark && (str = SvPV_nolen(*mark)))
644 status = win32_spawnvp(flag,
645 (const char*)(really ? SvPV_nolen(really) : argv[0]),
646 (const char* const*)argv);
648 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
649 /* possible shell-builtin, invoke with shell */
651 sh_items = w32_perlshell_items;
653 argv[index+sh_items] = argv[index];
654 while (--sh_items >= 0)
655 argv[sh_items] = w32_perlshell_vec[sh_items];
657 status = win32_spawnvp(flag,
658 (const char*)(really ? SvPV_nolen(really) : argv[0]),
659 (const char* const*)argv);
662 if (flag == P_NOWAIT) {
663 PL_statusvalue = -1; /* >16bits hint for pp_system() */
667 if (ckWARN(WARN_EXEC))
668 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
673 PL_statusvalue = status;
679 /* returns pointer to the next unquoted space or the end of the string */
681 find_next_space(const char *s)
683 bool in_quotes = FALSE;
685 /* ignore doubled backslashes, or backslash+quote */
686 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
689 /* keep track of when we're within quotes */
690 else if (*s == '"') {
692 in_quotes = !in_quotes;
694 /* break it up only at spaces that aren't in quotes */
695 else if (!in_quotes && isSPACE(*s))
704 do_spawn2(pTHX_ const char *cmd, int exectype) {
705 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
709 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
715 BOOL needToTry = TRUE;
718 /* Save an extra exec if possible. See if there are shell
719 * metacharacters in it */
720 if (!has_shell_metachars(cmd)) {
721 Newx(argv, strlen(cmd) / 2 + 2, char*);
722 Newx(cmd2, strlen(cmd) + 1, char);
725 for (s = cmd2; *s;) {
726 while (*s && isSPACE(*s))
730 s = find_next_space(s);
738 status = win32_spawnvp(P_WAIT, argv[0],
739 (const char* const*)argv);
741 case EXECF_SPAWN_NOWAIT:
742 status = do_spawnvp_handles(P_NOWAIT, argv[0],
743 (const char* const*)argv, handles);
746 status = win32_execvp(argv[0], (const char* const*)argv);
749 if (status != -1 || errno == 0)
759 Newx(argv, w32_perlshell_items + 2, char*);
760 while (++i < w32_perlshell_items)
761 argv[i] = w32_perlshell_vec[i];
762 argv[i++] = (char *)cmd;
766 status = win32_spawnvp(P_WAIT, argv[0],
767 (const char* const*)argv);
769 case EXECF_SPAWN_NOWAIT:
770 status = do_spawnvp_handles(P_NOWAIT, argv[0],
771 (const char* const*)argv, handles);
774 status = win32_execvp(argv[0], (const char* const*)argv);
780 if (exectype == EXECF_SPAWN_NOWAIT) {
781 PL_statusvalue = -1; /* >16bits hint for pp_system() */
785 if (ckWARN(WARN_EXEC))
786 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
787 (exectype == EXECF_EXEC ? "exec" : "spawn"),
788 cmd, strerror(errno));
793 PL_statusvalue = status;
799 Perl_do_spawn(pTHX_ char *cmd)
801 PERL_ARGS_ASSERT_DO_SPAWN;
803 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
807 Perl_do_spawn_nowait(pTHX_ char *cmd)
809 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
811 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
815 Perl_do_exec(pTHX_ const char *cmd)
817 PERL_ARGS_ASSERT_DO_EXEC;
819 do_spawn2(aTHX_ cmd, EXECF_EXEC);
823 /* The idea here is to read all the directory names into a string table
824 * (separated by nulls) and when one of the other dir functions is called
825 * return the pointer to the current file name.
828 win32_opendir(const char *filename)
834 char scanname[MAX_PATH+3];
835 WCHAR wscanname[sizeof(scanname)];
836 WIN32_FIND_DATAW wFindData;
837 char buffer[MAX_PATH*2];
840 len = strlen(filename);
845 if (len > MAX_PATH) {
846 errno = ENAMETOOLONG;
850 /* Get us a DIR structure */
853 /* Create the search pattern */
854 strcpy(scanname, filename);
856 /* bare drive name means look in cwd for drive */
857 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
858 scanname[len++] = '.';
859 scanname[len++] = '/';
861 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
862 scanname[len++] = '/';
864 scanname[len++] = '*';
865 scanname[len] = '\0';
867 /* do the FindFirstFile call */
868 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
870 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
872 if (dirp->handle == INVALID_HANDLE_VALUE) {
873 DWORD err = GetLastError();
874 /* FindFirstFile() fails on empty drives! */
876 case ERROR_FILE_NOT_FOUND:
878 case ERROR_NO_MORE_FILES:
879 case ERROR_PATH_NOT_FOUND:
882 case ERROR_NOT_ENOUGH_MEMORY:
894 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
895 wFindData.cFileName, -1,
896 buffer, sizeof(buffer), NULL, &use_default);
897 if (use_default && *wFindData.cAlternateFileName) {
898 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
899 wFindData.cAlternateFileName, -1,
900 buffer, sizeof(buffer), NULL, NULL);
903 /* now allocate the first part of the string table for
904 * the filenames that we find.
906 idx = strlen(buffer)+1;
911 Newx(dirp->start, dirp->size, char);
912 strcpy(dirp->start, buffer);
914 dirp->end = dirp->curr = dirp->start;
920 /* Readdir just returns the current string pointer and bumps the
921 * string pointer to the nDllExport entry.
923 DllExport struct direct *
924 win32_readdir(DIR *dirp)
929 /* first set up the structure to return */
930 len = strlen(dirp->curr);
931 strcpy(dirp->dirstr.d_name, dirp->curr);
932 dirp->dirstr.d_namlen = len;
935 dirp->dirstr.d_ino = dirp->curr - dirp->start;
937 /* Now set up for the next call to readdir */
938 dirp->curr += len + 1;
939 if (dirp->curr >= dirp->end) {
941 char buffer[MAX_PATH*2];
943 if (dirp->handle == INVALID_HANDLE_VALUE) {
946 /* finding the next file that matches the wildcard
947 * (which should be all of them in this directory!).
950 WIN32_FIND_DATAW wFindData;
951 res = FindNextFileW(dirp->handle, &wFindData);
953 BOOL use_default = FALSE;
954 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
955 wFindData.cFileName, -1,
956 buffer, sizeof(buffer), NULL, &use_default);
957 if (use_default && *wFindData.cAlternateFileName) {
958 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
959 wFindData.cAlternateFileName, -1,
960 buffer, sizeof(buffer), NULL, NULL);
965 long endpos = dirp->end - dirp->start;
966 long newsize = endpos + strlen(buffer) + 1;
967 /* bump the string table size by enough for the
968 * new name and its null terminator */
969 while (newsize > dirp->size) {
970 long curpos = dirp->curr - dirp->start;
972 Renew(dirp->start, dirp->size, char);
973 dirp->curr = dirp->start + curpos;
975 strcpy(dirp->start + endpos, buffer);
976 dirp->end = dirp->start + newsize;
981 if (dirp->handle != INVALID_HANDLE_VALUE) {
982 FindClose(dirp->handle);
983 dirp->handle = INVALID_HANDLE_VALUE;
987 return &(dirp->dirstr);
993 /* Telldir returns the current string pointer position */
995 win32_telldir(DIR *dirp)
997 return dirp->curr ? (dirp->curr - dirp->start) : -1;
1001 /* Seekdir moves the string pointer to a previously saved position
1002 * (returned by telldir).
1005 win32_seekdir(DIR *dirp, long loc)
1007 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
1010 /* Rewinddir resets the string pointer to the start */
1012 win32_rewinddir(DIR *dirp)
1014 dirp->curr = dirp->start;
1017 /* free the memory allocated by opendir */
1019 win32_closedir(DIR *dirp)
1021 if (dirp->handle != INVALID_HANDLE_VALUE)
1022 FindClose(dirp->handle);
1023 Safefree(dirp->start);
1028 /* duplicate a open DIR* for interpreter cloning */
1030 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1033 PerlInterpreter *const from = param->proto_perl;
1034 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1039 /* switch back to original interpreter because win32_readdir()
1040 * might Renew(dirp->start).
1046 /* mark current position; read all remaining entries into the
1047 * cache, and then restore to current position.
1049 pos = win32_telldir(dirp);
1050 while (win32_readdir(dirp)) {
1051 /* read all entries into cache */
1053 win32_seekdir(dirp, pos);
1055 /* switch back to new interpreter to allocate new DIR structure */
1061 memcpy(dup, dirp, sizeof(DIR));
1063 Newx(dup->start, dirp->size, char);
1064 memcpy(dup->start, dirp->start, dirp->size);
1066 dup->end = dup->start + (dirp->end - dirp->start);
1068 dup->curr = dup->start + (dirp->curr - dirp->start);
1080 * Just pretend that everyone is a superuser. NT will let us know if
1081 * we don\'t really have permission to do something.
1084 #define ROOT_UID ((uid_t)0)
1085 #define ROOT_GID ((gid_t)0)
1114 return (auid == ROOT_UID ? 0 : -1);
1120 return (agid == ROOT_GID ? 0 : -1);
1127 char *buf = w32_getlogin_buffer;
1128 DWORD size = sizeof(w32_getlogin_buffer);
1129 if (GetUserName(buf,&size))
1135 chown(const char *path, uid_t owner, gid_t group)
1142 * XXX this needs strengthening (for PerlIO)
1145 #if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
1146 int mkstemp(const char *path)
1149 char buf[MAX_PATH+1];
1153 if (i++ > 10) { /* give up */
1157 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1161 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1169 find_pid(pTHX_ int pid)
1171 long child = w32_num_children;
1172 while (--child >= 0) {
1173 if ((int)w32_child_pids[child] == pid)
1180 remove_dead_process(long child)
1184 CloseHandle(w32_child_handles[child]);
1185 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1186 (w32_num_children-child-1), HANDLE);
1187 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1188 (w32_num_children-child-1), DWORD);
1195 find_pseudo_pid(pTHX_ int pid)
1197 long child = w32_num_pseudo_children;
1198 while (--child >= 0) {
1199 if ((int)w32_pseudo_child_pids[child] == pid)
1206 remove_dead_pseudo_process(long child)
1210 CloseHandle(w32_pseudo_child_handles[child]);
1211 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1212 (w32_num_pseudo_children-child-1), HANDLE);
1213 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1214 (w32_num_pseudo_children-child-1), DWORD);
1215 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1216 (w32_num_pseudo_children-child-1), HWND);
1217 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1218 (w32_num_pseudo_children-child-1), char);
1219 w32_num_pseudo_children--;
1224 win32_wait_for_children(pTHX)
1226 if (w32_pseudo_children && w32_num_pseudo_children) {
1229 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1231 for (child = 0; child < w32_num_pseudo_children; ++child) {
1232 if (!w32_pseudo_child_sigterm[child])
1233 handles[count++] = w32_pseudo_child_handles[child];
1235 /* XXX should use MsgWaitForMultipleObjects() to continue
1236 * XXX processing messages while we wait.
1238 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1240 while (w32_num_pseudo_children)
1241 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1247 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1251 /* "Does process exist?" use of kill */
1254 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1259 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1262 default: /* For now be backwards compatible with perl 5.6 */
1264 /* Note that we will only be able to kill processes owned by the
1265 * current process owner, even when we are running as an administrator.
1266 * To kill processes of other owners we would need to set the
1267 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1269 if (TerminateProcess(process_handle, sig))
1276 /* returns number of processes killed */
1278 my_killpg(int pid, int sig)
1280 HANDLE process_handle;
1281 HANDLE snapshot_handle;
1284 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1285 if (process_handle == NULL)
1288 killed += terminate_process(pid, process_handle, sig);
1290 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1291 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1292 PROCESSENTRY32 entry;
1294 entry.dwSize = sizeof(entry);
1295 if (Process32First(snapshot_handle, &entry)) {
1297 if (entry.th32ParentProcessID == (DWORD)pid)
1298 killed += my_killpg(entry.th32ProcessID, sig);
1299 entry.dwSize = sizeof(entry);
1301 while (Process32Next(snapshot_handle, &entry));
1303 CloseHandle(snapshot_handle);
1305 CloseHandle(process_handle);
1309 /* returns number of processes killed */
1311 my_kill(int pid, int sig)
1314 HANDLE process_handle;
1317 return my_killpg(pid, -sig);
1319 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1320 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1321 if (process_handle != NULL) {
1322 retval = terminate_process(pid, process_handle, sig);
1323 CloseHandle(process_handle);
1329 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1330 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1331 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1332 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1334 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1335 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1336 * a HWND in the time period allowed.
1339 get_hwnd_delay(pTHX, long child, DWORD tries)
1341 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1342 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1344 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1345 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1346 * thread 100% of the time since threads are attached to a CPU for NUMA and
1347 * caching reasons, and the child thread was attached to a different CPU
1348 * therefore there is no workload on that CPU and Sleep(0) returns control
1349 * without yielding the time slot.
1350 * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
1353 win32_async_check(aTHX);
1354 hwnd = w32_pseudo_child_message_hwnds[child];
1355 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1358 unsigned int count = 0;
1359 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1360 while (count++ < tries) {
1362 win32_async_check(aTHX);
1363 hwnd = w32_pseudo_child_message_hwnds[child];
1364 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1368 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1373 win32_kill(int pid, int sig)
1379 /* it is a pseudo-forked child */
1380 child = find_pseudo_pid(aTHX_ -pid);
1382 HANDLE hProcess = w32_pseudo_child_handles[child];
1385 /* "Does process exist?" use of kill */
1389 /* kill -9 style un-graceful exit */
1390 /* Do a wait to make sure child starts and isn't in DLL
1392 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1393 if (TerminateThread(hProcess, sig)) {
1394 /* Allow the scheduler to finish cleaning up the other
1396 * Otherwise, if we ExitProcess() before another context
1397 * switch happens we will end up with a process exit
1398 * code of "sig" instead of our own exit status.
1399 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1402 remove_dead_pseudo_process(child);
1409 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1410 /* We fake signals to pseudo-processes using Win32
1412 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1413 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1415 /* Don't wait for child process to terminate after we send a
1416 * SIGTERM because the child may be blocked in a system call
1417 * and never receive the signal.
1419 if (sig == SIGTERM) {
1421 w32_pseudo_child_sigterm[child] = 1;
1423 /* It might be us ... */
1435 child = find_pid(aTHX_ pid);
1437 if (my_kill(pid, sig)) {
1439 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1440 exitcode != STILL_ACTIVE)
1442 remove_dead_process(child);
1448 if (my_kill(pid, sig))
1457 win32_stat(const char *path, Stat_t *sbuf)
1459 char buffer[MAX_PATH+1];
1460 int l = strlen(path);
1464 BOOL expect_dir = FALSE;
1467 switch(path[l - 1]) {
1468 /* FindFirstFile() and stat() are buggy with a trailing
1469 * slashes, except for the root directory of a drive */
1472 if (l > sizeof(buffer)) {
1473 errno = ENAMETOOLONG;
1477 strncpy(buffer, path, l);
1478 /* remove additional trailing slashes */
1479 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1481 /* add back slash if we otherwise end up with just a drive letter */
1482 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1489 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1491 if (l == 2 && isALPHA(path[0])) {
1492 buffer[0] = path[0];
1503 path = PerlDir_mapA(path);
1506 if (!w32_sloppystat) {
1507 /* We must open & close the file once; otherwise file attribute changes */
1508 /* might not yet have propagated to "other" hard links of the same file. */
1509 /* This also gives us an opportunity to determine the number of links. */
1510 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1511 if (handle != INVALID_HANDLE_VALUE) {
1512 BY_HANDLE_FILE_INFORMATION bhi;
1513 if (GetFileInformationByHandle(handle, &bhi))
1514 nlink = bhi.nNumberOfLinks;
1515 CloseHandle(handle);
1518 DWORD err = GetLastError();
1519 /* very common case, skip CRT stat and its also failing syscalls */
1520 if(err == ERROR_FILE_NOT_FOUND) {
1527 /* path will be mapped correctly above */
1528 #if defined(WIN64) || defined(USE_LARGE_FILES)
1529 res = _stati64(path, sbuf);
1531 res = stat(path, sbuf);
1533 sbuf->st_nlink = nlink;
1536 /* CRT is buggy on sharenames, so make sure it really isn't.
1537 * XXX using GetFileAttributesEx() will enable us to set
1538 * sbuf->st_*time (but note that's not available on the
1539 * Windows of 1995) */
1540 DWORD r = GetFileAttributesA(path);
1541 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1542 /* sbuf may still contain old garbage since stat() failed */
1543 Zero(sbuf, 1, Stat_t);
1544 sbuf->st_mode = S_IFDIR | S_IREAD;
1546 if (!(r & FILE_ATTRIBUTE_READONLY))
1547 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1552 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1553 && (path[2] == '\\' || path[2] == '/'))
1555 /* The drive can be inaccessible, some _stat()s are buggy */
1556 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1561 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1565 if (S_ISDIR(sbuf->st_mode)) {
1566 /* Ensure the "write" bit is switched off in the mode for
1567 * directories with the read-only attribute set. Some compilers
1568 * switch it on for directories, which is technically correct
1569 * (directories are indeed always writable unless denied by DACLs),
1570 * but we want stat() and -w to reflect the state of the read-only
1571 * attribute for symmetry with chmod(). */
1572 DWORD r = GetFileAttributesA(path);
1573 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1574 sbuf->st_mode &= ~S_IWRITE;
1581 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1582 #define SKIP_SLASHES(s) \
1584 while (*(s) && isSLASH(*(s))) \
1587 #define COPY_NONSLASHES(d,s) \
1589 while (*(s) && !isSLASH(*(s))) \
1593 /* Find the longname of a given path. path is destructively modified.
1594 * It should have space for at least MAX_PATH characters. */
1596 win32_longpath(char *path)
1598 WIN32_FIND_DATA fdata;
1600 char tmpbuf[MAX_PATH+1];
1601 char *tmpstart = tmpbuf;
1608 if (isALPHA(path[0]) && path[1] == ':') {
1610 *tmpstart++ = path[0];
1614 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1616 *tmpstart++ = path[0];
1617 *tmpstart++ = path[1];
1618 SKIP_SLASHES(start);
1619 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1621 *tmpstart++ = *start++;
1622 SKIP_SLASHES(start);
1623 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1628 /* copy initial slash, if any */
1629 if (isSLASH(*start)) {
1630 *tmpstart++ = *start++;
1632 SKIP_SLASHES(start);
1635 /* FindFirstFile() expands "." and "..", so we need to pass
1636 * those through unmolested */
1638 && (!start[1] || isSLASH(start[1])
1639 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1641 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1646 /* if this is the end, bust outta here */
1650 /* now we're at a non-slash; walk up to next slash */
1651 while (*start && !isSLASH(*start))
1654 /* stop and find full name of component */
1657 fhand = FindFirstFile(path,&fdata);
1659 if (fhand != INVALID_HANDLE_VALUE) {
1660 STRLEN len = strlen(fdata.cFileName);
1661 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1662 strcpy(tmpstart, fdata.cFileName);
1673 /* failed a step, just return without side effects */
1674 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1679 strcpy(path,tmpbuf);
1692 win32_croak_not_implemented(const char * fname)
1694 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1696 Perl_croak_nocontext("%s not implemented!\n", fname);
1699 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1700 * potentially using the system's default replacement character for any
1701 * unrepresentable characters. The caller must free() the returned string. */
1703 wstr_to_str(const wchar_t* wstr)
1705 BOOL used_default = FALSE;
1706 size_t wlen = wcslen(wstr) + 1;
1707 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1708 NULL, 0, NULL, NULL);
1709 char* str = (char*)malloc(len);
1712 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1713 str, len, NULL, &used_default);
1717 /* The win32_ansipath() function takes a Unicode filename and converts it
1718 * into the current Windows codepage. If some characters cannot be mapped,
1719 * then it will convert the short name instead.
1721 * The buffer to the ansi pathname must be freed with win32_free() when it
1722 * it no longer needed.
1724 * The argument to win32_ansipath() must exist before this function is
1725 * called; otherwise there is no way to determine the short path name.
1727 * Ideas for future refinement:
1728 * - Only convert those segments of the path that are not in the current
1729 * codepage, but leave the other segments in their long form.
1730 * - If the resulting name is longer than MAX_PATH, start converting
1731 * additional path segments into short names until the full name
1732 * is shorter than MAX_PATH. Shorten the filename part last!
1735 win32_ansipath(const WCHAR *widename)
1738 BOOL use_default = FALSE;
1739 size_t widelen = wcslen(widename)+1;
1740 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1741 NULL, 0, NULL, NULL);
1742 name = (char*)win32_malloc(len);
1746 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1747 name, len, NULL, &use_default);
1749 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1751 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1754 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1756 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1757 NULL, 0, NULL, NULL);
1758 name = (char*)win32_realloc(name, len);
1761 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1762 name, len, NULL, NULL);
1763 win32_free(shortname);
1769 /* the returned string must be freed with win32_freeenvironmentstrings which is
1770 * implemented as a macro
1771 * void win32_freeenvironmentstrings(void* block)
1774 win32_getenvironmentstrings(void)
1776 LPWSTR lpWStr, lpWTmp;
1778 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1780 /* Get the process environment strings */
1781 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1782 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1783 env_len = wcslen(lpWTmp);
1784 /* calculate the size of the environment strings */
1785 wenvstrings_len += env_len + 1;
1788 /* Get the number of bytes required to store the ACP encoded string */
1789 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1790 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1791 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1795 /* Convert the string from UTF-16 encoding to ACP encoding */
1796 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1797 aenvstrings_len, NULL, NULL);
1799 FreeEnvironmentStringsW(lpWStr);
1805 win32_getenv(const char *name)
1812 needlen = GetEnvironmentVariableA(name,NULL,0);
1814 curitem = sv_2mortal(newSVpvs(""));
1816 SvGROW(curitem, needlen+1);
1817 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1819 } while (needlen >= SvLEN(curitem));
1820 SvCUR_set(curitem, needlen);
1823 last_err = GetLastError();
1824 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1825 /* It appears the variable is in the env, but the Win32 API
1826 doesn't have a canned way of getting it. So we fall back to
1827 grabbing the whole env and pulling this value out if possible */
1828 char *envv = GetEnvironmentStrings();
1832 char *end = strchr(cur,'=');
1833 if (end && end != cur) {
1835 if (!strcmp(cur,name)) {
1836 curitem = sv_2mortal(newSVpv(end+1,0));
1841 cur = end + strlen(end+1)+2;
1843 else if ((len = strlen(cur)))
1846 FreeEnvironmentStrings(envv);
1848 #ifndef WIN32_NO_REGISTRY
1850 /* last ditch: allow any environment variables that begin with 'PERL'
1851 to be obtained from the registry, if found there */
1852 if (strncmp(name, "PERL", 4) == 0)
1853 (void)get_regstr(name, &curitem);
1857 if (curitem && SvCUR(curitem))
1858 return SvPVX(curitem);
1864 win32_putenv(const char *name)
1871 curitem = (char *) win32_malloc(strlen(name)+1);
1872 strcpy(curitem, name);
1873 val = strchr(curitem, '=');
1875 /* The sane way to deal with the environment.
1876 * Has these advantages over putenv() & co.:
1877 * * enables us to store a truly empty value in the
1878 * environment (like in UNIX).
1879 * * we don't have to deal with RTL globals, bugs and leaks
1880 * (specifically, see http://support.microsoft.com/kb/235601).
1882 * Why you may want to use the RTL environment handling
1883 * (previously enabled by USE_WIN32_RTL_ENV):
1884 * * environ[] and RTL functions will not reflect changes,
1885 * which might be an issue if extensions want to access
1886 * the env. via RTL. This cuts both ways, since RTL will
1887 * not see changes made by extensions that call the Win32
1888 * functions directly, either.
1892 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1895 win32_free(curitem);
1901 filetime_to_clock(PFILETIME ft)
1903 __int64 qw = ft->dwHighDateTime;
1905 qw |= ft->dwLowDateTime;
1906 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1911 win32_times(struct tms *timebuf)
1916 clock_t process_time_so_far = clock();
1917 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1919 timebuf->tms_utime = filetime_to_clock(&user);
1920 timebuf->tms_stime = filetime_to_clock(&kernel);
1921 timebuf->tms_cutime = 0;
1922 timebuf->tms_cstime = 0;
1924 /* That failed - e.g. Win95 fallback to clock() */
1925 timebuf->tms_utime = process_time_so_far;
1926 timebuf->tms_stime = 0;
1927 timebuf->tms_cutime = 0;
1928 timebuf->tms_cstime = 0;
1930 return process_time_so_far;
1933 /* fix utime() so it works on directories in NT */
1935 filetime_from_time(PFILETIME pFileTime, time_t Time)
1937 struct tm *pTM = localtime(&Time);
1938 SYSTEMTIME SystemTime;
1944 SystemTime.wYear = pTM->tm_year + 1900;
1945 SystemTime.wMonth = pTM->tm_mon + 1;
1946 SystemTime.wDay = pTM->tm_mday;
1947 SystemTime.wHour = pTM->tm_hour;
1948 SystemTime.wMinute = pTM->tm_min;
1949 SystemTime.wSecond = pTM->tm_sec;
1950 SystemTime.wMilliseconds = 0;
1952 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1953 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1957 win32_unlink(const char *filename)
1963 filename = PerlDir_mapA(filename);
1964 attrs = GetFileAttributesA(filename);
1965 if (attrs == 0xFFFFFFFF) {
1969 if (attrs & FILE_ATTRIBUTE_READONLY) {
1970 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1971 ret = unlink(filename);
1973 (void)SetFileAttributesA(filename, attrs);
1976 ret = unlink(filename);
1981 win32_utime(const char *filename, struct utimbuf *times)
1988 struct utimbuf TimeBuffer;
1991 filename = PerlDir_mapA(filename);
1992 rc = utime(filename, times);
1994 /* EACCES: path specifies directory or readonly file */
1995 if (rc == 0 || errno != EACCES)
1998 if (times == NULL) {
1999 times = &TimeBuffer;
2000 time(×->actime);
2001 times->modtime = times->actime;
2004 /* This will (and should) still fail on readonly files */
2005 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2006 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
2007 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2008 if (handle == INVALID_HANDLE_VALUE)
2011 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
2012 filetime_from_time(&ftAccess, times->actime) &&
2013 filetime_from_time(&ftWrite, times->modtime) &&
2014 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
2019 CloseHandle(handle);
2024 unsigned __int64 ft_i64;
2029 #define Const64(x) x##LL
2031 #define Const64(x) x##i64
2033 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2034 #define EPOCH_BIAS Const64(116444736000000000)
2036 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2037 * and appears to be unsupported even by glibc) */
2039 win32_gettimeofday(struct timeval *tp, void *not_used)
2043 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2044 GetSystemTimeAsFileTime(&ft.ft_val);
2046 /* seconds since epoch */
2047 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2049 /* microseconds remaining */
2050 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2056 win32_uname(struct utsname *name)
2058 struct hostent *hep;
2059 STRLEN nodemax = sizeof(name->nodename)-1;
2062 switch (g_osver.dwPlatformId) {
2063 case VER_PLATFORM_WIN32_WINDOWS:
2064 strcpy(name->sysname, "Windows");
2066 case VER_PLATFORM_WIN32_NT:
2067 strcpy(name->sysname, "Windows NT");
2069 case VER_PLATFORM_WIN32s:
2070 strcpy(name->sysname, "Win32s");
2073 strcpy(name->sysname, "Win32 Unknown");
2078 sprintf(name->release, "%d.%d",
2079 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2082 sprintf(name->version, "Build %d",
2083 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2084 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2085 if (g_osver.szCSDVersion[0]) {
2086 char *buf = name->version + strlen(name->version);
2087 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2091 hep = win32_gethostbyname("localhost");
2093 STRLEN len = strlen(hep->h_name);
2094 if (len <= nodemax) {
2095 strcpy(name->nodename, hep->h_name);
2098 strncpy(name->nodename, hep->h_name, nodemax);
2099 name->nodename[nodemax] = '\0';
2104 if (!GetComputerName(name->nodename, &sz))
2105 *name->nodename = '\0';
2108 /* machine (architecture) */
2113 GetSystemInfo(&info);
2115 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2116 procarch = info.u.s.wProcessorArchitecture;
2118 procarch = info.wProcessorArchitecture;
2121 case PROCESSOR_ARCHITECTURE_INTEL:
2122 arch = "x86"; break;
2123 case PROCESSOR_ARCHITECTURE_IA64:
2124 arch = "ia64"; break;
2125 case PROCESSOR_ARCHITECTURE_AMD64:
2126 arch = "amd64"; break;
2127 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2128 arch = "unknown"; break;
2130 sprintf(name->machine, "unknown(0x%x)", procarch);
2131 arch = name->machine;
2134 if (name->machine != arch)
2135 strcpy(name->machine, arch);
2140 /* Timing related stuff */
2143 do_raise(pTHX_ int sig)
2145 if (sig < SIG_SIZE) {
2146 Sighandler_t handler = w32_sighandler[sig];
2147 if (handler == SIG_IGN) {
2150 else if (handler != SIG_DFL) {
2155 /* Choose correct default behaviour */
2171 /* Tell caller to exit thread/process as appropriate */
2176 sig_terminate(pTHX_ int sig)
2178 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2179 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2186 win32_async_check(pTHX)
2189 HWND hwnd = w32_message_hwnd;
2191 /* Reset w32_poll_count before doing anything else, incase we dispatch
2192 * messages that end up calling back into perl */
2195 if (hwnd != INVALID_HANDLE_VALUE) {
2196 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2197 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2202 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2203 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2205 /* re-post a WM_QUIT message (we'll mark it as read later) */
2206 if(msg.message == WM_QUIT) {
2207 PostQuitMessage((int)msg.wParam);
2211 if(!CallMsgFilter(&msg, MSGF_USER))
2213 TranslateMessage(&msg);
2214 DispatchMessage(&msg);
2219 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2220 * This is necessary when we are being called by win32_msgwait() to
2221 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2222 * message over and over. An example how this can happen is when
2223 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2224 * is generating messages before the process terminated.
2226 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2228 /* Above or other stuff may have set a signal flag */
2235 /* This function will not return until the timeout has elapsed, or until
2236 * one of the handles is ready. */
2238 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2240 /* We may need several goes at this - so compute when we stop */
2242 unsigned __int64 endtime = timeout;
2243 if (timeout != INFINITE) {
2244 GetSystemTimeAsFileTime(&ticks.ft_val);
2245 ticks.ft_i64 /= 10000;
2246 endtime += ticks.ft_i64;
2248 /* This was a race condition. Do not let a non INFINITE timeout to
2249 * MsgWaitForMultipleObjects roll under 0 creating a near
2250 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2251 * user who did a CORE perl function with a non infinity timeout,
2252 * sleep for example. This is 64 to 32 truncation minefield.
2254 * This scenario can only be created if the timespan from the return of
2255 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2256 * generate the scenario, manual breakpoints in a C debugger are required,
2257 * or a context switch occurred in win32_async_check in PeekMessage, or random
2258 * messages are delivered to the *thread* message queue of the Perl thread
2259 * from another process (msctf.dll doing IPC among its instances, VS debugger
2260 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2262 while (ticks.ft_i64 <= endtime) {
2263 /* if timeout's type is lengthened, remember to split 64b timeout
2264 * into multiple non-infinity runs of MWFMO */
2265 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2266 (DWORD)(endtime - ticks.ft_i64),
2267 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2270 if (result == WAIT_TIMEOUT) {
2271 /* Ran out of time - explicit return of zero to avoid -ve if we
2272 have scheduling issues
2276 if (timeout != INFINITE) {
2277 GetSystemTimeAsFileTime(&ticks.ft_val);
2278 ticks.ft_i64 /= 10000;
2280 if (result == WAIT_OBJECT_0 + count) {
2281 /* Message has arrived - check it */
2282 (void)win32_async_check(aTHX);
2285 /* Not timeout or message - one of handles is ready */
2289 /* If we are past the end say zero */
2290 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2292 /* compute time left to wait */
2293 ticks.ft_i64 = endtime - ticks.ft_i64;
2294 /* if more ms than DWORD, then return max DWORD */
2295 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2299 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2301 /* XXX this wait emulation only knows about processes
2302 * spawned via win32_spawnvp(P_NOWAIT, ...).
2305 DWORD exitcode, waitcode;
2308 if (w32_num_pseudo_children) {
2309 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2310 timeout, &waitcode);
2311 /* Time out here if there are no other children to wait for. */
2312 if (waitcode == WAIT_TIMEOUT) {
2313 if (!w32_num_children) {
2317 else if (waitcode != WAIT_FAILED) {
2318 if (waitcode >= WAIT_ABANDONED_0
2319 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2320 i = waitcode - WAIT_ABANDONED_0;
2322 i = waitcode - WAIT_OBJECT_0;
2323 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2324 *status = (int)((exitcode & 0xff) << 8);
2325 retval = (int)w32_pseudo_child_pids[i];
2326 remove_dead_pseudo_process(i);
2333 if (!w32_num_children) {
2338 /* if a child exists, wait for it to die */
2339 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2340 if (waitcode == WAIT_TIMEOUT) {
2343 if (waitcode != WAIT_FAILED) {
2344 if (waitcode >= WAIT_ABANDONED_0
2345 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2346 i = waitcode - WAIT_ABANDONED_0;
2348 i = waitcode - WAIT_OBJECT_0;
2349 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2350 *status = (int)((exitcode & 0xff) << 8);
2351 retval = (int)w32_child_pids[i];
2352 remove_dead_process(i);
2357 errno = GetLastError();
2362 win32_waitpid(int pid, int *status, int flags)
2365 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2368 if (pid == -1) /* XXX threadid == 1 ? */
2369 return win32_internal_wait(aTHX_ status, timeout);
2372 child = find_pseudo_pid(aTHX_ -pid);
2374 HANDLE hThread = w32_pseudo_child_handles[child];
2376 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2377 if (waitcode == WAIT_TIMEOUT) {
2380 else if (waitcode == WAIT_OBJECT_0) {
2381 if (GetExitCodeThread(hThread, &waitcode)) {
2382 *status = (int)((waitcode & 0xff) << 8);
2383 retval = (int)w32_pseudo_child_pids[child];
2384 remove_dead_pseudo_process(child);
2396 child = find_pid(aTHX_ pid);
2398 hProcess = w32_child_handles[child];
2399 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2400 if (waitcode == WAIT_TIMEOUT) {
2403 else if (waitcode == WAIT_OBJECT_0) {
2404 if (GetExitCodeProcess(hProcess, &waitcode)) {
2405 *status = (int)((waitcode & 0xff) << 8);
2406 retval = (int)w32_child_pids[child];
2407 remove_dead_process(child);
2415 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2417 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2418 if (waitcode == WAIT_TIMEOUT) {
2419 CloseHandle(hProcess);
2422 else if (waitcode == WAIT_OBJECT_0) {
2423 if (GetExitCodeProcess(hProcess, &waitcode)) {
2424 *status = (int)((waitcode & 0xff) << 8);
2425 CloseHandle(hProcess);
2429 CloseHandle(hProcess);
2435 return retval >= 0 ? pid : retval;
2439 win32_wait(int *status)
2442 return win32_internal_wait(aTHX_ status, INFINITE);
2445 DllExport unsigned int
2446 win32_sleep(unsigned int t)
2449 /* Win32 times are in ms so *1000 in and /1000 out */
2450 if (t > UINT_MAX / 1000) {
2451 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2452 "sleep(%lu) too large", t);
2454 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2457 DllExport unsigned int
2458 win32_alarm(unsigned int sec)
2461 * the 'obvious' implentation is SetTimer() with a callback
2462 * which does whatever receiving SIGALRM would do
2463 * we cannot use SIGALRM even via raise() as it is not
2464 * one of the supported codes in <signal.h>
2468 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2469 w32_message_hwnd = win32_create_message_window();
2472 if (w32_message_hwnd == NULL)
2473 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2476 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2481 KillTimer(w32_message_hwnd, w32_timerid);
2488 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2491 win32_crypt(const char *txt, const char *salt)
2494 return des_fcrypt(txt, salt, w32_crypt_buffer);
2497 /* simulate flock by locking a range on the file */
2499 #define LK_LEN 0xffff0000
2502 win32_flock(int fd, int oper)
2508 fh = (HANDLE)_get_osfhandle(fd);
2509 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2512 memset(&o, 0, sizeof(o));
2515 case LOCK_SH: /* shared lock */
2516 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2519 case LOCK_EX: /* exclusive lock */
2520 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2523 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2524 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2527 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2528 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2532 case LOCK_UN: /* unlock lock */
2533 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2536 default: /* unknown */
2541 if (GetLastError() == ERROR_LOCK_VIOLATION)
2542 errno = EWOULDBLOCK;
2551 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2553 /* Get the errno value corresponding to the given err. This function is not
2554 * intended to handle conversion of general GetLastError() codes. It only exists
2555 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2556 * used to be assigned to errno/$! in earlier versions of perl; this function is
2557 * used to catch any old Perl code which is still trying to assign such values
2558 * to $! and convert them to errno values instead.
2561 win32_get_errno(int err)
2563 return convert_wsa_error_to_errno(err);
2567 * redirected io subsystem for all XS modules
2580 return (&(_environ));
2583 /* the rest are the remapped stdio routines */
2603 win32_ferror(FILE *fp)
2605 return (ferror(fp));
2610 win32_feof(FILE *fp)
2615 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2616 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2620 * Since the errors returned by the socket error function
2621 * WSAGetLastError() are not known by the library routine strerror
2622 * we have to roll our own to cover the case of socket errors
2623 * that could not be converted to regular errno values by
2624 * get_last_socket_error() in win32/win32sck.c.
2628 win32_strerror(int e)
2630 #if !defined __MINGW32__ /* compiler intolerance */
2631 extern int sys_nerr;
2634 if (e < 0 || e > sys_nerr) {
2638 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2639 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2640 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2641 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2642 * We must therefore still roll our own messages for these codes, and
2643 * additionally map them to corresponding Windows (sockets) error codes
2644 * first to avoid getting the wrong system message.
2646 else if (e >= EADDRINUSE && e <= EWOULDBLOCK) {
2647 e = convert_errno_to_wsa_error(e);
2651 aTHXa(PERL_GET_THX);
2652 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2653 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2654 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2657 strcpy(w32_strerror_buffer, "Unknown Error");
2659 return w32_strerror_buffer;
2663 #define strerror win32_strerror
2667 win32_str_os_error(void *sv, DWORD dwErr)
2671 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2672 |FORMAT_MESSAGE_IGNORE_INSERTS
2673 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2674 dwErr, 0, (char *)&sMsg, 1, NULL);
2675 /* strip trailing whitespace and period */
2678 --dwLen; /* dwLen doesn't include trailing null */
2679 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2680 if ('.' != sMsg[dwLen])
2685 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2687 dwLen = sprintf(sMsg,
2688 "Unknown error #0x%lX (lookup 0x%lX)",
2689 dwErr, GetLastError());
2693 sv_setpvn((SV*)sv, sMsg, dwLen);
2699 win32_fprintf(FILE *fp, const char *format, ...)
2702 va_start(marker, format); /* Initialize variable arguments. */
2704 return (vfprintf(fp, format, marker));
2708 win32_printf(const char *format, ...)
2711 va_start(marker, format); /* Initialize variable arguments. */
2713 return (vprintf(format, marker));
2717 win32_vfprintf(FILE *fp, const char *format, va_list args)
2719 return (vfprintf(fp, format, args));
2723 win32_vprintf(const char *format, va_list args)
2725 return (vprintf(format, args));
2729 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2731 return fread(buf, size, count, fp);
2735 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2737 return fwrite(buf, size, count, fp);
2740 #define MODE_SIZE 10
2743 win32_fopen(const char *filename, const char *mode)
2751 if (stricmp(filename, "/dev/null")==0)
2754 aTHXa(PERL_GET_THX);
2755 f = fopen(PerlDir_mapA(filename), mode);
2756 /* avoid buffering headaches for child processes */
2757 if (f && *mode == 'a')
2758 win32_fseek(f, 0, SEEK_END);
2763 win32_fdopen(int handle, const char *mode)
2766 f = fdopen(handle, (char *) mode);
2767 /* avoid buffering headaches for child processes */
2768 if (f && *mode == 'a')
2769 win32_fseek(f, 0, SEEK_END);
2774 win32_freopen(const char *path, const char *mode, FILE *stream)
2777 if (stricmp(path, "/dev/null")==0)
2780 aTHXa(PERL_GET_THX);
2781 return freopen(PerlDir_mapA(path), mode, stream);
2785 win32_fclose(FILE *pf)
2787 #ifdef WIN32_NO_SOCKETS
2790 return my_fclose(pf); /* defined in win32sck.c */
2795 win32_fputs(const char *s,FILE *pf)
2797 return fputs(s, pf);
2801 win32_fputc(int c,FILE *pf)
2807 win32_ungetc(int c,FILE *pf)
2809 return ungetc(c,pf);
2813 win32_getc(FILE *pf)
2819 win32_fileno(FILE *pf)
2825 win32_clearerr(FILE *pf)
2832 win32_fflush(FILE *pf)
2838 win32_ftell(FILE *pf)
2840 #if defined(WIN64) || defined(USE_LARGE_FILES)
2842 if (fgetpos(pf, &pos))
2851 win32_fseek(FILE *pf, Off_t offset,int origin)
2853 #if defined(WIN64) || defined(USE_LARGE_FILES)
2857 if (fgetpos(pf, &pos))
2862 fseek(pf, 0, SEEK_END);
2863 pos = _telli64(fileno(pf));
2872 return fsetpos(pf, &offset);
2874 return fseek(pf, (long)offset, origin);
2879 win32_fgetpos(FILE *pf,fpos_t *p)
2881 return fgetpos(pf, p);
2885 win32_fsetpos(FILE *pf,const fpos_t *p)
2887 return fsetpos(pf, p);
2891 win32_rewind(FILE *pf)
2900 char prefix[MAX_PATH+1];
2901 char filename[MAX_PATH+1];
2902 DWORD len = GetTempPath(MAX_PATH, prefix);
2903 if (len && len < MAX_PATH) {
2904 if (GetTempFileName(prefix, "plx", 0, filename)) {
2905 HANDLE fh = CreateFile(filename,
2906 DELETE | GENERIC_READ | GENERIC_WRITE,
2910 FILE_ATTRIBUTE_NORMAL
2911 | FILE_FLAG_DELETE_ON_CLOSE,
2913 if (fh != INVALID_HANDLE_VALUE) {
2914 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2917 DEBUG_p(PerlIO_printf(Perl_debug_log,
2918 "Created tmpfile=%s\n",filename));
2930 int fd = win32_tmpfd();
2932 return win32_fdopen(fd, "w+b");
2944 win32_fstat(int fd, Stat_t *sbufptr)
2946 #if defined(WIN64) || defined(USE_LARGE_FILES)
2947 return _fstati64(fd, sbufptr);
2949 return fstat(fd, sbufptr);
2954 win32_pipe(int *pfd, unsigned int size, int mode)
2956 return _pipe(pfd, size, mode);
2960 win32_popenlist(const char *mode, IV narg, SV **args)
2964 return do_popen(mode, NULL, narg, args);
2968 do_popen(const char *mode, const char *command, IV narg, SV **args) {
2977 const char **args_pvs = NULL;
2979 /* establish which ends read and write */
2980 if (strchr(mode,'w')) {
2981 stdfd = 0; /* stdin */
2984 nhandle = STD_INPUT_HANDLE;
2986 else if (strchr(mode,'r')) {
2987 stdfd = 1; /* stdout */
2990 nhandle = STD_OUTPUT_HANDLE;
2995 /* set the correct mode */
2996 if (strchr(mode,'b'))
2998 else if (strchr(mode,'t'))
3001 ourmode = _fmode & (O_TEXT | O_BINARY);
3003 /* the child doesn't inherit handles */
3004 ourmode |= O_NOINHERIT;
3006 if (win32_pipe(p, 512, ourmode) == -1)
3009 /* Previously this code redirected stdin/out temporarily so the
3010 child process inherited those handles, this caused race
3011 conditions when another thread was writing/reading those
3014 To avoid that we just feed the handles to CreateProcess() so
3015 the handles are redirected only in the child.
3017 handles[child] = p[child];
3018 handles[parent] = -1;
3021 /* CreateProcess() requires inheritable handles */
3022 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3023 HANDLE_FLAG_INHERIT)) {
3027 /* start the child */
3032 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3038 const char *exe_name;
3040 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3041 SAVEFREEPV(args_pvs);
3042 for (i = 0; i < narg; ++i)
3043 args_pvs[i] = SvPV_nolen(args[i]);
3045 exe_name = qualified_path(args_pvs[0], TRUE);
3047 /* let CreateProcess() try to find it instead */
3048 exe_name = args_pvs[0];
3050 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3055 win32_close(p[child]);
3057 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3059 /* set process id so that it can be returned by perl's open() */
3060 PL_forkprocess = childpid;
3063 /* we have an fd, return a file stream */
3064 return (PerlIO_fdopen(p[parent], (char *)mode));
3067 /* we don't need to check for errors here */
3075 * a popen() clone that respects PERL5SHELL
3077 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3081 win32_popen(const char *command, const char *mode)
3083 #ifdef USE_RTL_POPEN
3084 return _popen(command, mode);
3086 return do_popen(mode, command, 0, NULL);
3087 #endif /* USE_RTL_POPEN */
3095 win32_pclose(PerlIO *pf)
3097 #ifdef USE_RTL_POPEN
3101 int childpid, status;
3104 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3107 childpid = SvIVX(sv);
3123 if (win32_waitpid(childpid, &status, 0) == -1)
3128 #endif /* USE_RTL_POPEN */
3132 win32_link(const char *oldname, const char *newname)
3135 WCHAR wOldName[MAX_PATH+1];
3136 WCHAR wNewName[MAX_PATH+1];
3138 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3139 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3140 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3141 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3145 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3146 both permissions errors and if the source is a directory, while
3147 POSIX wants EACCES and EPERM respectively.
3149 Determined by experimentation on Windows 7 x64 SP1, since MS
3150 don't document what error codes are returned.
3152 switch (GetLastError()) {
3153 case ERROR_BAD_NET_NAME:
3154 case ERROR_BAD_NETPATH:
3155 case ERROR_BAD_PATHNAME:
3156 case ERROR_FILE_NOT_FOUND:
3157 case ERROR_FILENAME_EXCED_RANGE:
3158 case ERROR_INVALID_DRIVE:
3159 case ERROR_PATH_NOT_FOUND:
3162 case ERROR_ALREADY_EXISTS:
3165 case ERROR_ACCESS_DENIED:
3168 case ERROR_NOT_SAME_DEVICE:
3171 case ERROR_DISK_FULL:
3174 case ERROR_NOT_ENOUGH_QUOTA:
3178 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3186 win32_rename(const char *oname, const char *newname)
3188 char szOldName[MAX_PATH+1];
3190 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3193 if (stricmp(newname, oname))
3194 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3195 strcpy(szOldName, PerlDir_mapA(oname));
3197 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3199 DWORD err = GetLastError();
3201 case ERROR_BAD_NET_NAME:
3202 case ERROR_BAD_NETPATH:
3203 case ERROR_BAD_PATHNAME:
3204 case ERROR_FILE_NOT_FOUND:
3205 case ERROR_FILENAME_EXCED_RANGE:
3206 case ERROR_INVALID_DRIVE:
3207 case ERROR_NO_MORE_FILES:
3208 case ERROR_PATH_NOT_FOUND:
3211 case ERROR_DISK_FULL:
3214 case ERROR_NOT_ENOUGH_QUOTA:
3227 win32_setmode(int fd, int mode)
3229 return setmode(fd, mode);
3233 win32_chsize(int fd, Off_t size)
3235 #if defined(WIN64) || defined(USE_LARGE_FILES)
3237 Off_t cur, end, extend;
3239 cur = win32_tell(fd);
3242 end = win32_lseek(fd, 0, SEEK_END);
3245 extend = size - end;
3249 else if (extend > 0) {
3250 /* must grow the file, padding with nulls */
3252 int oldmode = win32_setmode(fd, O_BINARY);
3254 memset(b, '\0', sizeof(b));
3256 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3257 count = win32_write(fd, b, count);
3258 if ((int)count < 0) {
3262 } while ((extend -= count) > 0);
3263 win32_setmode(fd, oldmode);
3266 /* shrink the file */
3267 win32_lseek(fd, size, SEEK_SET);
3268 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3273 win32_lseek(fd, cur, SEEK_SET);
3276 return chsize(fd, (long)size);
3281 win32_lseek(int fd, Off_t offset, int origin)
3283 #if defined(WIN64) || defined(USE_LARGE_FILES)
3284 return _lseeki64(fd, offset, origin);
3286 return lseek(fd, (long)offset, origin);
3293 #if defined(WIN64) || defined(USE_LARGE_FILES)
3294 return _telli64(fd);
3301 win32_open(const char *path, int flag, ...)
3308 pmode = va_arg(ap, int);
3311 if (stricmp(path, "/dev/null")==0)
3314 aTHXa(PERL_GET_THX);
3315 return open(PerlDir_mapA(path), flag, pmode);
3318 /* close() that understands socket */
3319 extern int my_close(int); /* in win32sck.c */
3324 #ifdef WIN32_NO_SOCKETS
3327 return my_close(fd);
3338 win32_isatty(int fd)
3340 /* The Microsoft isatty() function returns true for *all*
3341 * character mode devices, including "nul". Our implementation
3342 * should only return true if the handle has a console buffer.
3345 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3346 if (fh == (HANDLE)-1) {
3347 /* errno is already set to EBADF */
3351 if (GetConsoleMode(fh, &mode))
3365 win32_dup2(int fd1,int fd2)
3367 return dup2(fd1,fd2);
3371 win32_read(int fd, void *buf, unsigned int cnt)
3373 return read(fd, buf, cnt);
3377 win32_write(int fd, const void *buf, unsigned int cnt)
3379 return write(fd, buf, cnt);
3383 win32_mkdir(const char *dir, int mode)
3386 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3390 win32_rmdir(const char *dir)
3393 return rmdir(PerlDir_mapA(dir));
3397 win32_chdir(const char *dir)
3399 if (!dir || !*dir) {
3407 win32_access(const char *path, int mode)
3410 return access(PerlDir_mapA(path), mode);
3414 win32_chmod(const char *path, int mode)
3417 return chmod(PerlDir_mapA(path), mode);
3422 create_command_line(char *cname, STRLEN clen, const char * const *args)
3429 bool bat_file = FALSE;
3430 bool cmd_shell = FALSE;
3431 bool dumb_shell = FALSE;
3432 bool extra_quotes = FALSE;
3433 bool quote_next = FALSE;
3436 cname = (char*)args[0];
3438 /* The NT cmd.exe shell has the following peculiarity that needs to be
3439 * worked around. It strips a leading and trailing dquote when any
3440 * of the following is true:
3441 * 1. the /S switch was used
3442 * 2. there are more than two dquotes
3443 * 3. there is a special character from this set: &<>()@^|
3444 * 4. no whitespace characters within the two dquotes
3445 * 5. string between two dquotes isn't an executable file
3446 * To work around this, we always add a leading and trailing dquote
3447 * to the string, if the first argument is either "cmd.exe" or "cmd",
3448 * and there were at least two or more arguments passed to cmd.exe
3449 * (not including switches).
3450 * XXX the above rules (from "cmd /?") don't seem to be applied
3451 * always, making for the convolutions below :-(
3455 clen = strlen(cname);
3458 && (stricmp(&cname[clen-4], ".bat") == 0
3459 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3465 char *exe = strrchr(cname, '/');
3466 char *exe2 = strrchr(cname, '\\');
3473 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3477 else if (stricmp(exe, "command.com") == 0
3478 || stricmp(exe, "command") == 0)
3485 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3486 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3487 STRLEN curlen = strlen(arg);
3488 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3489 len += 2; /* assume quoting needed (worst case) */
3491 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3493 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3496 Newx(cmd, len, char);
3501 extra_quotes = TRUE;
3504 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3506 STRLEN curlen = strlen(arg);
3508 /* we want to protect empty arguments and ones with spaces with
3509 * dquotes, but only if they aren't already there */
3514 else if (quote_next) {
3515 /* see if it really is multiple arguments pretending to
3516 * be one and force a set of quotes around it */
3517 if (*find_next_space(arg))
3520 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3522 while (i < curlen) {
3523 if (isSPACE(arg[i])) {
3526 else if (arg[i] == '"') {
3550 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3551 && stricmp(arg+curlen-2, "/c") == 0)
3553 /* is there a next argument? */
3554 if (args[index+1]) {
3555 /* are there two or more next arguments? */
3556 if (args[index+2]) {
3558 extra_quotes = TRUE;
3561 /* single argument, force quoting if it has spaces */
3576 static const char *exe_extensions[] =
3578 ".exe", /* this must be first */
3584 qualified_path(const char *cmd, bool other_exts)
3587 char *fullcmd, *curfullcmd;
3593 fullcmd = (char*)cmd;
3595 if (*fullcmd == '/' || *fullcmd == '\\')
3604 pathstr = PerlEnv_getenv("PATH");
3606 /* worst case: PATH is a single directory; we need additional space
3607 * to append "/", ".exe" and trailing "\0" */
3608 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3609 curfullcmd = fullcmd;
3614 /* start by appending the name to the current prefix */
3615 strcpy(curfullcmd, cmd);
3616 curfullcmd += cmdlen;
3618 /* if it doesn't end with '.', or has no extension, try adding
3619 * a trailing .exe first */
3620 if (cmd[cmdlen-1] != '.'
3621 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3624 /* first extension is .exe */
3625 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3626 for (i = 0; i < ext_limit; ++i) {
3627 strcpy(curfullcmd, exe_extensions[i]);
3628 res = GetFileAttributes(fullcmd);
3629 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3636 /* that failed, try the bare name */
3637 res = GetFileAttributes(fullcmd);
3638 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3641 /* quit if no other path exists, or if cmd already has path */
3642 if (!pathstr || !*pathstr || has_slash)
3645 /* skip leading semis */
3646 while (*pathstr == ';')
3649 /* build a new prefix from scratch */
3650 curfullcmd = fullcmd;
3651 while (*pathstr && *pathstr != ';') {
3652 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3653 pathstr++; /* skip initial '"' */
3654 while (*pathstr && *pathstr != '"') {
3655 *curfullcmd++ = *pathstr++;
3658 pathstr++; /* skip trailing '"' */
3661 *curfullcmd++ = *pathstr++;
3665 pathstr++; /* skip trailing semi */
3666 if (curfullcmd > fullcmd /* append a dir separator */
3667 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3669 *curfullcmd++ = '\\';
3677 /* The following are just place holders.
3678 * Some hosts may provide and environment that the OS is
3679 * not tracking, therefore, these host must provide that
3680 * environment and the current directory to CreateProcess
3684 win32_get_childenv(void)
3690 win32_free_childenv(void* d)
3695 win32_clearenv(void)
3697 char *envv = GetEnvironmentStrings();
3701 char *end = strchr(cur,'=');
3702 if (end && end != cur) {
3704 SetEnvironmentVariable(cur, NULL);
3706 cur = end + strlen(end+1)+2;
3708 else if ((len = strlen(cur)))
3711 FreeEnvironmentStrings(envv);
3715 win32_get_childdir(void)
3718 char szfilename[MAX_PATH+1];
3720 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3721 Newx(ptr, strlen(szfilename)+1, char);
3722 strcpy(ptr, szfilename);
3727 win32_free_childdir(char* d)
3733 /* XXX this needs to be made more compatible with the spawnvp()
3734 * provided by the various RTLs. In particular, searching for
3735 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3736 * This doesn't significantly affect perl itself, because we
3737 * always invoke things using PERL5SHELL if a direct attempt to
3738 * spawn the executable fails.
3740 * XXX splitting and rejoining the commandline between do_aspawn()
3741 * and win32_spawnvp() could also be avoided.
3745 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3747 #ifdef USE_RTL_SPAWNVP
3748 return _spawnvp(mode, cmdname, (char * const *)argv);
3750 return do_spawnvp_handles(mode, cmdname, argv, NULL);
3755 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3756 const int *handles) {
3762 STARTUPINFO StartupInfo;
3763 PROCESS_INFORMATION ProcessInformation;
3766 char *fullcmd = NULL;
3767 char *cname = (char *)cmdname;
3771 clen = strlen(cname);
3772 /* if command name contains dquotes, must remove them */
3773 if (strchr(cname, '"')) {
3775 Newx(cname,clen+1,char);
3788 cmd = create_command_line(cname, clen, argv);
3790 aTHXa(PERL_GET_THX);
3791 env = PerlEnv_get_childenv();
3792 dir = PerlEnv_get_childdir();
3795 case P_NOWAIT: /* asynch + remember result */
3796 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3801 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3804 create |= CREATE_NEW_PROCESS_GROUP;
3807 case P_WAIT: /* synchronous execution */
3809 default: /* invalid mode */
3815 memset(&StartupInfo,0,sizeof(StartupInfo));
3816 StartupInfo.cb = sizeof(StartupInfo);
3817 memset(&tbl,0,sizeof(tbl));
3818 PerlEnv_get_child_IO(&tbl);
3819 StartupInfo.dwFlags = tbl.dwFlags;
3820 StartupInfo.dwX = tbl.dwX;
3821 StartupInfo.dwY = tbl.dwY;
3822 StartupInfo.dwXSize = tbl.dwXSize;
3823 StartupInfo.dwYSize = tbl.dwYSize;
3824 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3825 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3826 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3827 StartupInfo.wShowWindow = tbl.wShowWindow;
3828 StartupInfo.hStdInput = handles && handles[0] != -1 ?
3829 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3830 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
3831 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3832 StartupInfo.hStdError = handles && handles[2] != -1 ?
3833 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3834 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3835 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3836 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3838 create |= CREATE_NEW_CONSOLE;
3841 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3843 if (w32_use_showwindow) {
3844 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3845 StartupInfo.wShowWindow = w32_showwindow;
3848 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3851 if (!CreateProcess(cname, /* search PATH to find executable */
3852 cmd, /* executable, and its arguments */
3853 NULL, /* process attributes */
3854 NULL, /* thread attributes */
3855 TRUE, /* inherit handles */
3856 create, /* creation flags */
3857 (LPVOID)env, /* inherit environment */
3858 dir, /* inherit cwd */
3860 &ProcessInformation))
3862 /* initial NULL argument to CreateProcess() does a PATH
3863 * search, but it always first looks in the directory
3864 * where the current process was started, which behavior
3865 * is undesirable for backward compatibility. So we
3866 * jump through our own hoops by picking out the path
3867 * we really want it to use. */
3869 fullcmd = qualified_path(cname, FALSE);
3871 if (cname != cmdname)
3874 DEBUG_p(PerlIO_printf(Perl_debug_log,
3875 "Retrying [%s] with same args\n",
3885 if (mode == P_NOWAIT) {
3886 /* asynchronous spawn -- store handle, return PID */
3887 ret = (int)ProcessInformation.dwProcessId;
3889 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3890 w32_child_pids[w32_num_children] = (DWORD)ret;
3895 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3896 /* FIXME: if msgwait returned due to message perhaps forward the
3897 "signal" to the process
3899 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3901 CloseHandle(ProcessInformation.hProcess);
3904 CloseHandle(ProcessInformation.hThread);
3907 PerlEnv_free_childenv(env);
3908 PerlEnv_free_childdir(dir);
3910 if (cname != cmdname)
3916 win32_execv(const char *cmdname, const char *const *argv)
3920 /* if this is a pseudo-forked child, we just want to spawn
3921 * the new program, and return */
3923 return _spawnv(P_WAIT, cmdname, argv);
3925 return _execv(cmdname, argv);
3929 win32_execvp(const char *cmdname, const char *const *argv)
3933 /* if this is a pseudo-forked child, we just want to spawn
3934 * the new program, and return */
3935 if (w32_pseudo_id) {
3936 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3945 return _execvp(cmdname, argv);
3949 win32_perror(const char *str)
3955 win32_setbuf(FILE *pf, char *buf)
3961 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3963 return setvbuf(pf, buf, type, size);
3967 win32_flushall(void)
3973 win32_fcloseall(void)
3979 win32_fgets(char *s, int n, FILE *pf)
3981 return fgets(s, n, pf);
3991 win32_fgetc(FILE *pf)
3997 win32_putc(int c, FILE *pf)
4003 win32_puts(const char *s)
4015 win32_putchar(int c)
4022 #ifndef USE_PERL_SBRK
4024 static char *committed = NULL; /* XXX threadead */
4025 static char *base = NULL; /* XXX threadead */
4026 static char *reserved = NULL; /* XXX threadead */
4027 static char *brk = NULL; /* XXX threadead */
4028 static DWORD pagesize = 0; /* XXX threadead */
4031 sbrk(ptrdiff_t need)
4036 GetSystemInfo(&info);
4037 /* Pretend page size is larger so we don't perpetually
4038 * call the OS to commit just one page ...
4040 pagesize = info.dwPageSize << 3;
4042 if (brk+need >= reserved)
4044 DWORD size = brk+need-reserved;
4046 char *prev_committed = NULL;
4047 if (committed && reserved && committed < reserved)
4049 /* Commit last of previous chunk cannot span allocations */
4050 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4053 /* Remember where we committed from in case we want to decommit later */
4054 prev_committed = committed;
4055 committed = reserved;
4058 /* Reserve some (more) space
4059 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4060 * this is only address space not memory...
4061 * Note this is a little sneaky, 1st call passes NULL as reserved
4062 * so lets system choose where we start, subsequent calls pass
4063 * the old end address so ask for a contiguous block
4066 if (size < 64*1024*1024)
4067 size = 64*1024*1024;
4068 size = ((size + pagesize - 1) / pagesize) * pagesize;
4069 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4072 reserved = addr+size;
4082 /* The existing block could not be extended far enough, so decommit
4083 * anything that was just committed above and start anew */
4086 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4089 reserved = base = committed = brk = NULL;
4100 if (brk > committed)
4102 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4104 if (committed+size > reserved)
4105 size = reserved-committed;
4106 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4119 win32_malloc(size_t size)
4121 return malloc(size);
4125 win32_calloc(size_t numitems, size_t size)
4127 return calloc(numitems,size);
4131 win32_realloc(void *block, size_t size)
4133 return realloc(block,size);
4137 win32_free(void *block)
4144 win32_open_osfhandle(intptr_t handle, int flags)
4146 return _open_osfhandle(handle, flags);
4150 win32_get_osfhandle(int fd)
4152 return (intptr_t)_get_osfhandle(fd);
4156 win32_fdupopen(FILE *pf)
4161 int fileno = win32_dup(win32_fileno(pf));
4163 /* open the file in the same mode */
4164 if((pf)->_flag & _IOREAD) {
4168 else if((pf)->_flag & _IOWRT) {
4172 else if((pf)->_flag & _IORW) {
4178 /* it appears that the binmode is attached to the
4179 * file descriptor so binmode files will be handled
4182 pfdup = win32_fdopen(fileno, mode);
4184 /* move the file pointer to the same position */
4185 if (!fgetpos(pf, &pos)) {
4186 fsetpos(pfdup, &pos);
4192 win32_dynaload(const char* filename)
4195 char buf[MAX_PATH+1];
4198 /* LoadLibrary() doesn't recognize forward slashes correctly,
4199 * so turn 'em back. */
4200 first = strchr(filename, '/');
4202 STRLEN len = strlen(filename);
4203 if (len <= MAX_PATH) {
4204 strcpy(buf, filename);
4205 filename = &buf[first - filename];
4207 if (*filename == '/')
4208 *(char*)filename = '\\';
4214 aTHXa(PERL_GET_THX);
4215 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4218 XS(w32_SetChildShowWindow)
4221 BOOL use_showwindow = w32_use_showwindow;
4222 /* use "unsigned short" because Perl has redefined "WORD" */
4223 unsigned short showwindow = w32_showwindow;
4226 croak_xs_usage(cv, "[showwindow]");
4228 if (items == 0 || !SvOK(ST(0)))
4229 w32_use_showwindow = FALSE;
4231 w32_use_showwindow = TRUE;
4232 w32_showwindow = (unsigned short)SvIV(ST(0));
4237 ST(0) = sv_2mortal(newSViv(showwindow));
4239 ST(0) = &PL_sv_undef;
4244 #ifdef PERL_IS_MINIPERL
4245 /* shelling out is much slower, full perl uses Win32.pm */
4249 /* Make the host for current directory */
4250 char* ptr = PerlEnv_get_childdir();
4253 * then it worked, set PV valid,
4254 * else return 'undef'
4257 SV *sv = sv_newmortal();
4259 PerlEnv_free_childdir(ptr);
4261 #ifndef INCOMPLETE_TAINTS
4273 Perl_init_os_extras(void)
4276 char *file = __FILE__;
4278 /* Initialize Win32CORE if it has been statically linked. */
4279 #ifndef PERL_IS_MINIPERL
4280 void (*pfn_init)(pTHX);
4281 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4282 ? GetModuleHandle(NULL)
4283 : w32_perldll_handle);
4284 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4285 aTHXa(PERL_GET_THX);
4289 aTHXa(PERL_GET_THX);
4292 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4293 #ifdef PERL_IS_MINIPERL
4294 newXS("Win32::GetCwd", w32_GetCwd, file);
4299 win32_signal_context(void)
4304 my_perl = PL_curinterp;
4305 PERL_SET_THX(my_perl);
4309 return PL_curinterp;
4315 win32_ctrlhandler(DWORD dwCtrlType)
4318 dTHXa(PERL_GET_SIG_CONTEXT);
4324 switch(dwCtrlType) {
4325 case CTRL_CLOSE_EVENT:
4326 /* A signal that the system sends to all processes attached to a console when
4327 the user closes the console (either by choosing the Close command from the
4328 console window's System menu, or by choosing the End Task command from the
4331 if (do_raise(aTHX_ 1)) /* SIGHUP */
4332 sig_terminate(aTHX_ 1);
4336 /* A CTRL+c signal was received */
4337 if (do_raise(aTHX_ SIGINT))
4338 sig_terminate(aTHX_ SIGINT);
4341 case CTRL_BREAK_EVENT:
4342 /* A CTRL+BREAK signal was received */
4343 if (do_raise(aTHX_ SIGBREAK))
4344 sig_terminate(aTHX_ SIGBREAK);
4347 case CTRL_LOGOFF_EVENT:
4348 /* A signal that the system sends to all console processes when a user is logging
4349 off. This signal does not indicate which user is logging off, so no
4350 assumptions can be made.
4353 case CTRL_SHUTDOWN_EVENT:
4354 /* A signal that the system sends to all console processes when the system is
4357 if (do_raise(aTHX_ SIGTERM))
4358 sig_terminate(aTHX_ SIGTERM);
4367 #ifdef SET_INVALID_PARAMETER_HANDLER
4368 # include <crtdbg.h>
4379 /* fetch Unicode version of PATH */
4381 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4383 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4385 win32_free(wide_path);
4391 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4396 /* convert to ANSI pathnames */
4397 wide_dir = wide_path;
4400 WCHAR *sep = wcschr(wide_dir, ';');
4408 /* remove quotes around pathname */
4409 if (*wide_dir == '"')
4411 wide_len = wcslen(wide_dir);
4412 if (wide_len && wide_dir[wide_len-1] == '"')
4413 wide_dir[wide_len-1] = '\0';
4415 /* append ansi_dir to ansi_path */
4416 ansi_dir = win32_ansipath(wide_dir);
4417 ansi_len = strlen(ansi_dir);
4419 size_t newlen = len + 1 + ansi_len;
4420 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4423 ansi_path[len] = ';';
4424 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4429 ansi_path = (char*)win32_malloc(5+len+1);
4432 memcpy(ansi_path, "PATH=", 5);
4433 memcpy(ansi_path+5, ansi_dir, len+1);
4436 win32_free(ansi_dir);
4441 /* Update C RTL environ array. This will only have full effect if
4442 * perl_parse() is later called with `environ` as the `env` argument.
4443 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4445 * We do have to ansify() the PATH before Perl has been fully
4446 * initialized because S_find_script() uses the PATH when perl
4447 * is being invoked with the -S option. This happens before %ENV
4448 * is initialized in S_init_postdump_symbols().
4450 * XXX Is this a bug? Should S_find_script() use the environment
4451 * XXX passed in the `env` arg to parse_perl()?
4454 /* Keep system environment in sync because S_init_postdump_symbols()
4455 * will not call mg_set() if it initializes %ENV from `environ`.
4457 SetEnvironmentVariableA("PATH", ansi_path+5);
4458 win32_free(ansi_path);
4460 win32_free(wide_path);
4464 Perl_win32_init(int *argcp, char ***argvp)
4466 #ifdef SET_INVALID_PARAMETER_HANDLER
4467 _invalid_parameter_handler oldHandler, newHandler;
4468 newHandler = my_invalid_parameter_handler;
4469 oldHandler = _set_invalid_parameter_handler(newHandler);
4470 _CrtSetReportMode(_CRT_ASSERT, 0);
4472 /* Disable floating point errors, Perl will trap the ones we
4473 * care about. VC++ RTL defaults to switching these off
4474 * already, but some RTLs don't. Since we don't
4475 * want to be at the vendor's whim on the default, we set
4476 * it explicitly here.
4478 #if !defined(__GNUC__)
4479 _control87(MCW_EM, MCW_EM);
4483 /* When the manifest resource requests Common-Controls v6 then
4484 * user32.dll no longer registers all the Windows classes used for
4485 * standard controls but leaves some of them to be registered by
4486 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4487 * it makes sure comctl32.dll gets loaded into the process and registers
4488 * the standard control classes. Without this even normal Windows APIs
4489 * like MessageBox() can fail under some versions of Windows XP.
4491 InitCommonControls();
4493 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4494 GetVersionEx(&g_osver);
4496 #ifdef WIN32_DYN_IOINFO_SIZE
4498 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4499 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4500 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4503 ioinfo_size /= IOINFO_ARRAY_ELTS;
4504 w32_ioinfo_size = ioinfo_size;
4510 #ifndef WIN32_NO_REGISTRY
4513 retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
4514 if (retval != ERROR_SUCCESS) {
4515 HKCU_Perl_hnd = NULL;
4517 retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
4518 if (retval != ERROR_SUCCESS) {
4519 HKLM_Perl_hnd = NULL;
4526 Perl_win32_term(void)
4533 #ifndef WIN32_NO_REGISTRY
4534 /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
4535 but no point of checking and we can't die() at this point */
4536 RegCloseKey(HKLM_Perl_hnd);
4537 RegCloseKey(HKCU_Perl_hnd);
4538 /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
4543 win32_get_child_IO(child_IO_table* ptbl)
4545 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4546 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4547 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4551 win32_signal(int sig, Sighandler_t subcode)
4554 if (sig < SIG_SIZE) {
4555 int save_errno = errno;
4556 Sighandler_t result;
4557 #ifdef SET_INVALID_PARAMETER_HANDLER
4558 /* Silence our invalid parameter handler since we expect to make some
4559 * calls with invalid signal numbers giving a SIG_ERR result. */
4560 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4562 result = signal(sig, subcode);
4563 #ifdef SET_INVALID_PARAMETER_HANDLER
4564 set_silent_invalid_parameter_handler(oldvalue);
4566 aTHXa(PERL_GET_THX);
4567 if (result == SIG_ERR) {
4568 result = w32_sighandler[sig];
4571 w32_sighandler[sig] = subcode;
4580 /* The PerlMessageWindowClass's WindowProc */
4582 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4584 return win32_process_message(hwnd, msg, wParam, lParam) ?
4585 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4588 /* The real message handler. Can be called with
4589 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4590 * that it processes */
4592 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4594 /* BEWARE. The context retrieved using dTHX; is the context of the
4595 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4596 * up to and including WM_CREATE. If it ever happens that you need the
4597 * 'child' context before this, then it needs to be passed into
4598 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4599 * from the lparam of CreateWindow(). It could then be stored/retrieved
4600 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4601 * the dTHX calls here. */
4602 /* XXX For now it is assumed that the overhead of the dTHX; for what
4603 * are relativley infrequent code-paths, is better than the added
4604 * complexity of getting the correct context passed into
4605 * win32_create_message_window() */
4611 case WM_USER_MESSAGE: {
4612 long child = find_pseudo_pid(aTHX_ (int)wParam);
4614 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4621 case WM_USER_KILL: {
4622 /* We use WM_USER_KILL to fake kill() with other signals */
4623 int sig = (int)wParam;
4624 if (do_raise(aTHX_ sig))
4625 sig_terminate(aTHX_ sig);
4631 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4632 if (w32_timerid && w32_timerid==(UINT)wParam) {
4633 KillTimer(w32_message_hwnd, w32_timerid);
4636 /* Now fake a call to signal handler */
4637 if (do_raise(aTHX_ 14))
4638 sig_terminate(aTHX_ 14);
4650 /* Above or other stuff may have set a signal flag, and we may not have
4651 * been called from win32_async_check() (e.g. some other GUI's message
4652 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4653 * handler that die's, and the message loop that calls here is wrapped
4654 * in an eval, then you may well end up with orphaned windows - signals
4655 * are dispatched by win32_async_check() */
4661 win32_create_message_window_class(void)
4663 /* create the window class for "message only" windows */
4667 wc.lpfnWndProc = win32_message_window_proc;
4668 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4669 wc.lpszClassName = "PerlMessageWindowClass";
4671 /* second and subsequent calls will fail, but class
4672 * will already be registered */
4677 win32_create_message_window(void)
4679 win32_create_message_window_class();
4680 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4681 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4684 #ifdef HAVE_INTERP_INTERN
4687 win32_csighandler(int sig)
4690 dTHXa(PERL_GET_SIG_CONTEXT);
4691 Perl_warn(aTHX_ "Got signal %d",sig);
4696 #if defined(__MINGW32__) && defined(__cplusplus)
4697 #define CAST_HWND__(x) (HWND__*)(x)
4699 #define CAST_HWND__(x) x
4703 Perl_sys_intern_init(pTHX)
4707 w32_perlshell_tokens = NULL;
4708 w32_perlshell_vec = (char**)NULL;
4709 w32_perlshell_items = 0;
4710 w32_fdpid = newAV();
4711 Newx(w32_children, 1, child_tab);
4712 w32_num_children = 0;
4713 # ifdef USE_ITHREADS
4715 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4716 w32_num_pseudo_children = 0;
4719 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4721 #ifdef PERL_IS_MINIPERL
4722 w32_sloppystat = TRUE;
4724 w32_sloppystat = FALSE;
4726 for (i=0; i < SIG_SIZE; i++) {
4727 w32_sighandler[i] = SIG_DFL;
4729 # ifdef MULTIPLICITY
4730 if (my_perl == PL_curinterp) {
4734 /* Force C runtime signal stuff to set its console handler */
4735 signal(SIGINT,win32_csighandler);
4736 signal(SIGBREAK,win32_csighandler);
4738 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4739 * flag. This has the side-effect of disabling Ctrl-C events in all
4740 * processes in this group.
4741 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4742 * with a NULL handler.
4744 SetConsoleCtrlHandler(NULL,FALSE);
4746 /* Push our handler on top */
4747 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4752 Perl_sys_intern_clear(pTHX)
4754 Safefree(w32_perlshell_tokens);
4755 Safefree(w32_perlshell_vec);
4756 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4757 Safefree(w32_children);
4759 KillTimer(w32_message_hwnd, w32_timerid);
4762 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4763 DestroyWindow(w32_message_hwnd);
4764 # ifdef MULTIPLICITY
4765 if (my_perl == PL_curinterp) {
4769 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4771 # ifdef USE_ITHREADS
4772 Safefree(w32_pseudo_children);
4776 # ifdef USE_ITHREADS
4779 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4781 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4783 dst->perlshell_tokens = NULL;
4784 dst->perlshell_vec = (char**)NULL;
4785 dst->perlshell_items = 0;
4786 dst->fdpid = newAV();
4787 Newxz(dst->children, 1, child_tab);
4789 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4791 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4792 dst->poll_count = 0;
4793 dst->sloppystat = src->sloppystat;
4794 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4796 # endif /* USE_ITHREADS */
4797 #endif /* HAVE_INTERP_INTERN */