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>
70 /* Mingw32 defaults to globing command line
71 * So we turn it off like this:
76 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
77 /* Mingw32-1.1 is missing some prototypes */
79 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
89 #define EXECF_SPAWN_NOWAIT 3
91 #if defined(PERL_IMPLICIT_SYS)
93 # define getlogin g_getlogin
96 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
97 * parameter handler. This functionality is not available in the
98 * 64-bit compiler from the Platform SDK, which unfortunately also
99 * believes itself to be MSC version 14.
101 * There is no #define related to _set_invalid_parameter_handler(),
102 * but we can check for one of the constants defined for
103 * _set_abort_behavior(), which was introduced into stdlib.h at
107 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
108 # define SET_INVALID_PARAMETER_HANDLER
111 #ifdef SET_INVALID_PARAMETER_HANDLER
112 static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
113 static void my_invalid_parameter_handler(const wchar_t* expression,
114 const wchar_t* function, const wchar_t* file,
115 unsigned int line, uintptr_t pReserved);
118 #ifndef WIN32_NO_REGISTRY
119 static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
120 static char* get_regstr(const char *valuename, SV **svp);
123 static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
124 char *trailing, ...);
125 static char* win32_get_xlib(const char *pl,
126 WIN32_NO_REGISTRY_M_(const char *xlib)
127 const char *libname, STRLEN *const len);
129 static BOOL has_shell_metachars(const char *ptr);
130 static long tokenize(const char *str, char **dest, char ***destv);
131 static void get_shell(void);
132 static char* find_next_space(const char *s);
133 static int do_spawn2(pTHX_ const char *cmd, int exectype);
134 static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
136 static int do_spawnvp_handles(int mode, const char *cmdname,
137 const char * const *argv, const int *handles);
138 static PerlIO * do_popen(const char *mode, const char *command, IV narg,
140 static long find_pid(pTHX_ int pid);
141 static void remove_dead_process(long child);
142 static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
143 static int my_killpg(int pid, int sig);
144 static int my_kill(int pid, int sig);
145 static void out_of_memory(void);
146 static char* wstr_to_str(const wchar_t* wstr);
147 static long filetime_to_clock(PFILETIME ft);
148 static BOOL filetime_from_time(PFILETIME ft, time_t t);
149 static char* create_command_line(char *cname, STRLEN clen,
150 const char * const *args);
151 static char* qualified_path(const char *cmd, bool other_exts);
152 static void ansify_path(void);
153 static LRESULT win32_process_message(HWND hwnd, UINT msg,
154 WPARAM wParam, LPARAM lParam);
157 static long find_pseudo_pid(pTHX_ int pid);
158 static void remove_dead_pseudo_process(long child);
159 static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
162 #ifdef HAVE_INTERP_INTERN
163 static void win32_csighandler(int sig);
167 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
168 char w32_module_name[MAX_PATH+1];
169 #ifdef WIN32_DYN_IOINFO_SIZE
170 Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
174 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
176 #ifndef WIN32_NO_REGISTRY
177 /* initialized by Perl_win32_init/PERL_SYS_INIT */
178 static HKEY HKCU_Perl_hnd;
179 static HKEY HKLM_Perl_hnd;
182 #ifdef SET_INVALID_PARAMETER_HANDLER
183 static BOOL silent_invalid_parameter_handler = FALSE;
186 set_silent_invalid_parameter_handler(BOOL newvalue)
188 BOOL oldvalue = silent_invalid_parameter_handler;
190 silent_invalid_parameter_handler = newvalue;
196 my_invalid_parameter_handler(const wchar_t* expression,
197 const wchar_t* function,
203 char* ansi_expression;
206 if (silent_invalid_parameter_handler)
208 ansi_expression = wstr_to_str(expression);
209 ansi_function = wstr_to_str(function);
210 ansi_file = wstr_to_str(file);
211 fprintf(stderr, "Invalid parameter detected in function %s. "
212 "File: %s, line: %d\n", ansi_function, ansi_file, line);
213 fprintf(stderr, "Expression: %s\n", ansi_expression);
214 free(ansi_expression);
222 set_w32_module_name(void)
224 /* this function may be called at DLL_PROCESS_ATTACH time */
226 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
227 ? GetModuleHandle(NULL)
228 : w32_perldll_handle);
230 WCHAR modulename[MAX_PATH];
231 WCHAR fullname[MAX_PATH];
234 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
235 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
236 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
238 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
240 /* Make sure we get an absolute pathname in case the module was loaded
241 * explicitly by LoadLibrary() with a relative path. */
242 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
244 /* Make sure we start with the long path name of the module because we
245 * later scan for pathname components to match "5.xx" to locate
246 * compatible sitelib directories, and the short pathname might mangle
247 * this path segment (e.g. by removing the dot on NTFS to something
248 * like "5xx~1.yy") */
249 if (pfnGetLongPathNameW)
250 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
252 /* remove \\?\ prefix */
253 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
254 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
256 ansi = win32_ansipath(fullname);
257 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
260 /* normalize to forward slashes */
261 ptr = w32_module_name;
269 #ifndef WIN32_NO_REGISTRY
270 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
272 get_regstr_from(HKEY handle, const char *valuename, SV **svp)
274 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
280 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
281 if (retval == ERROR_SUCCESS
282 && (type == REG_SZ || type == REG_EXPAND_SZ))
286 *svp = sv_2mortal(newSVpvs(""));
287 SvGROW(*svp, datalen);
288 retval = RegQueryValueEx(handle, valuename, 0, NULL,
289 (PBYTE)SvPVX(*svp), &datalen);
290 if (retval == ERROR_SUCCESS) {
292 SvCUR_set(*svp,datalen-1);
298 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
300 get_regstr(const char *valuename, SV **svp)
304 str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
311 str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
317 #endif /* ifndef WIN32_NO_REGISTRY */
319 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
321 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
325 char mod_name[MAX_PATH+1];
331 va_start(ap, trailing_path);
332 strip = va_arg(ap, char *);
334 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
335 baselen = strlen(base);
337 if (!*w32_module_name) {
338 set_w32_module_name();
340 strcpy(mod_name, w32_module_name);
341 ptr = strrchr(mod_name, '/');
342 while (ptr && strip) {
343 /* look for directories to skip back */
346 ptr = strrchr(mod_name, '/');
347 /* avoid stripping component if there is no slash,
348 * or it doesn't match ... */
349 if (!ptr || stricmp(ptr+1, strip) != 0) {
350 /* ... but not if component matches m|5\.$patchlevel.*| */
351 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
352 && strnEQ(strip, base, baselen)
353 && strnEQ(ptr+1, base, baselen)))
359 strip = va_arg(ap, char *);
367 strcpy(++ptr, trailing_path);
369 /* only add directory if it exists */
370 if (GetFileAttributes(mod_name) != (DWORD) -1) {
371 /* directory exists */
374 *prev_pathp = sv_2mortal(newSVpvs(""));
375 else if (SvPVX(*prev_pathp))
376 sv_catpvs(*prev_pathp, ";");
377 sv_catpv(*prev_pathp, mod_name);
379 *len = SvCUR(*prev_pathp);
380 return SvPVX(*prev_pathp);
387 win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
389 char *stdlib = "lib";
391 #ifndef WIN32_NO_REGISTRY
392 char buffer[MAX_PATH+1];
394 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
395 sprintf(buffer, "%s-%s", stdlib, pl);
396 if (!get_regstr(buffer, &sv))
397 (void)get_regstr(stdlib, &sv);
400 /* $stdlib .= ";$EMD/../../lib" */
401 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
405 win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib)
406 const char *libname, STRLEN *const len)
408 #ifndef WIN32_NO_REGISTRY
411 char pathstr[MAX_PATH+1];
415 #ifndef WIN32_NO_REGISTRY
416 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
417 sprintf(regstr, "%s-%s", xlib, pl);
418 (void)get_regstr(regstr, &sv1);
422 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
423 sprintf(pathstr, "%s/%s/lib", libname, pl);
424 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
426 #ifndef WIN32_NO_REGISTRY
427 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
428 (void)get_regstr(xlib, &sv2);
432 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
433 sprintf(pathstr, "%s/lib", libname);
434 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
452 win32_get_sitelib(const char *pl, STRLEN *const len)
454 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len);
457 #ifndef PERL_VENDORLIB_NAME
458 # define PERL_VENDORLIB_NAME "vendor"
462 win32_get_vendorlib(const char *pl, STRLEN *const len)
464 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len);
468 has_shell_metachars(const char *ptr)
474 * Scan string looking for redirection (< or >) or pipe
475 * characters (|) that are not in a quoted string.
476 * Shell variable interpolation (%VAR%) can also happen inside strings.
508 #if !defined(PERL_IMPLICIT_SYS)
509 /* since the current process environment is being updated in util.c
510 * the library functions will get the correct environment
513 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
515 PERL_FLUSHALL_FOR_CHILD;
516 return win32_popen(cmd, mode);
520 Perl_my_pclose(pTHX_ PerlIO *fp)
522 return win32_pclose(fp);
526 DllExport unsigned long
529 return (unsigned long)g_osver.dwPlatformId;
538 return -((int)w32_pseudo_id);
543 /* Tokenize a string. Words are null-separated, and the list
544 * ends with a doubled null. Any character (except null and
545 * including backslash) may be escaped by preceding it with a
546 * backslash (the backslash will be stripped).
547 * Returns number of words in result buffer.
550 tokenize(const char *str, char **dest, char ***destv)
552 char *retstart = NULL;
553 char **retvstart = 0;
556 int slen = strlen(str);
559 Newx(ret, slen+2, char);
560 Newx(retv, (slen+3)/2, char*);
568 if (*ret == '\\' && *str)
570 else if (*ret == ' ') {
586 retvstart[items] = NULL;
599 if (!w32_perlshell_tokens) {
600 /* we don't use COMSPEC here for two reasons:
601 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
602 * uncontrolled unportability of the ensuing scripts.
603 * 2. PERL5SHELL could be set to a shell that may not be fit for
604 * interactive use (which is what most programs look in COMSPEC
607 const char* defaultshell = "cmd.exe /x/d/c";
608 const char *usershell = PerlEnv_getenv("PERL5SHELL");
609 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
610 &w32_perlshell_tokens,
616 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
625 PERL_ARGS_ASSERT_DO_ASPAWN;
631 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
633 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
638 while (++mark <= sp) {
639 if (*mark && (str = SvPV_nolen(*mark)))
646 status = win32_spawnvp(flag,
647 (const char*)(really ? SvPV_nolen(really) : argv[0]),
648 (const char* const*)argv);
650 if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) {
651 /* possible shell-builtin, invoke with shell */
653 sh_items = w32_perlshell_items;
655 argv[index+sh_items] = argv[index];
656 while (--sh_items >= 0)
657 argv[sh_items] = w32_perlshell_vec[sh_items];
659 status = win32_spawnvp(flag,
660 (const char*)(really ? SvPV_nolen(really) : argv[0]),
661 (const char* const*)argv);
664 if (flag == P_NOWAIT) {
665 PL_statusvalue = -1; /* >16bits hint for pp_system() */
669 if (ckWARN(WARN_EXEC))
670 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
675 PL_statusvalue = status;
681 /* returns pointer to the next unquoted space or the end of the string */
683 find_next_space(const char *s)
685 bool in_quotes = FALSE;
687 /* ignore doubled backslashes, or backslash+quote */
688 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
691 /* keep track of when we're within quotes */
692 else if (*s == '"') {
694 in_quotes = !in_quotes;
696 /* break it up only at spaces that aren't in quotes */
697 else if (!in_quotes && isSPACE(*s))
706 do_spawn2(pTHX_ const char *cmd, int exectype) {
707 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
711 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
717 BOOL needToTry = TRUE;
720 /* Save an extra exec if possible. See if there are shell
721 * metacharacters in it */
722 if (!has_shell_metachars(cmd)) {
723 Newx(argv, strlen(cmd) / 2 + 2, char*);
724 Newx(cmd2, strlen(cmd) + 1, char);
727 for (s = cmd2; *s;) {
728 while (*s && isSPACE(*s))
732 s = find_next_space(s);
740 status = win32_spawnvp(P_WAIT, argv[0],
741 (const char* const*)argv);
743 case EXECF_SPAWN_NOWAIT:
744 status = do_spawnvp_handles(P_NOWAIT, argv[0],
745 (const char* const*)argv, handles);
748 status = win32_execvp(argv[0], (const char* const*)argv);
751 if (status != -1 || errno == 0)
761 Newx(argv, w32_perlshell_items + 2, char*);
762 while (++i < w32_perlshell_items)
763 argv[i] = w32_perlshell_vec[i];
764 argv[i++] = (char *)cmd;
768 status = win32_spawnvp(P_WAIT, argv[0],
769 (const char* const*)argv);
771 case EXECF_SPAWN_NOWAIT:
772 status = do_spawnvp_handles(P_NOWAIT, argv[0],
773 (const char* const*)argv, handles);
776 status = win32_execvp(argv[0], (const char* const*)argv);
782 if (exectype == EXECF_SPAWN_NOWAIT) {
783 PL_statusvalue = -1; /* >16bits hint for pp_system() */
787 if (ckWARN(WARN_EXEC))
788 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
789 (exectype == EXECF_EXEC ? "exec" : "spawn"),
790 cmd, strerror(errno));
795 PL_statusvalue = status;
801 Perl_do_spawn(pTHX_ char *cmd)
803 PERL_ARGS_ASSERT_DO_SPAWN;
805 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
809 Perl_do_spawn_nowait(pTHX_ char *cmd)
811 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
813 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
817 Perl_do_exec(pTHX_ const char *cmd)
819 PERL_ARGS_ASSERT_DO_EXEC;
821 do_spawn2(aTHX_ cmd, EXECF_EXEC);
825 /* The idea here is to read all the directory names into a string table
826 * (separated by nulls) and when one of the other dir functions is called
827 * return the pointer to the current file name.
830 win32_opendir(const char *filename)
836 char scanname[MAX_PATH+3];
837 WCHAR wscanname[sizeof(scanname)];
838 WIN32_FIND_DATAW wFindData;
839 char buffer[MAX_PATH*2];
842 len = strlen(filename);
847 if (len > MAX_PATH) {
848 errno = ENAMETOOLONG;
852 /* Get us a DIR structure */
855 /* Create the search pattern */
856 strcpy(scanname, filename);
858 /* bare drive name means look in cwd for drive */
859 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
860 scanname[len++] = '.';
861 scanname[len++] = '/';
863 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
864 scanname[len++] = '/';
866 scanname[len++] = '*';
867 scanname[len] = '\0';
869 /* do the FindFirstFile call */
870 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
872 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
874 if (dirp->handle == INVALID_HANDLE_VALUE) {
875 DWORD err = GetLastError();
876 /* FindFirstFile() fails on empty drives! */
878 case ERROR_FILE_NOT_FOUND:
880 case ERROR_NO_MORE_FILES:
881 case ERROR_PATH_NOT_FOUND:
884 case ERROR_NOT_ENOUGH_MEMORY:
896 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
897 wFindData.cFileName, -1,
898 buffer, sizeof(buffer), NULL, &use_default);
899 if (use_default && *wFindData.cAlternateFileName) {
900 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
901 wFindData.cAlternateFileName, -1,
902 buffer, sizeof(buffer), NULL, NULL);
905 /* now allocate the first part of the string table for
906 * the filenames that we find.
908 idx = strlen(buffer)+1;
913 Newx(dirp->start, dirp->size, char);
914 strcpy(dirp->start, buffer);
916 dirp->end = dirp->curr = dirp->start;
922 /* Readdir just returns the current string pointer and bumps the
923 * string pointer to the nDllExport entry.
925 DllExport struct direct *
926 win32_readdir(DIR *dirp)
931 /* first set up the structure to return */
932 len = strlen(dirp->curr);
933 strcpy(dirp->dirstr.d_name, dirp->curr);
934 dirp->dirstr.d_namlen = len;
937 dirp->dirstr.d_ino = dirp->curr - dirp->start;
939 /* Now set up for the next call to readdir */
940 dirp->curr += len + 1;
941 if (dirp->curr >= dirp->end) {
943 char buffer[MAX_PATH*2];
945 if (dirp->handle == INVALID_HANDLE_VALUE) {
948 /* finding the next file that matches the wildcard
949 * (which should be all of them in this directory!).
952 WIN32_FIND_DATAW wFindData;
953 res = FindNextFileW(dirp->handle, &wFindData);
955 BOOL use_default = FALSE;
956 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
957 wFindData.cFileName, -1,
958 buffer, sizeof(buffer), NULL, &use_default);
959 if (use_default && *wFindData.cAlternateFileName) {
960 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
961 wFindData.cAlternateFileName, -1,
962 buffer, sizeof(buffer), NULL, NULL);
967 long endpos = dirp->end - dirp->start;
968 long newsize = endpos + strlen(buffer) + 1;
969 /* bump the string table size by enough for the
970 * new name and its null terminator */
971 while (newsize > dirp->size) {
972 long curpos = dirp->curr - dirp->start;
973 Renew(dirp->start, dirp->size * 2, char);
975 dirp->curr = dirp->start + curpos;
977 strcpy(dirp->start + endpos, buffer);
978 dirp->end = dirp->start + newsize;
983 if (dirp->handle != INVALID_HANDLE_VALUE) {
984 FindClose(dirp->handle);
985 dirp->handle = INVALID_HANDLE_VALUE;
989 return &(dirp->dirstr);
995 /* Telldir returns the current string pointer position */
997 win32_telldir(DIR *dirp)
999 return dirp->curr ? (dirp->curr - dirp->start) : -1;
1003 /* Seekdir moves the string pointer to a previously saved position
1004 * (returned by telldir).
1007 win32_seekdir(DIR *dirp, long loc)
1009 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
1012 /* Rewinddir resets the string pointer to the start */
1014 win32_rewinddir(DIR *dirp)
1016 dirp->curr = dirp->start;
1019 /* free the memory allocated by opendir */
1021 win32_closedir(DIR *dirp)
1023 if (dirp->handle != INVALID_HANDLE_VALUE)
1024 FindClose(dirp->handle);
1025 Safefree(dirp->start);
1030 /* duplicate a open DIR* for interpreter cloning */
1032 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1035 PerlInterpreter *const from = param->proto_perl;
1036 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1041 /* switch back to original interpreter because win32_readdir()
1042 * might Renew(dirp->start).
1048 /* mark current position; read all remaining entries into the
1049 * cache, and then restore to current position.
1051 pos = win32_telldir(dirp);
1052 while (win32_readdir(dirp)) {
1053 /* read all entries into cache */
1055 win32_seekdir(dirp, pos);
1057 /* switch back to new interpreter to allocate new DIR structure */
1063 memcpy(dup, dirp, sizeof(DIR));
1065 Newx(dup->start, dirp->size, char);
1066 memcpy(dup->start, dirp->start, dirp->size);
1068 dup->end = dup->start + (dirp->end - dirp->start);
1070 dup->curr = dup->start + (dirp->curr - dirp->start);
1082 * Just pretend that everyone is a superuser. NT will let us know if
1083 * we don\'t really have permission to do something.
1086 #define ROOT_UID ((uid_t)0)
1087 #define ROOT_GID ((gid_t)0)
1116 return (auid == ROOT_UID ? 0 : -1);
1122 return (agid == ROOT_GID ? 0 : -1);
1129 char *buf = w32_getlogin_buffer;
1130 DWORD size = sizeof(w32_getlogin_buffer);
1131 if (GetUserName(buf,&size))
1137 chown(const char *path, uid_t owner, gid_t group)
1144 * XXX this needs strengthening (for PerlIO)
1147 #if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
1148 int mkstemp(const char *path)
1151 char buf[MAX_PATH+1];
1155 if (i++ > 10) { /* give up */
1159 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1163 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1171 find_pid(pTHX_ int pid)
1173 long child = w32_num_children;
1174 while (--child >= 0) {
1175 if ((int)w32_child_pids[child] == pid)
1182 remove_dead_process(long child)
1186 CloseHandle(w32_child_handles[child]);
1187 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1188 (w32_num_children-child-1), HANDLE);
1189 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1190 (w32_num_children-child-1), DWORD);
1197 find_pseudo_pid(pTHX_ int pid)
1199 long child = w32_num_pseudo_children;
1200 while (--child >= 0) {
1201 if ((int)w32_pseudo_child_pids[child] == pid)
1208 remove_dead_pseudo_process(long child)
1212 CloseHandle(w32_pseudo_child_handles[child]);
1213 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1214 (w32_num_pseudo_children-child-1), HANDLE);
1215 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1216 (w32_num_pseudo_children-child-1), DWORD);
1217 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1218 (w32_num_pseudo_children-child-1), HWND);
1219 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1220 (w32_num_pseudo_children-child-1), char);
1221 w32_num_pseudo_children--;
1226 win32_wait_for_children(pTHX)
1228 if (w32_pseudo_children && w32_num_pseudo_children) {
1231 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1233 for (child = 0; child < w32_num_pseudo_children; ++child) {
1234 if (!w32_pseudo_child_sigterm[child])
1235 handles[count++] = w32_pseudo_child_handles[child];
1237 /* XXX should use MsgWaitForMultipleObjects() to continue
1238 * XXX processing messages while we wait.
1240 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1242 while (w32_num_pseudo_children)
1243 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1249 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1253 /* "Does process exist?" use of kill */
1256 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1261 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1264 default: /* For now be backwards compatible with perl 5.6 */
1266 /* Note that we will only be able to kill processes owned by the
1267 * current process owner, even when we are running as an administrator.
1268 * To kill processes of other owners we would need to set the
1269 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1271 if (TerminateProcess(process_handle, sig))
1278 /* returns number of processes killed */
1280 my_killpg(int pid, int sig)
1282 HANDLE process_handle;
1283 HANDLE snapshot_handle;
1286 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1287 if (process_handle == NULL)
1290 killed += terminate_process(pid, process_handle, sig);
1292 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1293 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1294 PROCESSENTRY32 entry;
1296 entry.dwSize = sizeof(entry);
1297 if (Process32First(snapshot_handle, &entry)) {
1299 if (entry.th32ParentProcessID == (DWORD)pid)
1300 killed += my_killpg(entry.th32ProcessID, sig);
1301 entry.dwSize = sizeof(entry);
1303 while (Process32Next(snapshot_handle, &entry));
1305 CloseHandle(snapshot_handle);
1307 CloseHandle(process_handle);
1311 /* returns number of processes killed */
1313 my_kill(int pid, int sig)
1316 HANDLE process_handle;
1319 return my_killpg(pid, -sig);
1321 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1322 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1323 if (process_handle != NULL) {
1324 retval = terminate_process(pid, process_handle, sig);
1325 CloseHandle(process_handle);
1331 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1332 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1333 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1334 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1336 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1337 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1338 * a HWND in the time period allowed.
1341 get_hwnd_delay(pTHX, long child, DWORD tries)
1343 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1344 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1346 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1347 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1348 * thread 100% of the time since threads are attached to a CPU for NUMA and
1349 * caching reasons, and the child thread was attached to a different CPU
1350 * therefore there is no workload on that CPU and Sleep(0) returns control
1351 * without yielding the time slot.
1352 * https://github.com/Perl/perl5/issues/11267
1355 win32_async_check(aTHX);
1356 hwnd = w32_pseudo_child_message_hwnds[child];
1357 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1360 unsigned int count = 0;
1361 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1362 while (count++ < tries) {
1364 win32_async_check(aTHX);
1365 hwnd = w32_pseudo_child_message_hwnds[child];
1366 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1370 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1375 win32_kill(int pid, int sig)
1381 /* it is a pseudo-forked child */
1382 child = find_pseudo_pid(aTHX_ -pid);
1384 HANDLE hProcess = w32_pseudo_child_handles[child];
1387 /* "Does process exist?" use of kill */
1391 /* kill -9 style un-graceful exit */
1392 /* Do a wait to make sure child starts and isn't in DLL
1394 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1395 if (TerminateThread(hProcess, sig)) {
1396 /* Allow the scheduler to finish cleaning up the other
1398 * Otherwise, if we ExitProcess() before another context
1399 * switch happens we will end up with a process exit
1400 * code of "sig" instead of our own exit status.
1401 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1404 remove_dead_pseudo_process(child);
1411 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1412 /* We fake signals to pseudo-processes using Win32
1414 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1415 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1417 /* Don't wait for child process to terminate after we send a
1418 * SIGTERM because the child may be blocked in a system call
1419 * and never receive the signal.
1421 if (sig == SIGTERM) {
1423 w32_pseudo_child_sigterm[child] = 1;
1425 /* It might be us ... */
1437 child = find_pid(aTHX_ pid);
1439 if (my_kill(pid, sig)) {
1441 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1442 exitcode != STILL_ACTIVE)
1444 remove_dead_process(child);
1450 if (my_kill(pid, sig))
1459 win32_stat(const char *path, Stat_t *sbuf)
1461 char buffer[MAX_PATH+1];
1462 int l = strlen(path);
1466 BOOL expect_dir = FALSE;
1469 switch(path[l - 1]) {
1470 /* FindFirstFile() and stat() are buggy with a trailing
1471 * slashes, except for the root directory of a drive */
1474 if (l > sizeof(buffer)) {
1475 errno = ENAMETOOLONG;
1479 strncpy(buffer, path, l);
1480 /* remove additional trailing slashes */
1481 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1483 /* add back slash if we otherwise end up with just a drive letter */
1484 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1491 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1493 if (l == 2 && isALPHA(path[0])) {
1494 buffer[0] = path[0];
1505 path = PerlDir_mapA(path);
1508 if (!w32_sloppystat) {
1509 /* We must open & close the file once; otherwise file attribute changes */
1510 /* might not yet have propagated to "other" hard links of the same file. */
1511 /* This also gives us an opportunity to determine the number of links. */
1512 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1513 if (handle != INVALID_HANDLE_VALUE) {
1514 BY_HANDLE_FILE_INFORMATION bhi;
1515 if (GetFileInformationByHandle(handle, &bhi))
1516 nlink = bhi.nNumberOfLinks;
1517 CloseHandle(handle);
1520 DWORD err = GetLastError();
1521 /* very common case, skip CRT stat and its also failing syscalls */
1522 if(err == ERROR_FILE_NOT_FOUND) {
1529 /* path will be mapped correctly above */
1530 #if defined(WIN64) || defined(USE_LARGE_FILES)
1531 res = _stati64(path, sbuf);
1533 res = stat(path, sbuf);
1535 sbuf->st_nlink = nlink;
1538 /* CRT is buggy on sharenames, so make sure it really isn't.
1539 * XXX using GetFileAttributesEx() will enable us to set
1540 * sbuf->st_*time (but note that's not available on the
1541 * Windows of 1995) */
1542 DWORD r = GetFileAttributesA(path);
1543 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1544 /* sbuf may still contain old garbage since stat() failed */
1545 Zero(sbuf, 1, Stat_t);
1546 sbuf->st_mode = S_IFDIR | S_IREAD;
1548 if (!(r & FILE_ATTRIBUTE_READONLY))
1549 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1554 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1555 && (path[2] == '\\' || path[2] == '/'))
1557 /* The drive can be inaccessible, some _stat()s are buggy */
1558 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1563 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1567 if (S_ISDIR(sbuf->st_mode)) {
1568 /* Ensure the "write" bit is switched off in the mode for
1569 * directories with the read-only attribute set. Some compilers
1570 * switch it on for directories, which is technically correct
1571 * (directories are indeed always writable unless denied by DACLs),
1572 * but we want stat() and -w to reflect the state of the read-only
1573 * attribute for symmetry with chmod(). */
1574 DWORD r = GetFileAttributesA(path);
1575 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1576 sbuf->st_mode &= ~S_IWRITE;
1583 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1584 #define SKIP_SLASHES(s) \
1586 while (*(s) && isSLASH(*(s))) \
1589 #define COPY_NONSLASHES(d,s) \
1591 while (*(s) && !isSLASH(*(s))) \
1595 /* Find the longname of a given path. path is destructively modified.
1596 * It should have space for at least MAX_PATH characters. */
1598 win32_longpath(char *path)
1600 WIN32_FIND_DATA fdata;
1602 char tmpbuf[MAX_PATH+1];
1603 char *tmpstart = tmpbuf;
1610 if (isALPHA(path[0]) && path[1] == ':') {
1612 *tmpstart++ = path[0];
1616 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1618 *tmpstart++ = path[0];
1619 *tmpstart++ = path[1];
1620 SKIP_SLASHES(start);
1621 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1623 *tmpstart++ = *start++;
1624 SKIP_SLASHES(start);
1625 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1630 /* copy initial slash, if any */
1631 if (isSLASH(*start)) {
1632 *tmpstart++ = *start++;
1634 SKIP_SLASHES(start);
1637 /* FindFirstFile() expands "." and "..", so we need to pass
1638 * those through unmolested */
1640 && (!start[1] || isSLASH(start[1])
1641 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1643 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1648 /* if this is the end, bust outta here */
1652 /* now we're at a non-slash; walk up to next slash */
1653 while (*start && !isSLASH(*start))
1656 /* stop and find full name of component */
1659 fhand = FindFirstFile(path,&fdata);
1661 if (fhand != INVALID_HANDLE_VALUE) {
1662 STRLEN len = strlen(fdata.cFileName);
1663 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1664 strcpy(tmpstart, fdata.cFileName);
1675 /* failed a step, just return without side effects */
1676 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1681 strcpy(path,tmpbuf);
1696 win32_croak_not_implemented(const char * fname)
1698 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1700 Perl_croak_nocontext("%s not implemented!\n", fname);
1703 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1704 * potentially using the system's default replacement character for any
1705 * unrepresentable characters. The caller must free() the returned string. */
1707 wstr_to_str(const wchar_t* wstr)
1709 BOOL used_default = FALSE;
1710 size_t wlen = wcslen(wstr) + 1;
1711 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1712 NULL, 0, NULL, NULL);
1713 char* str = (char*)malloc(len);
1716 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1717 str, len, NULL, &used_default);
1721 /* The win32_ansipath() function takes a Unicode filename and converts it
1722 * into the current Windows codepage. If some characters cannot be mapped,
1723 * then it will convert the short name instead.
1725 * The buffer to the ansi pathname must be freed with win32_free() when it
1726 * it no longer needed.
1728 * The argument to win32_ansipath() must exist before this function is
1729 * called; otherwise there is no way to determine the short path name.
1731 * Ideas for future refinement:
1732 * - Only convert those segments of the path that are not in the current
1733 * codepage, but leave the other segments in their long form.
1734 * - If the resulting name is longer than MAX_PATH, start converting
1735 * additional path segments into short names until the full name
1736 * is shorter than MAX_PATH. Shorten the filename part last!
1739 win32_ansipath(const WCHAR *widename)
1742 BOOL use_default = FALSE;
1743 size_t widelen = wcslen(widename)+1;
1744 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1745 NULL, 0, NULL, NULL);
1746 name = (char*)win32_malloc(len);
1750 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1751 name, len, NULL, &use_default);
1753 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1755 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1758 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1760 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1761 NULL, 0, NULL, NULL);
1762 name = (char*)win32_realloc(name, len);
1765 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1766 name, len, NULL, NULL);
1767 win32_free(shortname);
1773 /* the returned string must be freed with win32_freeenvironmentstrings which is
1774 * implemented as a macro
1775 * void win32_freeenvironmentstrings(void* block)
1778 win32_getenvironmentstrings(void)
1780 LPWSTR lpWStr, lpWTmp;
1782 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1784 /* Get the process environment strings */
1785 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1786 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1787 env_len = wcslen(lpWTmp);
1788 /* calculate the size of the environment strings */
1789 wenvstrings_len += env_len + 1;
1792 /* Get the number of bytes required to store the ACP encoded string */
1793 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1794 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1795 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1799 /* Convert the string from UTF-16 encoding to ACP encoding */
1800 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1801 aenvstrings_len, NULL, NULL);
1803 FreeEnvironmentStringsW(lpWStr);
1809 win32_getenv(const char *name)
1816 needlen = GetEnvironmentVariableA(name,NULL,0);
1818 curitem = sv_2mortal(newSVpvs(""));
1820 SvGROW(curitem, needlen+1);
1821 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1823 } while (needlen >= SvLEN(curitem));
1824 SvCUR_set(curitem, needlen);
1827 last_err = GetLastError();
1828 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1829 /* It appears the variable is in the env, but the Win32 API
1830 doesn't have a canned way of getting it. So we fall back to
1831 grabbing the whole env and pulling this value out if possible */
1832 char *envv = GetEnvironmentStrings();
1836 char *end = strchr(cur,'=');
1837 if (end && end != cur) {
1839 if (strEQ(cur,name)) {
1840 curitem = sv_2mortal(newSVpv(end+1,0));
1845 cur = end + strlen(end+1)+2;
1847 else if ((len = strlen(cur)))
1850 FreeEnvironmentStrings(envv);
1852 #ifndef WIN32_NO_REGISTRY
1854 /* last ditch: allow any environment variables that begin with 'PERL'
1855 to be obtained from the registry, if found there */
1856 if (strBEGINs(name, "PERL"))
1857 (void)get_regstr(name, &curitem);
1861 if (curitem && SvCUR(curitem))
1862 return SvPVX(curitem);
1868 win32_putenv(const char *name)
1875 curitem = (char *) win32_malloc(strlen(name)+1);
1876 strcpy(curitem, name);
1877 val = strchr(curitem, '=');
1879 /* The sane way to deal with the environment.
1880 * Has these advantages over putenv() & co.:
1881 * * enables us to store a truly empty value in the
1882 * environment (like in UNIX).
1883 * * we don't have to deal with RTL globals, bugs and leaks
1884 * (specifically, see http://support.microsoft.com/kb/235601).
1886 * Why you may want to use the RTL environment handling
1887 * (previously enabled by USE_WIN32_RTL_ENV):
1888 * * environ[] and RTL functions will not reflect changes,
1889 * which might be an issue if extensions want to access
1890 * the env. via RTL. This cuts both ways, since RTL will
1891 * not see changes made by extensions that call the Win32
1892 * functions directly, either.
1896 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1899 win32_free(curitem);
1905 filetime_to_clock(PFILETIME ft)
1907 __int64 qw = ft->dwHighDateTime;
1909 qw |= ft->dwLowDateTime;
1910 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1915 win32_times(struct tms *timebuf)
1920 clock_t process_time_so_far = clock();
1921 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1923 timebuf->tms_utime = filetime_to_clock(&user);
1924 timebuf->tms_stime = filetime_to_clock(&kernel);
1925 timebuf->tms_cutime = 0;
1926 timebuf->tms_cstime = 0;
1928 /* That failed - e.g. Win95 fallback to clock() */
1929 timebuf->tms_utime = process_time_so_far;
1930 timebuf->tms_stime = 0;
1931 timebuf->tms_cutime = 0;
1932 timebuf->tms_cstime = 0;
1934 return process_time_so_far;
1937 /* fix utime() so it works on directories in NT */
1939 filetime_from_time(PFILETIME pFileTime, time_t Time)
1941 struct tm *pTM = localtime(&Time);
1942 SYSTEMTIME SystemTime;
1948 SystemTime.wYear = pTM->tm_year + 1900;
1949 SystemTime.wMonth = pTM->tm_mon + 1;
1950 SystemTime.wDay = pTM->tm_mday;
1951 SystemTime.wHour = pTM->tm_hour;
1952 SystemTime.wMinute = pTM->tm_min;
1953 SystemTime.wSecond = pTM->tm_sec;
1954 SystemTime.wMilliseconds = 0;
1956 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1957 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1961 win32_unlink(const char *filename)
1967 filename = PerlDir_mapA(filename);
1968 attrs = GetFileAttributesA(filename);
1969 if (attrs == 0xFFFFFFFF) {
1973 if (attrs & FILE_ATTRIBUTE_READONLY) {
1974 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1975 ret = unlink(filename);
1977 (void)SetFileAttributesA(filename, attrs);
1980 ret = unlink(filename);
1985 win32_utime(const char *filename, struct utimbuf *times)
1992 struct utimbuf TimeBuffer;
1995 filename = PerlDir_mapA(filename);
1996 rc = utime(filename, times);
1998 /* EACCES: path specifies directory or readonly file */
1999 if (rc == 0 || errno != EACCES)
2002 if (times == NULL) {
2003 times = &TimeBuffer;
2004 time(×->actime);
2005 times->modtime = times->actime;
2008 /* This will (and should) still fail on readonly files */
2009 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2010 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
2011 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2012 if (handle == INVALID_HANDLE_VALUE)
2015 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
2016 filetime_from_time(&ftAccess, times->actime) &&
2017 filetime_from_time(&ftWrite, times->modtime) &&
2018 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
2023 CloseHandle(handle);
2028 unsigned __int64 ft_i64;
2033 #define Const64(x) x##LL
2035 #define Const64(x) x##i64
2037 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2038 #define EPOCH_BIAS Const64(116444736000000000)
2040 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2041 * and appears to be unsupported even by glibc) */
2043 win32_gettimeofday(struct timeval *tp, void *not_used)
2047 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2048 GetSystemTimeAsFileTime(&ft.ft_val);
2050 /* seconds since epoch */
2051 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2053 /* microseconds remaining */
2054 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2060 win32_uname(struct utsname *name)
2062 struct hostent *hep;
2063 STRLEN nodemax = sizeof(name->nodename)-1;
2066 switch (g_osver.dwPlatformId) {
2067 case VER_PLATFORM_WIN32_WINDOWS:
2068 strcpy(name->sysname, "Windows");
2070 case VER_PLATFORM_WIN32_NT:
2071 strcpy(name->sysname, "Windows NT");
2073 case VER_PLATFORM_WIN32s:
2074 strcpy(name->sysname, "Win32s");
2077 strcpy(name->sysname, "Win32 Unknown");
2082 sprintf(name->release, "%d.%d",
2083 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2086 sprintf(name->version, "Build %d",
2087 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2088 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2089 if (g_osver.szCSDVersion[0]) {
2090 char *buf = name->version + strlen(name->version);
2091 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2095 hep = win32_gethostbyname("localhost");
2097 STRLEN len = strlen(hep->h_name);
2098 if (len <= nodemax) {
2099 strcpy(name->nodename, hep->h_name);
2102 strncpy(name->nodename, hep->h_name, nodemax);
2103 name->nodename[nodemax] = '\0';
2108 if (!GetComputerName(name->nodename, &sz))
2109 *name->nodename = '\0';
2112 /* machine (architecture) */
2117 GetSystemInfo(&info);
2119 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2120 procarch = info.u.s.wProcessorArchitecture;
2122 procarch = info.wProcessorArchitecture;
2125 case PROCESSOR_ARCHITECTURE_INTEL:
2126 arch = "x86"; break;
2127 case PROCESSOR_ARCHITECTURE_IA64:
2128 arch = "ia64"; break;
2129 case PROCESSOR_ARCHITECTURE_AMD64:
2130 arch = "amd64"; break;
2131 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2132 arch = "unknown"; break;
2134 sprintf(name->machine, "unknown(0x%x)", procarch);
2135 arch = name->machine;
2138 if (name->machine != arch)
2139 strcpy(name->machine, arch);
2144 /* Timing related stuff */
2147 do_raise(pTHX_ int sig)
2149 if (sig < SIG_SIZE) {
2150 Sighandler_t handler = w32_sighandler[sig];
2151 if (handler == SIG_IGN) {
2154 else if (handler != SIG_DFL) {
2159 /* Choose correct default behaviour */
2175 /* Tell caller to exit thread/process as appropriate */
2180 sig_terminate(pTHX_ int sig)
2182 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2183 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2190 win32_async_check(pTHX)
2193 HWND hwnd = w32_message_hwnd;
2195 /* Reset w32_poll_count before doing anything else, incase we dispatch
2196 * messages that end up calling back into perl */
2199 if (hwnd != INVALID_HANDLE_VALUE) {
2200 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2201 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2206 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2207 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2209 /* re-post a WM_QUIT message (we'll mark it as read later) */
2210 if(msg.message == WM_QUIT) {
2211 PostQuitMessage((int)msg.wParam);
2215 if(!CallMsgFilter(&msg, MSGF_USER))
2217 TranslateMessage(&msg);
2218 DispatchMessage(&msg);
2223 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2224 * This is necessary when we are being called by win32_msgwait() to
2225 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2226 * message over and over. An example how this can happen is when
2227 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2228 * is generating messages before the process terminated.
2230 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2232 /* Above or other stuff may have set a signal flag */
2239 /* This function will not return until the timeout has elapsed, or until
2240 * one of the handles is ready. */
2242 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2245 /* We may need several goes at this - so compute when we stop */
2247 unsigned __int64 endtime = timeout;
2248 if (timeout != INFINITE) {
2249 GetSystemTimeAsFileTime(&ticks.ft_val);
2250 ticks.ft_i64 /= 10000;
2251 endtime += ticks.ft_i64;
2253 /* This was a race condition. Do not let a non INFINITE timeout to
2254 * MsgWaitForMultipleObjects roll under 0 creating a near
2255 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2256 * user who did a CORE perl function with a non infinity timeout,
2257 * sleep for example. This is 64 to 32 truncation minefield.
2259 * This scenario can only be created if the timespan from the return of
2260 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2261 * generate the scenario, manual breakpoints in a C debugger are required,
2262 * or a context switch occurred in win32_async_check in PeekMessage, or random
2263 * messages are delivered to the *thread* message queue of the Perl thread
2264 * from another process (msctf.dll doing IPC among its instances, VS debugger
2265 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2267 while (ticks.ft_i64 <= endtime || retry) {
2268 /* if timeout's type is lengthened, remember to split 64b timeout
2269 * into multiple non-infinity runs of MWFMO */
2270 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2271 (DWORD)(endtime - ticks.ft_i64),
2272 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2276 if (result == WAIT_TIMEOUT) {
2277 /* Ran out of time - explicit return of zero to avoid -ve if we
2278 have scheduling issues
2282 if (timeout != INFINITE) {
2283 GetSystemTimeAsFileTime(&ticks.ft_val);
2284 ticks.ft_i64 /= 10000;
2286 if (result == WAIT_OBJECT_0 + count) {
2287 /* Message has arrived - check it */
2288 (void)win32_async_check(aTHX);
2292 /* Not timeout or message - one of handles is ready */
2296 /* If we are past the end say zero */
2297 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2299 /* compute time left to wait */
2300 ticks.ft_i64 = endtime - ticks.ft_i64;
2301 /* if more ms than DWORD, then return max DWORD */
2302 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2306 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2308 /* XXX this wait emulation only knows about processes
2309 * spawned via win32_spawnvp(P_NOWAIT, ...).
2312 DWORD exitcode, waitcode;
2315 if (w32_num_pseudo_children) {
2316 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2317 timeout, &waitcode);
2318 /* Time out here if there are no other children to wait for. */
2319 if (waitcode == WAIT_TIMEOUT) {
2320 if (!w32_num_children) {
2324 else if (waitcode != WAIT_FAILED) {
2325 if (waitcode >= WAIT_ABANDONED_0
2326 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2327 i = waitcode - WAIT_ABANDONED_0;
2329 i = waitcode - WAIT_OBJECT_0;
2330 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2331 *status = (int)((exitcode & 0xff) << 8);
2332 retval = (int)w32_pseudo_child_pids[i];
2333 remove_dead_pseudo_process(i);
2340 if (!w32_num_children) {
2345 /* if a child exists, wait for it to die */
2346 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2347 if (waitcode == WAIT_TIMEOUT) {
2350 if (waitcode != WAIT_FAILED) {
2351 if (waitcode >= WAIT_ABANDONED_0
2352 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2353 i = waitcode - WAIT_ABANDONED_0;
2355 i = waitcode - WAIT_OBJECT_0;
2356 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2357 *status = (int)((exitcode & 0xff) << 8);
2358 retval = (int)w32_child_pids[i];
2359 remove_dead_process(i);
2364 errno = GetLastError();
2369 win32_waitpid(int pid, int *status, int flags)
2372 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2375 if (pid == -1) /* XXX threadid == 1 ? */
2376 return win32_internal_wait(aTHX_ status, timeout);
2379 child = find_pseudo_pid(aTHX_ -pid);
2381 HANDLE hThread = w32_pseudo_child_handles[child];
2383 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2384 if (waitcode == WAIT_TIMEOUT) {
2387 else if (waitcode == WAIT_OBJECT_0) {
2388 if (GetExitCodeThread(hThread, &waitcode)) {
2389 *status = (int)((waitcode & 0xff) << 8);
2390 retval = (int)w32_pseudo_child_pids[child];
2391 remove_dead_pseudo_process(child);
2403 child = find_pid(aTHX_ pid);
2405 hProcess = w32_child_handles[child];
2406 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2407 if (waitcode == WAIT_TIMEOUT) {
2410 else if (waitcode == WAIT_OBJECT_0) {
2411 if (GetExitCodeProcess(hProcess, &waitcode)) {
2412 *status = (int)((waitcode & 0xff) << 8);
2413 retval = (int)w32_child_pids[child];
2414 remove_dead_process(child);
2422 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2424 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2425 if (waitcode == WAIT_TIMEOUT) {
2426 CloseHandle(hProcess);
2429 else if (waitcode == WAIT_OBJECT_0) {
2430 if (GetExitCodeProcess(hProcess, &waitcode)) {
2431 *status = (int)((waitcode & 0xff) << 8);
2432 CloseHandle(hProcess);
2436 CloseHandle(hProcess);
2442 return retval >= 0 ? pid : retval;
2446 win32_wait(int *status)
2449 return win32_internal_wait(aTHX_ status, INFINITE);
2452 DllExport unsigned int
2453 win32_sleep(unsigned int t)
2456 /* Win32 times are in ms so *1000 in and /1000 out */
2457 if (t > UINT_MAX / 1000) {
2458 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2459 "sleep(%lu) too large", t);
2461 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2468 win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
2472 DllExport unsigned int
2473 win32_alarm(unsigned int sec)
2476 * the 'obvious' implentation is SetTimer() with a callback
2477 * which does whatever receiving SIGALRM would do
2478 * we cannot use SIGALRM even via raise() as it is not
2479 * one of the supported codes in <signal.h>
2483 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2484 w32_message_hwnd = win32_create_message_window();
2487 if (w32_message_hwnd == NULL)
2488 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2491 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2496 KillTimer(w32_message_hwnd, w32_timerid);
2503 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2506 win32_crypt(const char *txt, const char *salt)
2509 return des_fcrypt(txt, salt, w32_crypt_buffer);
2512 /* simulate flock by locking a range on the file */
2514 #define LK_LEN 0xffff0000
2517 win32_flock(int fd, int oper)
2523 fh = (HANDLE)_get_osfhandle(fd);
2524 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2527 memset(&o, 0, sizeof(o));
2530 case LOCK_SH: /* shared lock */
2531 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2534 case LOCK_EX: /* exclusive lock */
2535 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2538 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2539 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2542 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2543 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2547 case LOCK_UN: /* unlock lock */
2548 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2551 default: /* unknown */
2556 if (GetLastError() == ERROR_LOCK_VIOLATION)
2557 errno = EWOULDBLOCK;
2566 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2568 /* Get the errno value corresponding to the given err. This function is not
2569 * intended to handle conversion of general GetLastError() codes. It only exists
2570 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2571 * used to be assigned to errno/$! in earlier versions of perl; this function is
2572 * used to catch any old Perl code which is still trying to assign such values
2573 * to $! and convert them to errno values instead.
2576 win32_get_errno(int err)
2578 return convert_wsa_error_to_errno(err);
2582 * redirected io subsystem for all XS modules
2595 return (&(_environ));
2598 /* the rest are the remapped stdio routines */
2618 win32_ferror(FILE *fp)
2620 return (ferror(fp));
2625 win32_feof(FILE *fp)
2630 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2631 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2635 * Since the errors returned by the socket error function
2636 * WSAGetLastError() are not known by the library routine strerror
2637 * we have to roll our own to cover the case of socket errors
2638 * that could not be converted to regular errno values by
2639 * get_last_socket_error() in win32/win32sck.c.
2643 win32_strerror(int e)
2645 #if !defined __MINGW32__ /* compiler intolerance */
2646 extern int sys_nerr;
2649 if (e < 0 || e > sys_nerr) {
2653 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2654 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2655 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2656 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2657 * We must therefore still roll our own messages for these codes, and
2658 * additionally map them to corresponding Windows (sockets) error codes
2659 * first to avoid getting the wrong system message.
2661 else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) {
2662 e = convert_errno_to_wsa_error(e);
2666 aTHXa(PERL_GET_THX);
2667 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2668 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2669 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2672 strcpy(w32_strerror_buffer, "Unknown Error");
2674 return w32_strerror_buffer;
2678 #define strerror win32_strerror
2682 win32_str_os_error(void *sv, DWORD dwErr)
2686 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2687 |FORMAT_MESSAGE_IGNORE_INSERTS
2688 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2689 dwErr, 0, (char *)&sMsg, 1, NULL);
2690 /* strip trailing whitespace and period */
2693 --dwLen; /* dwLen doesn't include trailing null */
2694 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2695 if ('.' != sMsg[dwLen])
2700 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2702 dwLen = sprintf(sMsg,
2703 "Unknown error #0x%lX (lookup 0x%lX)",
2704 dwErr, GetLastError());
2708 sv_setpvn((SV*)sv, sMsg, dwLen);
2714 win32_fprintf(FILE *fp, const char *format, ...)
2717 va_start(marker, format); /* Initialize variable arguments. */
2719 return (vfprintf(fp, format, marker));
2723 win32_printf(const char *format, ...)
2726 va_start(marker, format); /* Initialize variable arguments. */
2728 return (vprintf(format, marker));
2732 win32_vfprintf(FILE *fp, const char *format, va_list args)
2734 return (vfprintf(fp, format, args));
2738 win32_vprintf(const char *format, va_list args)
2740 return (vprintf(format, args));
2744 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2746 return fread(buf, size, count, fp);
2750 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2752 return fwrite(buf, size, count, fp);
2755 #define MODE_SIZE 10
2758 win32_fopen(const char *filename, const char *mode)
2766 if (stricmp(filename, "/dev/null")==0)
2769 aTHXa(PERL_GET_THX);
2770 f = fopen(PerlDir_mapA(filename), mode);
2771 /* avoid buffering headaches for child processes */
2772 if (f && *mode == 'a')
2773 win32_fseek(f, 0, SEEK_END);
2778 win32_fdopen(int handle, const char *mode)
2781 f = fdopen(handle, (char *) mode);
2782 /* avoid buffering headaches for child processes */
2783 if (f && *mode == 'a')
2784 win32_fseek(f, 0, SEEK_END);
2789 win32_freopen(const char *path, const char *mode, FILE *stream)
2792 if (stricmp(path, "/dev/null")==0)
2795 aTHXa(PERL_GET_THX);
2796 return freopen(PerlDir_mapA(path), mode, stream);
2800 win32_fclose(FILE *pf)
2802 #ifdef WIN32_NO_SOCKETS
2805 return my_fclose(pf); /* defined in win32sck.c */
2810 win32_fputs(const char *s,FILE *pf)
2812 return fputs(s, pf);
2816 win32_fputc(int c,FILE *pf)
2822 win32_ungetc(int c,FILE *pf)
2824 return ungetc(c,pf);
2828 win32_getc(FILE *pf)
2834 win32_fileno(FILE *pf)
2840 win32_clearerr(FILE *pf)
2847 win32_fflush(FILE *pf)
2853 win32_ftell(FILE *pf)
2855 #if defined(WIN64) || defined(USE_LARGE_FILES)
2857 if (fgetpos(pf, &pos))
2866 win32_fseek(FILE *pf, Off_t offset,int origin)
2868 #if defined(WIN64) || defined(USE_LARGE_FILES)
2872 if (fgetpos(pf, &pos))
2877 fseek(pf, 0, SEEK_END);
2878 pos = _telli64(fileno(pf));
2887 return fsetpos(pf, &offset);
2889 return fseek(pf, (long)offset, origin);
2894 win32_fgetpos(FILE *pf,fpos_t *p)
2896 return fgetpos(pf, p);
2900 win32_fsetpos(FILE *pf,const fpos_t *p)
2902 return fsetpos(pf, p);
2906 win32_rewind(FILE *pf)
2915 return win32_tmpfd_mode(0);
2919 win32_tmpfd_mode(int mode)
2921 char prefix[MAX_PATH+1];
2922 char filename[MAX_PATH+1];
2923 DWORD len = GetTempPath(MAX_PATH, prefix);
2924 mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
2926 if (len && len < MAX_PATH) {
2927 if (GetTempFileName(prefix, "plx", 0, filename)) {
2928 HANDLE fh = CreateFile(filename,
2929 DELETE | GENERIC_READ | GENERIC_WRITE,
2933 FILE_ATTRIBUTE_NORMAL
2934 | FILE_FLAG_DELETE_ON_CLOSE,
2936 if (fh != INVALID_HANDLE_VALUE) {
2937 int fd = win32_open_osfhandle((intptr_t)fh, mode);
2940 DEBUG_p(PerlIO_printf(Perl_debug_log,
2941 "Created tmpfile=%s\n",filename));
2953 int fd = win32_tmpfd();
2955 return win32_fdopen(fd, "w+b");
2967 win32_fstat(int fd, Stat_t *sbufptr)
2969 #if defined(WIN64) || defined(USE_LARGE_FILES)
2970 return _fstati64(fd, sbufptr);
2972 return fstat(fd, sbufptr);
2977 win32_pipe(int *pfd, unsigned int size, int mode)
2979 return _pipe(pfd, size, mode);
2983 win32_popenlist(const char *mode, IV narg, SV **args)
2987 return do_popen(mode, NULL, narg, args);
2991 do_popen(const char *mode, const char *command, IV narg, SV **args) {
3000 const char **args_pvs = NULL;
3002 /* establish which ends read and write */
3003 if (strchr(mode,'w')) {
3004 stdfd = 0; /* stdin */
3007 nhandle = STD_INPUT_HANDLE;
3009 else if (strchr(mode,'r')) {
3010 stdfd = 1; /* stdout */
3013 nhandle = STD_OUTPUT_HANDLE;
3018 /* set the correct mode */
3019 if (strchr(mode,'b'))
3021 else if (strchr(mode,'t'))
3024 ourmode = _fmode & (O_TEXT | O_BINARY);
3026 /* the child doesn't inherit handles */
3027 ourmode |= O_NOINHERIT;
3029 if (win32_pipe(p, 512, ourmode) == -1)
3032 /* Previously this code redirected stdin/out temporarily so the
3033 child process inherited those handles, this caused race
3034 conditions when another thread was writing/reading those
3037 To avoid that we just feed the handles to CreateProcess() so
3038 the handles are redirected only in the child.
3040 handles[child] = p[child];
3041 handles[parent] = -1;
3044 /* CreateProcess() requires inheritable handles */
3045 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3046 HANDLE_FLAG_INHERIT)) {
3050 /* start the child */
3055 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3061 const char *exe_name;
3063 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3064 SAVEFREEPV(args_pvs);
3065 for (i = 0; i < narg; ++i)
3066 args_pvs[i] = SvPV_nolen(args[i]);
3068 exe_name = qualified_path(args_pvs[0], TRUE);
3070 /* let CreateProcess() try to find it instead */
3071 exe_name = args_pvs[0];
3073 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3078 win32_close(p[child]);
3080 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3082 /* set process id so that it can be returned by perl's open() */
3083 PL_forkprocess = childpid;
3086 /* we have an fd, return a file stream */
3087 return (PerlIO_fdopen(p[parent], (char *)mode));
3090 /* we don't need to check for errors here */
3098 * a popen() clone that respects PERL5SHELL
3100 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3104 win32_popen(const char *command, const char *mode)
3106 #ifdef USE_RTL_POPEN
3107 return _popen(command, mode);
3109 return do_popen(mode, command, 0, NULL);
3110 #endif /* USE_RTL_POPEN */
3118 win32_pclose(PerlIO *pf)
3120 #ifdef USE_RTL_POPEN
3124 int childpid, status;
3127 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3130 childpid = SvIVX(sv);
3146 if (win32_waitpid(childpid, &status, 0) == -1)
3151 #endif /* USE_RTL_POPEN */
3155 win32_link(const char *oldname, const char *newname)
3158 WCHAR wOldName[MAX_PATH+1];
3159 WCHAR wNewName[MAX_PATH+1];
3161 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3162 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3163 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3164 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3168 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3169 both permissions errors and if the source is a directory, while
3170 POSIX wants EACCES and EPERM respectively.
3172 Determined by experimentation on Windows 7 x64 SP1, since MS
3173 don't document what error codes are returned.
3175 switch (GetLastError()) {
3176 case ERROR_BAD_NET_NAME:
3177 case ERROR_BAD_NETPATH:
3178 case ERROR_BAD_PATHNAME:
3179 case ERROR_FILE_NOT_FOUND:
3180 case ERROR_FILENAME_EXCED_RANGE:
3181 case ERROR_INVALID_DRIVE:
3182 case ERROR_PATH_NOT_FOUND:
3185 case ERROR_ALREADY_EXISTS:
3188 case ERROR_ACCESS_DENIED:
3191 case ERROR_NOT_SAME_DEVICE:
3194 case ERROR_DISK_FULL:
3197 case ERROR_NOT_ENOUGH_QUOTA:
3201 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3209 win32_rename(const char *oname, const char *newname)
3211 char szOldName[MAX_PATH+1];
3213 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3216 if (stricmp(newname, oname))
3217 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3218 strcpy(szOldName, PerlDir_mapA(oname));
3220 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3222 DWORD err = GetLastError();
3224 case ERROR_BAD_NET_NAME:
3225 case ERROR_BAD_NETPATH:
3226 case ERROR_BAD_PATHNAME:
3227 case ERROR_FILE_NOT_FOUND:
3228 case ERROR_FILENAME_EXCED_RANGE:
3229 case ERROR_INVALID_DRIVE:
3230 case ERROR_NO_MORE_FILES:
3231 case ERROR_PATH_NOT_FOUND:
3234 case ERROR_DISK_FULL:
3237 case ERROR_NOT_ENOUGH_QUOTA:
3250 win32_setmode(int fd, int mode)
3252 return setmode(fd, mode);
3256 win32_chsize(int fd, Off_t size)
3258 #if defined(WIN64) || defined(USE_LARGE_FILES)
3260 Off_t cur, end, extend;
3262 cur = win32_tell(fd);
3265 end = win32_lseek(fd, 0, SEEK_END);
3268 extend = size - end;
3272 else if (extend > 0) {
3273 /* must grow the file, padding with nulls */
3275 int oldmode = win32_setmode(fd, O_BINARY);
3277 memset(b, '\0', sizeof(b));
3279 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3280 count = win32_write(fd, b, count);
3281 if ((int)count < 0) {
3285 } while ((extend -= count) > 0);
3286 win32_setmode(fd, oldmode);
3289 /* shrink the file */
3290 win32_lseek(fd, size, SEEK_SET);
3291 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3296 win32_lseek(fd, cur, SEEK_SET);
3299 return chsize(fd, (long)size);
3304 win32_lseek(int fd, Off_t offset, int origin)
3306 #if defined(WIN64) || defined(USE_LARGE_FILES)
3307 return _lseeki64(fd, offset, origin);
3309 return lseek(fd, (long)offset, origin);
3316 #if defined(WIN64) || defined(USE_LARGE_FILES)
3317 return _telli64(fd);
3324 win32_open(const char *path, int flag, ...)
3331 pmode = va_arg(ap, int);
3334 if (stricmp(path, "/dev/null")==0)
3337 aTHXa(PERL_GET_THX);
3338 return open(PerlDir_mapA(path), flag, pmode);
3341 /* close() that understands socket */
3342 extern int my_close(int); /* in win32sck.c */
3347 #ifdef WIN32_NO_SOCKETS
3350 return my_close(fd);
3361 win32_isatty(int fd)
3363 /* The Microsoft isatty() function returns true for *all*
3364 * character mode devices, including "nul". Our implementation
3365 * should only return true if the handle has a console buffer.
3368 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3369 if (fh == (HANDLE)-1) {
3370 /* errno is already set to EBADF */
3374 if (GetConsoleMode(fh, &mode))
3388 win32_dup2(int fd1,int fd2)
3390 return dup2(fd1,fd2);
3394 win32_read(int fd, void *buf, unsigned int cnt)
3396 return read(fd, buf, cnt);
3400 win32_write(int fd, const void *buf, unsigned int cnt)
3402 return write(fd, buf, cnt);
3406 win32_mkdir(const char *dir, int mode)
3409 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3413 win32_rmdir(const char *dir)
3416 return rmdir(PerlDir_mapA(dir));
3420 win32_chdir(const char *dir)
3422 if (!dir || !*dir) {
3430 win32_access(const char *path, int mode)
3433 return access(PerlDir_mapA(path), mode);
3437 win32_chmod(const char *path, int mode)
3440 return chmod(PerlDir_mapA(path), mode);
3445 create_command_line(char *cname, STRLEN clen, const char * const *args)
3452 bool bat_file = FALSE;
3453 bool cmd_shell = FALSE;
3454 bool dumb_shell = FALSE;
3455 bool extra_quotes = FALSE;
3456 bool quote_next = FALSE;
3459 cname = (char*)args[0];
3461 /* The NT cmd.exe shell has the following peculiarity that needs to be
3462 * worked around. It strips a leading and trailing dquote when any
3463 * of the following is true:
3464 * 1. the /S switch was used
3465 * 2. there are more than two dquotes
3466 * 3. there is a special character from this set: &<>()@^|
3467 * 4. no whitespace characters within the two dquotes
3468 * 5. string between two dquotes isn't an executable file
3469 * To work around this, we always add a leading and trailing dquote
3470 * to the string, if the first argument is either "cmd.exe" or "cmd",
3471 * and there were at least two or more arguments passed to cmd.exe
3472 * (not including switches).
3473 * XXX the above rules (from "cmd /?") don't seem to be applied
3474 * always, making for the convolutions below :-(
3478 clen = strlen(cname);
3481 && (stricmp(&cname[clen-4], ".bat") == 0
3482 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3488 char *exe = strrchr(cname, '/');
3489 char *exe2 = strrchr(cname, '\\');
3496 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3500 else if (stricmp(exe, "command.com") == 0
3501 || stricmp(exe, "command") == 0)
3508 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3509 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3510 STRLEN curlen = strlen(arg);
3511 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3512 len += 2; /* assume quoting needed (worst case) */
3514 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3516 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3519 Newx(cmd, len, char);
3524 extra_quotes = TRUE;
3527 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3529 STRLEN curlen = strlen(arg);
3531 /* we want to protect empty arguments and ones with spaces with
3532 * dquotes, but only if they aren't already there */
3537 else if (quote_next) {
3538 /* see if it really is multiple arguments pretending to
3539 * be one and force a set of quotes around it */
3540 if (*find_next_space(arg))
3543 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3545 while (i < curlen) {
3546 if (isSPACE(arg[i])) {
3549 else if (arg[i] == '"') {
3573 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3574 && stricmp(arg+curlen-2, "/c") == 0)
3576 /* is there a next argument? */
3577 if (args[index+1]) {
3578 /* are there two or more next arguments? */
3579 if (args[index+2]) {
3581 extra_quotes = TRUE;
3584 /* single argument, force quoting if it has spaces */
3599 static const char *exe_extensions[] =
3601 ".exe", /* this must be first */
3607 qualified_path(const char *cmd, bool other_exts)
3610 char *fullcmd, *curfullcmd;
3616 fullcmd = (char*)cmd;
3618 if (*fullcmd == '/' || *fullcmd == '\\')
3627 pathstr = PerlEnv_getenv("PATH");
3629 /* worst case: PATH is a single directory; we need additional space
3630 * to append "/", ".exe" and trailing "\0" */
3631 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3632 curfullcmd = fullcmd;
3637 /* start by appending the name to the current prefix */
3638 strcpy(curfullcmd, cmd);
3639 curfullcmd += cmdlen;
3641 /* if it doesn't end with '.', or has no extension, try adding
3642 * a trailing .exe first */
3643 if (cmd[cmdlen-1] != '.'
3644 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3647 /* first extension is .exe */
3648 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3649 for (i = 0; i < ext_limit; ++i) {
3650 strcpy(curfullcmd, exe_extensions[i]);
3651 res = GetFileAttributes(fullcmd);
3652 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3659 /* that failed, try the bare name */
3660 res = GetFileAttributes(fullcmd);
3661 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3664 /* quit if no other path exists, or if cmd already has path */
3665 if (!pathstr || !*pathstr || has_slash)
3668 /* skip leading semis */
3669 while (*pathstr == ';')
3672 /* build a new prefix from scratch */
3673 curfullcmd = fullcmd;
3674 while (*pathstr && *pathstr != ';') {
3675 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3676 pathstr++; /* skip initial '"' */
3677 while (*pathstr && *pathstr != '"') {
3678 *curfullcmd++ = *pathstr++;
3681 pathstr++; /* skip trailing '"' */
3684 *curfullcmd++ = *pathstr++;
3688 pathstr++; /* skip trailing semi */
3689 if (curfullcmd > fullcmd /* append a dir separator */
3690 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3692 *curfullcmd++ = '\\';
3700 /* The following are just place holders.
3701 * Some hosts may provide and environment that the OS is
3702 * not tracking, therefore, these host must provide that
3703 * environment and the current directory to CreateProcess
3707 win32_get_childenv(void)
3713 win32_free_childenv(void* d)
3718 win32_clearenv(void)
3720 char *envv = GetEnvironmentStrings();
3724 char *end = strchr(cur,'=');
3725 if (end && end != cur) {
3727 SetEnvironmentVariable(cur, NULL);
3729 cur = end + strlen(end+1)+2;
3731 else if ((len = strlen(cur)))
3734 FreeEnvironmentStrings(envv);
3738 win32_get_childdir(void)
3741 char szfilename[MAX_PATH+1];
3743 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3744 Newx(ptr, strlen(szfilename)+1, char);
3745 strcpy(ptr, szfilename);
3750 win32_free_childdir(char* d)
3756 /* XXX this needs to be made more compatible with the spawnvp()
3757 * provided by the various RTLs. In particular, searching for
3758 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3759 * This doesn't significantly affect perl itself, because we
3760 * always invoke things using PERL5SHELL if a direct attempt to
3761 * spawn the executable fails.
3763 * XXX splitting and rejoining the commandline between do_aspawn()
3764 * and win32_spawnvp() could also be avoided.
3768 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3770 #ifdef USE_RTL_SPAWNVP
3771 return _spawnvp(mode, cmdname, (char * const *)argv);
3773 return do_spawnvp_handles(mode, cmdname, argv, NULL);
3778 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3779 const int *handles) {
3785 STARTUPINFO StartupInfo;
3786 PROCESS_INFORMATION ProcessInformation;
3789 char *fullcmd = NULL;
3790 char *cname = (char *)cmdname;
3794 clen = strlen(cname);
3795 /* if command name contains dquotes, must remove them */
3796 if (strchr(cname, '"')) {
3798 Newx(cname,clen+1,char);
3811 cmd = create_command_line(cname, clen, argv);
3813 aTHXa(PERL_GET_THX);
3814 env = PerlEnv_get_childenv();
3815 dir = PerlEnv_get_childdir();
3818 case P_NOWAIT: /* asynch + remember result */
3819 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3824 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3827 create |= CREATE_NEW_PROCESS_GROUP;
3830 case P_WAIT: /* synchronous execution */
3832 default: /* invalid mode */
3838 memset(&StartupInfo,0,sizeof(StartupInfo));
3839 StartupInfo.cb = sizeof(StartupInfo);
3840 memset(&tbl,0,sizeof(tbl));
3841 PerlEnv_get_child_IO(&tbl);
3842 StartupInfo.dwFlags = tbl.dwFlags;
3843 StartupInfo.dwX = tbl.dwX;
3844 StartupInfo.dwY = tbl.dwY;
3845 StartupInfo.dwXSize = tbl.dwXSize;
3846 StartupInfo.dwYSize = tbl.dwYSize;
3847 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3848 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3849 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3850 StartupInfo.wShowWindow = tbl.wShowWindow;
3851 StartupInfo.hStdInput = handles && handles[0] != -1 ?
3852 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3853 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
3854 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3855 StartupInfo.hStdError = handles && handles[2] != -1 ?
3856 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3857 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3858 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3859 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3861 create |= CREATE_NEW_CONSOLE;
3864 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3866 if (w32_use_showwindow) {
3867 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3868 StartupInfo.wShowWindow = w32_showwindow;
3871 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3874 if (!CreateProcess(cname, /* search PATH to find executable */
3875 cmd, /* executable, and its arguments */
3876 NULL, /* process attributes */
3877 NULL, /* thread attributes */
3878 TRUE, /* inherit handles */
3879 create, /* creation flags */
3880 (LPVOID)env, /* inherit environment */
3881 dir, /* inherit cwd */
3883 &ProcessInformation))
3885 /* initial NULL argument to CreateProcess() does a PATH
3886 * search, but it always first looks in the directory
3887 * where the current process was started, which behavior
3888 * is undesirable for backward compatibility. So we
3889 * jump through our own hoops by picking out the path
3890 * we really want it to use. */
3892 fullcmd = qualified_path(cname, FALSE);
3894 if (cname != cmdname)
3897 DEBUG_p(PerlIO_printf(Perl_debug_log,
3898 "Retrying [%s] with same args\n",
3908 if (mode == P_NOWAIT) {
3909 /* asynchronous spawn -- store handle, return PID */
3910 ret = (int)ProcessInformation.dwProcessId;
3912 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3913 w32_child_pids[w32_num_children] = (DWORD)ret;
3918 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3919 /* FIXME: if msgwait returned due to message perhaps forward the
3920 "signal" to the process
3922 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3924 CloseHandle(ProcessInformation.hProcess);
3927 CloseHandle(ProcessInformation.hThread);
3930 PerlEnv_free_childenv(env);
3931 PerlEnv_free_childdir(dir);
3933 if (cname != cmdname)
3939 win32_execv(const char *cmdname, const char *const *argv)
3943 /* if this is a pseudo-forked child, we just want to spawn
3944 * the new program, and return */
3946 return _spawnv(P_WAIT, cmdname, argv);
3948 return _execv(cmdname, argv);
3952 win32_execvp(const char *cmdname, const char *const *argv)
3956 /* if this is a pseudo-forked child, we just want to spawn
3957 * the new program, and return */
3958 if (w32_pseudo_id) {
3959 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3968 return _execvp(cmdname, argv);
3972 win32_perror(const char *str)
3978 win32_setbuf(FILE *pf, char *buf)
3984 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3986 return setvbuf(pf, buf, type, size);
3990 win32_flushall(void)
3996 win32_fcloseall(void)
4002 win32_fgets(char *s, int n, FILE *pf)
4004 return fgets(s, n, pf);
4014 win32_fgetc(FILE *pf)
4020 win32_putc(int c, FILE *pf)
4026 win32_puts(const char *s)
4038 win32_putchar(int c)
4045 #ifndef USE_PERL_SBRK
4047 static char *committed = NULL; /* XXX threadead */
4048 static char *base = NULL; /* XXX threadead */
4049 static char *reserved = NULL; /* XXX threadead */
4050 static char *brk = NULL; /* XXX threadead */
4051 static DWORD pagesize = 0; /* XXX threadead */
4054 sbrk(ptrdiff_t need)
4059 GetSystemInfo(&info);
4060 /* Pretend page size is larger so we don't perpetually
4061 * call the OS to commit just one page ...
4063 pagesize = info.dwPageSize << 3;
4065 if (brk+need >= reserved)
4067 DWORD size = brk+need-reserved;
4069 char *prev_committed = NULL;
4070 if (committed && reserved && committed < reserved)
4072 /* Commit last of previous chunk cannot span allocations */
4073 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4076 /* Remember where we committed from in case we want to decommit later */
4077 prev_committed = committed;
4078 committed = reserved;
4081 /* Reserve some (more) space
4082 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4083 * this is only address space not memory...
4084 * Note this is a little sneaky, 1st call passes NULL as reserved
4085 * so lets system choose where we start, subsequent calls pass
4086 * the old end address so ask for a contiguous block
4089 if (size < 64*1024*1024)
4090 size = 64*1024*1024;
4091 size = ((size + pagesize - 1) / pagesize) * pagesize;
4092 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4095 reserved = addr+size;
4105 /* The existing block could not be extended far enough, so decommit
4106 * anything that was just committed above and start anew */
4109 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4112 reserved = base = committed = brk = NULL;
4123 if (brk > committed)
4125 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4127 if (committed+size > reserved)
4128 size = reserved-committed;
4129 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4142 win32_malloc(size_t size)
4144 return malloc(size);
4148 win32_calloc(size_t numitems, size_t size)
4150 return calloc(numitems,size);
4154 win32_realloc(void *block, size_t size)
4156 return realloc(block,size);
4160 win32_free(void *block)
4167 win32_open_osfhandle(intptr_t handle, int flags)
4169 return _open_osfhandle(handle, flags);
4173 win32_get_osfhandle(int fd)
4175 return (intptr_t)_get_osfhandle(fd);
4179 win32_fdupopen(FILE *pf)
4184 int fileno = win32_dup(win32_fileno(pf));
4186 /* open the file in the same mode */
4187 if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
4191 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
4195 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
4201 /* it appears that the binmode is attached to the
4202 * file descriptor so binmode files will be handled
4205 pfdup = win32_fdopen(fileno, mode);
4207 /* move the file pointer to the same position */
4208 if (!fgetpos(pf, &pos)) {
4209 fsetpos(pfdup, &pos);
4215 win32_dynaload(const char* filename)
4218 char buf[MAX_PATH+1];
4221 /* LoadLibrary() doesn't recognize forward slashes correctly,
4222 * so turn 'em back. */
4223 first = strchr(filename, '/');
4225 STRLEN len = strlen(filename);
4226 if (len <= MAX_PATH) {
4227 strcpy(buf, filename);
4228 filename = &buf[first - filename];
4230 if (*filename == '/')
4231 *(char*)filename = '\\';
4237 aTHXa(PERL_GET_THX);
4238 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4241 XS(w32_SetChildShowWindow)
4244 BOOL use_showwindow = w32_use_showwindow;
4245 /* use "unsigned short" because Perl has redefined "WORD" */
4246 unsigned short showwindow = w32_showwindow;
4249 croak_xs_usage(cv, "[showwindow]");
4251 if (items == 0 || !SvOK(ST(0)))
4252 w32_use_showwindow = FALSE;
4254 w32_use_showwindow = TRUE;
4255 w32_showwindow = (unsigned short)SvIV(ST(0));
4260 ST(0) = sv_2mortal(newSViv(showwindow));
4262 ST(0) = &PL_sv_undef;
4267 #ifdef PERL_IS_MINIPERL
4268 /* shelling out is much slower, full perl uses Win32.pm */
4272 /* Make the host for current directory */
4273 char* ptr = PerlEnv_get_childdir();
4276 * then it worked, set PV valid,
4277 * else return 'undef'
4280 SV *sv = sv_newmortal();
4282 PerlEnv_free_childdir(ptr);
4284 #ifndef INCOMPLETE_TAINTS
4296 Perl_init_os_extras(void)
4299 char *file = __FILE__;
4301 /* Initialize Win32CORE if it has been statically linked. */
4302 #ifndef PERL_IS_MINIPERL
4303 void (*pfn_init)(pTHX);
4304 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4305 ? GetModuleHandle(NULL)
4306 : w32_perldll_handle);
4307 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4308 aTHXa(PERL_GET_THX);
4312 aTHXa(PERL_GET_THX);
4315 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4316 #ifdef PERL_IS_MINIPERL
4317 newXS("Win32::GetCwd", w32_GetCwd, file);
4322 win32_signal_context(void)
4327 my_perl = PL_curinterp;
4328 PERL_SET_THX(my_perl);
4332 return PL_curinterp;
4338 win32_ctrlhandler(DWORD dwCtrlType)
4341 dTHXa(PERL_GET_SIG_CONTEXT);
4347 switch(dwCtrlType) {
4348 case CTRL_CLOSE_EVENT:
4349 /* A signal that the system sends to all processes attached to a console when
4350 the user closes the console (either by choosing the Close command from the
4351 console window's System menu, or by choosing the End Task command from the
4354 if (do_raise(aTHX_ 1)) /* SIGHUP */
4355 sig_terminate(aTHX_ 1);
4359 /* A CTRL+c signal was received */
4360 if (do_raise(aTHX_ SIGINT))
4361 sig_terminate(aTHX_ SIGINT);
4364 case CTRL_BREAK_EVENT:
4365 /* A CTRL+BREAK signal was received */
4366 if (do_raise(aTHX_ SIGBREAK))
4367 sig_terminate(aTHX_ SIGBREAK);
4370 case CTRL_LOGOFF_EVENT:
4371 /* A signal that the system sends to all console processes when a user is logging
4372 off. This signal does not indicate which user is logging off, so no
4373 assumptions can be made.
4376 case CTRL_SHUTDOWN_EVENT:
4377 /* A signal that the system sends to all console processes when the system is
4380 if (do_raise(aTHX_ SIGTERM))
4381 sig_terminate(aTHX_ SIGTERM);
4390 #ifdef SET_INVALID_PARAMETER_HANDLER
4391 # include <crtdbg.h>
4402 /* fetch Unicode version of PATH */
4404 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4406 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4408 win32_free(wide_path);
4414 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4419 /* convert to ANSI pathnames */
4420 wide_dir = wide_path;
4423 WCHAR *sep = wcschr(wide_dir, ';');
4431 /* remove quotes around pathname */
4432 if (*wide_dir == '"')
4434 wide_len = wcslen(wide_dir);
4435 if (wide_len && wide_dir[wide_len-1] == '"')
4436 wide_dir[wide_len-1] = '\0';
4438 /* append ansi_dir to ansi_path */
4439 ansi_dir = win32_ansipath(wide_dir);
4440 ansi_len = strlen(ansi_dir);
4442 size_t newlen = len + 1 + ansi_len;
4443 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4446 ansi_path[len] = ';';
4447 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4452 ansi_path = (char*)win32_malloc(5+len+1);
4455 memcpy(ansi_path, "PATH=", 5);
4456 memcpy(ansi_path+5, ansi_dir, len+1);
4459 win32_free(ansi_dir);
4464 /* Update C RTL environ array. This will only have full effect if
4465 * perl_parse() is later called with `environ` as the `env` argument.
4466 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4468 * We do have to ansify() the PATH before Perl has been fully
4469 * initialized because S_find_script() uses the PATH when perl
4470 * is being invoked with the -S option. This happens before %ENV
4471 * is initialized in S_init_postdump_symbols().
4473 * XXX Is this a bug? Should S_find_script() use the environment
4474 * XXX passed in the `env` arg to parse_perl()?
4477 /* Keep system environment in sync because S_init_postdump_symbols()
4478 * will not call mg_set() if it initializes %ENV from `environ`.
4480 SetEnvironmentVariableA("PATH", ansi_path+5);
4481 win32_free(ansi_path);
4483 win32_free(wide_path);
4487 Perl_win32_init(int *argcp, char ***argvp)
4489 #ifdef SET_INVALID_PARAMETER_HANDLER
4490 _invalid_parameter_handler oldHandler, newHandler;
4491 newHandler = my_invalid_parameter_handler;
4492 oldHandler = _set_invalid_parameter_handler(newHandler);
4493 _CrtSetReportMode(_CRT_ASSERT, 0);
4495 /* Disable floating point errors, Perl will trap the ones we
4496 * care about. VC++ RTL defaults to switching these off
4497 * already, but some RTLs don't. Since we don't
4498 * want to be at the vendor's whim on the default, we set
4499 * it explicitly here.
4501 #if !defined(__GNUC__)
4502 _control87(MCW_EM, MCW_EM);
4506 /* When the manifest resource requests Common-Controls v6 then
4507 * user32.dll no longer registers all the Windows classes used for
4508 * standard controls but leaves some of them to be registered by
4509 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4510 * it makes sure comctl32.dll gets loaded into the process and registers
4511 * the standard control classes. Without this even normal Windows APIs
4512 * like MessageBox() can fail under some versions of Windows XP.
4514 InitCommonControls();
4516 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4517 GetVersionEx(&g_osver);
4519 #ifdef WIN32_DYN_IOINFO_SIZE
4521 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4522 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4523 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4526 ioinfo_size /= IOINFO_ARRAY_ELTS;
4527 w32_ioinfo_size = ioinfo_size;
4533 #ifndef WIN32_NO_REGISTRY
4536 retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
4537 if (retval != ERROR_SUCCESS) {
4538 HKCU_Perl_hnd = NULL;
4540 retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
4541 if (retval != ERROR_SUCCESS) {
4542 HKLM_Perl_hnd = NULL;
4549 Perl_win32_term(void)
4556 #ifndef WIN32_NO_REGISTRY
4557 /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
4558 but no point of checking and we can't die() at this point */
4559 RegCloseKey(HKLM_Perl_hnd);
4560 RegCloseKey(HKCU_Perl_hnd);
4561 /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
4566 win32_get_child_IO(child_IO_table* ptbl)
4568 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4569 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4570 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4574 win32_signal(int sig, Sighandler_t subcode)
4577 if (sig < SIG_SIZE) {
4578 int save_errno = errno;
4579 Sighandler_t result;
4580 #ifdef SET_INVALID_PARAMETER_HANDLER
4581 /* Silence our invalid parameter handler since we expect to make some
4582 * calls with invalid signal numbers giving a SIG_ERR result. */
4583 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4585 result = signal(sig, subcode);
4586 #ifdef SET_INVALID_PARAMETER_HANDLER
4587 set_silent_invalid_parameter_handler(oldvalue);
4589 aTHXa(PERL_GET_THX);
4590 if (result == SIG_ERR) {
4591 result = w32_sighandler[sig];
4594 w32_sighandler[sig] = subcode;
4603 /* The PerlMessageWindowClass's WindowProc */
4605 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4607 return win32_process_message(hwnd, msg, wParam, lParam) ?
4608 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4611 /* The real message handler. Can be called with
4612 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4613 * that it processes */
4615 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4617 /* BEWARE. The context retrieved using dTHX; is the context of the
4618 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4619 * up to and including WM_CREATE. If it ever happens that you need the
4620 * 'child' context before this, then it needs to be passed into
4621 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4622 * from the lparam of CreateWindow(). It could then be stored/retrieved
4623 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4624 * the dTHX calls here. */
4625 /* XXX For now it is assumed that the overhead of the dTHX; for what
4626 * are relativley infrequent code-paths, is better than the added
4627 * complexity of getting the correct context passed into
4628 * win32_create_message_window() */
4634 case WM_USER_MESSAGE: {
4635 long child = find_pseudo_pid(aTHX_ (int)wParam);
4637 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4644 case WM_USER_KILL: {
4645 /* We use WM_USER_KILL to fake kill() with other signals */
4646 int sig = (int)wParam;
4647 if (do_raise(aTHX_ sig))
4648 sig_terminate(aTHX_ sig);
4654 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4655 if (w32_timerid && w32_timerid==(UINT)wParam) {
4656 KillTimer(w32_message_hwnd, w32_timerid);
4659 /* Now fake a call to signal handler */
4660 if (do_raise(aTHX_ 14))
4661 sig_terminate(aTHX_ 14);
4673 /* Above or other stuff may have set a signal flag, and we may not have
4674 * been called from win32_async_check() (e.g. some other GUI's message
4675 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4676 * handler that die's, and the message loop that calls here is wrapped
4677 * in an eval, then you may well end up with orphaned windows - signals
4678 * are dispatched by win32_async_check() */
4684 win32_create_message_window_class(void)
4686 /* create the window class for "message only" windows */
4690 wc.lpfnWndProc = win32_message_window_proc;
4691 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4692 wc.lpszClassName = "PerlMessageWindowClass";
4694 /* second and subsequent calls will fail, but class
4695 * will already be registered */
4700 win32_create_message_window(void)
4702 win32_create_message_window_class();
4703 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4704 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4707 #ifdef HAVE_INTERP_INTERN
4710 win32_csighandler(int sig)
4713 dTHXa(PERL_GET_SIG_CONTEXT);
4714 Perl_warn(aTHX_ "Got signal %d",sig);
4719 #if defined(__MINGW32__) && defined(__cplusplus)
4720 #define CAST_HWND__(x) (HWND__*)(x)
4722 #define CAST_HWND__(x) x
4726 Perl_sys_intern_init(pTHX)
4731 w32_perlshell_tokens = NULL;
4732 w32_perlshell_vec = (char**)NULL;
4733 w32_perlshell_items = 0;
4734 w32_fdpid = newAV();
4735 Newx(w32_children, 1, child_tab);
4736 w32_num_children = 0;
4737 # ifdef USE_ITHREADS
4739 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4740 w32_num_pseudo_children = 0;
4743 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4745 #ifdef PERL_IS_MINIPERL
4746 w32_sloppystat = TRUE;
4748 w32_sloppystat = FALSE;
4750 for (i=0; i < SIG_SIZE; i++) {
4751 w32_sighandler[i] = SIG_DFL;
4753 # ifdef MULTIPLICITY
4754 if (my_perl == PL_curinterp) {
4758 /* Force C runtime signal stuff to set its console handler */
4759 signal(SIGINT,win32_csighandler);
4760 signal(SIGBREAK,win32_csighandler);
4762 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4763 * flag. This has the side-effect of disabling Ctrl-C events in all
4764 * processes in this group.
4765 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4766 * with a NULL handler.
4768 SetConsoleCtrlHandler(NULL,FALSE);
4770 /* Push our handler on top */
4771 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4776 Perl_sys_intern_clear(pTHX)
4780 Safefree(w32_perlshell_tokens);
4781 Safefree(w32_perlshell_vec);
4782 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4783 Safefree(w32_children);
4785 KillTimer(w32_message_hwnd, w32_timerid);
4788 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4789 DestroyWindow(w32_message_hwnd);
4790 # ifdef MULTIPLICITY
4791 if (my_perl == PL_curinterp) {
4795 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4797 # ifdef USE_ITHREADS
4798 Safefree(w32_pseudo_children);
4802 # ifdef USE_ITHREADS
4805 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4807 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4809 dst->perlshell_tokens = NULL;
4810 dst->perlshell_vec = (char**)NULL;
4811 dst->perlshell_items = 0;
4812 dst->fdpid = newAV();
4813 Newxz(dst->children, 1, child_tab);
4815 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4817 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4818 dst->poll_count = 0;
4819 dst->sloppystat = src->sloppystat;
4820 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4822 # endif /* USE_ITHREADS */
4823 #endif /* HAVE_INTERP_INTERN */