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