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
19 # define HWND_MESSAGE ((HWND)-3)
21 #ifndef WC_NO_BEST_FIT_CHARS
22 # define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */
30 #define SystemProcessesAndThreadsInformation 5
32 /* Inline some definitions from the DDK */
43 LARGE_INTEGER CreateTime;
44 LARGE_INTEGER UserTime;
45 LARGE_INTEGER KernelTime;
46 UNICODE_STRING ProcessName;
49 ULONG InheritedFromProcessId;
50 /* Remainder of the structure depends on the Windows version,
51 * but we don't need those additional fields anyways... */
54 /* #include "config.h" */
56 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
65 #define PERL_NO_GET_CONTEXT
70 /* assert.h conflicts with #define of assert in perl.h */
77 #if defined(_MSC_VER) || defined(__MINGW32__)
78 #include <sys/utime.h>
83 /* Mingw32 defaults to globing command line
84 * So we turn it off like this:
89 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
90 /* Mingw32-1.1 is missing some prototypes */
92 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
93 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
94 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
100 #if defined(__BORLANDC__)
102 # define _utimbuf utimbuf
106 #define EXECF_SPAWN 2
107 #define EXECF_SPAWN_NOWAIT 3
109 #if defined(PERL_IMPLICIT_SYS)
110 # undef win32_get_privlib
111 # define win32_get_privlib g_win32_get_privlib
112 # undef win32_get_sitelib
113 # define win32_get_sitelib g_win32_get_sitelib
114 # undef win32_get_vendorlib
115 # define win32_get_vendorlib g_win32_get_vendorlib
117 # define getlogin g_getlogin
120 static void get_shell(void);
121 static long tokenize(const char *str, char **dest, char ***destv);
122 static int do_spawn2(pTHX_ const char *cmd, int exectype);
123 static BOOL has_shell_metachars(const char *ptr);
124 static long filetime_to_clock(PFILETIME ft);
125 static BOOL filetime_from_time(PFILETIME ft, time_t t);
126 static char * get_emd_part(SV **leading, STRLEN *const len,
127 char *trailing, ...);
128 static void remove_dead_process(long deceased);
129 static long find_pid(int pid);
130 static char * qualified_path(const char *cmd);
131 static char * win32_get_xlib(const char *pl, const char *xlib,
132 const char *libname, STRLEN *const len);
133 static LRESULT win32_process_message(HWND hwnd, UINT msg,
134 WPARAM wParam, LPARAM lParam);
137 static void remove_dead_pseudo_process(long child);
138 static long find_pseudo_pid(int pid);
142 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
143 char w32_module_name[MAX_PATH+1];
146 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
148 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
149 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
150 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
151 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
154 /* Silence STDERR grumblings from Borland's math library. */
156 _matherr(struct _exception *a)
163 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
164 * parameter handler. This functionality is not available in the
165 * 64-bit compiler from the Platform SDK, which unfortunately also
166 * believes itself to be MSC version 14.
168 * There is no #define related to _set_invalid_parameter_handler(),
169 * but we can check for one of the constants defined for
170 * _set_abort_behavior(), which was introduced into stdlib.h at
174 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
175 # define SET_INVALID_PARAMETER_HANDLER
178 #ifdef SET_INVALID_PARAMETER_HANDLER
179 void my_invalid_parameter_handler(const wchar_t* expression,
180 const wchar_t* function,
186 wprintf(L"Invalid parameter detected in function %s."
187 L" File: %s Line: %d\n", function, file, line);
188 wprintf(L"Expression: %s\n", expression);
196 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
202 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
208 return (g_osver.dwMajorVersion > 4);
212 set_w32_module_name(void)
214 /* this function may be called at DLL_PROCESS_ATTACH time */
216 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
217 ? GetModuleHandle(NULL)
218 : w32_perldll_handle);
220 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
221 osver.dwOSVersionInfoSize = sizeof(osver);
222 GetVersionEx(&osver);
224 if (osver.dwMajorVersion > 4) {
225 WCHAR modulename[MAX_PATH];
226 WCHAR fullname[MAX_PATH];
229 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
230 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
231 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
233 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
235 /* Make sure we get an absolute pathname in case the module was loaded
236 * explicitly by LoadLibrary() with a relative path. */
237 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
239 /* Make sure we start with the long path name of the module because we
240 * later scan for pathname components to match "5.xx" to locate
241 * compatible sitelib directories, and the short pathname might mangle
242 * this path segment (e.g. by removing the dot on NTFS to something
243 * like "5xx~1.yy") */
244 if (pfnGetLongPathNameW)
245 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
247 /* remove \\?\ prefix */
248 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
249 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
251 ansi = win32_ansipath(fullname);
252 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
256 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
258 /* remove \\?\ prefix */
259 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
260 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
262 /* try to get full path to binary (which may be mangled when perl is
263 * run from a 16-bit app) */
264 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
265 win32_longpath(w32_module_name);
266 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
269 /* normalize to forward slashes */
270 ptr = w32_module_name;
278 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
280 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
282 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
285 const char *subkey = "Software\\Perl";
289 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
290 if (retval == ERROR_SUCCESS) {
292 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
293 if (retval == ERROR_SUCCESS
294 && (type == REG_SZ || type == REG_EXPAND_SZ))
298 *svp = sv_2mortal(newSVpvn("",0));
299 SvGROW(*svp, datalen);
300 retval = RegQueryValueEx(handle, valuename, 0, NULL,
301 (PBYTE)SvPVX(*svp), &datalen);
302 if (retval == ERROR_SUCCESS) {
304 SvCUR_set(*svp,datalen-1);
312 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
314 get_regstr(const char *valuename, SV **svp)
316 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
318 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
322 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
324 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
328 char mod_name[MAX_PATH+1];
334 va_start(ap, trailing_path);
335 strip = va_arg(ap, char *);
337 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
338 baselen = strlen(base);
340 if (!*w32_module_name) {
341 set_w32_module_name();
343 strcpy(mod_name, w32_module_name);
344 ptr = strrchr(mod_name, '/');
345 while (ptr && strip) {
346 /* look for directories to skip back */
349 ptr = strrchr(mod_name, '/');
350 /* avoid stripping component if there is no slash,
351 * or it doesn't match ... */
352 if (!ptr || stricmp(ptr+1, strip) != 0) {
353 /* ... but not if component matches m|5\.$patchlevel.*| */
354 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
355 && strncmp(strip, base, baselen) == 0
356 && strncmp(ptr+1, base, baselen) == 0))
362 strip = va_arg(ap, char *);
370 strcpy(++ptr, trailing_path);
372 /* only add directory if it exists */
373 if (GetFileAttributes(mod_name) != (DWORD) -1) {
374 /* directory exists */
377 *prev_pathp = sv_2mortal(newSVpvn("",0));
378 else if (SvPVX(*prev_pathp))
379 sv_catpvn(*prev_pathp, ";", 1);
380 sv_catpv(*prev_pathp, mod_name);
382 *len = SvCUR(*prev_pathp);
383 return SvPVX(*prev_pathp);
390 win32_get_privlib(const char *pl, STRLEN *const len)
393 char *stdlib = "lib";
394 char buffer[MAX_PATH+1];
397 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
398 sprintf(buffer, "%s-%s", stdlib, pl);
399 if (!get_regstr(buffer, &sv))
400 (void)get_regstr(stdlib, &sv);
402 /* $stdlib .= ";$EMD/../../lib" */
403 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
407 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
412 char pathstr[MAX_PATH+1];
416 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
417 sprintf(regstr, "%s-%s", xlib, pl);
418 (void)get_regstr(regstr, &sv1);
421 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
422 sprintf(pathstr, "%s/%s/lib", libname, pl);
423 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
425 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
426 (void)get_regstr(xlib, &sv2);
429 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
430 sprintf(pathstr, "%s/lib", libname);
431 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
438 sv_catpvn(sv1, ";", 1);
448 win32_get_sitelib(const char *pl, STRLEN *const len)
450 return win32_get_xlib(pl, "sitelib", "site", len);
453 #ifndef PERL_VENDORLIB_NAME
454 # define PERL_VENDORLIB_NAME "vendor"
458 win32_get_vendorlib(const char *pl, STRLEN *const len)
460 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
464 has_shell_metachars(const char *ptr)
470 * Scan string looking for redirection (< or >) or pipe
471 * characters (|) that are not in a quoted string.
472 * Shell variable interpolation (%VAR%) can also happen inside strings.
504 #if !defined(PERL_IMPLICIT_SYS)
505 /* since the current process environment is being updated in util.c
506 * the library functions will get the correct environment
509 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
512 #define fixcmd(x) { \
513 char *pspace = strchr((x),' '); \
516 while (p < pspace) { \
527 PERL_FLUSHALL_FOR_CHILD;
528 return win32_popen(cmd, mode);
532 Perl_my_pclose(pTHX_ PerlIO *fp)
534 return win32_pclose(fp);
538 DllExport unsigned long
541 return (unsigned long)g_osver.dwPlatformId;
551 return -((int)w32_pseudo_id);
554 /* Windows 9x appears to always reports a pid for threads and processes
555 * that has the high bit set. So we treat the lower 31 bits as the
556 * "real" PID for Perl's purposes. */
557 if (IsWin95() && pid < 0)
562 /* Tokenize a string. Words are null-separated, and the list
563 * ends with a doubled null. Any character (except null and
564 * including backslash) may be escaped by preceding it with a
565 * backslash (the backslash will be stripped).
566 * Returns number of words in result buffer.
569 tokenize(const char *str, char **dest, char ***destv)
571 char *retstart = NULL;
572 char **retvstart = 0;
576 int slen = strlen(str);
578 register char **retv;
579 Newx(ret, slen+2, char);
580 Newx(retv, (slen+3)/2, char*);
588 if (*ret == '\\' && *str)
590 else if (*ret == ' ') {
606 retvstart[items] = NULL;
619 if (!w32_perlshell_tokens) {
620 /* we don't use COMSPEC here for two reasons:
621 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
622 * uncontrolled unportability of the ensuing scripts.
623 * 2. PERL5SHELL could be set to a shell that may not be fit for
624 * interactive use (which is what most programs look in COMSPEC
627 const char* defaultshell = (IsWinNT()
628 ? "cmd.exe /x/d/c" : "command.com /c");
629 const char *usershell = PerlEnv_getenv("PERL5SHELL");
630 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
631 &w32_perlshell_tokens,
637 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
645 PERL_ARGS_ASSERT_DO_ASPAWN;
651 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
653 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
658 while (++mark <= sp) {
659 if (*mark && (str = SvPV_nolen(*mark)))
666 status = win32_spawnvp(flag,
667 (const char*)(really ? SvPV_nolen(really) : argv[0]),
668 (const char* const*)argv);
670 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
671 /* possible shell-builtin, invoke with shell */
673 sh_items = w32_perlshell_items;
675 argv[index+sh_items] = argv[index];
676 while (--sh_items >= 0)
677 argv[sh_items] = w32_perlshell_vec[sh_items];
679 status = win32_spawnvp(flag,
680 (const char*)(really ? SvPV_nolen(really) : argv[0]),
681 (const char* const*)argv);
684 if (flag == P_NOWAIT) {
685 PL_statusvalue = -1; /* >16bits hint for pp_system() */
689 if (ckWARN(WARN_EXEC))
690 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
695 PL_statusvalue = status;
701 /* returns pointer to the next unquoted space or the end of the string */
703 find_next_space(const char *s)
705 bool in_quotes = FALSE;
707 /* ignore doubled backslashes, or backslash+quote */
708 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
711 /* keep track of when we're within quotes */
712 else if (*s == '"') {
714 in_quotes = !in_quotes;
716 /* break it up only at spaces that aren't in quotes */
717 else if (!in_quotes && isSPACE(*s))
726 do_spawn2(pTHX_ const char *cmd, int exectype)
732 BOOL needToTry = TRUE;
735 /* Save an extra exec if possible. See if there are shell
736 * metacharacters in it */
737 if (!has_shell_metachars(cmd)) {
738 Newx(argv, strlen(cmd) / 2 + 2, char*);
739 Newx(cmd2, strlen(cmd) + 1, char);
742 for (s = cmd2; *s;) {
743 while (*s && isSPACE(*s))
747 s = find_next_space(s);
755 status = win32_spawnvp(P_WAIT, argv[0],
756 (const char* const*)argv);
758 case EXECF_SPAWN_NOWAIT:
759 status = win32_spawnvp(P_NOWAIT, argv[0],
760 (const char* const*)argv);
763 status = win32_execvp(argv[0], (const char* const*)argv);
766 if (status != -1 || errno == 0)
776 Newx(argv, w32_perlshell_items + 2, char*);
777 while (++i < w32_perlshell_items)
778 argv[i] = w32_perlshell_vec[i];
779 argv[i++] = (char *)cmd;
783 status = win32_spawnvp(P_WAIT, argv[0],
784 (const char* const*)argv);
786 case EXECF_SPAWN_NOWAIT:
787 status = win32_spawnvp(P_NOWAIT, argv[0],
788 (const char* const*)argv);
791 status = win32_execvp(argv[0], (const char* const*)argv);
797 if (exectype == EXECF_SPAWN_NOWAIT) {
798 PL_statusvalue = -1; /* >16bits hint for pp_system() */
802 if (ckWARN(WARN_EXEC))
803 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
804 (exectype == EXECF_EXEC ? "exec" : "spawn"),
805 cmd, strerror(errno));
810 PL_statusvalue = status;
816 Perl_do_spawn(pTHX_ char *cmd)
818 PERL_ARGS_ASSERT_DO_SPAWN;
820 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
824 Perl_do_spawn_nowait(pTHX_ char *cmd)
826 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
828 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
832 Perl_do_exec(pTHX_ const char *cmd)
834 PERL_ARGS_ASSERT_DO_EXEC;
836 do_spawn2(aTHX_ cmd, EXECF_EXEC);
840 /* The idea here is to read all the directory names into a string table
841 * (separated by nulls) and when one of the other dir functions is called
842 * return the pointer to the current file name.
845 win32_opendir(const char *filename)
851 char scanname[MAX_PATH+3];
853 WIN32_FIND_DATAA aFindData;
854 WIN32_FIND_DATAW wFindData;
856 char buffer[MAX_PATH*2];
859 len = strlen(filename);
863 /* check to see if filename is a directory */
864 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
867 /* Get us a DIR structure */
870 /* Create the search pattern */
871 strcpy(scanname, filename);
873 /* bare drive name means look in cwd for drive */
874 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
875 scanname[len++] = '.';
876 scanname[len++] = '/';
878 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
879 scanname[len++] = '/';
881 scanname[len++] = '*';
882 scanname[len] = '\0';
884 /* do the FindFirstFile call */
886 WCHAR wscanname[sizeof(scanname)];
887 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
888 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
892 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
894 if (dirp->handle == INVALID_HANDLE_VALUE) {
895 DWORD err = GetLastError();
896 /* FindFirstFile() fails on empty drives! */
898 case ERROR_FILE_NOT_FOUND:
900 case ERROR_NO_MORE_FILES:
901 case ERROR_PATH_NOT_FOUND:
904 case ERROR_NOT_ENOUGH_MEMORY:
916 BOOL use_default = FALSE;
917 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
918 wFindData.cFileName, -1,
919 buffer, sizeof(buffer), NULL, &use_default);
920 if (use_default && *wFindData.cAlternateFileName) {
921 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
922 wFindData.cAlternateFileName, -1,
923 buffer, sizeof(buffer), NULL, NULL);
928 ptr = aFindData.cFileName;
930 /* now allocate the first part of the string table for
931 * the filenames that we find.
938 Newx(dirp->start, dirp->size, char);
939 strcpy(dirp->start, ptr);
941 dirp->end = dirp->curr = dirp->start;
947 /* Readdir just returns the current string pointer and bumps the
948 * string pointer to the nDllExport entry.
950 DllExport struct direct *
951 win32_readdir(DIR *dirp)
956 /* first set up the structure to return */
957 len = strlen(dirp->curr);
958 strcpy(dirp->dirstr.d_name, dirp->curr);
959 dirp->dirstr.d_namlen = len;
962 dirp->dirstr.d_ino = dirp->curr - dirp->start;
964 /* Now set up for the next call to readdir */
965 dirp->curr += len + 1;
966 if (dirp->curr >= dirp->end) {
969 WIN32_FIND_DATAA aFindData;
970 char buffer[MAX_PATH*2];
973 /* finding the next file that matches the wildcard
974 * (which should be all of them in this directory!).
977 WIN32_FIND_DATAW wFindData;
978 res = FindNextFileW(dirp->handle, &wFindData);
980 BOOL use_default = FALSE;
981 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
982 wFindData.cFileName, -1,
983 buffer, sizeof(buffer), NULL, &use_default);
984 if (use_default && *wFindData.cAlternateFileName) {
985 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
986 wFindData.cAlternateFileName, -1,
987 buffer, sizeof(buffer), NULL, NULL);
993 res = FindNextFileA(dirp->handle, &aFindData);
994 ptr = aFindData.cFileName;
997 long endpos = dirp->end - dirp->start;
998 long newsize = endpos + strlen(ptr) + 1;
999 /* bump the string table size by enough for the
1000 * new name and its null terminator */
1001 while (newsize > dirp->size) {
1002 long curpos = dirp->curr - dirp->start;
1004 Renew(dirp->start, dirp->size, char);
1005 dirp->curr = dirp->start + curpos;
1007 strcpy(dirp->start + endpos, ptr);
1008 dirp->end = dirp->start + newsize;
1014 return &(dirp->dirstr);
1020 /* Telldir returns the current string pointer position */
1022 win32_telldir(DIR *dirp)
1024 return (dirp->curr - dirp->start);
1028 /* Seekdir moves the string pointer to a previously saved position
1029 * (returned by telldir).
1032 win32_seekdir(DIR *dirp, long loc)
1034 dirp->curr = dirp->start + loc;
1037 /* Rewinddir resets the string pointer to the start */
1039 win32_rewinddir(DIR *dirp)
1041 dirp->curr = dirp->start;
1044 /* free the memory allocated by opendir */
1046 win32_closedir(DIR *dirp)
1049 if (dirp->handle != INVALID_HANDLE_VALUE)
1050 FindClose(dirp->handle);
1051 Safefree(dirp->start);
1064 * Just pretend that everyone is a superuser. NT will let us know if
1065 * we don\'t really have permission to do something.
1068 #define ROOT_UID ((uid_t)0)
1069 #define ROOT_GID ((gid_t)0)
1098 return (auid == ROOT_UID ? 0 : -1);
1104 return (agid == ROOT_GID ? 0 : -1);
1111 char *buf = w32_getlogin_buffer;
1112 DWORD size = sizeof(w32_getlogin_buffer);
1113 if (GetUserName(buf,&size))
1119 chown(const char *path, uid_t owner, gid_t group)
1126 * XXX this needs strengthening (for PerlIO)
1129 int mkstemp(const char *path)
1132 char buf[MAX_PATH+1];
1136 if (i++ > 10) { /* give up */
1140 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1144 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1154 long child = w32_num_children;
1155 while (--child >= 0) {
1156 if ((int)w32_child_pids[child] == pid)
1163 remove_dead_process(long child)
1167 CloseHandle(w32_child_handles[child]);
1168 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1169 (w32_num_children-child-1), HANDLE);
1170 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1171 (w32_num_children-child-1), DWORD);
1178 find_pseudo_pid(int pid)
1181 long child = w32_num_pseudo_children;
1182 while (--child >= 0) {
1183 if ((int)w32_pseudo_child_pids[child] == pid)
1190 remove_dead_pseudo_process(long child)
1194 CloseHandle(w32_pseudo_child_handles[child]);
1195 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1196 (w32_num_pseudo_children-child-1), HANDLE);
1197 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1198 (w32_num_pseudo_children-child-1), DWORD);
1199 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1200 (w32_num_pseudo_children-child-1), HWND);
1201 w32_num_pseudo_children--;
1207 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1211 /* "Does process exist?" use of kill */
1214 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1219 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1222 default: /* For now be backwards compatible with perl 5.6 */
1224 /* Note that we will only be able to kill processes owned by the
1225 * current process owner, even when we are running as an administrator.
1226 * To kill processes of other owners we would need to set the
1227 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1229 if (TerminateProcess(process_handle, sig))
1236 /* Traverse process tree using ToolHelp functions */
1238 kill_process_tree_toolhelp(DWORD pid, int sig)
1240 HANDLE process_handle;
1241 HANDLE snapshot_handle;
1244 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1245 if (process_handle == NULL)
1248 killed += terminate_process(pid, process_handle, sig);
1250 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1251 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1252 PROCESSENTRY32 entry;
1254 entry.dwSize = sizeof(entry);
1255 if (pfnProcess32First(snapshot_handle, &entry)) {
1257 if (entry.th32ParentProcessID == pid)
1258 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1259 entry.dwSize = sizeof(entry);
1261 while (pfnProcess32Next(snapshot_handle, &entry));
1263 CloseHandle(snapshot_handle);
1265 CloseHandle(process_handle);
1269 /* Traverse process tree using undocumented system information structures.
1270 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1273 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1275 HANDLE process_handle;
1276 SYSTEM_PROCESSES *p = process_info;
1279 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1280 if (process_handle == NULL)
1283 killed += terminate_process(pid, process_handle, sig);
1286 if (p->InheritedFromProcessId == (DWORD)pid)
1287 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1289 if (p->NextEntryDelta == 0)
1292 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1295 CloseHandle(process_handle);
1300 killpg(int pid, int sig)
1302 /* Use "documented" method whenever available */
1303 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1304 return kill_process_tree_toolhelp((DWORD)pid, sig);
1307 /* Fall back to undocumented Windows internals on Windows NT */
1308 if (pfnZwQuerySystemInformation) {
1313 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1314 Newx(buffer, size, char);
1316 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1317 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1326 my_kill(int pid, int sig)
1329 HANDLE process_handle;
1332 return killpg(pid, -sig);
1334 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1335 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1336 if (process_handle != NULL) {
1337 retval = terminate_process(pid, process_handle, sig);
1338 CloseHandle(process_handle);
1344 win32_kill(int pid, int sig)
1350 /* it is a pseudo-forked child */
1351 child = find_pseudo_pid(-pid);
1353 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1354 HANDLE hProcess = w32_pseudo_child_handles[child];
1357 /* "Does process exist?" use of kill */
1361 /* kill -9 style un-graceful exit */
1362 if (TerminateThread(hProcess, sig)) {
1363 remove_dead_pseudo_process(child);
1370 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1371 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1372 /* Yield and wait for the other thread to send us its message_hwnd */
1374 win32_async_check(aTHX);
1375 hwnd = w32_pseudo_child_message_hwnds[child];
1378 if (hwnd != INVALID_HANDLE_VALUE) {
1379 /* We fake signals to pseudo-processes using Win32
1380 * message queue. In Win9X the pids are negative already. */
1381 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1382 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1384 /* It might be us ... */
1393 else if (IsWin95()) {
1401 child = find_pid(pid);
1403 if (my_kill(pid, sig)) {
1405 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1406 exitcode != STILL_ACTIVE)
1408 remove_dead_process(child);
1415 if (my_kill((IsWin95() ? -pid : pid), sig))
1424 win32_stat(const char *path, Stat_t *sbuf)
1427 char buffer[MAX_PATH+1];
1428 int l = strlen(path);
1431 BOOL expect_dir = FALSE;
1433 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1434 GV_NOTQUAL, SVt_PV);
1435 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1438 switch(path[l - 1]) {
1439 /* FindFirstFile() and stat() are buggy with a trailing
1440 * slashes, except for the root directory of a drive */
1443 if (l > sizeof(buffer)) {
1444 errno = ENAMETOOLONG;
1448 strncpy(buffer, path, l);
1449 /* remove additional trailing slashes */
1450 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1452 /* add back slash if we otherwise end up with just a drive letter */
1453 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1460 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1462 if (l == 2 && isALPHA(path[0])) {
1463 buffer[0] = path[0];
1474 path = PerlDir_mapA(path);
1478 /* We must open & close the file once; otherwise file attribute changes */
1479 /* might not yet have propagated to "other" hard links of the same file. */
1480 /* This also gives us an opportunity to determine the number of links. */
1481 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1482 if (handle != INVALID_HANDLE_VALUE) {
1483 BY_HANDLE_FILE_INFORMATION bhi;
1484 if (GetFileInformationByHandle(handle, &bhi))
1485 nlink = bhi.nNumberOfLinks;
1486 CloseHandle(handle);
1490 /* path will be mapped correctly above */
1491 #if defined(WIN64) || defined(USE_LARGE_FILES)
1492 res = _stati64(path, sbuf);
1494 res = stat(path, sbuf);
1496 sbuf->st_nlink = nlink;
1499 /* CRT is buggy on sharenames, so make sure it really isn't.
1500 * XXX using GetFileAttributesEx() will enable us to set
1501 * sbuf->st_*time (but note that's not available on the
1502 * Windows of 1995) */
1503 DWORD r = GetFileAttributesA(path);
1504 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1505 /* sbuf may still contain old garbage since stat() failed */
1506 Zero(sbuf, 1, Stat_t);
1507 sbuf->st_mode = S_IFDIR | S_IREAD;
1509 if (!(r & FILE_ATTRIBUTE_READONLY))
1510 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1515 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1516 && (path[2] == '\\' || path[2] == '/'))
1518 /* The drive can be inaccessible, some _stat()s are buggy */
1519 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1524 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1528 if (S_ISDIR(sbuf->st_mode)) {
1529 /* Ensure the "write" bit is switched off in the mode for
1530 * directories with the read-only attribute set. Borland (at least)
1531 * switches it on for directories, which is technically correct
1532 * (directories are indeed always writable unless denied by DACLs),
1533 * but we want stat() and -w to reflect the state of the read-only
1534 * attribute for symmetry with chmod(). */
1535 DWORD r = GetFileAttributesA(path);
1536 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1537 sbuf->st_mode &= ~S_IWRITE;
1541 if (S_ISDIR(sbuf->st_mode)) {
1542 sbuf->st_mode |= S_IEXEC;
1544 else if (S_ISREG(sbuf->st_mode)) {
1546 if (l >= 4 && path[l-4] == '.') {
1547 const char *e = path + l - 3;
1548 if (strnicmp(e,"exe",3)
1549 && strnicmp(e,"bat",3)
1550 && strnicmp(e,"com",3)
1551 && (IsWin95() || strnicmp(e,"cmd",3)))
1552 sbuf->st_mode &= ~S_IEXEC;
1554 sbuf->st_mode |= S_IEXEC;
1557 sbuf->st_mode &= ~S_IEXEC;
1558 /* Propagate permissions to _group_ and _others_ */
1559 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1560 sbuf->st_mode |= (perms>>3) | (perms>>6);
1567 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1568 #define SKIP_SLASHES(s) \
1570 while (*(s) && isSLASH(*(s))) \
1573 #define COPY_NONSLASHES(d,s) \
1575 while (*(s) && !isSLASH(*(s))) \
1579 /* Find the longname of a given path. path is destructively modified.
1580 * It should have space for at least MAX_PATH characters. */
1582 win32_longpath(char *path)
1584 WIN32_FIND_DATA fdata;
1586 char tmpbuf[MAX_PATH+1];
1587 char *tmpstart = tmpbuf;
1594 if (isALPHA(path[0]) && path[1] == ':') {
1596 *tmpstart++ = path[0];
1600 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1602 *tmpstart++ = path[0];
1603 *tmpstart++ = path[1];
1604 SKIP_SLASHES(start);
1605 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1607 *tmpstart++ = *start++;
1608 SKIP_SLASHES(start);
1609 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1614 /* copy initial slash, if any */
1615 if (isSLASH(*start)) {
1616 *tmpstart++ = *start++;
1618 SKIP_SLASHES(start);
1621 /* FindFirstFile() expands "." and "..", so we need to pass
1622 * those through unmolested */
1624 && (!start[1] || isSLASH(start[1])
1625 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1627 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1632 /* if this is the end, bust outta here */
1636 /* now we're at a non-slash; walk up to next slash */
1637 while (*start && !isSLASH(*start))
1640 /* stop and find full name of component */
1643 fhand = FindFirstFile(path,&fdata);
1645 if (fhand != INVALID_HANDLE_VALUE) {
1646 STRLEN len = strlen(fdata.cFileName);
1647 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1648 strcpy(tmpstart, fdata.cFileName);
1659 /* failed a step, just return without side effects */
1660 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1665 strcpy(path,tmpbuf);
1674 /* Can't use PerlIO to write as it allocates memory */
1675 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1676 PL_no_mem, strlen(PL_no_mem));
1682 /* The win32_ansipath() function takes a Unicode filename and converts it
1683 * into the current Windows codepage. If some characters cannot be mapped,
1684 * then it will convert the short name instead.
1686 * The buffer to the ansi pathname must be freed with win32_free() when it
1687 * it no longer needed.
1689 * The argument to win32_ansipath() must exist before this function is
1690 * called; otherwise there is no way to determine the short path name.
1692 * Ideas for future refinement:
1693 * - Only convert those segments of the path that are not in the current
1694 * codepage, but leave the other segments in their long form.
1695 * - If the resulting name is longer than MAX_PATH, start converting
1696 * additional path segments into short names until the full name
1697 * is shorter than MAX_PATH. Shorten the filename part last!
1700 win32_ansipath(const WCHAR *widename)
1703 BOOL use_default = FALSE;
1704 size_t widelen = wcslen(widename)+1;
1705 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1706 NULL, 0, NULL, NULL);
1707 name = win32_malloc(len);
1711 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1712 name, len, NULL, &use_default);
1714 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1716 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1719 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1721 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1722 NULL, 0, NULL, NULL);
1723 name = win32_realloc(name, len);
1726 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1727 name, len, NULL, NULL);
1728 win32_free(shortname);
1735 win32_getenv(const char *name)
1741 needlen = GetEnvironmentVariableA(name,NULL,0);
1743 curitem = sv_2mortal(newSVpvn("", 0));
1745 SvGROW(curitem, needlen+1);
1746 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1748 } while (needlen >= SvLEN(curitem));
1749 SvCUR_set(curitem, needlen);
1752 /* allow any environment variables that begin with 'PERL'
1753 to be stored in the registry */
1754 if (strncmp(name, "PERL", 4) == 0)
1755 (void)get_regstr(name, &curitem);
1757 if (curitem && SvCUR(curitem))
1758 return SvPVX(curitem);
1764 win32_putenv(const char *name)
1772 Newx(curitem,strlen(name)+1,char);
1773 strcpy(curitem, name);
1774 val = strchr(curitem, '=');
1776 /* The sane way to deal with the environment.
1777 * Has these advantages over putenv() & co.:
1778 * * enables us to store a truly empty value in the
1779 * environment (like in UNIX).
1780 * * we don't have to deal with RTL globals, bugs and leaks
1781 * (specifically, see http://support.microsoft.com/kb/235601).
1783 * Why you may want to use the RTL environment handling
1784 * (previously enabled by USE_WIN32_RTL_ENV):
1785 * * environ[] and RTL functions will not reflect changes,
1786 * which might be an issue if extensions want to access
1787 * the env. via RTL. This cuts both ways, since RTL will
1788 * not see changes made by extensions that call the Win32
1789 * functions directly, either.
1793 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1802 filetime_to_clock(PFILETIME ft)
1804 __int64 qw = ft->dwHighDateTime;
1806 qw |= ft->dwLowDateTime;
1807 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1812 win32_times(struct tms *timebuf)
1817 clock_t process_time_so_far = clock();
1818 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1820 timebuf->tms_utime = filetime_to_clock(&user);
1821 timebuf->tms_stime = filetime_to_clock(&kernel);
1822 timebuf->tms_cutime = 0;
1823 timebuf->tms_cstime = 0;
1825 /* That failed - e.g. Win95 fallback to clock() */
1826 timebuf->tms_utime = process_time_so_far;
1827 timebuf->tms_stime = 0;
1828 timebuf->tms_cutime = 0;
1829 timebuf->tms_cstime = 0;
1831 return process_time_so_far;
1834 /* fix utime() so it works on directories in NT */
1836 filetime_from_time(PFILETIME pFileTime, time_t Time)
1838 struct tm *pTM = localtime(&Time);
1839 SYSTEMTIME SystemTime;
1845 SystemTime.wYear = pTM->tm_year + 1900;
1846 SystemTime.wMonth = pTM->tm_mon + 1;
1847 SystemTime.wDay = pTM->tm_mday;
1848 SystemTime.wHour = pTM->tm_hour;
1849 SystemTime.wMinute = pTM->tm_min;
1850 SystemTime.wSecond = pTM->tm_sec;
1851 SystemTime.wMilliseconds = 0;
1853 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1854 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1858 win32_unlink(const char *filename)
1864 filename = PerlDir_mapA(filename);
1865 attrs = GetFileAttributesA(filename);
1866 if (attrs == 0xFFFFFFFF) {
1870 if (attrs & FILE_ATTRIBUTE_READONLY) {
1871 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1872 ret = unlink(filename);
1874 (void)SetFileAttributesA(filename, attrs);
1877 ret = unlink(filename);
1882 win32_utime(const char *filename, struct utimbuf *times)
1889 struct utimbuf TimeBuffer;
1892 filename = PerlDir_mapA(filename);
1893 rc = utime(filename, times);
1895 /* EACCES: path specifies directory or readonly file */
1896 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1899 if (times == NULL) {
1900 times = &TimeBuffer;
1901 time(×->actime);
1902 times->modtime = times->actime;
1905 /* This will (and should) still fail on readonly files */
1906 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1907 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1908 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1909 if (handle == INVALID_HANDLE_VALUE)
1912 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1913 filetime_from_time(&ftAccess, times->actime) &&
1914 filetime_from_time(&ftWrite, times->modtime) &&
1915 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1920 CloseHandle(handle);
1925 unsigned __int64 ft_i64;
1930 #define Const64(x) x##LL
1932 #define Const64(x) x##i64
1934 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1935 #define EPOCH_BIAS Const64(116444736000000000)
1937 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1938 * and appears to be unsupported even by glibc) */
1940 win32_gettimeofday(struct timeval *tp, void *not_used)
1944 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1945 GetSystemTimeAsFileTime(&ft.ft_val);
1947 /* seconds since epoch */
1948 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1950 /* microseconds remaining */
1951 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1957 win32_uname(struct utsname *name)
1959 struct hostent *hep;
1960 STRLEN nodemax = sizeof(name->nodename)-1;
1963 switch (g_osver.dwPlatformId) {
1964 case VER_PLATFORM_WIN32_WINDOWS:
1965 strcpy(name->sysname, "Windows");
1967 case VER_PLATFORM_WIN32_NT:
1968 strcpy(name->sysname, "Windows NT");
1970 case VER_PLATFORM_WIN32s:
1971 strcpy(name->sysname, "Win32s");
1974 strcpy(name->sysname, "Win32 Unknown");
1979 sprintf(name->release, "%d.%d",
1980 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1983 sprintf(name->version, "Build %d",
1984 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1985 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1986 if (g_osver.szCSDVersion[0]) {
1987 char *buf = name->version + strlen(name->version);
1988 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1992 hep = win32_gethostbyname("localhost");
1994 STRLEN len = strlen(hep->h_name);
1995 if (len <= nodemax) {
1996 strcpy(name->nodename, hep->h_name);
1999 strncpy(name->nodename, hep->h_name, nodemax);
2000 name->nodename[nodemax] = '\0';
2005 if (!GetComputerName(name->nodename, &sz))
2006 *name->nodename = '\0';
2009 /* machine (architecture) */
2014 GetSystemInfo(&info);
2016 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2017 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2018 procarch = info.u.s.wProcessorArchitecture;
2020 procarch = info.wProcessorArchitecture;
2023 case PROCESSOR_ARCHITECTURE_INTEL:
2024 arch = "x86"; break;
2025 case PROCESSOR_ARCHITECTURE_MIPS:
2026 arch = "mips"; break;
2027 case PROCESSOR_ARCHITECTURE_ALPHA:
2028 arch = "alpha"; break;
2029 case PROCESSOR_ARCHITECTURE_PPC:
2030 arch = "ppc"; break;
2031 #ifdef PROCESSOR_ARCHITECTURE_SHX
2032 case PROCESSOR_ARCHITECTURE_SHX:
2033 arch = "shx"; break;
2035 #ifdef PROCESSOR_ARCHITECTURE_ARM
2036 case PROCESSOR_ARCHITECTURE_ARM:
2037 arch = "arm"; break;
2039 #ifdef PROCESSOR_ARCHITECTURE_IA64
2040 case PROCESSOR_ARCHITECTURE_IA64:
2041 arch = "ia64"; break;
2043 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2044 case PROCESSOR_ARCHITECTURE_ALPHA64:
2045 arch = "alpha64"; break;
2047 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2048 case PROCESSOR_ARCHITECTURE_MSIL:
2049 arch = "msil"; break;
2051 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2052 case PROCESSOR_ARCHITECTURE_AMD64:
2053 arch = "amd64"; break;
2055 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2056 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2057 arch = "ia32-64"; break;
2059 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2060 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2061 arch = "unknown"; break;
2064 sprintf(name->machine, "unknown(0x%x)", procarch);
2065 arch = name->machine;
2068 if (name->machine != arch)
2069 strcpy(name->machine, arch);
2074 /* Timing related stuff */
2077 do_raise(pTHX_ int sig)
2079 if (sig < SIG_SIZE) {
2080 Sighandler_t handler = w32_sighandler[sig];
2081 if (handler == SIG_IGN) {
2084 else if (handler != SIG_DFL) {
2089 /* Choose correct default behaviour */
2105 /* Tell caller to exit thread/process as approriate */
2110 sig_terminate(pTHX_ int sig)
2112 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2113 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2120 win32_async_check(pTHX)
2123 HWND hwnd = w32_message_hwnd;
2125 /* Reset w32_poll_count before doing anything else, incase we dispatch
2126 * messages that end up calling back into perl */
2129 if (hwnd != INVALID_HANDLE_VALUE) {
2130 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2131 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2136 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2137 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2139 /* re-post a WM_QUIT message (we'll mark it as read later) */
2140 if(msg.message == WM_QUIT) {
2141 PostQuitMessage((int)msg.wParam);
2145 if(!CallMsgFilter(&msg, MSGF_USER))
2147 TranslateMessage(&msg);
2148 DispatchMessage(&msg);
2153 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2154 * This is necessary when we are being called by win32_msgwait() to
2155 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2156 * message over and over. An example how this can happen is when
2157 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2158 * is generating messages before the process terminated.
2160 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2162 /* Above or other stuff may have set a signal flag */
2169 /* This function will not return until the timeout has elapsed, or until
2170 * one of the handles is ready. */
2172 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2174 /* We may need several goes at this - so compute when we stop */
2176 if (timeout != INFINITE) {
2177 ticks = GetTickCount();
2181 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2184 if (result == WAIT_TIMEOUT) {
2185 /* Ran out of time - explicit return of zero to avoid -ve if we
2186 have scheduling issues
2190 if (timeout != INFINITE) {
2191 ticks = GetTickCount();
2193 if (result == WAIT_OBJECT_0 + count) {
2194 /* Message has arrived - check it */
2195 (void)win32_async_check(aTHX);
2198 /* Not timeout or message - one of handles is ready */
2202 /* compute time left to wait */
2203 ticks = timeout - ticks;
2204 /* If we are past the end say zero */
2205 return (ticks > 0) ? ticks : 0;
2209 win32_internal_wait(int *status, DWORD timeout)
2211 /* XXX this wait emulation only knows about processes
2212 * spawned via win32_spawnvp(P_NOWAIT, ...).
2216 DWORD exitcode, waitcode;
2219 if (w32_num_pseudo_children) {
2220 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2221 timeout, &waitcode);
2222 /* Time out here if there are no other children to wait for. */
2223 if (waitcode == WAIT_TIMEOUT) {
2224 if (!w32_num_children) {
2228 else if (waitcode != WAIT_FAILED) {
2229 if (waitcode >= WAIT_ABANDONED_0
2230 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2231 i = waitcode - WAIT_ABANDONED_0;
2233 i = waitcode - WAIT_OBJECT_0;
2234 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2235 *status = (int)((exitcode & 0xff) << 8);
2236 retval = (int)w32_pseudo_child_pids[i];
2237 remove_dead_pseudo_process(i);
2244 if (!w32_num_children) {
2249 /* if a child exists, wait for it to die */
2250 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2251 if (waitcode == WAIT_TIMEOUT) {
2254 if (waitcode != WAIT_FAILED) {
2255 if (waitcode >= WAIT_ABANDONED_0
2256 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2257 i = waitcode - WAIT_ABANDONED_0;
2259 i = waitcode - WAIT_OBJECT_0;
2260 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2261 *status = (int)((exitcode & 0xff) << 8);
2262 retval = (int)w32_child_pids[i];
2263 remove_dead_process(i);
2268 errno = GetLastError();
2273 win32_waitpid(int pid, int *status, int flags)
2276 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2279 if (pid == -1) /* XXX threadid == 1 ? */
2280 return win32_internal_wait(status, timeout);
2283 child = find_pseudo_pid(-pid);
2285 HANDLE hThread = w32_pseudo_child_handles[child];
2287 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2288 if (waitcode == WAIT_TIMEOUT) {
2291 else if (waitcode == WAIT_OBJECT_0) {
2292 if (GetExitCodeThread(hThread, &waitcode)) {
2293 *status = (int)((waitcode & 0xff) << 8);
2294 retval = (int)w32_pseudo_child_pids[child];
2295 remove_dead_pseudo_process(child);
2302 else if (IsWin95()) {
2311 child = find_pid(pid);
2313 hProcess = w32_child_handles[child];
2314 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2315 if (waitcode == WAIT_TIMEOUT) {
2318 else if (waitcode == WAIT_OBJECT_0) {
2319 if (GetExitCodeProcess(hProcess, &waitcode)) {
2320 *status = (int)((waitcode & 0xff) << 8);
2321 retval = (int)w32_child_pids[child];
2322 remove_dead_process(child);
2331 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2332 (IsWin95() ? -pid : pid));
2334 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2335 if (waitcode == WAIT_TIMEOUT) {
2336 CloseHandle(hProcess);
2339 else if (waitcode == WAIT_OBJECT_0) {
2340 if (GetExitCodeProcess(hProcess, &waitcode)) {
2341 *status = (int)((waitcode & 0xff) << 8);
2342 CloseHandle(hProcess);
2346 CloseHandle(hProcess);
2352 return retval >= 0 ? pid : retval;
2356 win32_wait(int *status)
2358 return win32_internal_wait(status, INFINITE);
2361 DllExport unsigned int
2362 win32_sleep(unsigned int t)
2365 /* Win32 times are in ms so *1000 in and /1000 out */
2366 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2369 DllExport unsigned int
2370 win32_alarm(unsigned int sec)
2373 * the 'obvious' implentation is SetTimer() with a callback
2374 * which does whatever receiving SIGALRM would do
2375 * we cannot use SIGALRM even via raise() as it is not
2376 * one of the supported codes in <signal.h>
2380 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2381 w32_message_hwnd = win32_create_message_window();
2384 if (w32_message_hwnd == NULL)
2385 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2388 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2393 KillTimer(w32_message_hwnd, w32_timerid);
2400 #ifdef HAVE_DES_FCRYPT
2401 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2405 win32_crypt(const char *txt, const char *salt)
2408 #ifdef HAVE_DES_FCRYPT
2409 return des_fcrypt(txt, salt, w32_crypt_buffer);
2411 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2416 #ifdef USE_FIXED_OSFHANDLE
2418 #define FOPEN 0x01 /* file handle open */
2419 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2420 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2421 #define FDEV 0x40 /* file handle refers to device */
2422 #define FTEXT 0x80 /* file handle is in text mode */
2425 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2428 * This function allocates a free C Runtime file handle and associates
2429 * it with the Win32 HANDLE specified by the first parameter. This is a
2430 * temperary fix for WIN95's brain damage GetFileType() error on socket
2431 * we just bypass that call for socket
2433 * This works with MSVC++ 4.0+ or GCC/Mingw32
2436 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2437 * int flags - flags to associate with C Runtime file handle.
2440 * returns index of entry in fh, if successful
2441 * return -1, if no free entry is found
2445 *******************************************************************************/
2448 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2449 * this lets sockets work on Win9X with GCC and should fix the problems
2454 /* create an ioinfo entry, kill its handle, and steal the entry */
2459 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2460 int fh = _open_osfhandle((intptr_t)hF, 0);
2464 EnterCriticalSection(&(_pioinfo(fh)->lock));
2469 my_open_osfhandle(intptr_t osfhandle, int flags)
2472 char fileflags; /* _osfile flags */
2474 /* copy relevant flags from second parameter */
2477 if (flags & O_APPEND)
2478 fileflags |= FAPPEND;
2483 if (flags & O_NOINHERIT)
2484 fileflags |= FNOINHERIT;
2486 /* attempt to allocate a C Runtime file handle */
2487 if ((fh = _alloc_osfhnd()) == -1) {
2488 errno = EMFILE; /* too many open files */
2489 _doserrno = 0L; /* not an OS error */
2490 return -1; /* return error to caller */
2493 /* the file is open. now, set the info in _osfhnd array */
2494 _set_osfhnd(fh, osfhandle);
2496 fileflags |= FOPEN; /* mark as open */
2498 _osfile(fh) = fileflags; /* set osfile entry */
2499 LeaveCriticalSection(&_pioinfo(fh)->lock);
2501 return fh; /* return handle */
2504 #endif /* USE_FIXED_OSFHANDLE */
2506 /* simulate flock by locking a range on the file */
2508 #define LK_LEN 0xffff0000
2511 win32_flock(int fd, int oper)
2519 Perl_croak_nocontext("flock() unimplemented on this platform");
2522 fh = (HANDLE)_get_osfhandle(fd);
2523 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2526 memset(&o, 0, sizeof(o));
2529 case LOCK_SH: /* shared lock */
2530 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2533 case LOCK_EX: /* exclusive lock */
2534 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2537 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2538 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2541 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2542 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2546 case LOCK_UN: /* unlock lock */
2547 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2550 default: /* unknown */
2555 if (GetLastError() == ERROR_LOCK_VIOLATION)
2556 errno = WSAEWOULDBLOCK;
2566 * redirected io subsystem for all XS modules
2579 return (&(_environ));
2582 /* the rest are the remapped stdio routines */
2602 win32_ferror(FILE *fp)
2604 return (ferror(fp));
2609 win32_feof(FILE *fp)
2615 * Since the errors returned by the socket error function
2616 * WSAGetLastError() are not known by the library routine strerror
2617 * we have to roll our own.
2621 win32_strerror(int e)
2623 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2624 extern int sys_nerr;
2627 if (e < 0 || e > sys_nerr) {
2632 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2633 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2634 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2637 strcpy(w32_strerror_buffer, "Unknown Error");
2639 return w32_strerror_buffer;
2643 #define strerror win32_strerror
2647 win32_str_os_error(void *sv, DWORD dwErr)
2651 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2652 |FORMAT_MESSAGE_IGNORE_INSERTS
2653 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2654 dwErr, 0, (char *)&sMsg, 1, NULL);
2655 /* strip trailing whitespace and period */
2658 --dwLen; /* dwLen doesn't include trailing null */
2659 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2660 if ('.' != sMsg[dwLen])
2665 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2667 dwLen = sprintf(sMsg,
2668 "Unknown error #0x%lX (lookup 0x%lX)",
2669 dwErr, GetLastError());
2673 sv_setpvn((SV*)sv, sMsg, dwLen);
2679 win32_fprintf(FILE *fp, const char *format, ...)
2682 va_start(marker, format); /* Initialize variable arguments. */
2684 return (vfprintf(fp, format, marker));
2688 win32_printf(const char *format, ...)
2691 va_start(marker, format); /* Initialize variable arguments. */
2693 return (vprintf(format, marker));
2697 win32_vfprintf(FILE *fp, const char *format, va_list args)
2699 return (vfprintf(fp, format, args));
2703 win32_vprintf(const char *format, va_list args)
2705 return (vprintf(format, args));
2709 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2711 return fread(buf, size, count, fp);
2715 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2717 return fwrite(buf, size, count, fp);
2720 #define MODE_SIZE 10
2723 win32_fopen(const char *filename, const char *mode)
2731 if (stricmp(filename, "/dev/null")==0)
2734 f = fopen(PerlDir_mapA(filename), mode);
2735 /* avoid buffering headaches for child processes */
2736 if (f && *mode == 'a')
2737 win32_fseek(f, 0, SEEK_END);
2741 #ifndef USE_SOCKETS_AS_HANDLES
2743 #define fdopen my_fdopen
2747 win32_fdopen(int handle, const char *mode)
2751 f = fdopen(handle, (char *) mode);
2752 /* avoid buffering headaches for child processes */
2753 if (f && *mode == 'a')
2754 win32_fseek(f, 0, SEEK_END);
2759 win32_freopen(const char *path, const char *mode, FILE *stream)
2762 if (stricmp(path, "/dev/null")==0)
2765 return freopen(PerlDir_mapA(path), mode, stream);
2769 win32_fclose(FILE *pf)
2771 return my_fclose(pf); /* defined in win32sck.c */
2775 win32_fputs(const char *s,FILE *pf)
2777 return fputs(s, pf);
2781 win32_fputc(int c,FILE *pf)
2787 win32_ungetc(int c,FILE *pf)
2789 return ungetc(c,pf);
2793 win32_getc(FILE *pf)
2799 win32_fileno(FILE *pf)
2805 win32_clearerr(FILE *pf)
2812 win32_fflush(FILE *pf)
2818 win32_ftell(FILE *pf)
2820 #if defined(WIN64) || defined(USE_LARGE_FILES)
2821 #if defined(__BORLANDC__) /* buk */
2822 return win32_tell( fileno( pf ) );
2825 if (fgetpos(pf, &pos))
2835 win32_fseek(FILE *pf, Off_t offset,int origin)
2837 #if defined(WIN64) || defined(USE_LARGE_FILES)
2838 #if defined(__BORLANDC__) /* buk */
2848 if (fgetpos(pf, &pos))
2853 fseek(pf, 0, SEEK_END);
2854 pos = _telli64(fileno(pf));
2863 return fsetpos(pf, &offset);
2866 return fseek(pf, (long)offset, origin);
2871 win32_fgetpos(FILE *pf,fpos_t *p)
2873 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2874 if( win32_tell(fileno(pf)) == -1L ) {
2880 return fgetpos(pf, p);
2885 win32_fsetpos(FILE *pf,const fpos_t *p)
2887 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2888 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2890 return fsetpos(pf, p);
2895 win32_rewind(FILE *pf)
2905 char prefix[MAX_PATH+1];
2906 char filename[MAX_PATH+1];
2907 DWORD len = GetTempPath(MAX_PATH, prefix);
2908 if (len && len < MAX_PATH) {
2909 if (GetTempFileName(prefix, "plx", 0, filename)) {
2910 HANDLE fh = CreateFile(filename,
2911 DELETE | GENERIC_READ | GENERIC_WRITE,
2915 FILE_ATTRIBUTE_NORMAL
2916 | FILE_FLAG_DELETE_ON_CLOSE,
2918 if (fh != INVALID_HANDLE_VALUE) {
2919 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2921 #if defined(__BORLANDC__)
2922 setmode(fd,O_BINARY);
2924 DEBUG_p(PerlIO_printf(Perl_debug_log,
2925 "Created tmpfile=%s\n",filename));
2937 int fd = win32_tmpfd();
2939 return win32_fdopen(fd, "w+b");
2951 win32_fstat(int fd, Stat_t *sbufptr)
2954 /* A file designated by filehandle is not shown as accessible
2955 * for write operations, probably because it is opened for reading.
2958 BY_HANDLE_FILE_INFORMATION bhfi;
2959 #if defined(WIN64) || defined(USE_LARGE_FILES)
2960 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2962 int rc = fstat(fd,&tmp);
2964 sbufptr->st_dev = tmp.st_dev;
2965 sbufptr->st_ino = tmp.st_ino;
2966 sbufptr->st_mode = tmp.st_mode;
2967 sbufptr->st_nlink = tmp.st_nlink;
2968 sbufptr->st_uid = tmp.st_uid;
2969 sbufptr->st_gid = tmp.st_gid;
2970 sbufptr->st_rdev = tmp.st_rdev;
2971 sbufptr->st_size = tmp.st_size;
2972 sbufptr->st_atime = tmp.st_atime;
2973 sbufptr->st_mtime = tmp.st_mtime;
2974 sbufptr->st_ctime = tmp.st_ctime;
2976 int rc = fstat(fd,sbufptr);
2979 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2980 #if defined(WIN64) || defined(USE_LARGE_FILES)
2981 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2983 sbufptr->st_mode &= 0xFE00;
2984 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2985 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2987 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2988 + ((S_IREAD|S_IWRITE) >> 6));
2992 return my_fstat(fd,sbufptr);
2997 win32_pipe(int *pfd, unsigned int size, int mode)
2999 return _pipe(pfd, size, mode);
3003 win32_popenlist(const char *mode, IV narg, SV **args)
3006 Perl_croak(aTHX_ "List form of pipe open not implemented");
3011 * a popen() clone that respects PERL5SHELL
3013 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3017 win32_popen(const char *command, const char *mode)
3019 #ifdef USE_RTL_POPEN
3020 return _popen(command, mode);
3032 /* establish which ends read and write */
3033 if (strchr(mode,'w')) {
3034 stdfd = 0; /* stdin */
3037 nhandle = STD_INPUT_HANDLE;
3039 else if (strchr(mode,'r')) {
3040 stdfd = 1; /* stdout */
3043 nhandle = STD_OUTPUT_HANDLE;
3048 /* set the correct mode */
3049 if (strchr(mode,'b'))
3051 else if (strchr(mode,'t'))
3054 ourmode = _fmode & (O_TEXT | O_BINARY);
3056 /* the child doesn't inherit handles */
3057 ourmode |= O_NOINHERIT;
3059 if (win32_pipe(p, 512, ourmode) == -1)
3062 /* save the old std handle (this needs to happen before the
3063 * dup2(), since that might call SetStdHandle() too) */
3066 old_h = GetStdHandle(nhandle);
3068 /* save current stdfd */
3069 if ((oldfd = win32_dup(stdfd)) == -1)
3072 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3073 /* stdfd will be inherited by the child */
3074 if (win32_dup2(p[child], stdfd) == -1)
3077 /* close the child end in parent */
3078 win32_close(p[child]);
3080 /* set the new std handle (in case dup2() above didn't) */
3081 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3083 /* start the child */
3086 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3089 /* revert stdfd to whatever it was before */
3090 if (win32_dup2(oldfd, stdfd) == -1)
3093 /* close saved handle */
3096 /* restore the old std handle (this needs to happen after the
3097 * dup2(), since that might call SetStdHandle() too */
3099 SetStdHandle(nhandle, old_h);
3104 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3106 /* set process id so that it can be returned by perl's open() */
3107 PL_forkprocess = childpid;
3110 /* we have an fd, return a file stream */
3111 return (PerlIO_fdopen(p[parent], (char *)mode));
3114 /* we don't need to check for errors here */
3118 win32_dup2(oldfd, stdfd);
3122 SetStdHandle(nhandle, old_h);
3128 #endif /* USE_RTL_POPEN */
3136 win32_pclose(PerlIO *pf)
3138 #ifdef USE_RTL_POPEN
3142 int childpid, status;
3145 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3148 childpid = SvIVX(sv);
3164 if (win32_waitpid(childpid, &status, 0) == -1)
3169 #endif /* USE_RTL_POPEN */
3175 LPCWSTR lpExistingFileName,
3176 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3179 WCHAR wFullName[MAX_PATH+1];
3180 LPVOID lpContext = NULL;
3181 WIN32_STREAM_ID StreamId;
3182 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3187 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3188 BOOL, BOOL, LPVOID*) =
3189 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3190 BOOL, BOOL, LPVOID*))
3191 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3192 if (pfnBackupWrite == NULL)
3195 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3198 dwLen = (dwLen+1)*sizeof(WCHAR);
3200 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3201 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3202 NULL, OPEN_EXISTING, 0, NULL);
3203 if (handle == INVALID_HANDLE_VALUE)
3206 StreamId.dwStreamId = BACKUP_LINK;
3207 StreamId.dwStreamAttributes = 0;
3208 StreamId.dwStreamNameSize = 0;
3209 #if defined(__BORLANDC__) \
3210 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3211 StreamId.Size.u.HighPart = 0;
3212 StreamId.Size.u.LowPart = dwLen;
3214 StreamId.Size.HighPart = 0;
3215 StreamId.Size.LowPart = dwLen;
3218 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3219 FALSE, FALSE, &lpContext);
3221 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3222 FALSE, FALSE, &lpContext);
3223 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3226 CloseHandle(handle);
3231 win32_link(const char *oldname, const char *newname)
3234 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3235 WCHAR wOldName[MAX_PATH+1];
3236 WCHAR wNewName[MAX_PATH+1];
3239 Perl_croak(aTHX_ PL_no_func, "link");
3241 pfnCreateHardLinkW =
3242 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3243 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3244 if (pfnCreateHardLinkW == NULL)
3245 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3247 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3248 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3249 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3250 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3254 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3259 win32_rename(const char *oname, const char *newname)
3261 char szOldName[MAX_PATH+1];
3262 char szNewName[MAX_PATH+1];
3266 /* XXX despite what the documentation says about MoveFileEx(),
3267 * it doesn't work under Windows95!
3270 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3271 if (stricmp(newname, oname))
3272 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3273 strcpy(szOldName, PerlDir_mapA(oname));
3274 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3276 DWORD err = GetLastError();
3278 case ERROR_BAD_NET_NAME:
3279 case ERROR_BAD_NETPATH:
3280 case ERROR_BAD_PATHNAME:
3281 case ERROR_FILE_NOT_FOUND:
3282 case ERROR_FILENAME_EXCED_RANGE:
3283 case ERROR_INVALID_DRIVE:
3284 case ERROR_NO_MORE_FILES:
3285 case ERROR_PATH_NOT_FOUND:
3298 char szTmpName[MAX_PATH+1];
3299 char dname[MAX_PATH+1];
3300 char *endname = NULL;
3302 DWORD from_attr, to_attr;
3304 strcpy(szOldName, PerlDir_mapA(oname));
3305 strcpy(szNewName, PerlDir_mapA(newname));
3307 /* if oname doesn't exist, do nothing */
3308 from_attr = GetFileAttributes(szOldName);
3309 if (from_attr == 0xFFFFFFFF) {
3314 /* if newname exists, rename it to a temporary name so that we
3315 * don't delete it in case oname happens to be the same file
3316 * (but perhaps accessed via a different path)
3318 to_attr = GetFileAttributes(szNewName);
3319 if (to_attr != 0xFFFFFFFF) {
3320 /* if newname is a directory, we fail
3321 * XXX could overcome this with yet more convoluted logic */
3322 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3326 tmplen = strlen(szNewName);
3327 strcpy(szTmpName,szNewName);
3328 endname = szTmpName+tmplen;
3329 for (; endname > szTmpName ; --endname) {
3330 if (*endname == '/' || *endname == '\\') {
3335 if (endname > szTmpName)
3336 endname = strcpy(dname,szTmpName);
3340 /* get a temporary filename in same directory
3341 * XXX is this really the best we can do? */
3342 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3346 DeleteFile(szTmpName);
3348 retval = rename(szNewName, szTmpName);
3355 /* rename oname to newname */
3356 retval = rename(szOldName, szNewName);
3358 /* if we created a temporary file before ... */
3359 if (endname != NULL) {
3360 /* ...and rename succeeded, delete temporary file/directory */
3362 DeleteFile(szTmpName);
3363 /* else restore it to what it was */
3365 (void)rename(szTmpName, szNewName);
3372 win32_setmode(int fd, int mode)
3374 return setmode(fd, mode);
3378 win32_chsize(int fd, Off_t size)
3380 #if defined(WIN64) || defined(USE_LARGE_FILES)
3382 Off_t cur, end, extend;
3384 cur = win32_tell(fd);
3387 end = win32_lseek(fd, 0, SEEK_END);
3390 extend = size - end;
3394 else if (extend > 0) {
3395 /* must grow the file, padding with nulls */
3397 int oldmode = win32_setmode(fd, O_BINARY);
3399 memset(b, '\0', sizeof(b));
3401 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3402 count = win32_write(fd, b, count);
3403 if ((int)count < 0) {
3407 } while ((extend -= count) > 0);
3408 win32_setmode(fd, oldmode);
3411 /* shrink the file */
3412 win32_lseek(fd, size, SEEK_SET);
3413 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3419 win32_lseek(fd, cur, SEEK_SET);
3422 return chsize(fd, (long)size);
3427 win32_lseek(int fd, Off_t offset, int origin)
3429 #if defined(WIN64) || defined(USE_LARGE_FILES)
3430 #if defined(__BORLANDC__) /* buk */
3432 pos.QuadPart = offset;
3433 pos.LowPart = SetFilePointer(
3434 (HANDLE)_get_osfhandle(fd),
3439 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3443 return pos.QuadPart;
3445 return _lseeki64(fd, offset, origin);
3448 return lseek(fd, (long)offset, origin);
3455 #if defined(WIN64) || defined(USE_LARGE_FILES)
3456 #if defined(__BORLANDC__) /* buk */
3459 pos.LowPart = SetFilePointer(
3460 (HANDLE)_get_osfhandle(fd),
3465 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3469 return pos.QuadPart;
3470 /* return tell(fd); */
3472 return _telli64(fd);
3480 win32_open(const char *path, int flag, ...)
3487 pmode = va_arg(ap, int);
3490 if (stricmp(path, "/dev/null")==0)
3493 return open(PerlDir_mapA(path), flag, pmode);
3496 /* close() that understands socket */
3497 extern int my_close(int); /* in win32sck.c */
3502 return my_close(fd);
3518 win32_dup2(int fd1,int fd2)
3520 return dup2(fd1,fd2);
3523 #ifdef PERL_MSVCRT_READFIX
3525 #define LF 10 /* line feed */
3526 #define CR 13 /* carriage return */
3527 #define CTRLZ 26 /* ctrl-z means eof for text */
3528 #define FOPEN 0x01 /* file handle open */
3529 #define FEOFLAG 0x02 /* end of file has been encountered */
3530 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3531 #define FPIPE 0x08 /* file handle refers to a pipe */
3532 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3533 #define FDEV 0x40 /* file handle refers to device */
3534 #define FTEXT 0x80 /* file handle is in text mode */
3535 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3538 _fixed_read(int fh, void *buf, unsigned cnt)
3540 int bytes_read; /* number of bytes read */
3541 char *buffer; /* buffer to read to */
3542 int os_read; /* bytes read on OS call */
3543 char *p, *q; /* pointers into buffer */
3544 char peekchr; /* peek-ahead character */
3545 ULONG filepos; /* file position after seek */
3546 ULONG dosretval; /* o.s. return value */
3548 /* validate handle */
3549 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3550 !(_osfile(fh) & FOPEN))
3552 /* out of range -- return error */
3554 _doserrno = 0; /* not o.s. error */
3559 * If lockinitflag is FALSE, assume fd is device
3560 * lockinitflag is set to TRUE by open.
3562 if (_pioinfo(fh)->lockinitflag)
3563 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3565 bytes_read = 0; /* nothing read yet */
3566 buffer = (char*)buf;
3568 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3569 /* nothing to read or at EOF, so return 0 read */
3573 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3574 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3576 *buffer++ = _pipech(fh);
3579 _pipech(fh) = LF; /* mark as empty */
3584 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3586 /* ReadFile has reported an error. recognize two special cases.
3588 * 1. map ERROR_ACCESS_DENIED to EBADF
3590 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3591 * means the handle is a read-handle on a pipe for which
3592 * all write-handles have been closed and all data has been
3595 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3596 /* wrong read/write mode should return EBADF, not EACCES */
3598 _doserrno = dosretval;
3602 else if (dosretval == ERROR_BROKEN_PIPE) {
3612 bytes_read += os_read; /* update bytes read */
3614 if (_osfile(fh) & FTEXT) {
3615 /* now must translate CR-LFs to LFs in the buffer */
3617 /* set CRLF flag to indicate LF at beginning of buffer */
3618 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3619 /* _osfile(fh) |= FCRLF; */
3621 /* _osfile(fh) &= ~FCRLF; */
3623 _osfile(fh) &= ~FCRLF;
3625 /* convert chars in the buffer: p is src, q is dest */
3627 while (p < (char *)buf + bytes_read) {
3629 /* if fh is not a device, set ctrl-z flag */
3630 if (!(_osfile(fh) & FDEV))
3631 _osfile(fh) |= FEOFLAG;
3632 break; /* stop translating */
3637 /* *p is CR, so must check next char for LF */
3638 if (p < (char *)buf + bytes_read - 1) {
3641 *q++ = LF; /* convert CR-LF to LF */
3644 *q++ = *p++; /* store char normally */
3647 /* This is the hard part. We found a CR at end of
3648 buffer. We must peek ahead to see if next char
3653 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3654 (LPDWORD)&os_read, NULL))
3655 dosretval = GetLastError();
3657 if (dosretval != 0 || os_read == 0) {
3658 /* couldn't read ahead, store CR */
3662 /* peekchr now has the extra character -- we now
3663 have several possibilities:
3664 1. disk file and char is not LF; just seek back
3666 2. disk file and char is LF; store LF, don't seek back
3667 3. pipe/device and char is LF; store LF.
3668 4. pipe/device and char isn't LF, store CR and
3669 put char in pipe lookahead buffer. */
3670 if (_osfile(fh) & (FDEV|FPIPE)) {
3671 /* non-seekable device */
3676 _pipech(fh) = peekchr;
3681 if (peekchr == LF) {
3682 /* nothing read yet; must make some
3685 /* turn on this flag for tell routine */
3686 _osfile(fh) |= FCRLF;
3689 HANDLE osHandle; /* o.s. handle value */
3691 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3693 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3694 dosretval = GetLastError();
3705 /* we now change bytes_read to reflect the true number of chars
3707 bytes_read = q - (char *)buf;
3711 if (_pioinfo(fh)->lockinitflag)
3712 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3717 #endif /* PERL_MSVCRT_READFIX */
3720 win32_read(int fd, void *buf, unsigned int cnt)
3722 #ifdef PERL_MSVCRT_READFIX
3723 return _fixed_read(fd, buf, cnt);
3725 return read(fd, buf, cnt);
3730 win32_write(int fd, const void *buf, unsigned int cnt)
3732 return write(fd, buf, cnt);
3736 win32_mkdir(const char *dir, int mode)
3739 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3743 win32_rmdir(const char *dir)
3746 return rmdir(PerlDir_mapA(dir));
3750 win32_chdir(const char *dir)
3761 win32_access(const char *path, int mode)
3764 return access(PerlDir_mapA(path), mode);
3768 win32_chmod(const char *path, int mode)
3771 return chmod(PerlDir_mapA(path), mode);
3776 create_command_line(char *cname, STRLEN clen, const char * const *args)
3783 bool bat_file = FALSE;
3784 bool cmd_shell = FALSE;
3785 bool dumb_shell = FALSE;
3786 bool extra_quotes = FALSE;
3787 bool quote_next = FALSE;
3790 cname = (char*)args[0];
3792 /* The NT cmd.exe shell has the following peculiarity that needs to be
3793 * worked around. It strips a leading and trailing dquote when any
3794 * of the following is true:
3795 * 1. the /S switch was used
3796 * 2. there are more than two dquotes
3797 * 3. there is a special character from this set: &<>()@^|
3798 * 4. no whitespace characters within the two dquotes
3799 * 5. string between two dquotes isn't an executable file
3800 * To work around this, we always add a leading and trailing dquote
3801 * to the string, if the first argument is either "cmd.exe" or "cmd",
3802 * and there were at least two or more arguments passed to cmd.exe
3803 * (not including switches).
3804 * XXX the above rules (from "cmd /?") don't seem to be applied
3805 * always, making for the convolutions below :-(
3809 clen = strlen(cname);
3812 && (stricmp(&cname[clen-4], ".bat") == 0
3813 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3820 char *exe = strrchr(cname, '/');
3821 char *exe2 = strrchr(cname, '\\');
3828 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3832 else if (stricmp(exe, "command.com") == 0
3833 || stricmp(exe, "command") == 0)
3840 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3841 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3842 STRLEN curlen = strlen(arg);
3843 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3844 len += 2; /* assume quoting needed (worst case) */
3846 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3848 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3851 Newx(cmd, len, char);
3854 if (bat_file && !IsWin95()) {
3856 extra_quotes = TRUE;
3859 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3861 STRLEN curlen = strlen(arg);
3863 /* we want to protect empty arguments and ones with spaces with
3864 * dquotes, but only if they aren't already there */
3869 else if (quote_next) {
3870 /* see if it really is multiple arguments pretending to
3871 * be one and force a set of quotes around it */
3872 if (*find_next_space(arg))
3875 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3877 while (i < curlen) {
3878 if (isSPACE(arg[i])) {
3881 else if (arg[i] == '"') {
3905 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3906 && stricmp(arg+curlen-2, "/c") == 0)
3908 /* is there a next argument? */
3909 if (args[index+1]) {
3910 /* are there two or more next arguments? */
3911 if (args[index+2]) {
3913 extra_quotes = TRUE;
3916 /* single argument, force quoting if it has spaces */
3932 qualified_path(const char *cmd)
3936 char *fullcmd, *curfullcmd;
3942 fullcmd = (char*)cmd;
3944 if (*fullcmd == '/' || *fullcmd == '\\')
3951 pathstr = PerlEnv_getenv("PATH");
3953 /* worst case: PATH is a single directory; we need additional space
3954 * to append "/", ".exe" and trailing "\0" */
3955 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3956 curfullcmd = fullcmd;
3961 /* start by appending the name to the current prefix */
3962 strcpy(curfullcmd, cmd);
3963 curfullcmd += cmdlen;
3965 /* if it doesn't end with '.', or has no extension, try adding
3966 * a trailing .exe first */
3967 if (cmd[cmdlen-1] != '.'
3968 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3970 strcpy(curfullcmd, ".exe");
3971 res = GetFileAttributes(fullcmd);
3972 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3977 /* that failed, try the bare name */
3978 res = GetFileAttributes(fullcmd);
3979 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3982 /* quit if no other path exists, or if cmd already has path */
3983 if (!pathstr || !*pathstr || has_slash)
3986 /* skip leading semis */
3987 while (*pathstr == ';')
3990 /* build a new prefix from scratch */
3991 curfullcmd = fullcmd;
3992 while (*pathstr && *pathstr != ';') {
3993 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3994 pathstr++; /* skip initial '"' */
3995 while (*pathstr && *pathstr != '"') {
3996 *curfullcmd++ = *pathstr++;
3999 pathstr++; /* skip trailing '"' */
4002 *curfullcmd++ = *pathstr++;
4006 pathstr++; /* skip trailing semi */
4007 if (curfullcmd > fullcmd /* append a dir separator */
4008 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
4010 *curfullcmd++ = '\\';
4018 /* The following are just place holders.
4019 * Some hosts may provide and environment that the OS is
4020 * not tracking, therefore, these host must provide that
4021 * environment and the current directory to CreateProcess
4025 win32_get_childenv(void)
4031 win32_free_childenv(void* d)
4036 win32_clearenv(void)
4038 char *envv = GetEnvironmentStrings();
4042 char *end = strchr(cur,'=');
4043 if (end && end != cur) {
4045 SetEnvironmentVariable(cur, NULL);
4047 cur = end + strlen(end+1)+2;
4049 else if ((len = strlen(cur)))
4052 FreeEnvironmentStrings(envv);
4056 win32_get_childdir(void)
4060 char szfilename[MAX_PATH+1];
4062 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4063 Newx(ptr, strlen(szfilename)+1, char);
4064 strcpy(ptr, szfilename);
4069 win32_free_childdir(char* d)
4076 /* XXX this needs to be made more compatible with the spawnvp()
4077 * provided by the various RTLs. In particular, searching for
4078 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4079 * This doesn't significantly affect perl itself, because we
4080 * always invoke things using PERL5SHELL if a direct attempt to
4081 * spawn the executable fails.
4083 * XXX splitting and rejoining the commandline between do_aspawn()
4084 * and win32_spawnvp() could also be avoided.
4088 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4090 #ifdef USE_RTL_SPAWNVP
4091 return spawnvp(mode, cmdname, (char * const *)argv);
4098 STARTUPINFO StartupInfo;
4099 PROCESS_INFORMATION ProcessInformation;
4102 char *fullcmd = NULL;
4103 char *cname = (char *)cmdname;
4107 clen = strlen(cname);
4108 /* if command name contains dquotes, must remove them */
4109 if (strchr(cname, '"')) {
4111 Newx(cname,clen+1,char);
4124 cmd = create_command_line(cname, clen, argv);
4126 env = PerlEnv_get_childenv();
4127 dir = PerlEnv_get_childdir();
4130 case P_NOWAIT: /* asynch + remember result */
4131 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4136 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4139 create |= CREATE_NEW_PROCESS_GROUP;
4142 case P_WAIT: /* synchronous execution */
4144 default: /* invalid mode */
4149 memset(&StartupInfo,0,sizeof(StartupInfo));
4150 StartupInfo.cb = sizeof(StartupInfo);
4151 memset(&tbl,0,sizeof(tbl));
4152 PerlEnv_get_child_IO(&tbl);
4153 StartupInfo.dwFlags = tbl.dwFlags;
4154 StartupInfo.dwX = tbl.dwX;
4155 StartupInfo.dwY = tbl.dwY;
4156 StartupInfo.dwXSize = tbl.dwXSize;
4157 StartupInfo.dwYSize = tbl.dwYSize;
4158 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4159 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4160 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4161 StartupInfo.wShowWindow = tbl.wShowWindow;
4162 StartupInfo.hStdInput = tbl.childStdIn;
4163 StartupInfo.hStdOutput = tbl.childStdOut;
4164 StartupInfo.hStdError = tbl.childStdErr;
4165 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4166 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4167 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4169 create |= CREATE_NEW_CONSOLE;
4172 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4174 if (w32_use_showwindow) {
4175 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4176 StartupInfo.wShowWindow = w32_showwindow;
4179 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4182 if (!CreateProcess(cname, /* search PATH to find executable */
4183 cmd, /* executable, and its arguments */
4184 NULL, /* process attributes */
4185 NULL, /* thread attributes */
4186 TRUE, /* inherit handles */
4187 create, /* creation flags */
4188 (LPVOID)env, /* inherit environment */
4189 dir, /* inherit cwd */
4191 &ProcessInformation))
4193 /* initial NULL argument to CreateProcess() does a PATH
4194 * search, but it always first looks in the directory
4195 * where the current process was started, which behavior
4196 * is undesirable for backward compatibility. So we
4197 * jump through our own hoops by picking out the path
4198 * we really want it to use. */
4200 fullcmd = qualified_path(cname);
4202 if (cname != cmdname)
4205 DEBUG_p(PerlIO_printf(Perl_debug_log,
4206 "Retrying [%s] with same args\n",
4216 if (mode == P_NOWAIT) {
4217 /* asynchronous spawn -- store handle, return PID */
4218 ret = (int)ProcessInformation.dwProcessId;
4219 if (IsWin95() && ret < 0)
4222 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4223 w32_child_pids[w32_num_children] = (DWORD)ret;
4228 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4229 /* FIXME: if msgwait returned due to message perhaps forward the
4230 "signal" to the process
4232 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4234 CloseHandle(ProcessInformation.hProcess);
4237 CloseHandle(ProcessInformation.hThread);
4240 PerlEnv_free_childenv(env);
4241 PerlEnv_free_childdir(dir);
4243 if (cname != cmdname)
4250 win32_execv(const char *cmdname, const char *const *argv)
4254 /* if this is a pseudo-forked child, we just want to spawn
4255 * the new program, and return */
4257 # ifdef __BORLANDC__
4258 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4260 return spawnv(P_WAIT, cmdname, argv);
4264 return execv(cmdname, (char *const *)argv);
4266 return execv(cmdname, argv);
4271 win32_execvp(const char *cmdname, const char *const *argv)
4275 /* if this is a pseudo-forked child, we just want to spawn
4276 * the new program, and return */
4277 if (w32_pseudo_id) {
4278 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4288 return execvp(cmdname, (char *const *)argv);
4290 return execvp(cmdname, argv);
4295 win32_perror(const char *str)
4301 win32_setbuf(FILE *pf, char *buf)
4307 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4309 return setvbuf(pf, buf, type, size);
4313 win32_flushall(void)
4319 win32_fcloseall(void)
4325 win32_fgets(char *s, int n, FILE *pf)
4327 return fgets(s, n, pf);
4337 win32_fgetc(FILE *pf)
4343 win32_putc(int c, FILE *pf)
4349 win32_puts(const char *s)
4361 win32_putchar(int c)
4368 #ifndef USE_PERL_SBRK
4370 static char *committed = NULL; /* XXX threadead */
4371 static char *base = NULL; /* XXX threadead */
4372 static char *reserved = NULL; /* XXX threadead */
4373 static char *brk = NULL; /* XXX threadead */
4374 static DWORD pagesize = 0; /* XXX threadead */
4377 sbrk(ptrdiff_t need)
4382 GetSystemInfo(&info);
4383 /* Pretend page size is larger so we don't perpetually
4384 * call the OS to commit just one page ...
4386 pagesize = info.dwPageSize << 3;
4388 if (brk+need >= reserved)
4390 DWORD size = brk+need-reserved;
4392 char *prev_committed = NULL;
4393 if (committed && reserved && committed < reserved)
4395 /* Commit last of previous chunk cannot span allocations */
4396 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4399 /* Remember where we committed from in case we want to decommit later */
4400 prev_committed = committed;
4401 committed = reserved;
4404 /* Reserve some (more) space
4405 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4406 * this is only address space not memory...
4407 * Note this is a little sneaky, 1st call passes NULL as reserved
4408 * so lets system choose where we start, subsequent calls pass
4409 * the old end address so ask for a contiguous block
4412 if (size < 64*1024*1024)
4413 size = 64*1024*1024;
4414 size = ((size + pagesize - 1) / pagesize) * pagesize;
4415 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4418 reserved = addr+size;
4428 /* The existing block could not be extended far enough, so decommit
4429 * anything that was just committed above and start anew */
4432 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4435 reserved = base = committed = brk = NULL;
4446 if (brk > committed)
4448 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4450 if (committed+size > reserved)
4451 size = reserved-committed;
4452 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4465 win32_malloc(size_t size)
4467 return malloc(size);
4471 win32_calloc(size_t numitems, size_t size)
4473 return calloc(numitems,size);
4477 win32_realloc(void *block, size_t size)
4479 return realloc(block,size);
4483 win32_free(void *block)
4490 win32_open_osfhandle(intptr_t handle, int flags)
4492 #ifdef USE_FIXED_OSFHANDLE
4494 return my_open_osfhandle(handle, flags);
4496 return _open_osfhandle(handle, flags);
4500 win32_get_osfhandle(int fd)
4502 return (intptr_t)_get_osfhandle(fd);
4506 win32_fdupopen(FILE *pf)
4511 int fileno = win32_dup(win32_fileno(pf));
4513 /* open the file in the same mode */
4515 if((pf)->flags & _F_READ) {
4519 else if((pf)->flags & _F_WRIT) {
4523 else if((pf)->flags & _F_RDWR) {
4529 if((pf)->_flag & _IOREAD) {
4533 else if((pf)->_flag & _IOWRT) {
4537 else if((pf)->_flag & _IORW) {
4544 /* it appears that the binmode is attached to the
4545 * file descriptor so binmode files will be handled
4548 pfdup = win32_fdopen(fileno, mode);
4550 /* move the file pointer to the same position */
4551 if (!fgetpos(pf, &pos)) {
4552 fsetpos(pfdup, &pos);
4558 win32_dynaload(const char* filename)
4561 char buf[MAX_PATH+1];
4564 /* LoadLibrary() doesn't recognize forward slashes correctly,
4565 * so turn 'em back. */
4566 first = strchr(filename, '/');
4568 STRLEN len = strlen(filename);
4569 if (len <= MAX_PATH) {
4570 strcpy(buf, filename);
4571 filename = &buf[first - filename];
4573 if (*filename == '/')
4574 *(char*)filename = '\\';
4580 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4583 XS(w32_SetChildShowWindow)
4586 BOOL use_showwindow = w32_use_showwindow;
4587 /* use "unsigned short" because Perl has redefined "WORD" */
4588 unsigned short showwindow = w32_showwindow;
4591 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4593 if (items == 0 || !SvOK(ST(0)))
4594 w32_use_showwindow = FALSE;
4596 w32_use_showwindow = TRUE;
4597 w32_showwindow = (unsigned short)SvIV(ST(0));
4602 ST(0) = sv_2mortal(newSViv(showwindow));
4604 ST(0) = &PL_sv_undef;
4609 Perl_init_os_extras(void)
4612 char *file = __FILE__;
4614 /* Initialize Win32CORE if it has been statically linked. */
4615 void (*pfn_init)(pTHX);
4616 #if defined(__BORLANDC__)
4617 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4618 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4620 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4625 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4629 win32_signal_context(void)
4634 my_perl = PL_curinterp;
4635 PERL_SET_THX(my_perl);
4639 return PL_curinterp;
4645 win32_ctrlhandler(DWORD dwCtrlType)
4648 dTHXa(PERL_GET_SIG_CONTEXT);
4654 switch(dwCtrlType) {
4655 case CTRL_CLOSE_EVENT:
4656 /* A signal that the system sends to all processes attached to a console when
4657 the user closes the console (either by choosing the Close command from the
4658 console window's System menu, or by choosing the End Task command from the
4661 if (do_raise(aTHX_ 1)) /* SIGHUP */
4662 sig_terminate(aTHX_ 1);
4666 /* A CTRL+c signal was received */
4667 if (do_raise(aTHX_ SIGINT))
4668 sig_terminate(aTHX_ SIGINT);
4671 case CTRL_BREAK_EVENT:
4672 /* A CTRL+BREAK signal was received */
4673 if (do_raise(aTHX_ SIGBREAK))
4674 sig_terminate(aTHX_ SIGBREAK);
4677 case CTRL_LOGOFF_EVENT:
4678 /* A signal that the system sends to all console processes when a user is logging
4679 off. This signal does not indicate which user is logging off, so no
4680 assumptions can be made.
4683 case CTRL_SHUTDOWN_EVENT:
4684 /* A signal that the system sends to all console processes when the system is
4687 if (do_raise(aTHX_ SIGTERM))
4688 sig_terminate(aTHX_ SIGTERM);
4697 #ifdef SET_INVALID_PARAMETER_HANDLER
4698 # include <crtdbg.h>
4709 /* win32_ansipath() requires Windows 2000 or later */
4713 /* fetch Unicode version of PATH */
4715 wide_path = win32_malloc(len*sizeof(WCHAR));
4717 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4721 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4726 /* convert to ANSI pathnames */
4727 wide_dir = wide_path;
4730 WCHAR *sep = wcschr(wide_dir, ';');
4738 /* remove quotes around pathname */
4739 if (*wide_dir == '"')
4741 wide_len = wcslen(wide_dir);
4742 if (wide_len && wide_dir[wide_len-1] == '"')
4743 wide_dir[wide_len-1] = '\0';
4745 /* append ansi_dir to ansi_path */
4746 ansi_dir = win32_ansipath(wide_dir);
4747 ansi_len = strlen(ansi_dir);
4749 size_t newlen = len + 1 + ansi_len;
4750 ansi_path = win32_realloc(ansi_path, newlen+1);
4753 ansi_path[len] = ';';
4754 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4759 ansi_path = win32_malloc(5+len+1);
4762 memcpy(ansi_path, "PATH=", 5);
4763 memcpy(ansi_path+5, ansi_dir, len+1);
4766 win32_free(ansi_dir);
4771 /* Update C RTL environ array. This will only have full effect if
4772 * perl_parse() is later called with `environ` as the `env` argument.
4773 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4775 * We do have to ansify() the PATH before Perl has been fully
4776 * initialized because S_find_script() uses the PATH when perl
4777 * is being invoked with the -S option. This happens before %ENV
4778 * is initialized in S_init_postdump_symbols().
4780 * XXX Is this a bug? Should S_find_script() use the environment
4781 * XXX passed in the `env` arg to parse_perl()?
4784 /* Keep system environment in sync because S_init_postdump_symbols()
4785 * will not call mg_set() if it initializes %ENV from `environ`.
4787 SetEnvironmentVariableA("PATH", ansi_path+5);
4788 /* We are intentionally leaking the ansi_path string here because
4789 * the Borland runtime library puts it directly into the environ
4790 * array. The Microsoft runtime library seems to make a copy,
4791 * but will leak the copy should it be replaced again later.
4792 * Since this code is only called once during PERL_SYS_INIT this
4793 * shouldn't really matter.
4796 win32_free(wide_path);
4800 Perl_win32_init(int *argcp, char ***argvp)
4804 #ifdef SET_INVALID_PARAMETER_HANDLER
4805 _invalid_parameter_handler oldHandler, newHandler;
4806 newHandler = my_invalid_parameter_handler;
4807 oldHandler = _set_invalid_parameter_handler(newHandler);
4808 _CrtSetReportMode(_CRT_ASSERT, 0);
4810 /* Disable floating point errors, Perl will trap the ones we
4811 * care about. VC++ RTL defaults to switching these off
4812 * already, but the Borland RTL doesn't. Since we don't
4813 * want to be at the vendor's whim on the default, we set
4814 * it explicitly here.
4816 #if !defined(_ALPHA_) && !defined(__GNUC__)
4817 _control87(MCW_EM, MCW_EM);
4821 /* When the manifest resource requests Common-Controls v6 then
4822 * user32.dll no longer registers all the Windows classes used for
4823 * standard controls but leaves some of them to be registered by
4824 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4825 * it makes sure comctl32.dll gets loaded into the process and registers
4826 * the standard control classes. Without this even normal Windows APIs
4827 * like MessageBox() can fail under some versions of Windows XP.
4829 InitCommonControls();
4831 module = GetModuleHandle("ntdll.dll");
4833 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4836 module = GetModuleHandle("kernel32.dll");
4838 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4839 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4840 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4843 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4844 GetVersionEx(&g_osver);
4850 Perl_win32_term(void)
4860 win32_get_child_IO(child_IO_table* ptbl)
4862 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4863 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4864 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4868 win32_signal(int sig, Sighandler_t subcode)
4871 if (sig < SIG_SIZE) {
4872 int save_errno = errno;
4873 Sighandler_t result = signal(sig, subcode);
4874 if (result == SIG_ERR) {
4875 result = w32_sighandler[sig];
4878 w32_sighandler[sig] = subcode;
4887 /* The PerlMessageWindowClass's WindowProc */
4889 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4891 return win32_process_message(hwnd, msg, wParam, lParam) ?
4892 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4895 /* we use a message filter hook to process thread messages, passing any
4896 * messages that we don't process on to the rest of the hook chain
4897 * Anyone else writing a message loop that wants to play nicely with perl
4899 * CallMsgFilter(&msg, MSGF_***);
4900 * between their GetMessage and DispatchMessage calls. */
4902 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4903 LPMSG pmsg = (LPMSG)lParam;
4905 /* we'll process it if code says we're allowed, and it's a thread message */
4906 if (code >= 0 && pmsg->hwnd == NULL
4907 && win32_process_message(pmsg->hwnd, pmsg->message,
4908 pmsg->wParam, pmsg->lParam))
4913 /* XXX: MSDN says that hhk is ignored, but we should really use the
4914 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4915 return CallNextHookEx(NULL, code, wParam, lParam);
4918 /* The real message handler. Can be called with
4919 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4920 * that it processes */
4922 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4924 /* BEWARE. The context retrieved using dTHX; is the context of the
4925 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4926 * up to and including WM_CREATE. If it ever happens that you need the
4927 * 'child' context before this, then it needs to be passed into
4928 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4929 * from the lparam of CreateWindow(). It could then be stored/retrieved
4930 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4931 * the dTHX calls here. */
4932 /* XXX For now it is assumed that the overhead of the dTHX; for what
4933 * are relativley infrequent code-paths, is better than the added
4934 * complexity of getting the correct context passed into
4935 * win32_create_message_window() */
4940 case WM_USER_MESSAGE: {
4941 long child = find_pseudo_pid((int)wParam);
4944 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4951 case WM_USER_KILL: {
4953 /* We use WM_USER_KILL to fake kill() with other signals */
4954 int sig = (int)wParam;
4955 if (do_raise(aTHX_ sig))
4956 sig_terminate(aTHX_ sig);
4963 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4964 if (w32_timerid && w32_timerid==(UINT)wParam) {
4965 KillTimer(w32_message_hwnd, w32_timerid);
4968 /* Now fake a call to signal handler */
4969 if (do_raise(aTHX_ 14))
4970 sig_terminate(aTHX_ 14);
4982 /* Above or other stuff may have set a signal flag, and we may not have
4983 * been called from win32_async_check() (e.g. some other GUI's message
4984 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4985 * handler that die's, and the message loop that calls here is wrapped
4986 * in an eval, then you may well end up with orphaned windows - signals
4987 * are dispatched by win32_async_check() */
4993 win32_create_message_window_class(void)
4995 /* create the window class for "message only" windows */
4999 wc.lpfnWndProc = win32_message_window_proc;
5000 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
5001 wc.lpszClassName = "PerlMessageWindowClass";
5003 /* second and subsequent calls will fail, but class
5004 * will already be registered */
5009 win32_create_message_window(void)
5013 /* "message-only" windows have been implemented in Windows 2000 and later.
5014 * On earlier versions we'll continue to post messages to a specific
5015 * thread and use hwnd==NULL. This is brittle when either an embedding
5016 * application or an XS module is also posting messages to hwnd=NULL
5017 * because once removed from the queue they cannot be delivered to the
5018 * "right" place with DispatchMessage() anymore, as there is no WindowProc
5019 * if there is no window handle.
5021 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
5022 * documentation to the contrary, however, there is some evidence that
5023 * there may be problems with the implementation on Win98. As it is not
5024 * officially supported we take the cautious route and stick with thread
5025 * messages (hwnd == NULL) on platforms prior to Win2k.
5028 win32_create_message_window_class();
5030 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
5031 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5034 /* If we din't create a window for any reason, then we'll use thread
5035 * messages for our signalling, so we install a hook which
5036 * is called by CallMsgFilter in win32_async_check(), or any other
5037 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5038 * that use OLE, etc. */
5040 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5041 NULL, GetCurrentThreadId());
5047 #ifdef HAVE_INTERP_INTERN
5050 win32_csighandler(int sig)
5053 dTHXa(PERL_GET_SIG_CONTEXT);
5054 Perl_warn(aTHX_ "Got signal %d",sig);
5059 #if defined(__MINGW32__) && defined(__cplusplus)
5060 #define CAST_HWND__(x) (HWND__*)(x)
5062 #define CAST_HWND__(x) x
5066 Perl_sys_intern_init(pTHX)
5070 w32_perlshell_tokens = NULL;
5071 w32_perlshell_vec = (char**)NULL;
5072 w32_perlshell_items = 0;
5073 w32_fdpid = newAV();
5074 Newx(w32_children, 1, child_tab);
5075 w32_num_children = 0;
5076 # ifdef USE_ITHREADS
5078 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5079 w32_num_pseudo_children = 0;
5082 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5084 for (i=0; i < SIG_SIZE; i++) {
5085 w32_sighandler[i] = SIG_DFL;
5087 # ifdef MULTIPLICITY
5088 if (my_perl == PL_curinterp) {
5092 /* Force C runtime signal stuff to set its console handler */
5093 signal(SIGINT,win32_csighandler);
5094 signal(SIGBREAK,win32_csighandler);
5096 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5097 * flag. This has the side-effect of disabling Ctrl-C events in all
5098 * processes in this group. At least on Windows NT and later we
5099 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5100 * with a NULL handler. This is not valid on Windows 9X.
5103 SetConsoleCtrlHandler(NULL,FALSE);
5105 /* Push our handler on top */
5106 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5111 Perl_sys_intern_clear(pTHX)
5113 Safefree(w32_perlshell_tokens);
5114 Safefree(w32_perlshell_vec);
5115 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5116 Safefree(w32_children);
5118 KillTimer(w32_message_hwnd, w32_timerid);
5121 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5122 DestroyWindow(w32_message_hwnd);
5123 # ifdef MULTIPLICITY
5124 if (my_perl == PL_curinterp) {
5128 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5130 # ifdef USE_ITHREADS
5131 Safefree(w32_pseudo_children);
5135 # ifdef USE_ITHREADS
5138 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5140 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5142 dst->perlshell_tokens = NULL;
5143 dst->perlshell_vec = (char**)NULL;
5144 dst->perlshell_items = 0;
5145 dst->fdpid = newAV();
5146 Newxz(dst->children, 1, child_tab);
5148 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5150 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5151 dst->poll_count = 0;
5152 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5154 # endif /* USE_ITHREADS */
5155 #endif /* HAVE_INTERP_INTERN */