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 */
29 #define SystemProcessesAndThreadsInformation 5
31 /* Inline some definitions from the DDK */
42 LARGE_INTEGER CreateTime;
43 LARGE_INTEGER UserTime;
44 LARGE_INTEGER KernelTime;
45 UNICODE_STRING ProcessName;
48 ULONG InheritedFromProcessId;
49 /* Remainder of the structure depends on the Windows version,
50 * but we don't need those additional fields anyways... */
53 /* #include "config.h" */
55 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
64 #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))
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_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2509 #define LK_LEN 0xffff0000
2512 win32_flock(int fd, int oper)
2520 Perl_croak_nocontext("flock() unimplemented on this platform");
2523 fh = (HANDLE)_get_osfhandle(fd);
2524 memset(&o, 0, sizeof(o));
2527 case LOCK_SH: /* shared lock */
2528 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2530 case LOCK_EX: /* exclusive lock */
2531 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2533 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2534 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2536 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2537 LK_ERR(LockFileEx(fh,
2538 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2539 0, LK_LEN, 0, &o),i);
2541 case LOCK_UN: /* unlock lock */
2542 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2544 default: /* unknown */
2555 * redirected io subsystem for all XS modules
2568 return (&(_environ));
2571 /* the rest are the remapped stdio routines */
2591 win32_ferror(FILE *fp)
2593 return (ferror(fp));
2598 win32_feof(FILE *fp)
2604 * Since the errors returned by the socket error function
2605 * WSAGetLastError() are not known by the library routine strerror
2606 * we have to roll our own.
2610 win32_strerror(int e)
2612 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2613 extern int sys_nerr;
2617 if (e < 0 || e > sys_nerr) {
2622 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2623 w32_strerror_buffer,
2624 sizeof(w32_strerror_buffer), NULL) == 0)
2625 strcpy(w32_strerror_buffer, "Unknown Error");
2627 return w32_strerror_buffer;
2633 win32_str_os_error(void *sv, DWORD dwErr)
2637 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2638 |FORMAT_MESSAGE_IGNORE_INSERTS
2639 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2640 dwErr, 0, (char *)&sMsg, 1, NULL);
2641 /* strip trailing whitespace and period */
2644 --dwLen; /* dwLen doesn't include trailing null */
2645 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2646 if ('.' != sMsg[dwLen])
2651 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2653 dwLen = sprintf(sMsg,
2654 "Unknown error #0x%lX (lookup 0x%lX)",
2655 dwErr, GetLastError());
2659 sv_setpvn((SV*)sv, sMsg, dwLen);
2665 win32_fprintf(FILE *fp, const char *format, ...)
2668 va_start(marker, format); /* Initialize variable arguments. */
2670 return (vfprintf(fp, format, marker));
2674 win32_printf(const char *format, ...)
2677 va_start(marker, format); /* Initialize variable arguments. */
2679 return (vprintf(format, marker));
2683 win32_vfprintf(FILE *fp, const char *format, va_list args)
2685 return (vfprintf(fp, format, args));
2689 win32_vprintf(const char *format, va_list args)
2691 return (vprintf(format, args));
2695 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2697 return fread(buf, size, count, fp);
2701 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2703 return fwrite(buf, size, count, fp);
2706 #define MODE_SIZE 10
2709 win32_fopen(const char *filename, const char *mode)
2717 if (stricmp(filename, "/dev/null")==0)
2720 f = fopen(PerlDir_mapA(filename), mode);
2721 /* avoid buffering headaches for child processes */
2722 if (f && *mode == 'a')
2723 win32_fseek(f, 0, SEEK_END);
2727 #ifndef USE_SOCKETS_AS_HANDLES
2729 #define fdopen my_fdopen
2733 win32_fdopen(int handle, const char *mode)
2737 f = fdopen(handle, (char *) mode);
2738 /* avoid buffering headaches for child processes */
2739 if (f && *mode == 'a')
2740 win32_fseek(f, 0, SEEK_END);
2745 win32_freopen(const char *path, const char *mode, FILE *stream)
2748 if (stricmp(path, "/dev/null")==0)
2751 return freopen(PerlDir_mapA(path), mode, stream);
2755 win32_fclose(FILE *pf)
2757 return my_fclose(pf); /* defined in win32sck.c */
2761 win32_fputs(const char *s,FILE *pf)
2763 return fputs(s, pf);
2767 win32_fputc(int c,FILE *pf)
2773 win32_ungetc(int c,FILE *pf)
2775 return ungetc(c,pf);
2779 win32_getc(FILE *pf)
2785 win32_fileno(FILE *pf)
2791 win32_clearerr(FILE *pf)
2798 win32_fflush(FILE *pf)
2804 win32_ftell(FILE *pf)
2806 #if defined(WIN64) || defined(USE_LARGE_FILES)
2807 #if defined(__BORLANDC__) /* buk */
2808 return win32_tell( fileno( pf ) );
2811 if (fgetpos(pf, &pos))
2821 win32_fseek(FILE *pf, Off_t offset,int origin)
2823 #if defined(WIN64) || defined(USE_LARGE_FILES)
2824 #if defined(__BORLANDC__) /* buk */
2834 if (fgetpos(pf, &pos))
2839 fseek(pf, 0, SEEK_END);
2840 pos = _telli64(fileno(pf));
2849 return fsetpos(pf, &offset);
2852 return fseek(pf, (long)offset, origin);
2857 win32_fgetpos(FILE *pf,fpos_t *p)
2859 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2860 if( win32_tell(fileno(pf)) == -1L ) {
2866 return fgetpos(pf, p);
2871 win32_fsetpos(FILE *pf,const fpos_t *p)
2873 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2874 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2876 return fsetpos(pf, p);
2881 win32_rewind(FILE *pf)
2891 char prefix[MAX_PATH+1];
2892 char filename[MAX_PATH+1];
2893 DWORD len = GetTempPath(MAX_PATH, prefix);
2894 if (len && len < MAX_PATH) {
2895 if (GetTempFileName(prefix, "plx", 0, filename)) {
2896 HANDLE fh = CreateFile(filename,
2897 DELETE | GENERIC_READ | GENERIC_WRITE,
2901 FILE_ATTRIBUTE_NORMAL
2902 | FILE_FLAG_DELETE_ON_CLOSE,
2904 if (fh != INVALID_HANDLE_VALUE) {
2905 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2907 #if defined(__BORLANDC__)
2908 setmode(fd,O_BINARY);
2910 DEBUG_p(PerlIO_printf(Perl_debug_log,
2911 "Created tmpfile=%s\n",filename));
2923 int fd = win32_tmpfd();
2925 return win32_fdopen(fd, "w+b");
2937 win32_fstat(int fd, Stat_t *sbufptr)
2940 /* A file designated by filehandle is not shown as accessible
2941 * for write operations, probably because it is opened for reading.
2944 BY_HANDLE_FILE_INFORMATION bhfi;
2945 #if defined(WIN64) || defined(USE_LARGE_FILES)
2946 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2948 int rc = fstat(fd,&tmp);
2950 sbufptr->st_dev = tmp.st_dev;
2951 sbufptr->st_ino = tmp.st_ino;
2952 sbufptr->st_mode = tmp.st_mode;
2953 sbufptr->st_nlink = tmp.st_nlink;
2954 sbufptr->st_uid = tmp.st_uid;
2955 sbufptr->st_gid = tmp.st_gid;
2956 sbufptr->st_rdev = tmp.st_rdev;
2957 sbufptr->st_size = tmp.st_size;
2958 sbufptr->st_atime = tmp.st_atime;
2959 sbufptr->st_mtime = tmp.st_mtime;
2960 sbufptr->st_ctime = tmp.st_ctime;
2962 int rc = fstat(fd,sbufptr);
2965 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2966 #if defined(WIN64) || defined(USE_LARGE_FILES)
2967 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2969 sbufptr->st_mode &= 0xFE00;
2970 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2971 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2973 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2974 + ((S_IREAD|S_IWRITE) >> 6));
2978 return my_fstat(fd,sbufptr);
2983 win32_pipe(int *pfd, unsigned int size, int mode)
2985 return _pipe(pfd, size, mode);
2989 win32_popenlist(const char *mode, IV narg, SV **args)
2992 Perl_croak(aTHX_ "List form of pipe open not implemented");
2997 * a popen() clone that respects PERL5SHELL
2999 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3003 win32_popen(const char *command, const char *mode)
3005 #ifdef USE_RTL_POPEN
3006 return _popen(command, mode);
3018 /* establish which ends read and write */
3019 if (strchr(mode,'w')) {
3020 stdfd = 0; /* stdin */
3023 nhandle = STD_INPUT_HANDLE;
3025 else if (strchr(mode,'r')) {
3026 stdfd = 1; /* stdout */
3029 nhandle = STD_OUTPUT_HANDLE;
3034 /* set the correct mode */
3035 if (strchr(mode,'b'))
3037 else if (strchr(mode,'t'))
3040 ourmode = _fmode & (O_TEXT | O_BINARY);
3042 /* the child doesn't inherit handles */
3043 ourmode |= O_NOINHERIT;
3045 if (win32_pipe(p, 512, ourmode) == -1)
3048 /* save the old std handle (this needs to happen before the
3049 * dup2(), since that might call SetStdHandle() too) */
3052 old_h = GetStdHandle(nhandle);
3054 /* save current stdfd */
3055 if ((oldfd = win32_dup(stdfd)) == -1)
3058 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3059 /* stdfd will be inherited by the child */
3060 if (win32_dup2(p[child], stdfd) == -1)
3063 /* close the child end in parent */
3064 win32_close(p[child]);
3066 /* set the new std handle (in case dup2() above didn't) */
3067 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3069 /* start the child */
3072 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3075 /* revert stdfd to whatever it was before */
3076 if (win32_dup2(oldfd, stdfd) == -1)
3079 /* close saved handle */
3082 /* restore the old std handle (this needs to happen after the
3083 * dup2(), since that might call SetStdHandle() too */
3085 SetStdHandle(nhandle, old_h);
3090 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3092 /* set process id so that it can be returned by perl's open() */
3093 PL_forkprocess = childpid;
3096 /* we have an fd, return a file stream */
3097 return (PerlIO_fdopen(p[parent], (char *)mode));
3100 /* we don't need to check for errors here */
3104 win32_dup2(oldfd, stdfd);
3108 SetStdHandle(nhandle, old_h);
3114 #endif /* USE_RTL_POPEN */
3122 win32_pclose(PerlIO *pf)
3124 #ifdef USE_RTL_POPEN
3128 int childpid, status;
3131 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3134 childpid = SvIVX(sv);
3150 if (win32_waitpid(childpid, &status, 0) == -1)
3155 #endif /* USE_RTL_POPEN */
3161 LPCWSTR lpExistingFileName,
3162 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3165 WCHAR wFullName[MAX_PATH+1];
3166 LPVOID lpContext = NULL;
3167 WIN32_STREAM_ID StreamId;
3168 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3173 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3174 BOOL, BOOL, LPVOID*) =
3175 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3176 BOOL, BOOL, LPVOID*))
3177 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3178 if (pfnBackupWrite == NULL)
3181 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3184 dwLen = (dwLen+1)*sizeof(WCHAR);
3186 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3187 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3188 NULL, OPEN_EXISTING, 0, NULL);
3189 if (handle == INVALID_HANDLE_VALUE)
3192 StreamId.dwStreamId = BACKUP_LINK;
3193 StreamId.dwStreamAttributes = 0;
3194 StreamId.dwStreamNameSize = 0;
3195 #if defined(__BORLANDC__) \
3196 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3197 StreamId.Size.u.HighPart = 0;
3198 StreamId.Size.u.LowPart = dwLen;
3200 StreamId.Size.HighPart = 0;
3201 StreamId.Size.LowPart = dwLen;
3204 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3205 FALSE, FALSE, &lpContext);
3207 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3208 FALSE, FALSE, &lpContext);
3209 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3212 CloseHandle(handle);
3217 win32_link(const char *oldname, const char *newname)
3220 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3221 WCHAR wOldName[MAX_PATH+1];
3222 WCHAR wNewName[MAX_PATH+1];
3225 Perl_croak(aTHX_ PL_no_func, "link");
3227 pfnCreateHardLinkW =
3228 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3229 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3230 if (pfnCreateHardLinkW == NULL)
3231 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3233 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3234 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3235 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3236 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3240 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3245 win32_rename(const char *oname, const char *newname)
3247 char szOldName[MAX_PATH+1];
3248 char szNewName[MAX_PATH+1];
3252 /* XXX despite what the documentation says about MoveFileEx(),
3253 * it doesn't work under Windows95!
3256 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3257 if (stricmp(newname, oname))
3258 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3259 strcpy(szOldName, PerlDir_mapA(oname));
3260 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3262 DWORD err = GetLastError();
3264 case ERROR_BAD_NET_NAME:
3265 case ERROR_BAD_NETPATH:
3266 case ERROR_BAD_PATHNAME:
3267 case ERROR_FILE_NOT_FOUND:
3268 case ERROR_FILENAME_EXCED_RANGE:
3269 case ERROR_INVALID_DRIVE:
3270 case ERROR_NO_MORE_FILES:
3271 case ERROR_PATH_NOT_FOUND:
3284 char szTmpName[MAX_PATH+1];
3285 char dname[MAX_PATH+1];
3286 char *endname = NULL;
3288 DWORD from_attr, to_attr;
3290 strcpy(szOldName, PerlDir_mapA(oname));
3291 strcpy(szNewName, PerlDir_mapA(newname));
3293 /* if oname doesn't exist, do nothing */
3294 from_attr = GetFileAttributes(szOldName);
3295 if (from_attr == 0xFFFFFFFF) {
3300 /* if newname exists, rename it to a temporary name so that we
3301 * don't delete it in case oname happens to be the same file
3302 * (but perhaps accessed via a different path)
3304 to_attr = GetFileAttributes(szNewName);
3305 if (to_attr != 0xFFFFFFFF) {
3306 /* if newname is a directory, we fail
3307 * XXX could overcome this with yet more convoluted logic */
3308 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3312 tmplen = strlen(szNewName);
3313 strcpy(szTmpName,szNewName);
3314 endname = szTmpName+tmplen;
3315 for (; endname > szTmpName ; --endname) {
3316 if (*endname == '/' || *endname == '\\') {
3321 if (endname > szTmpName)
3322 endname = strcpy(dname,szTmpName);
3326 /* get a temporary filename in same directory
3327 * XXX is this really the best we can do? */
3328 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3332 DeleteFile(szTmpName);
3334 retval = rename(szNewName, szTmpName);
3341 /* rename oname to newname */
3342 retval = rename(szOldName, szNewName);
3344 /* if we created a temporary file before ... */
3345 if (endname != NULL) {
3346 /* ...and rename succeeded, delete temporary file/directory */
3348 DeleteFile(szTmpName);
3349 /* else restore it to what it was */
3351 (void)rename(szTmpName, szNewName);
3358 win32_setmode(int fd, int mode)
3360 return setmode(fd, mode);
3364 win32_chsize(int fd, Off_t size)
3366 #if defined(WIN64) || defined(USE_LARGE_FILES)
3368 Off_t cur, end, extend;
3370 cur = win32_tell(fd);
3373 end = win32_lseek(fd, 0, SEEK_END);
3376 extend = size - end;
3380 else if (extend > 0) {
3381 /* must grow the file, padding with nulls */
3383 int oldmode = win32_setmode(fd, O_BINARY);
3385 memset(b, '\0', sizeof(b));
3387 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3388 count = win32_write(fd, b, count);
3389 if ((int)count < 0) {
3393 } while ((extend -= count) > 0);
3394 win32_setmode(fd, oldmode);
3397 /* shrink the file */
3398 win32_lseek(fd, size, SEEK_SET);
3399 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3405 win32_lseek(fd, cur, SEEK_SET);
3408 return chsize(fd, (long)size);
3413 win32_lseek(int fd, Off_t offset, int origin)
3415 #if defined(WIN64) || defined(USE_LARGE_FILES)
3416 #if defined(__BORLANDC__) /* buk */
3418 pos.QuadPart = offset;
3419 pos.LowPart = SetFilePointer(
3420 (HANDLE)_get_osfhandle(fd),
3425 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3429 return pos.QuadPart;
3431 return _lseeki64(fd, offset, origin);
3434 return lseek(fd, (long)offset, origin);
3441 #if defined(WIN64) || defined(USE_LARGE_FILES)
3442 #if defined(__BORLANDC__) /* buk */
3445 pos.LowPart = SetFilePointer(
3446 (HANDLE)_get_osfhandle(fd),
3451 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3455 return pos.QuadPart;
3456 /* return tell(fd); */
3458 return _telli64(fd);
3466 win32_open(const char *path, int flag, ...)
3473 pmode = va_arg(ap, int);
3476 if (stricmp(path, "/dev/null")==0)
3479 return open(PerlDir_mapA(path), flag, pmode);
3482 /* close() that understands socket */
3483 extern int my_close(int); /* in win32sck.c */
3488 return my_close(fd);
3504 win32_dup2(int fd1,int fd2)
3506 return dup2(fd1,fd2);
3509 #ifdef PERL_MSVCRT_READFIX
3511 #define LF 10 /* line feed */
3512 #define CR 13 /* carriage return */
3513 #define CTRLZ 26 /* ctrl-z means eof for text */
3514 #define FOPEN 0x01 /* file handle open */
3515 #define FEOFLAG 0x02 /* end of file has been encountered */
3516 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3517 #define FPIPE 0x08 /* file handle refers to a pipe */
3518 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3519 #define FDEV 0x40 /* file handle refers to device */
3520 #define FTEXT 0x80 /* file handle is in text mode */
3521 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3524 _fixed_read(int fh, void *buf, unsigned cnt)
3526 int bytes_read; /* number of bytes read */
3527 char *buffer; /* buffer to read to */
3528 int os_read; /* bytes read on OS call */
3529 char *p, *q; /* pointers into buffer */
3530 char peekchr; /* peek-ahead character */
3531 ULONG filepos; /* file position after seek */
3532 ULONG dosretval; /* o.s. return value */
3534 /* validate handle */
3535 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3536 !(_osfile(fh) & FOPEN))
3538 /* out of range -- return error */
3540 _doserrno = 0; /* not o.s. error */
3545 * If lockinitflag is FALSE, assume fd is device
3546 * lockinitflag is set to TRUE by open.
3548 if (_pioinfo(fh)->lockinitflag)
3549 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3551 bytes_read = 0; /* nothing read yet */
3552 buffer = (char*)buf;
3554 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3555 /* nothing to read or at EOF, so return 0 read */
3559 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3560 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3562 *buffer++ = _pipech(fh);
3565 _pipech(fh) = LF; /* mark as empty */
3570 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3572 /* ReadFile has reported an error. recognize two special cases.
3574 * 1. map ERROR_ACCESS_DENIED to EBADF
3576 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3577 * means the handle is a read-handle on a pipe for which
3578 * all write-handles have been closed and all data has been
3581 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3582 /* wrong read/write mode should return EBADF, not EACCES */
3584 _doserrno = dosretval;
3588 else if (dosretval == ERROR_BROKEN_PIPE) {
3598 bytes_read += os_read; /* update bytes read */
3600 if (_osfile(fh) & FTEXT) {
3601 /* now must translate CR-LFs to LFs in the buffer */
3603 /* set CRLF flag to indicate LF at beginning of buffer */
3604 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3605 /* _osfile(fh) |= FCRLF; */
3607 /* _osfile(fh) &= ~FCRLF; */
3609 _osfile(fh) &= ~FCRLF;
3611 /* convert chars in the buffer: p is src, q is dest */
3613 while (p < (char *)buf + bytes_read) {
3615 /* if fh is not a device, set ctrl-z flag */
3616 if (!(_osfile(fh) & FDEV))
3617 _osfile(fh) |= FEOFLAG;
3618 break; /* stop translating */
3623 /* *p is CR, so must check next char for LF */
3624 if (p < (char *)buf + bytes_read - 1) {
3627 *q++ = LF; /* convert CR-LF to LF */
3630 *q++ = *p++; /* store char normally */
3633 /* This is the hard part. We found a CR at end of
3634 buffer. We must peek ahead to see if next char
3639 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3640 (LPDWORD)&os_read, NULL))
3641 dosretval = GetLastError();
3643 if (dosretval != 0 || os_read == 0) {
3644 /* couldn't read ahead, store CR */
3648 /* peekchr now has the extra character -- we now
3649 have several possibilities:
3650 1. disk file and char is not LF; just seek back
3652 2. disk file and char is LF; store LF, don't seek back
3653 3. pipe/device and char is LF; store LF.
3654 4. pipe/device and char isn't LF, store CR and
3655 put char in pipe lookahead buffer. */
3656 if (_osfile(fh) & (FDEV|FPIPE)) {
3657 /* non-seekable device */
3662 _pipech(fh) = peekchr;
3667 if (peekchr == LF) {
3668 /* nothing read yet; must make some
3671 /* turn on this flag for tell routine */
3672 _osfile(fh) |= FCRLF;
3675 HANDLE osHandle; /* o.s. handle value */
3677 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3679 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3680 dosretval = GetLastError();
3691 /* we now change bytes_read to reflect the true number of chars
3693 bytes_read = q - (char *)buf;
3697 if (_pioinfo(fh)->lockinitflag)
3698 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3703 #endif /* PERL_MSVCRT_READFIX */
3706 win32_read(int fd, void *buf, unsigned int cnt)
3708 #ifdef PERL_MSVCRT_READFIX
3709 return _fixed_read(fd, buf, cnt);
3711 return read(fd, buf, cnt);
3716 win32_write(int fd, const void *buf, unsigned int cnt)
3718 return write(fd, buf, cnt);
3722 win32_mkdir(const char *dir, int mode)
3725 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3729 win32_rmdir(const char *dir)
3732 return rmdir(PerlDir_mapA(dir));
3736 win32_chdir(const char *dir)
3747 win32_access(const char *path, int mode)
3750 return access(PerlDir_mapA(path), mode);
3754 win32_chmod(const char *path, int mode)
3757 return chmod(PerlDir_mapA(path), mode);
3762 create_command_line(char *cname, STRLEN clen, const char * const *args)
3769 bool bat_file = FALSE;
3770 bool cmd_shell = FALSE;
3771 bool dumb_shell = FALSE;
3772 bool extra_quotes = FALSE;
3773 bool quote_next = FALSE;
3776 cname = (char*)args[0];
3778 /* The NT cmd.exe shell has the following peculiarity that needs to be
3779 * worked around. It strips a leading and trailing dquote when any
3780 * of the following is true:
3781 * 1. the /S switch was used
3782 * 2. there are more than two dquotes
3783 * 3. there is a special character from this set: &<>()@^|
3784 * 4. no whitespace characters within the two dquotes
3785 * 5. string between two dquotes isn't an executable file
3786 * To work around this, we always add a leading and trailing dquote
3787 * to the string, if the first argument is either "cmd.exe" or "cmd",
3788 * and there were at least two or more arguments passed to cmd.exe
3789 * (not including switches).
3790 * XXX the above rules (from "cmd /?") don't seem to be applied
3791 * always, making for the convolutions below :-(
3795 clen = strlen(cname);
3798 && (stricmp(&cname[clen-4], ".bat") == 0
3799 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3806 char *exe = strrchr(cname, '/');
3807 char *exe2 = strrchr(cname, '\\');
3814 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3818 else if (stricmp(exe, "command.com") == 0
3819 || stricmp(exe, "command") == 0)
3826 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3827 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3828 STRLEN curlen = strlen(arg);
3829 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3830 len += 2; /* assume quoting needed (worst case) */
3832 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3834 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3837 Newx(cmd, len, char);
3840 if (bat_file && !IsWin95()) {
3842 extra_quotes = TRUE;
3845 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3847 STRLEN curlen = strlen(arg);
3849 /* we want to protect empty arguments and ones with spaces with
3850 * dquotes, but only if they aren't already there */
3855 else if (quote_next) {
3856 /* see if it really is multiple arguments pretending to
3857 * be one and force a set of quotes around it */
3858 if (*find_next_space(arg))
3861 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3863 while (i < curlen) {
3864 if (isSPACE(arg[i])) {
3867 else if (arg[i] == '"') {
3891 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3892 && stricmp(arg+curlen-2, "/c") == 0)
3894 /* is there a next argument? */
3895 if (args[index+1]) {
3896 /* are there two or more next arguments? */
3897 if (args[index+2]) {
3899 extra_quotes = TRUE;
3902 /* single argument, force quoting if it has spaces */
3918 qualified_path(const char *cmd)
3922 char *fullcmd, *curfullcmd;
3928 fullcmd = (char*)cmd;
3930 if (*fullcmd == '/' || *fullcmd == '\\')
3937 pathstr = PerlEnv_getenv("PATH");
3939 /* worst case: PATH is a single directory; we need additional space
3940 * to append "/", ".exe" and trailing "\0" */
3941 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3942 curfullcmd = fullcmd;
3947 /* start by appending the name to the current prefix */
3948 strcpy(curfullcmd, cmd);
3949 curfullcmd += cmdlen;
3951 /* if it doesn't end with '.', or has no extension, try adding
3952 * a trailing .exe first */
3953 if (cmd[cmdlen-1] != '.'
3954 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3956 strcpy(curfullcmd, ".exe");
3957 res = GetFileAttributes(fullcmd);
3958 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3963 /* that failed, try the bare name */
3964 res = GetFileAttributes(fullcmd);
3965 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3968 /* quit if no other path exists, or if cmd already has path */
3969 if (!pathstr || !*pathstr || has_slash)
3972 /* skip leading semis */
3973 while (*pathstr == ';')
3976 /* build a new prefix from scratch */
3977 curfullcmd = fullcmd;
3978 while (*pathstr && *pathstr != ';') {
3979 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3980 pathstr++; /* skip initial '"' */
3981 while (*pathstr && *pathstr != '"') {
3982 *curfullcmd++ = *pathstr++;
3985 pathstr++; /* skip trailing '"' */
3988 *curfullcmd++ = *pathstr++;
3992 pathstr++; /* skip trailing semi */
3993 if (curfullcmd > fullcmd /* append a dir separator */
3994 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3996 *curfullcmd++ = '\\';
4004 /* The following are just place holders.
4005 * Some hosts may provide and environment that the OS is
4006 * not tracking, therefore, these host must provide that
4007 * environment and the current directory to CreateProcess
4011 win32_get_childenv(void)
4017 win32_free_childenv(void* d)
4022 win32_clearenv(void)
4024 char *envv = GetEnvironmentStrings();
4028 char *end = strchr(cur,'=');
4029 if (end && end != cur) {
4031 SetEnvironmentVariable(cur, NULL);
4033 cur = end + strlen(end+1)+2;
4035 else if ((len = strlen(cur)))
4038 FreeEnvironmentStrings(envv);
4042 win32_get_childdir(void)
4046 char szfilename[MAX_PATH+1];
4048 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4049 Newx(ptr, strlen(szfilename)+1, char);
4050 strcpy(ptr, szfilename);
4055 win32_free_childdir(char* d)
4062 /* XXX this needs to be made more compatible with the spawnvp()
4063 * provided by the various RTLs. In particular, searching for
4064 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4065 * This doesn't significantly affect perl itself, because we
4066 * always invoke things using PERL5SHELL if a direct attempt to
4067 * spawn the executable fails.
4069 * XXX splitting and rejoining the commandline between do_aspawn()
4070 * and win32_spawnvp() could also be avoided.
4074 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4076 #ifdef USE_RTL_SPAWNVP
4077 return spawnvp(mode, cmdname, (char * const *)argv);
4084 STARTUPINFO StartupInfo;
4085 PROCESS_INFORMATION ProcessInformation;
4088 char *fullcmd = NULL;
4089 char *cname = (char *)cmdname;
4093 clen = strlen(cname);
4094 /* if command name contains dquotes, must remove them */
4095 if (strchr(cname, '"')) {
4097 Newx(cname,clen+1,char);
4110 cmd = create_command_line(cname, clen, argv);
4112 env = PerlEnv_get_childenv();
4113 dir = PerlEnv_get_childdir();
4116 case P_NOWAIT: /* asynch + remember result */
4117 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4122 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4125 create |= CREATE_NEW_PROCESS_GROUP;
4128 case P_WAIT: /* synchronous execution */
4130 default: /* invalid mode */
4135 memset(&StartupInfo,0,sizeof(StartupInfo));
4136 StartupInfo.cb = sizeof(StartupInfo);
4137 memset(&tbl,0,sizeof(tbl));
4138 PerlEnv_get_child_IO(&tbl);
4139 StartupInfo.dwFlags = tbl.dwFlags;
4140 StartupInfo.dwX = tbl.dwX;
4141 StartupInfo.dwY = tbl.dwY;
4142 StartupInfo.dwXSize = tbl.dwXSize;
4143 StartupInfo.dwYSize = tbl.dwYSize;
4144 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4145 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4146 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4147 StartupInfo.wShowWindow = tbl.wShowWindow;
4148 StartupInfo.hStdInput = tbl.childStdIn;
4149 StartupInfo.hStdOutput = tbl.childStdOut;
4150 StartupInfo.hStdError = tbl.childStdErr;
4151 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4152 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4153 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4155 create |= CREATE_NEW_CONSOLE;
4158 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4160 if (w32_use_showwindow) {
4161 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4162 StartupInfo.wShowWindow = w32_showwindow;
4165 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4168 if (!CreateProcess(cname, /* search PATH to find executable */
4169 cmd, /* executable, and its arguments */
4170 NULL, /* process attributes */
4171 NULL, /* thread attributes */
4172 TRUE, /* inherit handles */
4173 create, /* creation flags */
4174 (LPVOID)env, /* inherit environment */
4175 dir, /* inherit cwd */
4177 &ProcessInformation))
4179 /* initial NULL argument to CreateProcess() does a PATH
4180 * search, but it always first looks in the directory
4181 * where the current process was started, which behavior
4182 * is undesirable for backward compatibility. So we
4183 * jump through our own hoops by picking out the path
4184 * we really want it to use. */
4186 fullcmd = qualified_path(cname);
4188 if (cname != cmdname)
4191 DEBUG_p(PerlIO_printf(Perl_debug_log,
4192 "Retrying [%s] with same args\n",
4202 if (mode == P_NOWAIT) {
4203 /* asynchronous spawn -- store handle, return PID */
4204 ret = (int)ProcessInformation.dwProcessId;
4205 if (IsWin95() && ret < 0)
4208 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4209 w32_child_pids[w32_num_children] = (DWORD)ret;
4214 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4215 /* FIXME: if msgwait returned due to message perhaps forward the
4216 "signal" to the process
4218 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4220 CloseHandle(ProcessInformation.hProcess);
4223 CloseHandle(ProcessInformation.hThread);
4226 PerlEnv_free_childenv(env);
4227 PerlEnv_free_childdir(dir);
4229 if (cname != cmdname)
4236 win32_execv(const char *cmdname, const char *const *argv)
4240 /* if this is a pseudo-forked child, we just want to spawn
4241 * the new program, and return */
4243 # ifdef __BORLANDC__
4244 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4246 return spawnv(P_WAIT, cmdname, argv);
4250 return execv(cmdname, (char *const *)argv);
4252 return execv(cmdname, argv);
4257 win32_execvp(const char *cmdname, const char *const *argv)
4261 /* if this is a pseudo-forked child, we just want to spawn
4262 * the new program, and return */
4263 if (w32_pseudo_id) {
4264 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4274 return execvp(cmdname, (char *const *)argv);
4276 return execvp(cmdname, argv);
4281 win32_perror(const char *str)
4287 win32_setbuf(FILE *pf, char *buf)
4293 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4295 return setvbuf(pf, buf, type, size);
4299 win32_flushall(void)
4305 win32_fcloseall(void)
4311 win32_fgets(char *s, int n, FILE *pf)
4313 return fgets(s, n, pf);
4323 win32_fgetc(FILE *pf)
4329 win32_putc(int c, FILE *pf)
4335 win32_puts(const char *s)
4347 win32_putchar(int c)
4354 #ifndef USE_PERL_SBRK
4356 static char *committed = NULL; /* XXX threadead */
4357 static char *base = NULL; /* XXX threadead */
4358 static char *reserved = NULL; /* XXX threadead */
4359 static char *brk = NULL; /* XXX threadead */
4360 static DWORD pagesize = 0; /* XXX threadead */
4363 sbrk(ptrdiff_t need)
4368 GetSystemInfo(&info);
4369 /* Pretend page size is larger so we don't perpetually
4370 * call the OS to commit just one page ...
4372 pagesize = info.dwPageSize << 3;
4374 if (brk+need >= reserved)
4376 DWORD size = brk+need-reserved;
4378 char *prev_committed = NULL;
4379 if (committed && reserved && committed < reserved)
4381 /* Commit last of previous chunk cannot span allocations */
4382 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4385 /* Remember where we committed from in case we want to decommit later */
4386 prev_committed = committed;
4387 committed = reserved;
4390 /* Reserve some (more) space
4391 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4392 * this is only address space not memory...
4393 * Note this is a little sneaky, 1st call passes NULL as reserved
4394 * so lets system choose where we start, subsequent calls pass
4395 * the old end address so ask for a contiguous block
4398 if (size < 64*1024*1024)
4399 size = 64*1024*1024;
4400 size = ((size + pagesize - 1) / pagesize) * pagesize;
4401 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4404 reserved = addr+size;
4414 /* The existing block could not be extended far enough, so decommit
4415 * anything that was just committed above and start anew */
4418 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4421 reserved = base = committed = brk = NULL;
4432 if (brk > committed)
4434 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4436 if (committed+size > reserved)
4437 size = reserved-committed;
4438 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4451 win32_malloc(size_t size)
4453 return malloc(size);
4457 win32_calloc(size_t numitems, size_t size)
4459 return calloc(numitems,size);
4463 win32_realloc(void *block, size_t size)
4465 return realloc(block,size);
4469 win32_free(void *block)
4476 win32_open_osfhandle(intptr_t handle, int flags)
4478 #ifdef USE_FIXED_OSFHANDLE
4480 return my_open_osfhandle(handle, flags);
4482 return _open_osfhandle(handle, flags);
4486 win32_get_osfhandle(int fd)
4488 return (intptr_t)_get_osfhandle(fd);
4492 win32_fdupopen(FILE *pf)
4497 int fileno = win32_dup(win32_fileno(pf));
4499 /* open the file in the same mode */
4501 if((pf)->flags & _F_READ) {
4505 else if((pf)->flags & _F_WRIT) {
4509 else if((pf)->flags & _F_RDWR) {
4515 if((pf)->_flag & _IOREAD) {
4519 else if((pf)->_flag & _IOWRT) {
4523 else if((pf)->_flag & _IORW) {
4530 /* it appears that the binmode is attached to the
4531 * file descriptor so binmode files will be handled
4534 pfdup = win32_fdopen(fileno, mode);
4536 /* move the file pointer to the same position */
4537 if (!fgetpos(pf, &pos)) {
4538 fsetpos(pfdup, &pos);
4544 win32_dynaload(const char* filename)
4547 char buf[MAX_PATH+1];
4550 /* LoadLibrary() doesn't recognize forward slashes correctly,
4551 * so turn 'em back. */
4552 first = strchr(filename, '/');
4554 STRLEN len = strlen(filename);
4555 if (len <= MAX_PATH) {
4556 strcpy(buf, filename);
4557 filename = &buf[first - filename];
4559 if (*filename == '/')
4560 *(char*)filename = '\\';
4566 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4569 XS(w32_SetChildShowWindow)
4572 BOOL use_showwindow = w32_use_showwindow;
4573 /* use "unsigned short" because Perl has redefined "WORD" */
4574 unsigned short showwindow = w32_showwindow;
4577 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4579 if (items == 0 || !SvOK(ST(0)))
4580 w32_use_showwindow = FALSE;
4582 w32_use_showwindow = TRUE;
4583 w32_showwindow = (unsigned short)SvIV(ST(0));
4588 ST(0) = sv_2mortal(newSViv(showwindow));
4590 ST(0) = &PL_sv_undef;
4595 Perl_init_os_extras(void)
4598 char *file = __FILE__;
4600 /* Initialize Win32CORE if it has been statically linked. */
4601 void (*pfn_init)(pTHX);
4602 #if defined(__BORLANDC__)
4603 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4604 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4606 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4611 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4615 win32_signal_context(void)
4620 my_perl = PL_curinterp;
4621 PERL_SET_THX(my_perl);
4625 return PL_curinterp;
4631 win32_ctrlhandler(DWORD dwCtrlType)
4634 dTHXa(PERL_GET_SIG_CONTEXT);
4640 switch(dwCtrlType) {
4641 case CTRL_CLOSE_EVENT:
4642 /* A signal that the system sends to all processes attached to a console when
4643 the user closes the console (either by choosing the Close command from the
4644 console window's System menu, or by choosing the End Task command from the
4647 if (do_raise(aTHX_ 1)) /* SIGHUP */
4648 sig_terminate(aTHX_ 1);
4652 /* A CTRL+c signal was received */
4653 if (do_raise(aTHX_ SIGINT))
4654 sig_terminate(aTHX_ SIGINT);
4657 case CTRL_BREAK_EVENT:
4658 /* A CTRL+BREAK signal was received */
4659 if (do_raise(aTHX_ SIGBREAK))
4660 sig_terminate(aTHX_ SIGBREAK);
4663 case CTRL_LOGOFF_EVENT:
4664 /* A signal that the system sends to all console processes when a user is logging
4665 off. This signal does not indicate which user is logging off, so no
4666 assumptions can be made.
4669 case CTRL_SHUTDOWN_EVENT:
4670 /* A signal that the system sends to all console processes when the system is
4673 if (do_raise(aTHX_ SIGTERM))
4674 sig_terminate(aTHX_ SIGTERM);
4683 #ifdef SET_INVALID_PARAMETER_HANDLER
4684 # include <crtdbg.h>
4695 /* win32_ansipath() requires Windows 2000 or later */
4699 /* fetch Unicode version of PATH */
4701 wide_path = win32_malloc(len*sizeof(WCHAR));
4703 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4707 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4712 /* convert to ANSI pathnames */
4713 wide_dir = wide_path;
4716 WCHAR *sep = wcschr(wide_dir, ';');
4724 /* remove quotes around pathname */
4725 if (*wide_dir == '"')
4727 wide_len = wcslen(wide_dir);
4728 if (wide_len && wide_dir[wide_len-1] == '"')
4729 wide_dir[wide_len-1] = '\0';
4731 /* append ansi_dir to ansi_path */
4732 ansi_dir = win32_ansipath(wide_dir);
4733 ansi_len = strlen(ansi_dir);
4735 size_t newlen = len + 1 + ansi_len;
4736 ansi_path = win32_realloc(ansi_path, newlen+1);
4739 ansi_path[len] = ';';
4740 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4745 ansi_path = win32_malloc(5+len+1);
4748 memcpy(ansi_path, "PATH=", 5);
4749 memcpy(ansi_path+5, ansi_dir, len+1);
4752 win32_free(ansi_dir);
4757 /* Update C RTL environ array. This will only have full effect if
4758 * perl_parse() is later called with `environ` as the `env` argument.
4759 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4761 * We do have to ansify() the PATH before Perl has been fully
4762 * initialized because S_find_script() uses the PATH when perl
4763 * is being invoked with the -S option. This happens before %ENV
4764 * is initialized in S_init_postdump_symbols().
4766 * XXX Is this a bug? Should S_find_script() use the environment
4767 * XXX passed in the `env` arg to parse_perl()?
4770 /* Keep system environment in sync because S_init_postdump_symbols()
4771 * will not call mg_set() if it initializes %ENV from `environ`.
4773 SetEnvironmentVariableA("PATH", ansi_path+5);
4774 /* We are intentionally leaking the ansi_path string here because
4775 * the Borland runtime library puts it directly into the environ
4776 * array. The Microsoft runtime library seems to make a copy,
4777 * but will leak the copy should it be replaced again later.
4778 * Since this code is only called once during PERL_SYS_INIT this
4779 * shouldn't really matter.
4782 win32_free(wide_path);
4786 Perl_win32_init(int *argcp, char ***argvp)
4790 #ifdef SET_INVALID_PARAMETER_HANDLER
4791 _invalid_parameter_handler oldHandler, newHandler;
4792 newHandler = my_invalid_parameter_handler;
4793 oldHandler = _set_invalid_parameter_handler(newHandler);
4794 _CrtSetReportMode(_CRT_ASSERT, 0);
4796 /* Disable floating point errors, Perl will trap the ones we
4797 * care about. VC++ RTL defaults to switching these off
4798 * already, but the Borland RTL doesn't. Since we don't
4799 * want to be at the vendor's whim on the default, we set
4800 * it explicitly here.
4802 #if !defined(_ALPHA_) && !defined(__GNUC__)
4803 _control87(MCW_EM, MCW_EM);
4807 module = GetModuleHandle("ntdll.dll");
4809 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4812 module = GetModuleHandle("kernel32.dll");
4814 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4815 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4816 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4819 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4820 GetVersionEx(&g_osver);
4826 Perl_win32_term(void)
4836 win32_get_child_IO(child_IO_table* ptbl)
4838 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4839 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4840 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4844 win32_signal(int sig, Sighandler_t subcode)
4847 if (sig < SIG_SIZE) {
4848 int save_errno = errno;
4849 Sighandler_t result = signal(sig, subcode);
4850 if (result == SIG_ERR) {
4851 result = w32_sighandler[sig];
4854 w32_sighandler[sig] = subcode;
4863 /* The PerlMessageWindowClass's WindowProc */
4865 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4867 return win32_process_message(hwnd, msg, wParam, lParam) ?
4868 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4871 /* we use a message filter hook to process thread messages, passing any
4872 * messages that we don't process on to the rest of the hook chain
4873 * Anyone else writing a message loop that wants to play nicely with perl
4875 * CallMsgFilter(&msg, MSGF_***);
4876 * between their GetMessage and DispatchMessage calls. */
4878 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4879 LPMSG pmsg = (LPMSG)lParam;
4881 /* we'll process it if code says we're allowed, and it's a thread message */
4882 if (code >= 0 && pmsg->hwnd == NULL
4883 && win32_process_message(pmsg->hwnd, pmsg->message,
4884 pmsg->wParam, pmsg->lParam))
4889 /* XXX: MSDN says that hhk is ignored, but we should really use the
4890 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4891 return CallNextHookEx(NULL, code, wParam, lParam);
4894 /* The real message handler. Can be called with
4895 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4896 * that it processes */
4898 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4900 /* BEWARE. The context retrieved using dTHX; is the context of the
4901 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4902 * up to and including WM_CREATE. If it ever happens that you need the
4903 * 'child' context before this, then it needs to be passed into
4904 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4905 * from the lparam of CreateWindow(). It could then be stored/retrieved
4906 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4907 * the dTHX calls here. */
4908 /* XXX For now it is assumed that the overhead of the dTHX; for what
4909 * are relativley infrequent code-paths, is better than the added
4910 * complexity of getting the correct context passed into
4911 * win32_create_message_window() */
4916 case WM_USER_MESSAGE: {
4917 long child = find_pseudo_pid((int)wParam);
4920 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4927 case WM_USER_KILL: {
4929 /* We use WM_USER_KILL to fake kill() with other signals */
4930 int sig = (int)wParam;
4931 if (do_raise(aTHX_ sig))
4932 sig_terminate(aTHX_ sig);
4939 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4940 if (w32_timerid && w32_timerid==(UINT)wParam) {
4941 KillTimer(w32_message_hwnd, w32_timerid);
4944 /* Now fake a call to signal handler */
4945 if (do_raise(aTHX_ 14))
4946 sig_terminate(aTHX_ 14);
4958 /* Above or other stuff may have set a signal flag, and we may not have
4959 * been called from win32_async_check() (e.g. some other GUI's message
4960 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4961 * handler that die's, and the message loop that calls here is wrapped
4962 * in an eval, then you may well end up with orphaned windows - signals
4963 * are dispatched by win32_async_check() */
4969 win32_create_message_window_class(void)
4971 /* create the window class for "message only" windows */
4975 wc.lpfnWndProc = win32_message_window_proc;
4976 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4977 wc.lpszClassName = "PerlMessageWindowClass";
4979 /* second and subsequent calls will fail, but class
4980 * will already be registered */
4985 win32_create_message_window(void)
4989 /* "message-only" windows have been implemented in Windows 2000 and later.
4990 * On earlier versions we'll continue to post messages to a specific
4991 * thread and use hwnd==NULL. This is brittle when either an embedding
4992 * application or an XS module is also posting messages to hwnd=NULL
4993 * because once removed from the queue they cannot be delivered to the
4994 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4995 * if there is no window handle.
4997 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4998 * documentation to the contrary, however, there is some evidence that
4999 * there may be problems with the implementation on Win98. As it is not
5000 * officially supported we take the cautious route and stick with thread
5001 * messages (hwnd == NULL) on platforms prior to Win2k.
5004 win32_create_message_window_class();
5006 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
5007 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5010 /* If we din't create a window for any reason, then we'll use thread
5011 * messages for our signalling, so we install a hook which
5012 * is called by CallMsgFilter in win32_async_check(), or any other
5013 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5014 * that use OLE, etc. */
5016 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5017 NULL, GetCurrentThreadId());
5023 #ifdef HAVE_INTERP_INTERN
5026 win32_csighandler(int sig)
5029 dTHXa(PERL_GET_SIG_CONTEXT);
5030 Perl_warn(aTHX_ "Got signal %d",sig);
5035 #if defined(__MINGW32__) && defined(__cplusplus)
5036 #define CAST_HWND__(x) (HWND__*)(x)
5038 #define CAST_HWND__(x) x
5042 Perl_sys_intern_init(pTHX)
5046 w32_perlshell_tokens = NULL;
5047 w32_perlshell_vec = (char**)NULL;
5048 w32_perlshell_items = 0;
5049 w32_fdpid = newAV();
5050 Newx(w32_children, 1, child_tab);
5051 w32_num_children = 0;
5052 # ifdef USE_ITHREADS
5054 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5055 w32_num_pseudo_children = 0;
5058 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5060 for (i=0; i < SIG_SIZE; i++) {
5061 w32_sighandler[i] = SIG_DFL;
5063 # ifdef MULTIPLICITY
5064 if (my_perl == PL_curinterp) {
5068 /* Force C runtime signal stuff to set its console handler */
5069 signal(SIGINT,win32_csighandler);
5070 signal(SIGBREAK,win32_csighandler);
5072 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5073 * flag. This has the side-effect of disabling Ctrl-C events in all
5074 * processes in this group. At least on Windows NT and later we
5075 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5076 * with a NULL handler. This is not valid on Windows 9X.
5079 SetConsoleCtrlHandler(NULL,FALSE);
5081 /* Push our handler on top */
5082 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5087 Perl_sys_intern_clear(pTHX)
5089 Safefree(w32_perlshell_tokens);
5090 Safefree(w32_perlshell_vec);
5091 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5092 Safefree(w32_children);
5094 KillTimer(w32_message_hwnd, w32_timerid);
5097 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5098 DestroyWindow(w32_message_hwnd);
5099 # ifdef MULTIPLICITY
5100 if (my_perl == PL_curinterp) {
5104 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5106 # ifdef USE_ITHREADS
5107 Safefree(w32_pseudo_children);
5111 # ifdef USE_ITHREADS
5114 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5116 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5118 dst->perlshell_tokens = NULL;
5119 dst->perlshell_vec = (char**)NULL;
5120 dst->perlshell_items = 0;
5121 dst->fdpid = newAV();
5122 Newxz(dst->children, 1, child_tab);
5124 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5126 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5127 dst->poll_count = 0;
5128 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5130 # endif /* USE_ITHREADS */
5131 #endif /* HAVE_INTERP_INTERN */