3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc.
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
16 # define Win32_Winsock
20 # define _WIN32_WINNT 0x0500 /* needed for CreateHardlink() etc. */
26 # define HWND_MESSAGE ((HWND)-3)
29 #ifndef PROCESSOR_ARCHITECTURE_AMD64
30 # define PROCESSOR_ARCHITECTURE_AMD64 9
33 #ifndef WC_NO_BEST_FIT_CHARS
34 # define WC_NO_BEST_FIT_CHARS 0x00000400
43 /* #include "config.h" */
45 #if !defined(PERLIO_IS_STDIO)
54 #define PERL_NO_GET_CONTEXT
59 /* assert.h conflicts with #define of assert in perl.h */
67 #include <sys/utime.h>
70 /* Mingw32 defaults to globing command line
71 * So we turn it off like this:
76 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
77 /* Mingw32-1.1 is missing some prototypes */
79 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
89 #define EXECF_SPAWN_NOWAIT 3
91 #if defined(PERL_IMPLICIT_SYS)
92 # undef win32_get_privlib
93 # define win32_get_privlib g_win32_get_privlib
94 # undef win32_get_sitelib
95 # define win32_get_sitelib g_win32_get_sitelib
96 # undef win32_get_vendorlib
97 # define win32_get_vendorlib g_win32_get_vendorlib
99 # define getlogin g_getlogin
102 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
103 * parameter handler. This functionality is not available in the
104 * 64-bit compiler from the Platform SDK, which unfortunately also
105 * believes itself to be MSC version 14.
107 * There is no #define related to _set_invalid_parameter_handler(),
108 * but we can check for one of the constants defined for
109 * _set_abort_behavior(), which was introduced into stdlib.h at
113 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
114 # define SET_INVALID_PARAMETER_HANDLER
117 #ifdef SET_INVALID_PARAMETER_HANDLER
118 static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
119 static void my_invalid_parameter_handler(const wchar_t* expression,
120 const wchar_t* function, const wchar_t* file,
121 unsigned int line, uintptr_t pReserved);
124 static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
125 static char* get_regstr(const char *valuename, SV **svp);
126 static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
127 char *trailing, ...);
128 static char* win32_get_xlib(const char *pl, const char *xlib,
129 const char *libname, STRLEN *const len);
130 static BOOL has_shell_metachars(const char *ptr);
131 static long tokenize(const char *str, char **dest, char ***destv);
132 static void get_shell(void);
133 static char* find_next_space(const char *s);
134 static int do_spawn2(pTHX_ const char *cmd, int exectype);
135 static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
137 static int do_spawnvp_handles(int mode, const char *cmdname,
138 const char * const *argv, const int *handles);
139 static long find_pid(pTHX_ int pid);
140 static void remove_dead_process(long child);
141 static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
142 static int my_killpg(int pid, int sig);
143 static int my_kill(int pid, int sig);
144 static void out_of_memory(void);
145 static char* wstr_to_str(const wchar_t* wstr);
146 static long filetime_to_clock(PFILETIME ft);
147 static BOOL filetime_from_time(PFILETIME ft, time_t t);
148 static char* create_command_line(char *cname, STRLEN clen,
149 const char * const *args);
150 static char* qualified_path(const char *cmd);
151 static void ansify_path(void);
152 static LRESULT win32_process_message(HWND hwnd, UINT msg,
153 WPARAM wParam, LPARAM lParam);
156 static long find_pseudo_pid(pTHX_ int pid);
157 static void remove_dead_pseudo_process(long child);
158 static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
161 #ifdef HAVE_INTERP_INTERN
162 static void win32_csighandler(int sig);
166 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
167 char w32_module_name[MAX_PATH+1];
168 #ifdef WIN32_DYN_IOINFO_SIZE
169 Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
173 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
175 #ifdef SET_INVALID_PARAMETER_HANDLER
176 static BOOL silent_invalid_parameter_handler = FALSE;
179 set_silent_invalid_parameter_handler(BOOL newvalue)
181 BOOL oldvalue = silent_invalid_parameter_handler;
183 silent_invalid_parameter_handler = newvalue;
189 my_invalid_parameter_handler(const wchar_t* expression,
190 const wchar_t* function,
196 char* ansi_expression;
199 if (silent_invalid_parameter_handler)
201 ansi_expression = wstr_to_str(expression);
202 ansi_function = wstr_to_str(function);
203 ansi_file = wstr_to_str(file);
204 fprintf(stderr, "Invalid parameter detected in function %s. "
205 "File: %s, line: %d\n", ansi_function, ansi_file, line);
206 fprintf(stderr, "Expression: %s\n", ansi_expression);
207 free(ansi_expression);
215 set_w32_module_name(void)
217 /* this function may be called at DLL_PROCESS_ATTACH time */
219 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
220 ? GetModuleHandle(NULL)
221 : w32_perldll_handle);
223 WCHAR modulename[MAX_PATH];
224 WCHAR fullname[MAX_PATH];
227 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
228 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
229 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
231 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
233 /* Make sure we get an absolute pathname in case the module was loaded
234 * explicitly by LoadLibrary() with a relative path. */
235 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
237 /* Make sure we start with the long path name of the module because we
238 * later scan for pathname components to match "5.xx" to locate
239 * compatible sitelib directories, and the short pathname might mangle
240 * this path segment (e.g. by removing the dot on NTFS to something
241 * like "5xx~1.yy") */
242 if (pfnGetLongPathNameW)
243 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
245 /* remove \\?\ prefix */
246 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
247 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
249 ansi = win32_ansipath(fullname);
250 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
253 /* normalize to forward slashes */
254 ptr = w32_module_name;
262 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
264 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
266 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
269 const char *subkey = "Software\\Perl";
273 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
274 if (retval == ERROR_SUCCESS) {
276 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
277 if (retval == ERROR_SUCCESS
278 && (type == REG_SZ || type == REG_EXPAND_SZ))
282 *svp = sv_2mortal(newSVpvs(""));
283 SvGROW(*svp, datalen);
284 retval = RegQueryValueEx(handle, valuename, 0, NULL,
285 (PBYTE)SvPVX(*svp), &datalen);
286 if (retval == ERROR_SUCCESS) {
288 SvCUR_set(*svp,datalen-1);
296 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
298 get_regstr(const char *valuename, SV **svp)
300 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
302 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
306 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
308 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
312 char mod_name[MAX_PATH+1];
318 va_start(ap, trailing_path);
319 strip = va_arg(ap, char *);
321 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
322 baselen = strlen(base);
324 if (!*w32_module_name) {
325 set_w32_module_name();
327 strcpy(mod_name, w32_module_name);
328 ptr = strrchr(mod_name, '/');
329 while (ptr && strip) {
330 /* look for directories to skip back */
333 ptr = strrchr(mod_name, '/');
334 /* avoid stripping component if there is no slash,
335 * or it doesn't match ... */
336 if (!ptr || stricmp(ptr+1, strip) != 0) {
337 /* ... but not if component matches m|5\.$patchlevel.*| */
338 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
339 && strncmp(strip, base, baselen) == 0
340 && strncmp(ptr+1, base, baselen) == 0))
346 strip = va_arg(ap, char *);
354 strcpy(++ptr, trailing_path);
356 /* only add directory if it exists */
357 if (GetFileAttributes(mod_name) != (DWORD) -1) {
358 /* directory exists */
361 *prev_pathp = sv_2mortal(newSVpvs(""));
362 else if (SvPVX(*prev_pathp))
363 sv_catpvs(*prev_pathp, ";");
364 sv_catpv(*prev_pathp, mod_name);
366 *len = SvCUR(*prev_pathp);
367 return SvPVX(*prev_pathp);
374 win32_get_privlib(const char *pl, STRLEN *const len)
376 char *stdlib = "lib";
377 char buffer[MAX_PATH+1];
380 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
381 sprintf(buffer, "%s-%s", stdlib, pl);
382 if (!get_regstr(buffer, &sv))
383 (void)get_regstr(stdlib, &sv);
385 /* $stdlib .= ";$EMD/../../lib" */
386 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
390 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
394 char pathstr[MAX_PATH+1];
398 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
399 sprintf(regstr, "%s-%s", xlib, pl);
400 (void)get_regstr(regstr, &sv1);
403 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
404 sprintf(pathstr, "%s/%s/lib", libname, pl);
405 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
407 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
408 (void)get_regstr(xlib, &sv2);
411 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
412 sprintf(pathstr, "%s/lib", libname);
413 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
431 win32_get_sitelib(const char *pl, STRLEN *const len)
433 return win32_get_xlib(pl, "sitelib", "site", len);
436 #ifndef PERL_VENDORLIB_NAME
437 # define PERL_VENDORLIB_NAME "vendor"
441 win32_get_vendorlib(const char *pl, STRLEN *const len)
443 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
447 has_shell_metachars(const char *ptr)
453 * Scan string looking for redirection (< or >) or pipe
454 * characters (|) that are not in a quoted string.
455 * Shell variable interpolation (%VAR%) can also happen inside strings.
487 #if !defined(PERL_IMPLICIT_SYS)
488 /* since the current process environment is being updated in util.c
489 * the library functions will get the correct environment
492 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
494 PERL_FLUSHALL_FOR_CHILD;
495 return win32_popen(cmd, mode);
499 Perl_my_pclose(pTHX_ PerlIO *fp)
501 return win32_pclose(fp);
505 DllExport unsigned long
508 return (unsigned long)g_osver.dwPlatformId;
517 return -((int)w32_pseudo_id);
522 /* Tokenize a string. Words are null-separated, and the list
523 * ends with a doubled null. Any character (except null and
524 * including backslash) may be escaped by preceding it with a
525 * backslash (the backslash will be stripped).
526 * Returns number of words in result buffer.
529 tokenize(const char *str, char **dest, char ***destv)
531 char *retstart = NULL;
532 char **retvstart = 0;
535 int slen = strlen(str);
538 Newx(ret, slen+2, char);
539 Newx(retv, (slen+3)/2, char*);
547 if (*ret == '\\' && *str)
549 else if (*ret == ' ') {
565 retvstart[items] = NULL;
578 if (!w32_perlshell_tokens) {
579 /* we don't use COMSPEC here for two reasons:
580 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
581 * uncontrolled unportability of the ensuing scripts.
582 * 2. PERL5SHELL could be set to a shell that may not be fit for
583 * interactive use (which is what most programs look in COMSPEC
586 const char* defaultshell = "cmd.exe /x/d/c";
587 const char *usershell = PerlEnv_getenv("PERL5SHELL");
588 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
589 &w32_perlshell_tokens,
595 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
603 PERL_ARGS_ASSERT_DO_ASPAWN;
609 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
611 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
616 while (++mark <= sp) {
617 if (*mark && (str = SvPV_nolen(*mark)))
624 status = win32_spawnvp(flag,
625 (const char*)(really ? SvPV_nolen(really) : argv[0]),
626 (const char* const*)argv);
628 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
629 /* possible shell-builtin, invoke with shell */
631 sh_items = w32_perlshell_items;
633 argv[index+sh_items] = argv[index];
634 while (--sh_items >= 0)
635 argv[sh_items] = w32_perlshell_vec[sh_items];
637 status = win32_spawnvp(flag,
638 (const char*)(really ? SvPV_nolen(really) : argv[0]),
639 (const char* const*)argv);
642 if (flag == P_NOWAIT) {
643 PL_statusvalue = -1; /* >16bits hint for pp_system() */
647 if (ckWARN(WARN_EXEC))
648 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
653 PL_statusvalue = status;
659 /* returns pointer to the next unquoted space or the end of the string */
661 find_next_space(const char *s)
663 bool in_quotes = FALSE;
665 /* ignore doubled backslashes, or backslash+quote */
666 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
669 /* keep track of when we're within quotes */
670 else if (*s == '"') {
672 in_quotes = !in_quotes;
674 /* break it up only at spaces that aren't in quotes */
675 else if (!in_quotes && isSPACE(*s))
684 do_spawn2(pTHX_ const char *cmd, int exectype) {
685 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
689 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
695 BOOL needToTry = TRUE;
698 /* Save an extra exec if possible. See if there are shell
699 * metacharacters in it */
700 if (!has_shell_metachars(cmd)) {
701 Newx(argv, strlen(cmd) / 2 + 2, char*);
702 Newx(cmd2, strlen(cmd) + 1, char);
705 for (s = cmd2; *s;) {
706 while (*s && isSPACE(*s))
710 s = find_next_space(s);
718 status = win32_spawnvp(P_WAIT, argv[0],
719 (const char* const*)argv);
721 case EXECF_SPAWN_NOWAIT:
722 status = do_spawnvp_handles(P_NOWAIT, argv[0],
723 (const char* const*)argv, handles);
726 status = win32_execvp(argv[0], (const char* const*)argv);
729 if (status != -1 || errno == 0)
739 Newx(argv, w32_perlshell_items + 2, char*);
740 while (++i < w32_perlshell_items)
741 argv[i] = w32_perlshell_vec[i];
742 argv[i++] = (char *)cmd;
746 status = win32_spawnvp(P_WAIT, argv[0],
747 (const char* const*)argv);
749 case EXECF_SPAWN_NOWAIT:
750 status = do_spawnvp_handles(P_NOWAIT, argv[0],
751 (const char* const*)argv, handles);
754 status = win32_execvp(argv[0], (const char* const*)argv);
760 if (exectype == EXECF_SPAWN_NOWAIT) {
761 PL_statusvalue = -1; /* >16bits hint for pp_system() */
765 if (ckWARN(WARN_EXEC))
766 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
767 (exectype == EXECF_EXEC ? "exec" : "spawn"),
768 cmd, strerror(errno));
773 PL_statusvalue = status;
779 Perl_do_spawn(pTHX_ char *cmd)
781 PERL_ARGS_ASSERT_DO_SPAWN;
783 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
787 Perl_do_spawn_nowait(pTHX_ char *cmd)
789 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
791 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
795 Perl_do_exec(pTHX_ const char *cmd)
797 PERL_ARGS_ASSERT_DO_EXEC;
799 do_spawn2(aTHX_ cmd, EXECF_EXEC);
803 /* The idea here is to read all the directory names into a string table
804 * (separated by nulls) and when one of the other dir functions is called
805 * return the pointer to the current file name.
808 win32_opendir(const char *filename)
814 char scanname[MAX_PATH+3];
815 WCHAR wscanname[sizeof(scanname)];
816 WIN32_FIND_DATAW wFindData;
817 char buffer[MAX_PATH*2];
820 len = strlen(filename);
825 if (len > MAX_PATH) {
826 errno = ENAMETOOLONG;
830 /* Get us a DIR structure */
833 /* Create the search pattern */
834 strcpy(scanname, filename);
836 /* bare drive name means look in cwd for drive */
837 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
838 scanname[len++] = '.';
839 scanname[len++] = '/';
841 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
842 scanname[len++] = '/';
844 scanname[len++] = '*';
845 scanname[len] = '\0';
847 /* do the FindFirstFile call */
848 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
850 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
852 if (dirp->handle == INVALID_HANDLE_VALUE) {
853 DWORD err = GetLastError();
854 /* FindFirstFile() fails on empty drives! */
856 case ERROR_FILE_NOT_FOUND:
858 case ERROR_NO_MORE_FILES:
859 case ERROR_PATH_NOT_FOUND:
862 case ERROR_NOT_ENOUGH_MEMORY:
874 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
875 wFindData.cFileName, -1,
876 buffer, sizeof(buffer), NULL, &use_default);
877 if (use_default && *wFindData.cAlternateFileName) {
878 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
879 wFindData.cAlternateFileName, -1,
880 buffer, sizeof(buffer), NULL, NULL);
883 /* now allocate the first part of the string table for
884 * the filenames that we find.
886 idx = strlen(buffer)+1;
891 Newx(dirp->start, dirp->size, char);
892 strcpy(dirp->start, buffer);
894 dirp->end = dirp->curr = dirp->start;
900 /* Readdir just returns the current string pointer and bumps the
901 * string pointer to the nDllExport entry.
903 DllExport struct direct *
904 win32_readdir(DIR *dirp)
909 /* first set up the structure to return */
910 len = strlen(dirp->curr);
911 strcpy(dirp->dirstr.d_name, dirp->curr);
912 dirp->dirstr.d_namlen = len;
915 dirp->dirstr.d_ino = dirp->curr - dirp->start;
917 /* Now set up for the next call to readdir */
918 dirp->curr += len + 1;
919 if (dirp->curr >= dirp->end) {
921 char buffer[MAX_PATH*2];
923 if (dirp->handle == INVALID_HANDLE_VALUE) {
926 /* finding the next file that matches the wildcard
927 * (which should be all of them in this directory!).
930 WIN32_FIND_DATAW wFindData;
931 res = FindNextFileW(dirp->handle, &wFindData);
933 BOOL use_default = FALSE;
934 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
935 wFindData.cFileName, -1,
936 buffer, sizeof(buffer), NULL, &use_default);
937 if (use_default && *wFindData.cAlternateFileName) {
938 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
939 wFindData.cAlternateFileName, -1,
940 buffer, sizeof(buffer), NULL, NULL);
945 long endpos = dirp->end - dirp->start;
946 long newsize = endpos + strlen(buffer) + 1;
947 /* bump the string table size by enough for the
948 * new name and its null terminator */
949 while (newsize > dirp->size) {
950 long curpos = dirp->curr - dirp->start;
952 Renew(dirp->start, dirp->size, char);
953 dirp->curr = dirp->start + curpos;
955 strcpy(dirp->start + endpos, buffer);
956 dirp->end = dirp->start + newsize;
961 if (dirp->handle != INVALID_HANDLE_VALUE) {
962 FindClose(dirp->handle);
963 dirp->handle = INVALID_HANDLE_VALUE;
967 return &(dirp->dirstr);
973 /* Telldir returns the current string pointer position */
975 win32_telldir(DIR *dirp)
977 return dirp->curr ? (dirp->curr - dirp->start) : -1;
981 /* Seekdir moves the string pointer to a previously saved position
982 * (returned by telldir).
985 win32_seekdir(DIR *dirp, long loc)
987 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
990 /* Rewinddir resets the string pointer to the start */
992 win32_rewinddir(DIR *dirp)
994 dirp->curr = dirp->start;
997 /* free the memory allocated by opendir */
999 win32_closedir(DIR *dirp)
1001 if (dirp->handle != INVALID_HANDLE_VALUE)
1002 FindClose(dirp->handle);
1003 Safefree(dirp->start);
1008 /* duplicate a open DIR* for interpreter cloning */
1010 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1013 PerlInterpreter *const from = param->proto_perl;
1014 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1019 /* switch back to original interpreter because win32_readdir()
1020 * might Renew(dirp->start).
1026 /* mark current position; read all remaining entries into the
1027 * cache, and then restore to current position.
1029 pos = win32_telldir(dirp);
1030 while (win32_readdir(dirp)) {
1031 /* read all entries into cache */
1033 win32_seekdir(dirp, pos);
1035 /* switch back to new interpreter to allocate new DIR structure */
1041 memcpy(dup, dirp, sizeof(DIR));
1043 Newx(dup->start, dirp->size, char);
1044 memcpy(dup->start, dirp->start, dirp->size);
1046 dup->end = dup->start + (dirp->end - dirp->start);
1048 dup->curr = dup->start + (dirp->curr - dirp->start);
1060 * Just pretend that everyone is a superuser. NT will let us know if
1061 * we don\'t really have permission to do something.
1064 #define ROOT_UID ((uid_t)0)
1065 #define ROOT_GID ((gid_t)0)
1094 return (auid == ROOT_UID ? 0 : -1);
1100 return (agid == ROOT_GID ? 0 : -1);
1107 char *buf = w32_getlogin_buffer;
1108 DWORD size = sizeof(w32_getlogin_buffer);
1109 if (GetUserName(buf,&size))
1115 chown(const char *path, uid_t owner, gid_t group)
1122 * XXX this needs strengthening (for PerlIO)
1125 int mkstemp(const char *path)
1128 char buf[MAX_PATH+1];
1132 if (i++ > 10) { /* give up */
1136 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1140 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1147 find_pid(pTHX_ int pid)
1149 long child = w32_num_children;
1150 while (--child >= 0) {
1151 if ((int)w32_child_pids[child] == pid)
1158 remove_dead_process(long child)
1162 CloseHandle(w32_child_handles[child]);
1163 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1164 (w32_num_children-child-1), HANDLE);
1165 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1166 (w32_num_children-child-1), DWORD);
1173 find_pseudo_pid(pTHX_ int pid)
1175 long child = w32_num_pseudo_children;
1176 while (--child >= 0) {
1177 if ((int)w32_pseudo_child_pids[child] == pid)
1184 remove_dead_pseudo_process(long child)
1188 CloseHandle(w32_pseudo_child_handles[child]);
1189 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1190 (w32_num_pseudo_children-child-1), HANDLE);
1191 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1192 (w32_num_pseudo_children-child-1), DWORD);
1193 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1194 (w32_num_pseudo_children-child-1), HWND);
1195 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1196 (w32_num_pseudo_children-child-1), char);
1197 w32_num_pseudo_children--;
1202 win32_wait_for_children(pTHX)
1204 if (w32_pseudo_children && w32_num_pseudo_children) {
1207 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1209 for (child = 0; child < w32_num_pseudo_children; ++child) {
1210 if (!w32_pseudo_child_sigterm[child])
1211 handles[count++] = w32_pseudo_child_handles[child];
1213 /* XXX should use MsgWaitForMultipleObjects() to continue
1214 * XXX processing messages while we wait.
1216 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1218 while (w32_num_pseudo_children)
1219 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1225 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1229 /* "Does process exist?" use of kill */
1232 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1237 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1240 default: /* For now be backwards compatible with perl 5.6 */
1242 /* Note that we will only be able to kill processes owned by the
1243 * current process owner, even when we are running as an administrator.
1244 * To kill processes of other owners we would need to set the
1245 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1247 if (TerminateProcess(process_handle, sig))
1254 /* returns number of processes killed */
1256 my_killpg(int pid, int sig)
1258 HANDLE process_handle;
1259 HANDLE snapshot_handle;
1262 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1263 if (process_handle == NULL)
1266 killed += terminate_process(pid, process_handle, sig);
1268 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1269 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1270 PROCESSENTRY32 entry;
1272 entry.dwSize = sizeof(entry);
1273 if (Process32First(snapshot_handle, &entry)) {
1275 if (entry.th32ParentProcessID == (DWORD)pid)
1276 killed += my_killpg(entry.th32ProcessID, sig);
1277 entry.dwSize = sizeof(entry);
1279 while (Process32Next(snapshot_handle, &entry));
1281 CloseHandle(snapshot_handle);
1283 CloseHandle(process_handle);
1287 /* returns number of processes killed */
1289 my_kill(int pid, int sig)
1292 HANDLE process_handle;
1295 return my_killpg(pid, -sig);
1297 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1298 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1299 if (process_handle != NULL) {
1300 retval = terminate_process(pid, process_handle, sig);
1301 CloseHandle(process_handle);
1307 /* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1308 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1309 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1310 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1312 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1313 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1314 * a HWND in the time period allowed.
1317 get_hwnd_delay(pTHX, long child, DWORD tries)
1319 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1320 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1322 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1323 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1324 * thread 100% of the time since threads are attached to a CPU for NUMA and
1325 * caching reasons, and the child thread was attached to a different CPU
1326 * therefore there is no workload on that CPU and Sleep(0) returns control
1327 * without yielding the time slot.
1328 * https://rt.perl.org/rt3/Ticket/Display.html?id=88840
1331 win32_async_check(aTHX);
1332 hwnd = w32_pseudo_child_message_hwnds[child];
1333 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1336 unsigned int count = 0;
1337 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1338 while (count++ < tries) {
1340 win32_async_check(aTHX);
1341 hwnd = w32_pseudo_child_message_hwnds[child];
1342 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1346 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1351 win32_kill(int pid, int sig)
1357 /* it is a pseudo-forked child */
1358 child = find_pseudo_pid(aTHX_ -pid);
1360 HANDLE hProcess = w32_pseudo_child_handles[child];
1363 /* "Does process exist?" use of kill */
1367 /* kill -9 style un-graceful exit */
1368 /* Do a wait to make sure child starts and isn't in DLL
1370 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1371 if (TerminateThread(hProcess, sig)) {
1372 /* Allow the scheduler to finish cleaning up the other
1374 * Otherwise, if we ExitProcess() before another context
1375 * switch happens we will end up with a process exit
1376 * code of "sig" instead of our own exit status.
1377 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1380 remove_dead_pseudo_process(child);
1387 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1388 /* We fake signals to pseudo-processes using Win32
1390 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1391 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1393 /* Don't wait for child process to terminate after we send a
1394 * SIGTERM because the child may be blocked in a system call
1395 * and never receive the signal.
1397 if (sig == SIGTERM) {
1399 w32_pseudo_child_sigterm[child] = 1;
1401 /* It might be us ... */
1413 child = find_pid(aTHX_ pid);
1415 if (my_kill(pid, sig)) {
1417 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1418 exitcode != STILL_ACTIVE)
1420 remove_dead_process(child);
1426 if (my_kill(pid, sig))
1435 win32_stat(const char *path, Stat_t *sbuf)
1437 char buffer[MAX_PATH+1];
1438 int l = strlen(path);
1442 BOOL expect_dir = FALSE;
1444 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1445 GV_NOTQUAL, SVt_PV);
1446 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1449 switch(path[l - 1]) {
1450 /* FindFirstFile() and stat() are buggy with a trailing
1451 * slashes, except for the root directory of a drive */
1454 if (l > sizeof(buffer)) {
1455 errno = ENAMETOOLONG;
1459 strncpy(buffer, path, l);
1460 /* remove additional trailing slashes */
1461 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1463 /* add back slash if we otherwise end up with just a drive letter */
1464 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1471 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1473 if (l == 2 && isALPHA(path[0])) {
1474 buffer[0] = path[0];
1485 path = PerlDir_mapA(path);
1489 /* We must open & close the file once; otherwise file attribute changes */
1490 /* might not yet have propagated to "other" hard links of the same file. */
1491 /* This also gives us an opportunity to determine the number of links. */
1492 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1493 if (handle != INVALID_HANDLE_VALUE) {
1494 BY_HANDLE_FILE_INFORMATION bhi;
1495 if (GetFileInformationByHandle(handle, &bhi))
1496 nlink = bhi.nNumberOfLinks;
1497 CloseHandle(handle);
1501 /* path will be mapped correctly above */
1502 #if defined(WIN64) || defined(USE_LARGE_FILES)
1503 res = _stati64(path, sbuf);
1505 res = stat(path, sbuf);
1507 sbuf->st_nlink = nlink;
1510 /* CRT is buggy on sharenames, so make sure it really isn't.
1511 * XXX using GetFileAttributesEx() will enable us to set
1512 * sbuf->st_*time (but note that's not available on the
1513 * Windows of 1995) */
1514 DWORD r = GetFileAttributesA(path);
1515 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1516 /* sbuf may still contain old garbage since stat() failed */
1517 Zero(sbuf, 1, Stat_t);
1518 sbuf->st_mode = S_IFDIR | S_IREAD;
1520 if (!(r & FILE_ATTRIBUTE_READONLY))
1521 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1526 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1527 && (path[2] == '\\' || path[2] == '/'))
1529 /* The drive can be inaccessible, some _stat()s are buggy */
1530 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1535 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1539 if (S_ISDIR(sbuf->st_mode)) {
1540 /* Ensure the "write" bit is switched off in the mode for
1541 * directories with the read-only attribute set. Some compilers
1542 * switch it on for directories, which is technically correct
1543 * (directories are indeed always writable unless denied by DACLs),
1544 * but we want stat() and -w to reflect the state of the read-only
1545 * attribute for symmetry with chmod(). */
1546 DWORD r = GetFileAttributesA(path);
1547 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1548 sbuf->st_mode &= ~S_IWRITE;
1555 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1556 #define SKIP_SLASHES(s) \
1558 while (*(s) && isSLASH(*(s))) \
1561 #define COPY_NONSLASHES(d,s) \
1563 while (*(s) && !isSLASH(*(s))) \
1567 /* Find the longname of a given path. path is destructively modified.
1568 * It should have space for at least MAX_PATH characters. */
1570 win32_longpath(char *path)
1572 WIN32_FIND_DATA fdata;
1574 char tmpbuf[MAX_PATH+1];
1575 char *tmpstart = tmpbuf;
1582 if (isALPHA(path[0]) && path[1] == ':') {
1584 *tmpstart++ = path[0];
1588 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1590 *tmpstart++ = path[0];
1591 *tmpstart++ = path[1];
1592 SKIP_SLASHES(start);
1593 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1595 *tmpstart++ = *start++;
1596 SKIP_SLASHES(start);
1597 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1602 /* copy initial slash, if any */
1603 if (isSLASH(*start)) {
1604 *tmpstart++ = *start++;
1606 SKIP_SLASHES(start);
1609 /* FindFirstFile() expands "." and "..", so we need to pass
1610 * those through unmolested */
1612 && (!start[1] || isSLASH(start[1])
1613 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1615 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1620 /* if this is the end, bust outta here */
1624 /* now we're at a non-slash; walk up to next slash */
1625 while (*start && !isSLASH(*start))
1628 /* stop and find full name of component */
1631 fhand = FindFirstFile(path,&fdata);
1633 if (fhand != INVALID_HANDLE_VALUE) {
1634 STRLEN len = strlen(fdata.cFileName);
1635 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1636 strcpy(tmpstart, fdata.cFileName);
1647 /* failed a step, just return without side effects */
1648 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1653 strcpy(path,tmpbuf);
1666 win32_croak_not_implemented(const char * fname)
1668 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1670 Perl_croak_nocontext("%s not implemented!\n", fname);
1673 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1674 * potentially using the system's default replacement character for any
1675 * unrepresentable characters. The caller must free() the returned string. */
1677 wstr_to_str(const wchar_t* wstr)
1679 BOOL used_default = FALSE;
1680 size_t wlen = wcslen(wstr) + 1;
1681 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1682 NULL, 0, NULL, NULL);
1683 char* str = (char*)malloc(len);
1686 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1687 str, len, NULL, &used_default);
1691 /* The win32_ansipath() function takes a Unicode filename and converts it
1692 * into the current Windows codepage. If some characters cannot be mapped,
1693 * then it will convert the short name instead.
1695 * The buffer to the ansi pathname must be freed with win32_free() when it
1696 * it no longer needed.
1698 * The argument to win32_ansipath() must exist before this function is
1699 * called; otherwise there is no way to determine the short path name.
1701 * Ideas for future refinement:
1702 * - Only convert those segments of the path that are not in the current
1703 * codepage, but leave the other segments in their long form.
1704 * - If the resulting name is longer than MAX_PATH, start converting
1705 * additional path segments into short names until the full name
1706 * is shorter than MAX_PATH. Shorten the filename part last!
1709 win32_ansipath(const WCHAR *widename)
1712 BOOL use_default = FALSE;
1713 size_t widelen = wcslen(widename)+1;
1714 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1715 NULL, 0, NULL, NULL);
1716 name = (char*)win32_malloc(len);
1720 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1721 name, len, NULL, &use_default);
1723 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1725 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
1728 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1730 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1731 NULL, 0, NULL, NULL);
1732 name = (char*)win32_realloc(name, len);
1735 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1736 name, len, NULL, NULL);
1737 win32_free(shortname);
1743 /* the returned string must be freed with win32_freeenvironmentstrings which is
1744 * implemented as a macro
1745 * void win32_freeenvironmentstrings(void* block)
1748 win32_getenvironmentstrings(void)
1750 LPWSTR lpWStr, lpWTmp;
1752 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1754 /* Get the process environment strings */
1755 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
1756 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
1757 env_len = wcslen(lpWTmp);
1758 /* calculate the size of the environment strings */
1759 wenvstrings_len += env_len + 1;
1762 /* Get the number of bytes required to store the ACP encoded string */
1763 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1764 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
1765 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1769 /* Convert the string from UTF-16 encoding to ACP encoding */
1770 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
1771 aenvstrings_len, NULL, NULL);
1773 FreeEnvironmentStringsW(lpWStr);
1779 win32_getenv(const char *name)
1786 needlen = GetEnvironmentVariableA(name,NULL,0);
1788 curitem = sv_2mortal(newSVpvs(""));
1790 SvGROW(curitem, needlen+1);
1791 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1793 } while (needlen >= SvLEN(curitem));
1794 SvCUR_set(curitem, needlen);
1797 last_err = GetLastError();
1798 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1799 /* It appears the variable is in the env, but the Win32 API
1800 doesn't have a canned way of getting it. So we fall back to
1801 grabbing the whole env and pulling this value out if possible */
1802 char *envv = GetEnvironmentStrings();
1806 char *end = strchr(cur,'=');
1807 if (end && end != cur) {
1809 if (!strcmp(cur,name)) {
1810 curitem = sv_2mortal(newSVpv(end+1,0));
1815 cur = end + strlen(end+1)+2;
1817 else if ((len = strlen(cur)))
1820 FreeEnvironmentStrings(envv);
1823 /* last ditch: allow any environment variables that begin with 'PERL'
1824 to be obtained from the registry, if found there */
1825 if (strncmp(name, "PERL", 4) == 0)
1826 (void)get_regstr(name, &curitem);
1829 if (curitem && SvCUR(curitem))
1830 return SvPVX(curitem);
1836 win32_putenv(const char *name)
1843 curitem = (char *) win32_malloc(strlen(name)+1);
1844 strcpy(curitem, name);
1845 val = strchr(curitem, '=');
1847 /* The sane way to deal with the environment.
1848 * Has these advantages over putenv() & co.:
1849 * * enables us to store a truly empty value in the
1850 * environment (like in UNIX).
1851 * * we don't have to deal with RTL globals, bugs and leaks
1852 * (specifically, see http://support.microsoft.com/kb/235601).
1854 * Why you may want to use the RTL environment handling
1855 * (previously enabled by USE_WIN32_RTL_ENV):
1856 * * environ[] and RTL functions will not reflect changes,
1857 * which might be an issue if extensions want to access
1858 * the env. via RTL. This cuts both ways, since RTL will
1859 * not see changes made by extensions that call the Win32
1860 * functions directly, either.
1864 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1867 win32_free(curitem);
1873 filetime_to_clock(PFILETIME ft)
1875 __int64 qw = ft->dwHighDateTime;
1877 qw |= ft->dwLowDateTime;
1878 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1883 win32_times(struct tms *timebuf)
1888 clock_t process_time_so_far = clock();
1889 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1891 timebuf->tms_utime = filetime_to_clock(&user);
1892 timebuf->tms_stime = filetime_to_clock(&kernel);
1893 timebuf->tms_cutime = 0;
1894 timebuf->tms_cstime = 0;
1896 /* That failed - e.g. Win95 fallback to clock() */
1897 timebuf->tms_utime = process_time_so_far;
1898 timebuf->tms_stime = 0;
1899 timebuf->tms_cutime = 0;
1900 timebuf->tms_cstime = 0;
1902 return process_time_so_far;
1905 /* fix utime() so it works on directories in NT */
1907 filetime_from_time(PFILETIME pFileTime, time_t Time)
1909 struct tm *pTM = localtime(&Time);
1910 SYSTEMTIME SystemTime;
1916 SystemTime.wYear = pTM->tm_year + 1900;
1917 SystemTime.wMonth = pTM->tm_mon + 1;
1918 SystemTime.wDay = pTM->tm_mday;
1919 SystemTime.wHour = pTM->tm_hour;
1920 SystemTime.wMinute = pTM->tm_min;
1921 SystemTime.wSecond = pTM->tm_sec;
1922 SystemTime.wMilliseconds = 0;
1924 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1925 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1929 win32_unlink(const char *filename)
1935 filename = PerlDir_mapA(filename);
1936 attrs = GetFileAttributesA(filename);
1937 if (attrs == 0xFFFFFFFF) {
1941 if (attrs & FILE_ATTRIBUTE_READONLY) {
1942 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1943 ret = unlink(filename);
1945 (void)SetFileAttributesA(filename, attrs);
1948 ret = unlink(filename);
1953 win32_utime(const char *filename, struct utimbuf *times)
1960 struct utimbuf TimeBuffer;
1963 filename = PerlDir_mapA(filename);
1964 rc = utime(filename, times);
1966 /* EACCES: path specifies directory or readonly file */
1967 if (rc == 0 || errno != EACCES)
1970 if (times == NULL) {
1971 times = &TimeBuffer;
1972 time(×->actime);
1973 times->modtime = times->actime;
1976 /* This will (and should) still fail on readonly files */
1977 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1978 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1979 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1980 if (handle == INVALID_HANDLE_VALUE)
1983 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1984 filetime_from_time(&ftAccess, times->actime) &&
1985 filetime_from_time(&ftWrite, times->modtime) &&
1986 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1991 CloseHandle(handle);
1996 unsigned __int64 ft_i64;
2001 #define Const64(x) x##LL
2003 #define Const64(x) x##i64
2005 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2006 #define EPOCH_BIAS Const64(116444736000000000)
2008 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2009 * and appears to be unsupported even by glibc) */
2011 win32_gettimeofday(struct timeval *tp, void *not_used)
2015 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2016 GetSystemTimeAsFileTime(&ft.ft_val);
2018 /* seconds since epoch */
2019 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2021 /* microseconds remaining */
2022 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2028 win32_uname(struct utsname *name)
2030 struct hostent *hep;
2031 STRLEN nodemax = sizeof(name->nodename)-1;
2034 switch (g_osver.dwPlatformId) {
2035 case VER_PLATFORM_WIN32_WINDOWS:
2036 strcpy(name->sysname, "Windows");
2038 case VER_PLATFORM_WIN32_NT:
2039 strcpy(name->sysname, "Windows NT");
2041 case VER_PLATFORM_WIN32s:
2042 strcpy(name->sysname, "Win32s");
2045 strcpy(name->sysname, "Win32 Unknown");
2050 sprintf(name->release, "%d.%d",
2051 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2054 sprintf(name->version, "Build %d",
2055 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2056 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2057 if (g_osver.szCSDVersion[0]) {
2058 char *buf = name->version + strlen(name->version);
2059 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2063 hep = win32_gethostbyname("localhost");
2065 STRLEN len = strlen(hep->h_name);
2066 if (len <= nodemax) {
2067 strcpy(name->nodename, hep->h_name);
2070 strncpy(name->nodename, hep->h_name, nodemax);
2071 name->nodename[nodemax] = '\0';
2076 if (!GetComputerName(name->nodename, &sz))
2077 *name->nodename = '\0';
2080 /* machine (architecture) */
2085 GetSystemInfo(&info);
2087 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2088 procarch = info.u.s.wProcessorArchitecture;
2090 procarch = info.wProcessorArchitecture;
2093 case PROCESSOR_ARCHITECTURE_INTEL:
2094 arch = "x86"; break;
2095 case PROCESSOR_ARCHITECTURE_IA64:
2096 arch = "ia64"; break;
2097 case PROCESSOR_ARCHITECTURE_AMD64:
2098 arch = "amd64"; break;
2099 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2100 arch = "unknown"; break;
2102 sprintf(name->machine, "unknown(0x%x)", procarch);
2103 arch = name->machine;
2106 if (name->machine != arch)
2107 strcpy(name->machine, arch);
2112 /* Timing related stuff */
2115 do_raise(pTHX_ int sig)
2117 if (sig < SIG_SIZE) {
2118 Sighandler_t handler = w32_sighandler[sig];
2119 if (handler == SIG_IGN) {
2122 else if (handler != SIG_DFL) {
2127 /* Choose correct default behaviour */
2143 /* Tell caller to exit thread/process as approriate */
2148 sig_terminate(pTHX_ int sig)
2150 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2151 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2158 win32_async_check(pTHX)
2161 HWND hwnd = w32_message_hwnd;
2163 /* Reset w32_poll_count before doing anything else, incase we dispatch
2164 * messages that end up calling back into perl */
2167 if (hwnd != INVALID_HANDLE_VALUE) {
2168 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2169 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2174 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2175 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2177 /* re-post a WM_QUIT message (we'll mark it as read later) */
2178 if(msg.message == WM_QUIT) {
2179 PostQuitMessage((int)msg.wParam);
2183 if(!CallMsgFilter(&msg, MSGF_USER))
2185 TranslateMessage(&msg);
2186 DispatchMessage(&msg);
2191 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2192 * This is necessary when we are being called by win32_msgwait() to
2193 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2194 * message over and over. An example how this can happen is when
2195 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2196 * is generating messages before the process terminated.
2198 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2200 /* Above or other stuff may have set a signal flag */
2207 /* This function will not return until the timeout has elapsed, or until
2208 * one of the handles is ready. */
2210 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2212 /* We may need several goes at this - so compute when we stop */
2214 unsigned __int64 endtime = timeout;
2215 if (timeout != INFINITE) {
2216 GetSystemTimeAsFileTime(&ticks.ft_val);
2217 ticks.ft_i64 /= 10000;
2218 endtime += ticks.ft_i64;
2220 /* This was a race condition. Do not let a non INFINITE timeout to
2221 * MsgWaitForMultipleObjects roll under 0 creating a near
2222 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2223 * user who did a CORE perl function with a non infinity timeout,
2224 * sleep for example. This is 64 to 32 truncation minefield.
2226 * This scenario can only be created if the timespan from the return of
2227 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2228 * generate the scenario, manual breakpoints in a C debugger are required,
2229 * or a context switch occured in win32_async_check in PeekMessage, or random
2230 * messages are delivered to the *thread* message queue of the Perl thread
2231 * from another process (msctf.dll doing IPC among its instances, VS debugger
2232 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2234 while (ticks.ft_i64 <= endtime) {
2235 /* if timeout's type is lengthened, remember to split 64b timeout
2236 * into multiple non-infinity runs of MWFMO */
2237 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2238 (DWORD)(endtime - ticks.ft_i64),
2239 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2242 if (result == WAIT_TIMEOUT) {
2243 /* Ran out of time - explicit return of zero to avoid -ve if we
2244 have scheduling issues
2248 if (timeout != INFINITE) {
2249 GetSystemTimeAsFileTime(&ticks.ft_val);
2250 ticks.ft_i64 /= 10000;
2252 if (result == WAIT_OBJECT_0 + count) {
2253 /* Message has arrived - check it */
2254 (void)win32_async_check(aTHX);
2257 /* Not timeout or message - one of handles is ready */
2261 /* If we are past the end say zero */
2262 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2264 /* compute time left to wait */
2265 ticks.ft_i64 = endtime - ticks.ft_i64;
2266 /* if more ms than DWORD, then return max DWORD */
2267 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2271 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2273 /* XXX this wait emulation only knows about processes
2274 * spawned via win32_spawnvp(P_NOWAIT, ...).
2277 DWORD exitcode, waitcode;
2280 if (w32_num_pseudo_children) {
2281 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2282 timeout, &waitcode);
2283 /* Time out here if there are no other children to wait for. */
2284 if (waitcode == WAIT_TIMEOUT) {
2285 if (!w32_num_children) {
2289 else if (waitcode != WAIT_FAILED) {
2290 if (waitcode >= WAIT_ABANDONED_0
2291 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2292 i = waitcode - WAIT_ABANDONED_0;
2294 i = waitcode - WAIT_OBJECT_0;
2295 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2296 *status = (int)((exitcode & 0xff) << 8);
2297 retval = (int)w32_pseudo_child_pids[i];
2298 remove_dead_pseudo_process(i);
2305 if (!w32_num_children) {
2310 /* if a child exists, wait for it to die */
2311 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2312 if (waitcode == WAIT_TIMEOUT) {
2315 if (waitcode != WAIT_FAILED) {
2316 if (waitcode >= WAIT_ABANDONED_0
2317 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2318 i = waitcode - WAIT_ABANDONED_0;
2320 i = waitcode - WAIT_OBJECT_0;
2321 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2322 *status = (int)((exitcode & 0xff) << 8);
2323 retval = (int)w32_child_pids[i];
2324 remove_dead_process(i);
2329 errno = GetLastError();
2334 win32_waitpid(int pid, int *status, int flags)
2337 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2340 if (pid == -1) /* XXX threadid == 1 ? */
2341 return win32_internal_wait(aTHX_ status, timeout);
2344 child = find_pseudo_pid(aTHX_ -pid);
2346 HANDLE hThread = w32_pseudo_child_handles[child];
2348 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2349 if (waitcode == WAIT_TIMEOUT) {
2352 else if (waitcode == WAIT_OBJECT_0) {
2353 if (GetExitCodeThread(hThread, &waitcode)) {
2354 *status = (int)((waitcode & 0xff) << 8);
2355 retval = (int)w32_pseudo_child_pids[child];
2356 remove_dead_pseudo_process(child);
2368 child = find_pid(aTHX_ pid);
2370 hProcess = w32_child_handles[child];
2371 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2372 if (waitcode == WAIT_TIMEOUT) {
2375 else if (waitcode == WAIT_OBJECT_0) {
2376 if (GetExitCodeProcess(hProcess, &waitcode)) {
2377 *status = (int)((waitcode & 0xff) << 8);
2378 retval = (int)w32_child_pids[child];
2379 remove_dead_process(child);
2387 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2389 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2390 if (waitcode == WAIT_TIMEOUT) {
2391 CloseHandle(hProcess);
2394 else if (waitcode == WAIT_OBJECT_0) {
2395 if (GetExitCodeProcess(hProcess, &waitcode)) {
2396 *status = (int)((waitcode & 0xff) << 8);
2397 CloseHandle(hProcess);
2401 CloseHandle(hProcess);
2407 return retval >= 0 ? pid : retval;
2411 win32_wait(int *status)
2414 return win32_internal_wait(aTHX_ status, INFINITE);
2417 DllExport unsigned int
2418 win32_sleep(unsigned int t)
2421 /* Win32 times are in ms so *1000 in and /1000 out */
2422 if (t > UINT_MAX / 1000) {
2423 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2424 "sleep(%lu) too large", t);
2426 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2429 DllExport unsigned int
2430 win32_alarm(unsigned int sec)
2433 * the 'obvious' implentation is SetTimer() with a callback
2434 * which does whatever receiving SIGALRM would do
2435 * we cannot use SIGALRM even via raise() as it is not
2436 * one of the supported codes in <signal.h>
2440 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2441 w32_message_hwnd = win32_create_message_window();
2444 if (w32_message_hwnd == NULL)
2445 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2448 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2453 KillTimer(w32_message_hwnd, w32_timerid);
2460 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2463 win32_crypt(const char *txt, const char *salt)
2466 return des_fcrypt(txt, salt, w32_crypt_buffer);
2469 /* simulate flock by locking a range on the file */
2471 #define LK_LEN 0xffff0000
2474 win32_flock(int fd, int oper)
2480 fh = (HANDLE)_get_osfhandle(fd);
2481 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2484 memset(&o, 0, sizeof(o));
2487 case LOCK_SH: /* shared lock */
2488 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2491 case LOCK_EX: /* exclusive lock */
2492 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2495 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2496 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2499 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2500 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2504 case LOCK_UN: /* unlock lock */
2505 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2508 default: /* unknown */
2513 if (GetLastError() == ERROR_LOCK_VIOLATION)
2514 errno = EWOULDBLOCK;
2523 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2525 /* Get the errno value corresponding to the given err. This function is not
2526 * intended to handle conversion of general GetLastError() codes. It only exists
2527 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2528 * used to be assigned to errno/$! in earlier versions of perl; this function is
2529 * used to catch any old Perl code which is still trying to assign such values
2530 * to $! and convert them to errno values instead.
2533 win32_get_errno(int err)
2535 return convert_wsa_error_to_errno(err);
2539 * redirected io subsystem for all XS modules
2552 return (&(_environ));
2555 /* the rest are the remapped stdio routines */
2575 win32_ferror(FILE *fp)
2577 return (ferror(fp));
2582 win32_feof(FILE *fp)
2587 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2588 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2592 * Since the errors returned by the socket error function
2593 * WSAGetLastError() are not known by the library routine strerror
2594 * we have to roll our own to cover the case of socket errors
2595 * that could not be converted to regular errno values by
2596 * get_last_socket_error() in win32/win32sck.c.
2600 win32_strerror(int e)
2602 #if !defined __MINGW32__ /* compiler intolerance */
2603 extern int sys_nerr;
2606 if (e < 0 || e > sys_nerr) {
2610 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2611 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2612 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2613 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2614 * We must therefore still roll our own messages for these codes, and
2615 * additionally map them to corresponding Windows (sockets) error codes
2616 * first to avoid getting the wrong system message.
2618 else if (e >= EADDRINUSE && e <= EWOULDBLOCK) {
2619 e = convert_errno_to_wsa_error(e);
2623 aTHXa(PERL_GET_THX);
2624 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2625 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2626 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2629 strcpy(w32_strerror_buffer, "Unknown Error");
2631 return w32_strerror_buffer;
2635 #define strerror win32_strerror
2639 win32_str_os_error(void *sv, DWORD dwErr)
2643 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2644 |FORMAT_MESSAGE_IGNORE_INSERTS
2645 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2646 dwErr, 0, (char *)&sMsg, 1, NULL);
2647 /* strip trailing whitespace and period */
2650 --dwLen; /* dwLen doesn't include trailing null */
2651 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2652 if ('.' != sMsg[dwLen])
2657 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2659 dwLen = sprintf(sMsg,
2660 "Unknown error #0x%lX (lookup 0x%lX)",
2661 dwErr, GetLastError());
2665 sv_setpvn((SV*)sv, sMsg, dwLen);
2671 win32_fprintf(FILE *fp, const char *format, ...)
2674 va_start(marker, format); /* Initialize variable arguments. */
2676 return (vfprintf(fp, format, marker));
2680 win32_printf(const char *format, ...)
2683 va_start(marker, format); /* Initialize variable arguments. */
2685 return (vprintf(format, marker));
2689 win32_vfprintf(FILE *fp, const char *format, va_list args)
2691 return (vfprintf(fp, format, args));
2695 win32_vprintf(const char *format, va_list args)
2697 return (vprintf(format, args));
2701 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2703 return fread(buf, size, count, fp);
2707 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2709 return fwrite(buf, size, count, fp);
2712 #define MODE_SIZE 10
2715 win32_fopen(const char *filename, const char *mode)
2723 if (stricmp(filename, "/dev/null")==0)
2726 aTHXa(PERL_GET_THX);
2727 f = fopen(PerlDir_mapA(filename), mode);
2728 /* avoid buffering headaches for child processes */
2729 if (f && *mode == 'a')
2730 win32_fseek(f, 0, SEEK_END);
2735 win32_fdopen(int handle, const char *mode)
2738 f = fdopen(handle, (char *) mode);
2739 /* avoid buffering headaches for child processes */
2740 if (f && *mode == 'a')
2741 win32_fseek(f, 0, SEEK_END);
2746 win32_freopen(const char *path, const char *mode, FILE *stream)
2749 if (stricmp(path, "/dev/null")==0)
2752 aTHXa(PERL_GET_THX);
2753 return freopen(PerlDir_mapA(path), mode, stream);
2757 win32_fclose(FILE *pf)
2759 #ifdef WIN32_NO_SOCKETS
2762 return my_fclose(pf); /* defined in win32sck.c */
2767 win32_fputs(const char *s,FILE *pf)
2769 return fputs(s, pf);
2773 win32_fputc(int c,FILE *pf)
2779 win32_ungetc(int c,FILE *pf)
2781 return ungetc(c,pf);
2785 win32_getc(FILE *pf)
2791 win32_fileno(FILE *pf)
2797 win32_clearerr(FILE *pf)
2804 win32_fflush(FILE *pf)
2810 win32_ftell(FILE *pf)
2812 #if defined(WIN64) || defined(USE_LARGE_FILES)
2814 if (fgetpos(pf, &pos))
2823 win32_fseek(FILE *pf, Off_t offset,int origin)
2825 #if defined(WIN64) || defined(USE_LARGE_FILES)
2829 if (fgetpos(pf, &pos))
2834 fseek(pf, 0, SEEK_END);
2835 pos = _telli64(fileno(pf));
2844 return fsetpos(pf, &offset);
2846 return fseek(pf, (long)offset, origin);
2851 win32_fgetpos(FILE *pf,fpos_t *p)
2853 return fgetpos(pf, p);
2857 win32_fsetpos(FILE *pf,const fpos_t *p)
2859 return fsetpos(pf, p);
2863 win32_rewind(FILE *pf)
2872 char prefix[MAX_PATH+1];
2873 char filename[MAX_PATH+1];
2874 DWORD len = GetTempPath(MAX_PATH, prefix);
2875 if (len && len < MAX_PATH) {
2876 if (GetTempFileName(prefix, "plx", 0, filename)) {
2877 HANDLE fh = CreateFile(filename,
2878 DELETE | GENERIC_READ | GENERIC_WRITE,
2882 FILE_ATTRIBUTE_NORMAL
2883 | FILE_FLAG_DELETE_ON_CLOSE,
2885 if (fh != INVALID_HANDLE_VALUE) {
2886 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2889 DEBUG_p(PerlIO_printf(Perl_debug_log,
2890 "Created tmpfile=%s\n",filename));
2902 int fd = win32_tmpfd();
2904 return win32_fdopen(fd, "w+b");
2916 win32_fstat(int fd, Stat_t *sbufptr)
2918 #if defined(WIN64) || defined(USE_LARGE_FILES)
2919 return _fstati64(fd, sbufptr);
2921 return fstat(fd, sbufptr);
2926 win32_pipe(int *pfd, unsigned int size, int mode)
2928 return _pipe(pfd, size, mode);
2932 win32_popenlist(const char *mode, IV narg, SV **args)
2934 Perl_croak_nocontext("List form of pipe open not implemented");
2939 * a popen() clone that respects PERL5SHELL
2941 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2945 win32_popen(const char *command, const char *mode)
2947 #ifdef USE_RTL_POPEN
2948 return _popen(command, mode);
2959 /* establish which ends read and write */
2960 if (strchr(mode,'w')) {
2961 stdfd = 0; /* stdin */
2964 nhandle = STD_INPUT_HANDLE;
2966 else if (strchr(mode,'r')) {
2967 stdfd = 1; /* stdout */
2970 nhandle = STD_OUTPUT_HANDLE;
2975 /* set the correct mode */
2976 if (strchr(mode,'b'))
2978 else if (strchr(mode,'t'))
2981 ourmode = _fmode & (O_TEXT | O_BINARY);
2983 /* the child doesn't inherit handles */
2984 ourmode |= O_NOINHERIT;
2986 if (win32_pipe(p, 512, ourmode) == -1)
2989 /* Previously this code redirected stdin/out temporarily so the
2990 child process inherited those handles, this caused race
2991 conditions when another thread was writing/reading those
2994 To avoid that we just feed the handles to CreateProcess() so
2995 the handles are redirected only in the child.
2997 handles[child] = p[child];
2998 handles[parent] = -1;
3001 /* CreateProcess() requires inheritable handles */
3002 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3003 HANDLE_FLAG_INHERIT)) {
3007 /* start the child */
3011 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3014 win32_close(p[child]);
3016 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3018 /* set process id so that it can be returned by perl's open() */
3019 PL_forkprocess = childpid;
3022 /* we have an fd, return a file stream */
3023 return (PerlIO_fdopen(p[parent], (char *)mode));
3026 /* we don't need to check for errors here */
3032 #endif /* USE_RTL_POPEN */
3040 win32_pclose(PerlIO *pf)
3042 #ifdef USE_RTL_POPEN
3046 int childpid, status;
3049 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3052 childpid = SvIVX(sv);
3068 if (win32_waitpid(childpid, &status, 0) == -1)
3073 #endif /* USE_RTL_POPEN */
3077 win32_link(const char *oldname, const char *newname)
3080 WCHAR wOldName[MAX_PATH+1];
3081 WCHAR wNewName[MAX_PATH+1];
3083 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3084 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3085 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3086 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3090 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3091 both permissions errors and if the source is a directory, while
3092 POSIX wants EACCES and EPERM respectively.
3094 Determined by experimentation on Windows 7 x64 SP1, since MS
3095 don't document what error codes are returned.
3097 switch (GetLastError()) {
3098 case ERROR_BAD_NET_NAME:
3099 case ERROR_BAD_NETPATH:
3100 case ERROR_BAD_PATHNAME:
3101 case ERROR_FILE_NOT_FOUND:
3102 case ERROR_FILENAME_EXCED_RANGE:
3103 case ERROR_INVALID_DRIVE:
3104 case ERROR_PATH_NOT_FOUND:
3107 case ERROR_ALREADY_EXISTS:
3110 case ERROR_ACCESS_DENIED:
3113 case ERROR_NOT_SAME_DEVICE:
3116 case ERROR_DISK_FULL:
3119 case ERROR_NOT_ENOUGH_QUOTA:
3123 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3131 win32_rename(const char *oname, const char *newname)
3133 char szOldName[MAX_PATH+1];
3135 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3138 if (stricmp(newname, oname))
3139 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3140 strcpy(szOldName, PerlDir_mapA(oname));
3142 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3144 DWORD err = GetLastError();
3146 case ERROR_BAD_NET_NAME:
3147 case ERROR_BAD_NETPATH:
3148 case ERROR_BAD_PATHNAME:
3149 case ERROR_FILE_NOT_FOUND:
3150 case ERROR_FILENAME_EXCED_RANGE:
3151 case ERROR_INVALID_DRIVE:
3152 case ERROR_NO_MORE_FILES:
3153 case ERROR_PATH_NOT_FOUND:
3156 case ERROR_DISK_FULL:
3159 case ERROR_NOT_ENOUGH_QUOTA:
3172 win32_setmode(int fd, int mode)
3174 return setmode(fd, mode);
3178 win32_chsize(int fd, Off_t size)
3180 #if defined(WIN64) || defined(USE_LARGE_FILES)
3182 Off_t cur, end, extend;
3184 cur = win32_tell(fd);
3187 end = win32_lseek(fd, 0, SEEK_END);
3190 extend = size - end;
3194 else if (extend > 0) {
3195 /* must grow the file, padding with nulls */
3197 int oldmode = win32_setmode(fd, O_BINARY);
3199 memset(b, '\0', sizeof(b));
3201 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3202 count = win32_write(fd, b, count);
3203 if ((int)count < 0) {
3207 } while ((extend -= count) > 0);
3208 win32_setmode(fd, oldmode);
3211 /* shrink the file */
3212 win32_lseek(fd, size, SEEK_SET);
3213 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3219 win32_lseek(fd, cur, SEEK_SET);
3222 return chsize(fd, (long)size);
3227 win32_lseek(int fd, Off_t offset, int origin)
3229 #if defined(WIN64) || defined(USE_LARGE_FILES)
3230 return _lseeki64(fd, offset, origin);
3232 return lseek(fd, (long)offset, origin);
3239 #if defined(WIN64) || defined(USE_LARGE_FILES)
3240 return _telli64(fd);
3247 win32_open(const char *path, int flag, ...)
3254 pmode = va_arg(ap, int);
3257 if (stricmp(path, "/dev/null")==0)
3260 aTHXa(PERL_GET_THX);
3261 return open(PerlDir_mapA(path), flag, pmode);
3264 /* close() that understands socket */
3265 extern int my_close(int); /* in win32sck.c */
3270 #ifdef WIN32_NO_SOCKETS
3273 return my_close(fd);
3284 win32_isatty(int fd)
3286 /* The Microsoft isatty() function returns true for *all*
3287 * character mode devices, including "nul". Our implementation
3288 * should only return true if the handle has a console buffer.
3291 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3292 if (fh == (HANDLE)-1) {
3293 /* errno is already set to EBADF */
3297 if (GetConsoleMode(fh, &mode))
3311 win32_dup2(int fd1,int fd2)
3313 return dup2(fd1,fd2);
3317 win32_read(int fd, void *buf, unsigned int cnt)
3319 return read(fd, buf, cnt);
3323 win32_write(int fd, const void *buf, unsigned int cnt)
3325 return write(fd, buf, cnt);
3329 win32_mkdir(const char *dir, int mode)
3332 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3336 win32_rmdir(const char *dir)
3339 return rmdir(PerlDir_mapA(dir));
3343 win32_chdir(const char *dir)
3353 win32_access(const char *path, int mode)
3356 return access(PerlDir_mapA(path), mode);
3360 win32_chmod(const char *path, int mode)
3363 return chmod(PerlDir_mapA(path), mode);
3368 create_command_line(char *cname, STRLEN clen, const char * const *args)
3375 bool bat_file = FALSE;
3376 bool cmd_shell = FALSE;
3377 bool dumb_shell = FALSE;
3378 bool extra_quotes = FALSE;
3379 bool quote_next = FALSE;
3382 cname = (char*)args[0];
3384 /* The NT cmd.exe shell has the following peculiarity that needs to be
3385 * worked around. It strips a leading and trailing dquote when any
3386 * of the following is true:
3387 * 1. the /S switch was used
3388 * 2. there are more than two dquotes
3389 * 3. there is a special character from this set: &<>()@^|
3390 * 4. no whitespace characters within the two dquotes
3391 * 5. string between two dquotes isn't an executable file
3392 * To work around this, we always add a leading and trailing dquote
3393 * to the string, if the first argument is either "cmd.exe" or "cmd",
3394 * and there were at least two or more arguments passed to cmd.exe
3395 * (not including switches).
3396 * XXX the above rules (from "cmd /?") don't seem to be applied
3397 * always, making for the convolutions below :-(
3401 clen = strlen(cname);
3404 && (stricmp(&cname[clen-4], ".bat") == 0
3405 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3411 char *exe = strrchr(cname, '/');
3412 char *exe2 = strrchr(cname, '\\');
3419 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3423 else if (stricmp(exe, "command.com") == 0
3424 || stricmp(exe, "command") == 0)
3431 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3432 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3433 STRLEN curlen = strlen(arg);
3434 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3435 len += 2; /* assume quoting needed (worst case) */
3437 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3439 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3442 Newx(cmd, len, char);
3447 extra_quotes = TRUE;
3450 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3452 STRLEN curlen = strlen(arg);
3454 /* we want to protect empty arguments and ones with spaces with
3455 * dquotes, but only if they aren't already there */
3460 else if (quote_next) {
3461 /* see if it really is multiple arguments pretending to
3462 * be one and force a set of quotes around it */
3463 if (*find_next_space(arg))
3466 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3468 while (i < curlen) {
3469 if (isSPACE(arg[i])) {
3472 else if (arg[i] == '"') {
3496 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3497 && stricmp(arg+curlen-2, "/c") == 0)
3499 /* is there a next argument? */
3500 if (args[index+1]) {
3501 /* are there two or more next arguments? */
3502 if (args[index+2]) {
3504 extra_quotes = TRUE;
3507 /* single argument, force quoting if it has spaces */
3523 qualified_path(const char *cmd)
3526 char *fullcmd, *curfullcmd;
3532 fullcmd = (char*)cmd;
3534 if (*fullcmd == '/' || *fullcmd == '\\')
3543 pathstr = PerlEnv_getenv("PATH");
3545 /* worst case: PATH is a single directory; we need additional space
3546 * to append "/", ".exe" and trailing "\0" */
3547 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3548 curfullcmd = fullcmd;
3553 /* start by appending the name to the current prefix */
3554 strcpy(curfullcmd, cmd);
3555 curfullcmd += cmdlen;
3557 /* if it doesn't end with '.', or has no extension, try adding
3558 * a trailing .exe first */
3559 if (cmd[cmdlen-1] != '.'
3560 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3562 strcpy(curfullcmd, ".exe");
3563 res = GetFileAttributes(fullcmd);
3564 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3569 /* that failed, try the bare name */
3570 res = GetFileAttributes(fullcmd);
3571 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3574 /* quit if no other path exists, or if cmd already has path */
3575 if (!pathstr || !*pathstr || has_slash)
3578 /* skip leading semis */
3579 while (*pathstr == ';')
3582 /* build a new prefix from scratch */
3583 curfullcmd = fullcmd;
3584 while (*pathstr && *pathstr != ';') {
3585 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3586 pathstr++; /* skip initial '"' */
3587 while (*pathstr && *pathstr != '"') {
3588 *curfullcmd++ = *pathstr++;
3591 pathstr++; /* skip trailing '"' */
3594 *curfullcmd++ = *pathstr++;
3598 pathstr++; /* skip trailing semi */
3599 if (curfullcmd > fullcmd /* append a dir separator */
3600 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3602 *curfullcmd++ = '\\';
3610 /* The following are just place holders.
3611 * Some hosts may provide and environment that the OS is
3612 * not tracking, therefore, these host must provide that
3613 * environment and the current directory to CreateProcess
3617 win32_get_childenv(void)
3623 win32_free_childenv(void* d)
3628 win32_clearenv(void)
3630 char *envv = GetEnvironmentStrings();
3634 char *end = strchr(cur,'=');
3635 if (end && end != cur) {
3637 SetEnvironmentVariable(cur, NULL);
3639 cur = end + strlen(end+1)+2;
3641 else if ((len = strlen(cur)))
3644 FreeEnvironmentStrings(envv);
3648 win32_get_childdir(void)
3651 char szfilename[MAX_PATH+1];
3653 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3654 Newx(ptr, strlen(szfilename)+1, char);
3655 strcpy(ptr, szfilename);
3660 win32_free_childdir(char* d)
3666 /* XXX this needs to be made more compatible with the spawnvp()
3667 * provided by the various RTLs. In particular, searching for
3668 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3669 * This doesn't significantly affect perl itself, because we
3670 * always invoke things using PERL5SHELL if a direct attempt to
3671 * spawn the executable fails.
3673 * XXX splitting and rejoining the commandline between do_aspawn()
3674 * and win32_spawnvp() could also be avoided.
3678 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3680 #ifdef USE_RTL_SPAWNVP
3681 return spawnvp(mode, cmdname, (char * const *)argv);
3683 return do_spawnvp_handles(mode, cmdname, argv, NULL);
3688 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
3689 const int *handles) {
3695 STARTUPINFO StartupInfo;
3696 PROCESS_INFORMATION ProcessInformation;
3699 char *fullcmd = NULL;
3700 char *cname = (char *)cmdname;
3704 clen = strlen(cname);
3705 /* if command name contains dquotes, must remove them */
3706 if (strchr(cname, '"')) {
3708 Newx(cname,clen+1,char);
3721 cmd = create_command_line(cname, clen, argv);
3723 aTHXa(PERL_GET_THX);
3724 env = PerlEnv_get_childenv();
3725 dir = PerlEnv_get_childdir();
3728 case P_NOWAIT: /* asynch + remember result */
3729 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3734 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3737 create |= CREATE_NEW_PROCESS_GROUP;
3740 case P_WAIT: /* synchronous execution */
3742 default: /* invalid mode */
3748 memset(&StartupInfo,0,sizeof(StartupInfo));
3749 StartupInfo.cb = sizeof(StartupInfo);
3750 memset(&tbl,0,sizeof(tbl));
3751 PerlEnv_get_child_IO(&tbl);
3752 StartupInfo.dwFlags = tbl.dwFlags;
3753 StartupInfo.dwX = tbl.dwX;
3754 StartupInfo.dwY = tbl.dwY;
3755 StartupInfo.dwXSize = tbl.dwXSize;
3756 StartupInfo.dwYSize = tbl.dwYSize;
3757 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3758 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3759 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3760 StartupInfo.wShowWindow = tbl.wShowWindow;
3761 StartupInfo.hStdInput = handles && handles[0] != -1 ?
3762 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
3763 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
3764 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
3765 StartupInfo.hStdError = handles && handles[2] != -1 ?
3766 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
3767 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3768 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3769 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3771 create |= CREATE_NEW_CONSOLE;
3774 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3776 if (w32_use_showwindow) {
3777 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3778 StartupInfo.wShowWindow = w32_showwindow;
3781 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3784 if (!CreateProcess(cname, /* search PATH to find executable */
3785 cmd, /* executable, and its arguments */
3786 NULL, /* process attributes */
3787 NULL, /* thread attributes */
3788 TRUE, /* inherit handles */
3789 create, /* creation flags */
3790 (LPVOID)env, /* inherit environment */
3791 dir, /* inherit cwd */
3793 &ProcessInformation))
3795 /* initial NULL argument to CreateProcess() does a PATH
3796 * search, but it always first looks in the directory
3797 * where the current process was started, which behavior
3798 * is undesirable for backward compatibility. So we
3799 * jump through our own hoops by picking out the path
3800 * we really want it to use. */
3802 fullcmd = qualified_path(cname);
3804 if (cname != cmdname)
3807 DEBUG_p(PerlIO_printf(Perl_debug_log,
3808 "Retrying [%s] with same args\n",
3818 if (mode == P_NOWAIT) {
3819 /* asynchronous spawn -- store handle, return PID */
3820 ret = (int)ProcessInformation.dwProcessId;
3822 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3823 w32_child_pids[w32_num_children] = (DWORD)ret;
3828 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3829 /* FIXME: if msgwait returned due to message perhaps forward the
3830 "signal" to the process
3832 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3834 CloseHandle(ProcessInformation.hProcess);
3837 CloseHandle(ProcessInformation.hThread);
3840 PerlEnv_free_childenv(env);
3841 PerlEnv_free_childdir(dir);
3843 if (cname != cmdname)
3849 win32_execv(const char *cmdname, const char *const *argv)
3853 /* if this is a pseudo-forked child, we just want to spawn
3854 * the new program, and return */
3856 return spawnv(P_WAIT, cmdname, argv);
3858 return execv(cmdname, argv);
3862 win32_execvp(const char *cmdname, const char *const *argv)
3866 /* if this is a pseudo-forked child, we just want to spawn
3867 * the new program, and return */
3868 if (w32_pseudo_id) {
3869 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3878 return execvp(cmdname, argv);
3882 win32_perror(const char *str)
3888 win32_setbuf(FILE *pf, char *buf)
3894 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3896 return setvbuf(pf, buf, type, size);
3900 win32_flushall(void)
3906 win32_fcloseall(void)
3912 win32_fgets(char *s, int n, FILE *pf)
3914 return fgets(s, n, pf);
3924 win32_fgetc(FILE *pf)
3930 win32_putc(int c, FILE *pf)
3936 win32_puts(const char *s)
3948 win32_putchar(int c)
3955 #ifndef USE_PERL_SBRK
3957 static char *committed = NULL; /* XXX threadead */
3958 static char *base = NULL; /* XXX threadead */
3959 static char *reserved = NULL; /* XXX threadead */
3960 static char *brk = NULL; /* XXX threadead */
3961 static DWORD pagesize = 0; /* XXX threadead */
3964 sbrk(ptrdiff_t need)
3969 GetSystemInfo(&info);
3970 /* Pretend page size is larger so we don't perpetually
3971 * call the OS to commit just one page ...
3973 pagesize = info.dwPageSize << 3;
3975 if (brk+need >= reserved)
3977 DWORD size = brk+need-reserved;
3979 char *prev_committed = NULL;
3980 if (committed && reserved && committed < reserved)
3982 /* Commit last of previous chunk cannot span allocations */
3983 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3986 /* Remember where we committed from in case we want to decommit later */
3987 prev_committed = committed;
3988 committed = reserved;
3991 /* Reserve some (more) space
3992 * Contiguous blocks give us greater efficiency, so reserve big blocks -
3993 * this is only address space not memory...
3994 * Note this is a little sneaky, 1st call passes NULL as reserved
3995 * so lets system choose where we start, subsequent calls pass
3996 * the old end address so ask for a contiguous block
3999 if (size < 64*1024*1024)
4000 size = 64*1024*1024;
4001 size = ((size + pagesize - 1) / pagesize) * pagesize;
4002 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4005 reserved = addr+size;
4015 /* The existing block could not be extended far enough, so decommit
4016 * anything that was just committed above and start anew */
4019 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4022 reserved = base = committed = brk = NULL;
4033 if (brk > committed)
4035 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4037 if (committed+size > reserved)
4038 size = reserved-committed;
4039 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4052 win32_malloc(size_t size)
4054 return malloc(size);
4058 win32_calloc(size_t numitems, size_t size)
4060 return calloc(numitems,size);
4064 win32_realloc(void *block, size_t size)
4066 return realloc(block,size);
4070 win32_free(void *block)
4077 win32_open_osfhandle(intptr_t handle, int flags)
4079 return _open_osfhandle(handle, flags);
4083 win32_get_osfhandle(int fd)
4085 return (intptr_t)_get_osfhandle(fd);
4089 win32_fdupopen(FILE *pf)
4094 int fileno = win32_dup(win32_fileno(pf));
4096 /* open the file in the same mode */
4097 if((pf)->_flag & _IOREAD) {
4101 else if((pf)->_flag & _IOWRT) {
4105 else if((pf)->_flag & _IORW) {
4111 /* it appears that the binmode is attached to the
4112 * file descriptor so binmode files will be handled
4115 pfdup = win32_fdopen(fileno, mode);
4117 /* move the file pointer to the same position */
4118 if (!fgetpos(pf, &pos)) {
4119 fsetpos(pfdup, &pos);
4125 win32_dynaload(const char* filename)
4128 char buf[MAX_PATH+1];
4131 /* LoadLibrary() doesn't recognize forward slashes correctly,
4132 * so turn 'em back. */
4133 first = strchr(filename, '/');
4135 STRLEN len = strlen(filename);
4136 if (len <= MAX_PATH) {
4137 strcpy(buf, filename);
4138 filename = &buf[first - filename];
4140 if (*filename == '/')
4141 *(char*)filename = '\\';
4147 aTHXa(PERL_GET_THX);
4148 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4151 XS(w32_SetChildShowWindow)
4154 BOOL use_showwindow = w32_use_showwindow;
4155 /* use "unsigned short" because Perl has redefined "WORD" */
4156 unsigned short showwindow = w32_showwindow;
4159 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4161 if (items == 0 || !SvOK(ST(0)))
4162 w32_use_showwindow = FALSE;
4164 w32_use_showwindow = TRUE;
4165 w32_showwindow = (unsigned short)SvIV(ST(0));
4170 ST(0) = sv_2mortal(newSViv(showwindow));
4172 ST(0) = &PL_sv_undef;
4177 Perl_init_os_extras(void)
4180 char *file = __FILE__;
4182 /* Initialize Win32CORE if it has been statically linked. */
4183 #ifndef PERL_IS_MINIPERL
4184 void (*pfn_init)(pTHX);
4185 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4186 ? GetModuleHandle(NULL)
4187 : w32_perldll_handle);
4188 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4189 aTHXa(PERL_GET_THX);
4193 aTHXa(PERL_GET_THX);
4196 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4200 win32_signal_context(void)
4205 my_perl = PL_curinterp;
4206 PERL_SET_THX(my_perl);
4210 return PL_curinterp;
4216 win32_ctrlhandler(DWORD dwCtrlType)
4219 dTHXa(PERL_GET_SIG_CONTEXT);
4225 switch(dwCtrlType) {
4226 case CTRL_CLOSE_EVENT:
4227 /* A signal that the system sends to all processes attached to a console when
4228 the user closes the console (either by choosing the Close command from the
4229 console window's System menu, or by choosing the End Task command from the
4232 if (do_raise(aTHX_ 1)) /* SIGHUP */
4233 sig_terminate(aTHX_ 1);
4237 /* A CTRL+c signal was received */
4238 if (do_raise(aTHX_ SIGINT))
4239 sig_terminate(aTHX_ SIGINT);
4242 case CTRL_BREAK_EVENT:
4243 /* A CTRL+BREAK signal was received */
4244 if (do_raise(aTHX_ SIGBREAK))
4245 sig_terminate(aTHX_ SIGBREAK);
4248 case CTRL_LOGOFF_EVENT:
4249 /* A signal that the system sends to all console processes when a user is logging
4250 off. This signal does not indicate which user is logging off, so no
4251 assumptions can be made.
4254 case CTRL_SHUTDOWN_EVENT:
4255 /* A signal that the system sends to all console processes when the system is
4258 if (do_raise(aTHX_ SIGTERM))
4259 sig_terminate(aTHX_ SIGTERM);
4268 #ifdef SET_INVALID_PARAMETER_HANDLER
4269 # include <crtdbg.h>
4280 /* fetch Unicode version of PATH */
4282 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4284 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4286 win32_free(wide_path);
4292 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4297 /* convert to ANSI pathnames */
4298 wide_dir = wide_path;
4301 WCHAR *sep = wcschr(wide_dir, ';');
4309 /* remove quotes around pathname */
4310 if (*wide_dir == '"')
4312 wide_len = wcslen(wide_dir);
4313 if (wide_len && wide_dir[wide_len-1] == '"')
4314 wide_dir[wide_len-1] = '\0';
4316 /* append ansi_dir to ansi_path */
4317 ansi_dir = win32_ansipath(wide_dir);
4318 ansi_len = strlen(ansi_dir);
4320 size_t newlen = len + 1 + ansi_len;
4321 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4324 ansi_path[len] = ';';
4325 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4330 ansi_path = (char*)win32_malloc(5+len+1);
4333 memcpy(ansi_path, "PATH=", 5);
4334 memcpy(ansi_path+5, ansi_dir, len+1);
4337 win32_free(ansi_dir);
4342 /* Update C RTL environ array. This will only have full effect if
4343 * perl_parse() is later called with `environ` as the `env` argument.
4344 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4346 * We do have to ansify() the PATH before Perl has been fully
4347 * initialized because S_find_script() uses the PATH when perl
4348 * is being invoked with the -S option. This happens before %ENV
4349 * is initialized in S_init_postdump_symbols().
4351 * XXX Is this a bug? Should S_find_script() use the environment
4352 * XXX passed in the `env` arg to parse_perl()?
4355 /* Keep system environment in sync because S_init_postdump_symbols()
4356 * will not call mg_set() if it initializes %ENV from `environ`.
4358 SetEnvironmentVariableA("PATH", ansi_path+5);
4359 win32_free(ansi_path);
4361 win32_free(wide_path);
4365 Perl_win32_init(int *argcp, char ***argvp)
4367 #ifdef SET_INVALID_PARAMETER_HANDLER
4368 _invalid_parameter_handler oldHandler, newHandler;
4369 newHandler = my_invalid_parameter_handler;
4370 oldHandler = _set_invalid_parameter_handler(newHandler);
4371 _CrtSetReportMode(_CRT_ASSERT, 0);
4373 /* Disable floating point errors, Perl will trap the ones we
4374 * care about. VC++ RTL defaults to switching these off
4375 * already, but some RTLs don't. Since we don't
4376 * want to be at the vendor's whim on the default, we set
4377 * it explicitly here.
4379 #if !defined(__GNUC__)
4380 _control87(MCW_EM, MCW_EM);
4384 /* When the manifest resource requests Common-Controls v6 then
4385 * user32.dll no longer registers all the Windows classes used for
4386 * standard controls but leaves some of them to be registered by
4387 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4388 * it makes sure comctl32.dll gets loaded into the process and registers
4389 * the standard control classes. Without this even normal Windows APIs
4390 * like MessageBox() can fail under some versions of Windows XP.
4392 InitCommonControls();
4394 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4395 GetVersionEx(&g_osver);
4397 #ifdef WIN32_DYN_IOINFO_SIZE
4399 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4400 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4401 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4404 ioinfo_size /= IOINFO_ARRAY_ELTS;
4405 w32_ioinfo_size = ioinfo_size;
4413 Perl_win32_term(void)
4422 win32_get_child_IO(child_IO_table* ptbl)
4424 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4425 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4426 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4430 win32_signal(int sig, Sighandler_t subcode)
4433 if (sig < SIG_SIZE) {
4434 int save_errno = errno;
4435 Sighandler_t result;
4436 #ifdef SET_INVALID_PARAMETER_HANDLER
4437 /* Silence our invalid parameter handler since we expect to make some
4438 * calls with invalid signal numbers giving a SIG_ERR result. */
4439 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4441 result = signal(sig, subcode);
4442 #ifdef SET_INVALID_PARAMETER_HANDLER
4443 set_silent_invalid_parameter_handler(oldvalue);
4445 aTHXa(PERL_GET_THX);
4446 if (result == SIG_ERR) {
4447 result = w32_sighandler[sig];
4450 w32_sighandler[sig] = subcode;
4459 /* The PerlMessageWindowClass's WindowProc */
4461 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4463 return win32_process_message(hwnd, msg, wParam, lParam) ?
4464 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4467 /* The real message handler. Can be called with
4468 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4469 * that it processes */
4471 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4473 /* BEWARE. The context retrieved using dTHX; is the context of the
4474 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4475 * up to and including WM_CREATE. If it ever happens that you need the
4476 * 'child' context before this, then it needs to be passed into
4477 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4478 * from the lparam of CreateWindow(). It could then be stored/retrieved
4479 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4480 * the dTHX calls here. */
4481 /* XXX For now it is assumed that the overhead of the dTHX; for what
4482 * are relativley infrequent code-paths, is better than the added
4483 * complexity of getting the correct context passed into
4484 * win32_create_message_window() */
4490 case WM_USER_MESSAGE: {
4491 long child = find_pseudo_pid(aTHX_ (int)wParam);
4493 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4500 case WM_USER_KILL: {
4501 /* We use WM_USER_KILL to fake kill() with other signals */
4502 int sig = (int)wParam;
4503 if (do_raise(aTHX_ sig))
4504 sig_terminate(aTHX_ sig);
4510 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4511 if (w32_timerid && w32_timerid==(UINT)wParam) {
4512 KillTimer(w32_message_hwnd, w32_timerid);
4515 /* Now fake a call to signal handler */
4516 if (do_raise(aTHX_ 14))
4517 sig_terminate(aTHX_ 14);
4529 /* Above or other stuff may have set a signal flag, and we may not have
4530 * been called from win32_async_check() (e.g. some other GUI's message
4531 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4532 * handler that die's, and the message loop that calls here is wrapped
4533 * in an eval, then you may well end up with orphaned windows - signals
4534 * are dispatched by win32_async_check() */
4540 win32_create_message_window_class(void)
4542 /* create the window class for "message only" windows */
4546 wc.lpfnWndProc = win32_message_window_proc;
4547 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4548 wc.lpszClassName = "PerlMessageWindowClass";
4550 /* second and subsequent calls will fail, but class
4551 * will already be registered */
4556 win32_create_message_window(void)
4558 win32_create_message_window_class();
4559 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4560 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4563 #ifdef HAVE_INTERP_INTERN
4566 win32_csighandler(int sig)
4569 dTHXa(PERL_GET_SIG_CONTEXT);
4570 Perl_warn(aTHX_ "Got signal %d",sig);
4575 #if defined(__MINGW32__) && defined(__cplusplus)
4576 #define CAST_HWND__(x) (HWND__*)(x)
4578 #define CAST_HWND__(x) x
4582 Perl_sys_intern_init(pTHX)
4586 w32_perlshell_tokens = NULL;
4587 w32_perlshell_vec = (char**)NULL;
4588 w32_perlshell_items = 0;
4589 w32_fdpid = newAV();
4590 Newx(w32_children, 1, child_tab);
4591 w32_num_children = 0;
4592 # ifdef USE_ITHREADS
4594 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4595 w32_num_pseudo_children = 0;
4598 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4600 for (i=0; i < SIG_SIZE; i++) {
4601 w32_sighandler[i] = SIG_DFL;
4603 # ifdef MULTIPLICITY
4604 if (my_perl == PL_curinterp) {
4608 /* Force C runtime signal stuff to set its console handler */
4609 signal(SIGINT,win32_csighandler);
4610 signal(SIGBREAK,win32_csighandler);
4612 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4613 * flag. This has the side-effect of disabling Ctrl-C events in all
4614 * processes in this group.
4615 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4616 * with a NULL handler.
4618 SetConsoleCtrlHandler(NULL,FALSE);
4620 /* Push our handler on top */
4621 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4626 Perl_sys_intern_clear(pTHX)
4628 Safefree(w32_perlshell_tokens);
4629 Safefree(w32_perlshell_vec);
4630 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4631 Safefree(w32_children);
4633 KillTimer(w32_message_hwnd, w32_timerid);
4636 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4637 DestroyWindow(w32_message_hwnd);
4638 # ifdef MULTIPLICITY
4639 if (my_perl == PL_curinterp) {
4643 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4645 # ifdef USE_ITHREADS
4646 Safefree(w32_pseudo_children);
4650 # ifdef USE_ITHREADS
4653 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4655 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4657 dst->perlshell_tokens = NULL;
4658 dst->perlshell_vec = (char**)NULL;
4659 dst->perlshell_items = 0;
4660 dst->fdpid = newAV();
4661 Newxz(dst->children, 1, child_tab);
4663 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4665 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4666 dst->poll_count = 0;
4667 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4669 # endif /* USE_ITHREADS */
4670 #endif /* HAVE_INTERP_INTERN */