3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
19 # define HWND_MESSAGE ((HWND)-3)
21 #ifndef WC_NO_BEST_FIT_CHARS
22 # define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */
29 #define SystemProcessesAndThreadsInformation 5
31 /* Inline some definitions from the DDK */
42 LARGE_INTEGER CreateTime;
43 LARGE_INTEGER UserTime;
44 LARGE_INTEGER KernelTime;
45 UNICODE_STRING ProcessName;
48 ULONG InheritedFromProcessId;
49 /* Remainder of the structure depends on the Windows version,
50 * but we don't need those additional fields anyways... */
53 /* #include "config.h" */
55 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
64 #define PERL_NO_GET_CONTEXT
70 /* assert.h conflicts with #define of assert in perl.h */
77 #if defined(_MSC_VER) || defined(__MINGW32__)
78 #include <sys/utime.h>
83 /* Mingw32 defaults to globing command line
84 * So we turn it off like this:
89 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
90 /* Mingw32-1.1 is missing some prototypes */
92 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
93 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
94 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
100 #if defined(__BORLANDC__)
102 # define _utimbuf utimbuf
106 #define EXECF_SPAWN 2
107 #define EXECF_SPAWN_NOWAIT 3
109 #if defined(PERL_IMPLICIT_SYS)
110 # undef win32_get_privlib
111 # define win32_get_privlib g_win32_get_privlib
112 # undef win32_get_sitelib
113 # define win32_get_sitelib g_win32_get_sitelib
114 # undef win32_get_vendorlib
115 # define win32_get_vendorlib g_win32_get_vendorlib
117 # define getlogin g_getlogin
120 static void get_shell(void);
121 static long tokenize(const char *str, char **dest, char ***destv);
122 static int do_spawn2(pTHX_ const char *cmd, int exectype);
123 static BOOL has_shell_metachars(const char *ptr);
124 static long filetime_to_clock(PFILETIME ft);
125 static BOOL filetime_from_time(PFILETIME ft, time_t t);
126 static char * get_emd_part(SV **leading, STRLEN *const len,
127 char *trailing, ...);
128 static void remove_dead_process(long deceased);
129 static long find_pid(int pid);
130 static char * qualified_path(const char *cmd);
131 static char * win32_get_xlib(const char *pl, const char *xlib,
132 const char *libname, STRLEN *const len);
133 static LRESULT win32_process_message(HWND hwnd, UINT msg,
134 WPARAM wParam, LPARAM lParam);
137 static void remove_dead_pseudo_process(long child);
138 static long find_pseudo_pid(int pid);
142 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
143 char w32_module_name[MAX_PATH+1];
146 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
148 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
149 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
150 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
151 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
154 /* Silence STDERR grumblings from Borland's math library. */
156 _matherr(struct _exception *a)
163 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
164 * parameter handler. This functionality is not available in the
165 * 64-bit compiler from the Platform SDK, which unfortunately also
166 * believes itself to be MSC version 14.
168 * There is no #define related to _set_invalid_parameter_handler(),
169 * but we can check for one of the constants defined for
170 * _set_abort_behavior(), which was introduced into stdlib.h at
174 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
175 # define SET_INVALID_PARAMETER_HANDLER
178 #ifdef SET_INVALID_PARAMETER_HANDLER
179 void my_invalid_parameter_handler(const wchar_t* expression,
180 const wchar_t* function,
186 wprintf(L"Invalid parameter detected in function %s."
187 L" File: %s Line: %d\n", function, file, line);
188 wprintf(L"Expression: %s\n", expression);
196 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
202 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
208 return (g_osver.dwMajorVersion > 4);
212 set_w32_module_name(void)
214 /* this function may be called at DLL_PROCESS_ATTACH time */
216 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
217 ? GetModuleHandle(NULL)
218 : w32_perldll_handle);
220 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
221 osver.dwOSVersionInfoSize = sizeof(osver);
222 GetVersionEx(&osver);
224 if (osver.dwMajorVersion > 4) {
225 WCHAR modulename[MAX_PATH];
226 WCHAR fullname[MAX_PATH];
229 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
231 /* Make sure we get an absolute pathname in case the module was loaded
232 * explicitly by LoadLibrary() with a relative path. */
233 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
235 /* remove \\?\ prefix */
236 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
237 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
239 ansi = win32_ansipath(fullname);
240 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
244 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
246 /* remove \\?\ prefix */
247 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
248 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
250 /* try to get full path to binary (which may be mangled when perl is
251 * run from a 16-bit app) */
252 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
253 win32_longpath(w32_module_name);
254 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
257 /* normalize to forward slashes */
258 ptr = w32_module_name;
266 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
268 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
270 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
273 const char *subkey = "Software\\Perl";
277 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
278 if (retval == ERROR_SUCCESS) {
280 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
281 if (retval == ERROR_SUCCESS
282 && (type == REG_SZ || type == REG_EXPAND_SZ))
286 *svp = sv_2mortal(newSVpvn("",0));
287 SvGROW(*svp, datalen);
288 retval = RegQueryValueEx(handle, valuename, 0, NULL,
289 (PBYTE)SvPVX(*svp), &datalen);
290 if (retval == ERROR_SUCCESS) {
292 SvCUR_set(*svp,datalen-1);
300 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
302 get_regstr(const char *valuename, SV **svp)
304 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
306 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
310 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
312 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
316 char mod_name[MAX_PATH+1];
322 va_start(ap, trailing_path);
323 strip = va_arg(ap, char *);
325 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
326 baselen = strlen(base);
328 if (!*w32_module_name) {
329 set_w32_module_name();
331 strcpy(mod_name, w32_module_name);
332 ptr = strrchr(mod_name, '/');
333 while (ptr && strip) {
334 /* look for directories to skip back */
337 ptr = strrchr(mod_name, '/');
338 /* avoid stripping component if there is no slash,
339 * or it doesn't match ... */
340 if (!ptr || stricmp(ptr+1, strip) != 0) {
341 /* ... but not if component matches m|5\.$patchlevel.*| */
342 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
343 && strncmp(strip, base, baselen) == 0
344 && strncmp(ptr+1, base, baselen) == 0))
350 strip = va_arg(ap, char *);
358 strcpy(++ptr, trailing_path);
360 /* only add directory if it exists */
361 if (GetFileAttributes(mod_name) != (DWORD) -1) {
362 /* directory exists */
365 *prev_pathp = sv_2mortal(newSVpvn("",0));
366 else if (SvPVX(*prev_pathp))
367 sv_catpvn(*prev_pathp, ";", 1);
368 sv_catpv(*prev_pathp, mod_name);
370 *len = SvCUR(*prev_pathp);
371 return SvPVX(*prev_pathp);
378 win32_get_privlib(const char *pl, STRLEN *const len)
381 char *stdlib = "lib";
382 char buffer[MAX_PATH+1];
385 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
386 sprintf(buffer, "%s-%s", stdlib, pl);
387 if (!get_regstr(buffer, &sv))
388 (void)get_regstr(stdlib, &sv);
390 /* $stdlib .= ";$EMD/../../lib" */
391 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
395 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
400 char pathstr[MAX_PATH+1];
404 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
405 sprintf(regstr, "%s-%s", xlib, pl);
406 (void)get_regstr(regstr, &sv1);
409 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
410 sprintf(pathstr, "%s/%s/lib", libname, pl);
411 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
413 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
414 (void)get_regstr(xlib, &sv2);
417 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
418 sprintf(pathstr, "%s/lib", libname);
419 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
426 sv_catpvn(sv1, ";", 1);
436 win32_get_sitelib(const char *pl, STRLEN *const len)
438 return win32_get_xlib(pl, "sitelib", "site", len);
441 #ifndef PERL_VENDORLIB_NAME
442 # define PERL_VENDORLIB_NAME "vendor"
446 win32_get_vendorlib(const char *pl, STRLEN *const len)
448 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
452 has_shell_metachars(const char *ptr)
458 * Scan string looking for redirection (< or >) or pipe
459 * characters (|) that are not in a quoted string.
460 * Shell variable interpolation (%VAR%) can also happen inside strings.
492 #if !defined(PERL_IMPLICIT_SYS)
493 /* since the current process environment is being updated in util.c
494 * the library functions will get the correct environment
497 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
500 #define fixcmd(x) { \
501 char *pspace = strchr((x),' '); \
504 while (p < pspace) { \
515 PERL_FLUSHALL_FOR_CHILD;
516 return win32_popen(cmd, mode);
520 Perl_my_pclose(pTHX_ PerlIO *fp)
522 return win32_pclose(fp);
526 DllExport unsigned long
529 return (unsigned long)g_osver.dwPlatformId;
539 return -((int)w32_pseudo_id);
542 /* Windows 9x appears to always reports a pid for threads and processes
543 * that has the high bit set. So we treat the lower 31 bits as the
544 * "real" PID for Perl's purposes. */
545 if (IsWin95() && pid < 0)
550 /* Tokenize a string. Words are null-separated, and the list
551 * ends with a doubled null. Any character (except null and
552 * including backslash) may be escaped by preceding it with a
553 * backslash (the backslash will be stripped).
554 * Returns number of words in result buffer.
557 tokenize(const char *str, char **dest, char ***destv)
559 char *retstart = NULL;
560 char **retvstart = 0;
564 int slen = strlen(str);
566 register char **retv;
567 Newx(ret, slen+2, char);
568 Newx(retv, (slen+3)/2, char*);
576 if (*ret == '\\' && *str)
578 else if (*ret == ' ') {
594 retvstart[items] = NULL;
607 if (!w32_perlshell_tokens) {
608 /* we don't use COMSPEC here for two reasons:
609 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
610 * uncontrolled unportability of the ensuing scripts.
611 * 2. PERL5SHELL could be set to a shell that may not be fit for
612 * interactive use (which is what most programs look in COMSPEC
615 const char* defaultshell = (IsWinNT()
616 ? "cmd.exe /x/d/c" : "command.com /c");
617 const char *usershell = PerlEnv_getenv("PERL5SHELL");
618 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
619 &w32_perlshell_tokens,
625 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
633 PERL_ARGS_ASSERT_DO_ASPAWN;
639 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
641 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
646 while (++mark <= sp) {
647 if (*mark && (str = SvPV_nolen(*mark)))
654 status = win32_spawnvp(flag,
655 (const char*)(really ? SvPV_nolen(really) : argv[0]),
656 (const char* const*)argv);
658 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
659 /* possible shell-builtin, invoke with shell */
661 sh_items = w32_perlshell_items;
663 argv[index+sh_items] = argv[index];
664 while (--sh_items >= 0)
665 argv[sh_items] = w32_perlshell_vec[sh_items];
667 status = win32_spawnvp(flag,
668 (const char*)(really ? SvPV_nolen(really) : argv[0]),
669 (const char* const*)argv);
672 if (flag == P_NOWAIT) {
673 PL_statusvalue = -1; /* >16bits hint for pp_system() */
677 if (ckWARN(WARN_EXEC))
678 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
683 PL_statusvalue = status;
689 /* returns pointer to the next unquoted space or the end of the string */
691 find_next_space(const char *s)
693 bool in_quotes = FALSE;
695 /* ignore doubled backslashes, or backslash+quote */
696 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
699 /* keep track of when we're within quotes */
700 else if (*s == '"') {
702 in_quotes = !in_quotes;
704 /* break it up only at spaces that aren't in quotes */
705 else if (!in_quotes && isSPACE(*s))
714 do_spawn2(pTHX_ const char *cmd, int exectype)
720 BOOL needToTry = TRUE;
723 /* Save an extra exec if possible. See if there are shell
724 * metacharacters in it */
725 if (!has_shell_metachars(cmd)) {
726 Newx(argv, strlen(cmd) / 2 + 2, char*);
727 Newx(cmd2, strlen(cmd) + 1, char);
730 for (s = cmd2; *s;) {
731 while (*s && isSPACE(*s))
735 s = find_next_space(s);
743 status = win32_spawnvp(P_WAIT, argv[0],
744 (const char* const*)argv);
746 case EXECF_SPAWN_NOWAIT:
747 status = win32_spawnvp(P_NOWAIT, argv[0],
748 (const char* const*)argv);
751 status = win32_execvp(argv[0], (const char* const*)argv);
754 if (status != -1 || errno == 0)
764 Newx(argv, w32_perlshell_items + 2, char*);
765 while (++i < w32_perlshell_items)
766 argv[i] = w32_perlshell_vec[i];
767 argv[i++] = (char *)cmd;
771 status = win32_spawnvp(P_WAIT, argv[0],
772 (const char* const*)argv);
774 case EXECF_SPAWN_NOWAIT:
775 status = win32_spawnvp(P_NOWAIT, argv[0],
776 (const char* const*)argv);
779 status = win32_execvp(argv[0], (const char* const*)argv);
785 if (exectype == EXECF_SPAWN_NOWAIT) {
786 PL_statusvalue = -1; /* >16bits hint for pp_system() */
790 if (ckWARN(WARN_EXEC))
791 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
792 (exectype == EXECF_EXEC ? "exec" : "spawn"),
793 cmd, strerror(errno));
798 PL_statusvalue = status;
804 Perl_do_spawn(pTHX_ char *cmd)
806 PERL_ARGS_ASSERT_DO_SPAWN;
808 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
812 Perl_do_spawn_nowait(pTHX_ char *cmd)
814 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
816 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
820 Perl_do_exec(pTHX_ const char *cmd)
822 PERL_ARGS_ASSERT_DO_EXEC;
824 do_spawn2(aTHX_ cmd, EXECF_EXEC);
828 /* The idea here is to read all the directory names into a string table
829 * (separated by nulls) and when one of the other dir functions is called
830 * return the pointer to the current file name.
833 win32_opendir(const char *filename)
839 char scanname[MAX_PATH+3];
841 WIN32_FIND_DATAA aFindData;
842 WIN32_FIND_DATAW wFindData;
844 char buffer[MAX_PATH*2];
847 len = strlen(filename);
851 /* check to see if filename is a directory */
852 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
855 /* Get us a DIR structure */
858 /* Create the search pattern */
859 strcpy(scanname, filename);
861 /* bare drive name means look in cwd for drive */
862 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
863 scanname[len++] = '.';
864 scanname[len++] = '/';
866 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
867 scanname[len++] = '/';
869 scanname[len++] = '*';
870 scanname[len] = '\0';
872 /* do the FindFirstFile call */
874 WCHAR wscanname[sizeof(scanname)];
875 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
876 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
880 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
882 if (dirp->handle == INVALID_HANDLE_VALUE) {
883 DWORD err = GetLastError();
884 /* FindFirstFile() fails on empty drives! */
886 case ERROR_FILE_NOT_FOUND:
888 case ERROR_NO_MORE_FILES:
889 case ERROR_PATH_NOT_FOUND:
892 case ERROR_NOT_ENOUGH_MEMORY:
904 BOOL use_default = FALSE;
905 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
906 wFindData.cFileName, -1,
907 buffer, sizeof(buffer), NULL, &use_default);
908 if (use_default && *wFindData.cAlternateFileName) {
909 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
910 wFindData.cAlternateFileName, -1,
911 buffer, sizeof(buffer), NULL, NULL);
916 ptr = aFindData.cFileName;
918 /* now allocate the first part of the string table for
919 * the filenames that we find.
926 Newx(dirp->start, dirp->size, char);
927 strcpy(dirp->start, ptr);
929 dirp->end = dirp->curr = dirp->start;
935 /* Readdir just returns the current string pointer and bumps the
936 * string pointer to the nDllExport entry.
938 DllExport struct direct *
939 win32_readdir(DIR *dirp)
944 /* first set up the structure to return */
945 len = strlen(dirp->curr);
946 strcpy(dirp->dirstr.d_name, dirp->curr);
947 dirp->dirstr.d_namlen = len;
950 dirp->dirstr.d_ino = dirp->curr - dirp->start;
952 /* Now set up for the next call to readdir */
953 dirp->curr += len + 1;
954 if (dirp->curr >= dirp->end) {
957 WIN32_FIND_DATAA aFindData;
958 char buffer[MAX_PATH*2];
961 /* finding the next file that matches the wildcard
962 * (which should be all of them in this directory!).
965 WIN32_FIND_DATAW wFindData;
966 res = FindNextFileW(dirp->handle, &wFindData);
968 BOOL use_default = FALSE;
969 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
970 wFindData.cFileName, -1,
971 buffer, sizeof(buffer), NULL, &use_default);
972 if (use_default && *wFindData.cAlternateFileName) {
973 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
974 wFindData.cAlternateFileName, -1,
975 buffer, sizeof(buffer), NULL, NULL);
981 res = FindNextFileA(dirp->handle, &aFindData);
982 ptr = aFindData.cFileName;
985 long endpos = dirp->end - dirp->start;
986 long newsize = endpos + strlen(ptr) + 1;
987 /* bump the string table size by enough for the
988 * new name and its null terminator */
989 while (newsize > dirp->size) {
990 long curpos = dirp->curr - dirp->start;
992 Renew(dirp->start, dirp->size, char);
993 dirp->curr = dirp->start + curpos;
995 strcpy(dirp->start + endpos, ptr);
996 dirp->end = dirp->start + newsize;
1002 return &(dirp->dirstr);
1008 /* Telldir returns the current string pointer position */
1010 win32_telldir(DIR *dirp)
1012 return (dirp->curr - dirp->start);
1016 /* Seekdir moves the string pointer to a previously saved position
1017 * (returned by telldir).
1020 win32_seekdir(DIR *dirp, long loc)
1022 dirp->curr = dirp->start + loc;
1025 /* Rewinddir resets the string pointer to the start */
1027 win32_rewinddir(DIR *dirp)
1029 dirp->curr = dirp->start;
1032 /* free the memory allocated by opendir */
1034 win32_closedir(DIR *dirp)
1037 if (dirp->handle != INVALID_HANDLE_VALUE)
1038 FindClose(dirp->handle);
1039 Safefree(dirp->start);
1052 * Just pretend that everyone is a superuser. NT will let us know if
1053 * we don\'t really have permission to do something.
1056 #define ROOT_UID ((uid_t)0)
1057 #define ROOT_GID ((gid_t)0)
1086 return (auid == ROOT_UID ? 0 : -1);
1092 return (agid == ROOT_GID ? 0 : -1);
1099 char *buf = w32_getlogin_buffer;
1100 DWORD size = sizeof(w32_getlogin_buffer);
1101 if (GetUserName(buf,&size))
1107 chown(const char *path, uid_t owner, gid_t group)
1114 * XXX this needs strengthening (for PerlIO)
1117 int mkstemp(const char *path)
1120 char buf[MAX_PATH+1];
1124 if (i++ > 10) { /* give up */
1128 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1132 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1142 long child = w32_num_children;
1143 while (--child >= 0) {
1144 if ((int)w32_child_pids[child] == pid)
1151 remove_dead_process(long child)
1155 CloseHandle(w32_child_handles[child]);
1156 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1157 (w32_num_children-child-1), HANDLE);
1158 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1159 (w32_num_children-child-1), DWORD);
1166 find_pseudo_pid(int pid)
1169 long child = w32_num_pseudo_children;
1170 while (--child >= 0) {
1171 if ((int)w32_pseudo_child_pids[child] == pid)
1178 remove_dead_pseudo_process(long child)
1182 CloseHandle(w32_pseudo_child_handles[child]);
1183 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1184 (w32_num_pseudo_children-child-1), HANDLE);
1185 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1186 (w32_num_pseudo_children-child-1), DWORD);
1187 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1188 (w32_num_pseudo_children-child-1), HWND);
1189 w32_num_pseudo_children--;
1195 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1199 /* "Does process exist?" use of kill */
1202 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1207 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1210 default: /* For now be backwards compatible with perl 5.6 */
1212 /* Note that we will only be able to kill processes owned by the
1213 * current process owner, even when we are running as an administrator.
1214 * To kill processes of other owners we would need to set the
1215 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1217 if (TerminateProcess(process_handle, sig))
1224 /* Traverse process tree using ToolHelp functions */
1226 kill_process_tree_toolhelp(DWORD pid, int sig)
1228 HANDLE process_handle;
1229 HANDLE snapshot_handle;
1232 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1233 if (process_handle == NULL)
1236 killed += terminate_process(pid, process_handle, sig);
1238 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1239 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1240 PROCESSENTRY32 entry;
1242 entry.dwSize = sizeof(entry);
1243 if (pfnProcess32First(snapshot_handle, &entry)) {
1245 if (entry.th32ParentProcessID == pid)
1246 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1247 entry.dwSize = sizeof(entry);
1249 while (pfnProcess32Next(snapshot_handle, &entry));
1251 CloseHandle(snapshot_handle);
1253 CloseHandle(process_handle);
1257 /* Traverse process tree using undocumented system information structures.
1258 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1261 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1263 HANDLE process_handle;
1264 SYSTEM_PROCESSES *p = process_info;
1267 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1268 if (process_handle == NULL)
1271 killed += terminate_process(pid, process_handle, sig);
1274 if (p->InheritedFromProcessId == (DWORD)pid)
1275 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1277 if (p->NextEntryDelta == 0)
1280 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1283 CloseHandle(process_handle);
1288 killpg(int pid, int sig)
1290 /* Use "documented" method whenever available */
1291 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1292 return kill_process_tree_toolhelp((DWORD)pid, sig);
1295 /* Fall back to undocumented Windows internals on Windows NT */
1296 if (pfnZwQuerySystemInformation) {
1301 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1302 Newx(buffer, size, char);
1304 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1305 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1314 my_kill(int pid, int sig)
1317 HANDLE process_handle;
1320 return killpg(pid, -sig);
1322 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1323 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1324 if (process_handle != NULL) {
1325 retval = terminate_process(pid, process_handle, sig);
1326 CloseHandle(process_handle);
1332 win32_kill(int pid, int sig)
1338 /* it is a pseudo-forked child */
1339 child = find_pseudo_pid(-pid);
1341 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1342 HANDLE hProcess = w32_pseudo_child_handles[child];
1345 /* "Does process exist?" use of kill */
1349 /* kill -9 style un-graceful exit */
1350 if (TerminateThread(hProcess, sig)) {
1351 remove_dead_pseudo_process(child);
1358 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1359 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1360 /* Yield and wait for the other thread to send us its message_hwnd */
1362 win32_async_check(aTHX);
1363 hwnd = w32_pseudo_child_message_hwnds[child];
1366 if (hwnd != INVALID_HANDLE_VALUE) {
1367 /* We fake signals to pseudo-processes using Win32
1368 * message queue. In Win9X the pids are negative already. */
1369 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1370 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1372 /* It might be us ... */
1381 else if (IsWin95()) {
1389 child = find_pid(pid);
1391 if (my_kill(pid, sig)) {
1393 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1394 exitcode != STILL_ACTIVE)
1396 remove_dead_process(child);
1403 if (my_kill((IsWin95() ? -pid : pid), sig))
1412 win32_stat(const char *path, Stat_t *sbuf)
1415 char buffer[MAX_PATH+1];
1416 int l = strlen(path);
1419 BOOL expect_dir = FALSE;
1421 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1422 GV_NOTQUAL, SVt_PV);
1423 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1426 switch(path[l - 1]) {
1427 /* FindFirstFile() and stat() are buggy with a trailing
1428 * slashes, except for the root directory of a drive */
1431 if (l > sizeof(buffer)) {
1432 errno = ENAMETOOLONG;
1436 strncpy(buffer, path, l);
1437 /* remove additional trailing slashes */
1438 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1440 /* add back slash if we otherwise end up with just a drive letter */
1441 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1448 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1450 if (l == 2 && isALPHA(path[0])) {
1451 buffer[0] = path[0];
1462 path = PerlDir_mapA(path);
1466 /* We must open & close the file once; otherwise file attribute changes */
1467 /* might not yet have propagated to "other" hard links of the same file. */
1468 /* This also gives us an opportunity to determine the number of links. */
1469 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1470 if (handle != INVALID_HANDLE_VALUE) {
1471 BY_HANDLE_FILE_INFORMATION bhi;
1472 if (GetFileInformationByHandle(handle, &bhi))
1473 nlink = bhi.nNumberOfLinks;
1474 CloseHandle(handle);
1478 /* path will be mapped correctly above */
1479 #if defined(WIN64) || defined(USE_LARGE_FILES)
1480 res = _stati64(path, sbuf);
1482 res = stat(path, sbuf);
1484 sbuf->st_nlink = nlink;
1487 /* CRT is buggy on sharenames, so make sure it really isn't.
1488 * XXX using GetFileAttributesEx() will enable us to set
1489 * sbuf->st_*time (but note that's not available on the
1490 * Windows of 1995) */
1491 DWORD r = GetFileAttributesA(path);
1492 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1493 /* sbuf may still contain old garbage since stat() failed */
1494 Zero(sbuf, 1, Stat_t);
1495 sbuf->st_mode = S_IFDIR | S_IREAD;
1497 if (!(r & FILE_ATTRIBUTE_READONLY))
1498 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1503 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1504 && (path[2] == '\\' || path[2] == '/'))
1506 /* The drive can be inaccessible, some _stat()s are buggy */
1507 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1512 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1516 if (S_ISDIR(sbuf->st_mode)) {
1517 /* Ensure the "write" bit is switched off in the mode for
1518 * directories with the read-only attribute set. Borland (at least)
1519 * switches it on for directories, which is technically correct
1520 * (directories are indeed always writable unless denied by DACLs),
1521 * but we want stat() and -w to reflect the state of the read-only
1522 * attribute for symmetry with chmod(). */
1523 DWORD r = GetFileAttributesA(path);
1524 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1525 sbuf->st_mode &= ~S_IWRITE;
1529 if (S_ISDIR(sbuf->st_mode)) {
1530 sbuf->st_mode |= S_IEXEC;
1532 else if (S_ISREG(sbuf->st_mode)) {
1534 if (l >= 4 && path[l-4] == '.') {
1535 const char *e = path + l - 3;
1536 if (strnicmp(e,"exe",3)
1537 && strnicmp(e,"bat",3)
1538 && strnicmp(e,"com",3)
1539 && (IsWin95() || strnicmp(e,"cmd",3)))
1540 sbuf->st_mode &= ~S_IEXEC;
1542 sbuf->st_mode |= S_IEXEC;
1545 sbuf->st_mode &= ~S_IEXEC;
1546 /* Propagate permissions to _group_ and _others_ */
1547 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1548 sbuf->st_mode |= (perms>>3) | (perms>>6);
1555 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1556 #define SKIP_SLASHES(s) \
1558 while (*(s) && isSLASH(*(s))) \
1561 #define COPY_NONSLASHES(d,s) \
1563 while (*(s) && !isSLASH(*(s))) \
1567 /* Find the longname of a given path. path is destructively modified.
1568 * It should have space for at least MAX_PATH characters. */
1570 win32_longpath(char *path)
1572 WIN32_FIND_DATA fdata;
1574 char tmpbuf[MAX_PATH+1];
1575 char *tmpstart = tmpbuf;
1582 if (isALPHA(path[0]) && path[1] == ':') {
1584 *tmpstart++ = path[0];
1588 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1590 *tmpstart++ = path[0];
1591 *tmpstart++ = path[1];
1592 SKIP_SLASHES(start);
1593 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1595 *tmpstart++ = *start++;
1596 SKIP_SLASHES(start);
1597 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1602 /* copy initial slash, if any */
1603 if (isSLASH(*start)) {
1604 *tmpstart++ = *start++;
1606 SKIP_SLASHES(start);
1609 /* FindFirstFile() expands "." and "..", so we need to pass
1610 * those through unmolested */
1612 && (!start[1] || isSLASH(start[1])
1613 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1615 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1620 /* if this is the end, bust outta here */
1624 /* now we're at a non-slash; walk up to next slash */
1625 while (*start && !isSLASH(*start))
1628 /* stop and find full name of component */
1631 fhand = FindFirstFile(path,&fdata);
1633 if (fhand != INVALID_HANDLE_VALUE) {
1634 STRLEN len = strlen(fdata.cFileName);
1635 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1636 strcpy(tmpstart, fdata.cFileName);
1647 /* failed a step, just return without side effects */
1648 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1653 strcpy(path,tmpbuf);
1662 /* Can't use PerlIO to write as it allocates memory */
1663 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1664 PL_no_mem, strlen(PL_no_mem));
1670 /* The win32_ansipath() function takes a Unicode filename and converts it
1671 * into the current Windows codepage. If some characters cannot be mapped,
1672 * then it will convert the short name instead.
1674 * The buffer to the ansi pathname must be freed with win32_free() when it
1675 * it no longer needed.
1677 * The argument to win32_ansipath() must exist before this function is
1678 * called; otherwise there is no way to determine the short path name.
1680 * Ideas for future refinement:
1681 * - Only convert those segments of the path that are not in the current
1682 * codepage, but leave the other segments in their long form.
1683 * - If the resulting name is longer than MAX_PATH, start converting
1684 * additional path segments into short names until the full name
1685 * is shorter than MAX_PATH. Shorten the filename part last!
1688 win32_ansipath(const WCHAR *widename)
1691 BOOL use_default = FALSE;
1692 size_t widelen = wcslen(widename)+1;
1693 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1694 NULL, 0, NULL, NULL);
1695 name = win32_malloc(len);
1699 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1700 name, len, NULL, &use_default);
1702 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1704 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1707 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1709 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1710 NULL, 0, NULL, NULL);
1711 name = win32_realloc(name, len);
1714 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1715 name, len, NULL, NULL);
1716 win32_free(shortname);
1723 win32_getenv(const char *name)
1729 needlen = GetEnvironmentVariableA(name,NULL,0);
1731 curitem = sv_2mortal(newSVpvn("", 0));
1733 SvGROW(curitem, needlen+1);
1734 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1736 } while (needlen >= SvLEN(curitem));
1737 SvCUR_set(curitem, needlen);
1740 /* allow any environment variables that begin with 'PERL'
1741 to be stored in the registry */
1742 if (strncmp(name, "PERL", 4) == 0)
1743 (void)get_regstr(name, &curitem);
1745 if (curitem && SvCUR(curitem))
1746 return SvPVX(curitem);
1752 win32_putenv(const char *name)
1760 Newx(curitem,strlen(name)+1,char);
1761 strcpy(curitem, name);
1762 val = strchr(curitem, '=');
1764 /* The sane way to deal with the environment.
1765 * Has these advantages over putenv() & co.:
1766 * * enables us to store a truly empty value in the
1767 * environment (like in UNIX).
1768 * * we don't have to deal with RTL globals, bugs and leaks.
1770 * Why you may want to enable USE_WIN32_RTL_ENV:
1771 * * environ[] and RTL functions will not reflect changes,
1772 * which might be an issue if extensions want to access
1773 * the env. via RTL. This cuts both ways, since RTL will
1774 * not see changes made by extensions that call the Win32
1775 * functions directly, either.
1779 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1788 filetime_to_clock(PFILETIME ft)
1790 __int64 qw = ft->dwHighDateTime;
1792 qw |= ft->dwLowDateTime;
1793 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1798 win32_times(struct tms *timebuf)
1803 clock_t process_time_so_far = clock();
1804 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1806 timebuf->tms_utime = filetime_to_clock(&user);
1807 timebuf->tms_stime = filetime_to_clock(&kernel);
1808 timebuf->tms_cutime = 0;
1809 timebuf->tms_cstime = 0;
1811 /* That failed - e.g. Win95 fallback to clock() */
1812 timebuf->tms_utime = process_time_so_far;
1813 timebuf->tms_stime = 0;
1814 timebuf->tms_cutime = 0;
1815 timebuf->tms_cstime = 0;
1817 return process_time_so_far;
1820 /* fix utime() so it works on directories in NT */
1822 filetime_from_time(PFILETIME pFileTime, time_t Time)
1824 struct tm *pTM = localtime(&Time);
1825 SYSTEMTIME SystemTime;
1831 SystemTime.wYear = pTM->tm_year + 1900;
1832 SystemTime.wMonth = pTM->tm_mon + 1;
1833 SystemTime.wDay = pTM->tm_mday;
1834 SystemTime.wHour = pTM->tm_hour;
1835 SystemTime.wMinute = pTM->tm_min;
1836 SystemTime.wSecond = pTM->tm_sec;
1837 SystemTime.wMilliseconds = 0;
1839 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1840 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1844 win32_unlink(const char *filename)
1850 filename = PerlDir_mapA(filename);
1851 attrs = GetFileAttributesA(filename);
1852 if (attrs == 0xFFFFFFFF) {
1856 if (attrs & FILE_ATTRIBUTE_READONLY) {
1857 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1858 ret = unlink(filename);
1860 (void)SetFileAttributesA(filename, attrs);
1863 ret = unlink(filename);
1868 win32_utime(const char *filename, struct utimbuf *times)
1875 struct utimbuf TimeBuffer;
1878 filename = PerlDir_mapA(filename);
1879 rc = utime(filename, times);
1881 /* EACCES: path specifies directory or readonly file */
1882 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1885 if (times == NULL) {
1886 times = &TimeBuffer;
1887 time(×->actime);
1888 times->modtime = times->actime;
1891 /* This will (and should) still fail on readonly files */
1892 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1893 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1894 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1895 if (handle == INVALID_HANDLE_VALUE)
1898 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1899 filetime_from_time(&ftAccess, times->actime) &&
1900 filetime_from_time(&ftWrite, times->modtime) &&
1901 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1906 CloseHandle(handle);
1911 unsigned __int64 ft_i64;
1916 #define Const64(x) x##LL
1918 #define Const64(x) x##i64
1920 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1921 #define EPOCH_BIAS Const64(116444736000000000)
1923 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1924 * and appears to be unsupported even by glibc) */
1926 win32_gettimeofday(struct timeval *tp, void *not_used)
1930 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1931 GetSystemTimeAsFileTime(&ft.ft_val);
1933 /* seconds since epoch */
1934 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1936 /* microseconds remaining */
1937 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1943 win32_uname(struct utsname *name)
1945 struct hostent *hep;
1946 STRLEN nodemax = sizeof(name->nodename)-1;
1949 switch (g_osver.dwPlatformId) {
1950 case VER_PLATFORM_WIN32_WINDOWS:
1951 strcpy(name->sysname, "Windows");
1953 case VER_PLATFORM_WIN32_NT:
1954 strcpy(name->sysname, "Windows NT");
1956 case VER_PLATFORM_WIN32s:
1957 strcpy(name->sysname, "Win32s");
1960 strcpy(name->sysname, "Win32 Unknown");
1965 sprintf(name->release, "%d.%d",
1966 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1969 sprintf(name->version, "Build %d",
1970 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1971 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1972 if (g_osver.szCSDVersion[0]) {
1973 char *buf = name->version + strlen(name->version);
1974 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1978 hep = win32_gethostbyname("localhost");
1980 STRLEN len = strlen(hep->h_name);
1981 if (len <= nodemax) {
1982 strcpy(name->nodename, hep->h_name);
1985 strncpy(name->nodename, hep->h_name, nodemax);
1986 name->nodename[nodemax] = '\0';
1991 if (!GetComputerName(name->nodename, &sz))
1992 *name->nodename = '\0';
1995 /* machine (architecture) */
2000 GetSystemInfo(&info);
2002 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2003 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2004 procarch = info.u.s.wProcessorArchitecture;
2006 procarch = info.wProcessorArchitecture;
2009 case PROCESSOR_ARCHITECTURE_INTEL:
2010 arch = "x86"; break;
2011 case PROCESSOR_ARCHITECTURE_MIPS:
2012 arch = "mips"; break;
2013 case PROCESSOR_ARCHITECTURE_ALPHA:
2014 arch = "alpha"; break;
2015 case PROCESSOR_ARCHITECTURE_PPC:
2016 arch = "ppc"; break;
2017 #ifdef PROCESSOR_ARCHITECTURE_SHX
2018 case PROCESSOR_ARCHITECTURE_SHX:
2019 arch = "shx"; break;
2021 #ifdef PROCESSOR_ARCHITECTURE_ARM
2022 case PROCESSOR_ARCHITECTURE_ARM:
2023 arch = "arm"; break;
2025 #ifdef PROCESSOR_ARCHITECTURE_IA64
2026 case PROCESSOR_ARCHITECTURE_IA64:
2027 arch = "ia64"; break;
2029 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2030 case PROCESSOR_ARCHITECTURE_ALPHA64:
2031 arch = "alpha64"; break;
2033 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2034 case PROCESSOR_ARCHITECTURE_MSIL:
2035 arch = "msil"; break;
2037 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2038 case PROCESSOR_ARCHITECTURE_AMD64:
2039 arch = "amd64"; break;
2041 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2042 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2043 arch = "ia32-64"; break;
2045 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2046 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2047 arch = "unknown"; break;
2050 sprintf(name->machine, "unknown(0x%x)", procarch);
2051 arch = name->machine;
2054 if (name->machine != arch)
2055 strcpy(name->machine, arch);
2060 /* Timing related stuff */
2063 do_raise(pTHX_ int sig)
2065 if (sig < SIG_SIZE) {
2066 Sighandler_t handler = w32_sighandler[sig];
2067 if (handler == SIG_IGN) {
2070 else if (handler != SIG_DFL) {
2075 /* Choose correct default behaviour */
2091 /* Tell caller to exit thread/process as approriate */
2096 sig_terminate(pTHX_ int sig)
2098 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2099 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2106 win32_async_check(pTHX)
2109 HWND hwnd = w32_message_hwnd;
2111 /* Reset w32_poll_count before doing anything else, incase we dispatch
2112 * messages that end up calling back into perl */
2115 if (hwnd != INVALID_HANDLE_VALUE) {
2116 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2117 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2122 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2123 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2125 /* re-post a WM_QUIT message (we'll mark it as read later) */
2126 if(msg.message == WM_QUIT) {
2127 PostQuitMessage((int)msg.wParam);
2131 if(!CallMsgFilter(&msg, MSGF_USER))
2133 TranslateMessage(&msg);
2134 DispatchMessage(&msg);
2139 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2140 * This is necessary when we are being called by win32_msgwait() to
2141 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2142 * message over and over. An example how this can happen is when
2143 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2144 * is generating messages before the process terminated.
2146 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2148 /* Above or other stuff may have set a signal flag */
2155 /* This function will not return until the timeout has elapsed, or until
2156 * one of the handles is ready. */
2158 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2160 /* We may need several goes at this - so compute when we stop */
2162 if (timeout != INFINITE) {
2163 ticks = GetTickCount();
2167 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2170 if (result == WAIT_TIMEOUT) {
2171 /* Ran out of time - explicit return of zero to avoid -ve if we
2172 have scheduling issues
2176 if (timeout != INFINITE) {
2177 ticks = GetTickCount();
2179 if (result == WAIT_OBJECT_0 + count) {
2180 /* Message has arrived - check it */
2181 (void)win32_async_check(aTHX);
2184 /* Not timeout or message - one of handles is ready */
2188 /* compute time left to wait */
2189 ticks = timeout - ticks;
2190 /* If we are past the end say zero */
2191 return (ticks > 0) ? ticks : 0;
2195 win32_internal_wait(int *status, DWORD timeout)
2197 /* XXX this wait emulation only knows about processes
2198 * spawned via win32_spawnvp(P_NOWAIT, ...).
2202 DWORD exitcode, waitcode;
2205 if (w32_num_pseudo_children) {
2206 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2207 timeout, &waitcode);
2208 /* Time out here if there are no other children to wait for. */
2209 if (waitcode == WAIT_TIMEOUT) {
2210 if (!w32_num_children) {
2214 else if (waitcode != WAIT_FAILED) {
2215 if (waitcode >= WAIT_ABANDONED_0
2216 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2217 i = waitcode - WAIT_ABANDONED_0;
2219 i = waitcode - WAIT_OBJECT_0;
2220 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2221 *status = (int)((exitcode & 0xff) << 8);
2222 retval = (int)w32_pseudo_child_pids[i];
2223 remove_dead_pseudo_process(i);
2230 if (!w32_num_children) {
2235 /* if a child exists, wait for it to die */
2236 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2237 if (waitcode == WAIT_TIMEOUT) {
2240 if (waitcode != WAIT_FAILED) {
2241 if (waitcode >= WAIT_ABANDONED_0
2242 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2243 i = waitcode - WAIT_ABANDONED_0;
2245 i = waitcode - WAIT_OBJECT_0;
2246 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2247 *status = (int)((exitcode & 0xff) << 8);
2248 retval = (int)w32_child_pids[i];
2249 remove_dead_process(i);
2254 errno = GetLastError();
2259 win32_waitpid(int pid, int *status, int flags)
2262 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2265 if (pid == -1) /* XXX threadid == 1 ? */
2266 return win32_internal_wait(status, timeout);
2269 child = find_pseudo_pid(-pid);
2271 HANDLE hThread = w32_pseudo_child_handles[child];
2273 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2274 if (waitcode == WAIT_TIMEOUT) {
2277 else if (waitcode == WAIT_OBJECT_0) {
2278 if (GetExitCodeThread(hThread, &waitcode)) {
2279 *status = (int)((waitcode & 0xff) << 8);
2280 retval = (int)w32_pseudo_child_pids[child];
2281 remove_dead_pseudo_process(child);
2288 else if (IsWin95()) {
2297 child = find_pid(pid);
2299 hProcess = w32_child_handles[child];
2300 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2301 if (waitcode == WAIT_TIMEOUT) {
2304 else if (waitcode == WAIT_OBJECT_0) {
2305 if (GetExitCodeProcess(hProcess, &waitcode)) {
2306 *status = (int)((waitcode & 0xff) << 8);
2307 retval = (int)w32_child_pids[child];
2308 remove_dead_process(child);
2317 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2318 (IsWin95() ? -pid : pid));
2320 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2321 if (waitcode == WAIT_TIMEOUT) {
2322 CloseHandle(hProcess);
2325 else if (waitcode == WAIT_OBJECT_0) {
2326 if (GetExitCodeProcess(hProcess, &waitcode)) {
2327 *status = (int)((waitcode & 0xff) << 8);
2328 CloseHandle(hProcess);
2332 CloseHandle(hProcess);
2338 return retval >= 0 ? pid : retval;
2342 win32_wait(int *status)
2344 return win32_internal_wait(status, INFINITE);
2347 DllExport unsigned int
2348 win32_sleep(unsigned int t)
2351 /* Win32 times are in ms so *1000 in and /1000 out */
2352 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2355 DllExport unsigned int
2356 win32_alarm(unsigned int sec)
2359 * the 'obvious' implentation is SetTimer() with a callback
2360 * which does whatever receiving SIGALRM would do
2361 * we cannot use SIGALRM even via raise() as it is not
2362 * one of the supported codes in <signal.h>
2366 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2367 w32_message_hwnd = win32_create_message_window();
2370 if (w32_message_hwnd == NULL)
2371 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2374 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2379 KillTimer(w32_message_hwnd, w32_timerid);
2386 #ifdef HAVE_DES_FCRYPT
2387 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2391 win32_crypt(const char *txt, const char *salt)
2394 #ifdef HAVE_DES_FCRYPT
2395 return des_fcrypt(txt, salt, w32_crypt_buffer);
2397 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2402 #ifdef USE_FIXED_OSFHANDLE
2404 #define FOPEN 0x01 /* file handle open */
2405 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2406 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2407 #define FDEV 0x40 /* file handle refers to device */
2408 #define FTEXT 0x80 /* file handle is in text mode */
2411 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2414 * This function allocates a free C Runtime file handle and associates
2415 * it with the Win32 HANDLE specified by the first parameter. This is a
2416 * temperary fix for WIN95's brain damage GetFileType() error on socket
2417 * we just bypass that call for socket
2419 * This works with MSVC++ 4.0+ or GCC/Mingw32
2422 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2423 * int flags - flags to associate with C Runtime file handle.
2426 * returns index of entry in fh, if successful
2427 * return -1, if no free entry is found
2431 *******************************************************************************/
2434 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2435 * this lets sockets work on Win9X with GCC and should fix the problems
2440 /* create an ioinfo entry, kill its handle, and steal the entry */
2445 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2446 int fh = _open_osfhandle((intptr_t)hF, 0);
2450 EnterCriticalSection(&(_pioinfo(fh)->lock));
2455 my_open_osfhandle(intptr_t osfhandle, int flags)
2458 char fileflags; /* _osfile flags */
2460 /* copy relevant flags from second parameter */
2463 if (flags & O_APPEND)
2464 fileflags |= FAPPEND;
2469 if (flags & O_NOINHERIT)
2470 fileflags |= FNOINHERIT;
2472 /* attempt to allocate a C Runtime file handle */
2473 if ((fh = _alloc_osfhnd()) == -1) {
2474 errno = EMFILE; /* too many open files */
2475 _doserrno = 0L; /* not an OS error */
2476 return -1; /* return error to caller */
2479 /* the file is open. now, set the info in _osfhnd array */
2480 _set_osfhnd(fh, osfhandle);
2482 fileflags |= FOPEN; /* mark as open */
2484 _osfile(fh) = fileflags; /* set osfile entry */
2485 LeaveCriticalSection(&_pioinfo(fh)->lock);
2487 return fh; /* return handle */
2490 #endif /* USE_FIXED_OSFHANDLE */
2492 /* simulate flock by locking a range on the file */
2494 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2495 #define LK_LEN 0xffff0000
2498 win32_flock(int fd, int oper)
2506 Perl_croak_nocontext("flock() unimplemented on this platform");
2509 fh = (HANDLE)_get_osfhandle(fd);
2510 memset(&o, 0, sizeof(o));
2513 case LOCK_SH: /* shared lock */
2514 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2516 case LOCK_EX: /* exclusive lock */
2517 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2519 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2520 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2522 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2523 LK_ERR(LockFileEx(fh,
2524 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2525 0, LK_LEN, 0, &o),i);
2527 case LOCK_UN: /* unlock lock */
2528 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2530 default: /* unknown */
2541 * redirected io subsystem for all XS modules
2554 return (&(_environ));
2557 /* the rest are the remapped stdio routines */
2577 win32_ferror(FILE *fp)
2579 return (ferror(fp));
2584 win32_feof(FILE *fp)
2590 * Since the errors returned by the socket error function
2591 * WSAGetLastError() are not known by the library routine strerror
2592 * we have to roll our own.
2596 win32_strerror(int e)
2598 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2599 extern int sys_nerr;
2603 if (e < 0 || e > sys_nerr) {
2608 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2609 w32_strerror_buffer,
2610 sizeof(w32_strerror_buffer), NULL) == 0)
2611 strcpy(w32_strerror_buffer, "Unknown Error");
2613 return w32_strerror_buffer;
2619 win32_str_os_error(void *sv, DWORD dwErr)
2623 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2624 |FORMAT_MESSAGE_IGNORE_INSERTS
2625 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2626 dwErr, 0, (char *)&sMsg, 1, NULL);
2627 /* strip trailing whitespace and period */
2630 --dwLen; /* dwLen doesn't include trailing null */
2631 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2632 if ('.' != sMsg[dwLen])
2637 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2639 dwLen = sprintf(sMsg,
2640 "Unknown error #0x%lX (lookup 0x%lX)",
2641 dwErr, GetLastError());
2645 sv_setpvn((SV*)sv, sMsg, dwLen);
2651 win32_fprintf(FILE *fp, const char *format, ...)
2654 va_start(marker, format); /* Initialize variable arguments. */
2656 return (vfprintf(fp, format, marker));
2660 win32_printf(const char *format, ...)
2663 va_start(marker, format); /* Initialize variable arguments. */
2665 return (vprintf(format, marker));
2669 win32_vfprintf(FILE *fp, const char *format, va_list args)
2671 return (vfprintf(fp, format, args));
2675 win32_vprintf(const char *format, va_list args)
2677 return (vprintf(format, args));
2681 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2683 return fread(buf, size, count, fp);
2687 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2689 return fwrite(buf, size, count, fp);
2692 #define MODE_SIZE 10
2695 win32_fopen(const char *filename, const char *mode)
2703 if (stricmp(filename, "/dev/null")==0)
2706 f = fopen(PerlDir_mapA(filename), mode);
2707 /* avoid buffering headaches for child processes */
2708 if (f && *mode == 'a')
2709 win32_fseek(f, 0, SEEK_END);
2713 #ifndef USE_SOCKETS_AS_HANDLES
2715 #define fdopen my_fdopen
2719 win32_fdopen(int handle, const char *mode)
2723 f = fdopen(handle, (char *) mode);
2724 /* avoid buffering headaches for child processes */
2725 if (f && *mode == 'a')
2726 win32_fseek(f, 0, SEEK_END);
2731 win32_freopen(const char *path, const char *mode, FILE *stream)
2734 if (stricmp(path, "/dev/null")==0)
2737 return freopen(PerlDir_mapA(path), mode, stream);
2741 win32_fclose(FILE *pf)
2743 return my_fclose(pf); /* defined in win32sck.c */
2747 win32_fputs(const char *s,FILE *pf)
2749 return fputs(s, pf);
2753 win32_fputc(int c,FILE *pf)
2759 win32_ungetc(int c,FILE *pf)
2761 return ungetc(c,pf);
2765 win32_getc(FILE *pf)
2771 win32_fileno(FILE *pf)
2777 win32_clearerr(FILE *pf)
2784 win32_fflush(FILE *pf)
2790 win32_ftell(FILE *pf)
2792 #if defined(WIN64) || defined(USE_LARGE_FILES)
2793 #if defined(__BORLANDC__) /* buk */
2794 return win32_tell( fileno( pf ) );
2797 if (fgetpos(pf, &pos))
2807 win32_fseek(FILE *pf, Off_t offset,int origin)
2809 #if defined(WIN64) || defined(USE_LARGE_FILES)
2810 #if defined(__BORLANDC__) /* buk */
2820 if (fgetpos(pf, &pos))
2825 fseek(pf, 0, SEEK_END);
2826 pos = _telli64(fileno(pf));
2835 return fsetpos(pf, &offset);
2838 return fseek(pf, (long)offset, origin);
2843 win32_fgetpos(FILE *pf,fpos_t *p)
2845 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2846 if( win32_tell(fileno(pf)) == -1L ) {
2852 return fgetpos(pf, p);
2857 win32_fsetpos(FILE *pf,const fpos_t *p)
2859 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2860 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2862 return fsetpos(pf, p);
2867 win32_rewind(FILE *pf)
2877 char prefix[MAX_PATH+1];
2878 char filename[MAX_PATH+1];
2879 DWORD len = GetTempPath(MAX_PATH, prefix);
2880 if (len && len < MAX_PATH) {
2881 if (GetTempFileName(prefix, "plx", 0, filename)) {
2882 HANDLE fh = CreateFile(filename,
2883 DELETE | GENERIC_READ | GENERIC_WRITE,
2887 FILE_ATTRIBUTE_NORMAL
2888 | FILE_FLAG_DELETE_ON_CLOSE,
2890 if (fh != INVALID_HANDLE_VALUE) {
2891 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2893 #if defined(__BORLANDC__)
2894 setmode(fd,O_BINARY);
2896 DEBUG_p(PerlIO_printf(Perl_debug_log,
2897 "Created tmpfile=%s\n",filename));
2909 int fd = win32_tmpfd();
2911 return win32_fdopen(fd, "w+b");
2923 win32_fstat(int fd, Stat_t *sbufptr)
2926 /* A file designated by filehandle is not shown as accessible
2927 * for write operations, probably because it is opened for reading.
2930 BY_HANDLE_FILE_INFORMATION bhfi;
2931 #if defined(WIN64) || defined(USE_LARGE_FILES)
2932 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2934 int rc = fstat(fd,&tmp);
2936 sbufptr->st_dev = tmp.st_dev;
2937 sbufptr->st_ino = tmp.st_ino;
2938 sbufptr->st_mode = tmp.st_mode;
2939 sbufptr->st_nlink = tmp.st_nlink;
2940 sbufptr->st_uid = tmp.st_uid;
2941 sbufptr->st_gid = tmp.st_gid;
2942 sbufptr->st_rdev = tmp.st_rdev;
2943 sbufptr->st_size = tmp.st_size;
2944 sbufptr->st_atime = tmp.st_atime;
2945 sbufptr->st_mtime = tmp.st_mtime;
2946 sbufptr->st_ctime = tmp.st_ctime;
2948 int rc = fstat(fd,sbufptr);
2951 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2952 #if defined(WIN64) || defined(USE_LARGE_FILES)
2953 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2955 sbufptr->st_mode &= 0xFE00;
2956 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2957 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2959 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2960 + ((S_IREAD|S_IWRITE) >> 6));
2964 return my_fstat(fd,sbufptr);
2969 win32_pipe(int *pfd, unsigned int size, int mode)
2971 return _pipe(pfd, size, mode);
2975 win32_popenlist(const char *mode, IV narg, SV **args)
2978 Perl_croak(aTHX_ "List form of pipe open not implemented");
2983 * a popen() clone that respects PERL5SHELL
2985 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2989 win32_popen(const char *command, const char *mode)
2991 #ifdef USE_RTL_POPEN
2992 return _popen(command, mode);
3004 /* establish which ends read and write */
3005 if (strchr(mode,'w')) {
3006 stdfd = 0; /* stdin */
3009 nhandle = STD_INPUT_HANDLE;
3011 else if (strchr(mode,'r')) {
3012 stdfd = 1; /* stdout */
3015 nhandle = STD_OUTPUT_HANDLE;
3020 /* set the correct mode */
3021 if (strchr(mode,'b'))
3023 else if (strchr(mode,'t'))
3026 ourmode = _fmode & (O_TEXT | O_BINARY);
3028 /* the child doesn't inherit handles */
3029 ourmode |= O_NOINHERIT;
3031 if (win32_pipe(p, 512, ourmode) == -1)
3034 /* save the old std handle (this needs to happen before the
3035 * dup2(), since that might call SetStdHandle() too) */
3038 old_h = GetStdHandle(nhandle);
3040 /* save current stdfd */
3041 if ((oldfd = win32_dup(stdfd)) == -1)
3044 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3045 /* stdfd will be inherited by the child */
3046 if (win32_dup2(p[child], stdfd) == -1)
3049 /* close the child end in parent */
3050 win32_close(p[child]);
3052 /* set the new std handle (in case dup2() above didn't) */
3053 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3055 /* start the child */
3058 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3061 /* revert stdfd to whatever it was before */
3062 if (win32_dup2(oldfd, stdfd) == -1)
3065 /* close saved handle */
3068 /* restore the old std handle (this needs to happen after the
3069 * dup2(), since that might call SetStdHandle() too */
3071 SetStdHandle(nhandle, old_h);
3077 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3080 /* set process id so that it can be returned by perl's open() */
3081 PL_forkprocess = childpid;
3084 /* we have an fd, return a file stream */
3085 return (PerlIO_fdopen(p[parent], (char *)mode));
3088 /* we don't need to check for errors here */
3092 win32_dup2(oldfd, stdfd);
3096 SetStdHandle(nhandle, old_h);
3102 #endif /* USE_RTL_POPEN */
3110 win32_pclose(PerlIO *pf)
3112 #ifdef USE_RTL_POPEN
3116 int childpid, status;
3120 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3123 childpid = SvIVX(sv);
3141 if (win32_waitpid(childpid, &status, 0) == -1)
3146 #endif /* USE_RTL_POPEN */
3152 LPCWSTR lpExistingFileName,
3153 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3156 WCHAR wFullName[MAX_PATH+1];
3157 LPVOID lpContext = NULL;
3158 WIN32_STREAM_ID StreamId;
3159 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3164 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3165 BOOL, BOOL, LPVOID*) =
3166 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3167 BOOL, BOOL, LPVOID*))
3168 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3169 if (pfnBackupWrite == NULL)
3172 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3175 dwLen = (dwLen+1)*sizeof(WCHAR);
3177 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3178 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3179 NULL, OPEN_EXISTING, 0, NULL);
3180 if (handle == INVALID_HANDLE_VALUE)
3183 StreamId.dwStreamId = BACKUP_LINK;
3184 StreamId.dwStreamAttributes = 0;
3185 StreamId.dwStreamNameSize = 0;
3186 #if defined(__BORLANDC__) \
3187 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3188 StreamId.Size.u.HighPart = 0;
3189 StreamId.Size.u.LowPart = dwLen;
3191 StreamId.Size.HighPart = 0;
3192 StreamId.Size.LowPart = dwLen;
3195 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3196 FALSE, FALSE, &lpContext);
3198 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3199 FALSE, FALSE, &lpContext);
3200 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3203 CloseHandle(handle);
3208 win32_link(const char *oldname, const char *newname)
3211 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3212 WCHAR wOldName[MAX_PATH+1];
3213 WCHAR wNewName[MAX_PATH+1];
3216 Perl_croak(aTHX_ PL_no_func, "link");
3218 pfnCreateHardLinkW =
3219 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3220 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3221 if (pfnCreateHardLinkW == NULL)
3222 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3224 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3225 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3226 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3227 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3231 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3236 win32_rename(const char *oname, const char *newname)
3238 char szOldName[MAX_PATH+1];
3239 char szNewName[MAX_PATH+1];
3243 /* XXX despite what the documentation says about MoveFileEx(),
3244 * it doesn't work under Windows95!
3247 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3248 if (stricmp(newname, oname))
3249 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3250 strcpy(szOldName, PerlDir_mapA(oname));
3251 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3253 DWORD err = GetLastError();
3255 case ERROR_BAD_NET_NAME:
3256 case ERROR_BAD_NETPATH:
3257 case ERROR_BAD_PATHNAME:
3258 case ERROR_FILE_NOT_FOUND:
3259 case ERROR_FILENAME_EXCED_RANGE:
3260 case ERROR_INVALID_DRIVE:
3261 case ERROR_NO_MORE_FILES:
3262 case ERROR_PATH_NOT_FOUND:
3275 char szTmpName[MAX_PATH+1];
3276 char dname[MAX_PATH+1];
3277 char *endname = NULL;
3279 DWORD from_attr, to_attr;
3281 strcpy(szOldName, PerlDir_mapA(oname));
3282 strcpy(szNewName, PerlDir_mapA(newname));
3284 /* if oname doesn't exist, do nothing */
3285 from_attr = GetFileAttributes(szOldName);
3286 if (from_attr == 0xFFFFFFFF) {
3291 /* if newname exists, rename it to a temporary name so that we
3292 * don't delete it in case oname happens to be the same file
3293 * (but perhaps accessed via a different path)
3295 to_attr = GetFileAttributes(szNewName);
3296 if (to_attr != 0xFFFFFFFF) {
3297 /* if newname is a directory, we fail
3298 * XXX could overcome this with yet more convoluted logic */
3299 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3303 tmplen = strlen(szNewName);
3304 strcpy(szTmpName,szNewName);
3305 endname = szTmpName+tmplen;
3306 for (; endname > szTmpName ; --endname) {
3307 if (*endname == '/' || *endname == '\\') {
3312 if (endname > szTmpName)
3313 endname = strcpy(dname,szTmpName);
3317 /* get a temporary filename in same directory
3318 * XXX is this really the best we can do? */
3319 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3323 DeleteFile(szTmpName);
3325 retval = rename(szNewName, szTmpName);
3332 /* rename oname to newname */
3333 retval = rename(szOldName, szNewName);
3335 /* if we created a temporary file before ... */
3336 if (endname != NULL) {
3337 /* ...and rename succeeded, delete temporary file/directory */
3339 DeleteFile(szTmpName);
3340 /* else restore it to what it was */
3342 (void)rename(szTmpName, szNewName);
3349 win32_setmode(int fd, int mode)
3351 return setmode(fd, mode);
3355 win32_chsize(int fd, Off_t size)
3357 #if defined(WIN64) || defined(USE_LARGE_FILES)
3359 Off_t cur, end, extend;
3361 cur = win32_tell(fd);
3364 end = win32_lseek(fd, 0, SEEK_END);
3367 extend = size - end;
3371 else if (extend > 0) {
3372 /* must grow the file, padding with nulls */
3374 int oldmode = win32_setmode(fd, O_BINARY);
3376 memset(b, '\0', sizeof(b));
3378 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3379 count = win32_write(fd, b, count);
3380 if ((int)count < 0) {
3384 } while ((extend -= count) > 0);
3385 win32_setmode(fd, oldmode);
3388 /* shrink the file */
3389 win32_lseek(fd, size, SEEK_SET);
3390 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3396 win32_lseek(fd, cur, SEEK_SET);
3399 return chsize(fd, (long)size);
3404 win32_lseek(int fd, Off_t offset, int origin)
3406 #if defined(WIN64) || defined(USE_LARGE_FILES)
3407 #if defined(__BORLANDC__) /* buk */
3409 pos.QuadPart = offset;
3410 pos.LowPart = SetFilePointer(
3411 (HANDLE)_get_osfhandle(fd),
3416 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3420 return pos.QuadPart;
3422 return _lseeki64(fd, offset, origin);
3425 return lseek(fd, (long)offset, origin);
3432 #if defined(WIN64) || defined(USE_LARGE_FILES)
3433 #if defined(__BORLANDC__) /* buk */
3436 pos.LowPart = SetFilePointer(
3437 (HANDLE)_get_osfhandle(fd),
3442 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3446 return pos.QuadPart;
3447 /* return tell(fd); */
3449 return _telli64(fd);
3457 win32_open(const char *path, int flag, ...)
3464 pmode = va_arg(ap, int);
3467 if (stricmp(path, "/dev/null")==0)
3470 return open(PerlDir_mapA(path), flag, pmode);
3473 /* close() that understands socket */
3474 extern int my_close(int); /* in win32sck.c */
3479 return my_close(fd);
3495 win32_dup2(int fd1,int fd2)
3497 return dup2(fd1,fd2);
3500 #ifdef PERL_MSVCRT_READFIX
3502 #define LF 10 /* line feed */
3503 #define CR 13 /* carriage return */
3504 #define CTRLZ 26 /* ctrl-z means eof for text */
3505 #define FOPEN 0x01 /* file handle open */
3506 #define FEOFLAG 0x02 /* end of file has been encountered */
3507 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3508 #define FPIPE 0x08 /* file handle refers to a pipe */
3509 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3510 #define FDEV 0x40 /* file handle refers to device */
3511 #define FTEXT 0x80 /* file handle is in text mode */
3512 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3515 _fixed_read(int fh, void *buf, unsigned cnt)
3517 int bytes_read; /* number of bytes read */
3518 char *buffer; /* buffer to read to */
3519 int os_read; /* bytes read on OS call */
3520 char *p, *q; /* pointers into buffer */
3521 char peekchr; /* peek-ahead character */
3522 ULONG filepos; /* file position after seek */
3523 ULONG dosretval; /* o.s. return value */
3525 /* validate handle */
3526 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3527 !(_osfile(fh) & FOPEN))
3529 /* out of range -- return error */
3531 _doserrno = 0; /* not o.s. error */
3536 * If lockinitflag is FALSE, assume fd is device
3537 * lockinitflag is set to TRUE by open.
3539 if (_pioinfo(fh)->lockinitflag)
3540 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3542 bytes_read = 0; /* nothing read yet */
3543 buffer = (char*)buf;
3545 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3546 /* nothing to read or at EOF, so return 0 read */
3550 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3551 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3553 *buffer++ = _pipech(fh);
3556 _pipech(fh) = LF; /* mark as empty */
3561 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3563 /* ReadFile has reported an error. recognize two special cases.
3565 * 1. map ERROR_ACCESS_DENIED to EBADF
3567 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3568 * means the handle is a read-handle on a pipe for which
3569 * all write-handles have been closed and all data has been
3572 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3573 /* wrong read/write mode should return EBADF, not EACCES */
3575 _doserrno = dosretval;
3579 else if (dosretval == ERROR_BROKEN_PIPE) {
3589 bytes_read += os_read; /* update bytes read */
3591 if (_osfile(fh) & FTEXT) {
3592 /* now must translate CR-LFs to LFs in the buffer */
3594 /* set CRLF flag to indicate LF at beginning of buffer */
3595 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3596 /* _osfile(fh) |= FCRLF; */
3598 /* _osfile(fh) &= ~FCRLF; */
3600 _osfile(fh) &= ~FCRLF;
3602 /* convert chars in the buffer: p is src, q is dest */
3604 while (p < (char *)buf + bytes_read) {
3606 /* if fh is not a device, set ctrl-z flag */
3607 if (!(_osfile(fh) & FDEV))
3608 _osfile(fh) |= FEOFLAG;
3609 break; /* stop translating */
3614 /* *p is CR, so must check next char for LF */
3615 if (p < (char *)buf + bytes_read - 1) {
3618 *q++ = LF; /* convert CR-LF to LF */
3621 *q++ = *p++; /* store char normally */
3624 /* This is the hard part. We found a CR at end of
3625 buffer. We must peek ahead to see if next char
3630 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3631 (LPDWORD)&os_read, NULL))
3632 dosretval = GetLastError();
3634 if (dosretval != 0 || os_read == 0) {
3635 /* couldn't read ahead, store CR */
3639 /* peekchr now has the extra character -- we now
3640 have several possibilities:
3641 1. disk file and char is not LF; just seek back
3643 2. disk file and char is LF; store LF, don't seek back
3644 3. pipe/device and char is LF; store LF.
3645 4. pipe/device and char isn't LF, store CR and
3646 put char in pipe lookahead buffer. */
3647 if (_osfile(fh) & (FDEV|FPIPE)) {
3648 /* non-seekable device */
3653 _pipech(fh) = peekchr;
3658 if (peekchr == LF) {
3659 /* nothing read yet; must make some
3662 /* turn on this flag for tell routine */
3663 _osfile(fh) |= FCRLF;
3666 HANDLE osHandle; /* o.s. handle value */
3668 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3670 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3671 dosretval = GetLastError();
3682 /* we now change bytes_read to reflect the true number of chars
3684 bytes_read = q - (char *)buf;
3688 if (_pioinfo(fh)->lockinitflag)
3689 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3694 #endif /* PERL_MSVCRT_READFIX */
3697 win32_read(int fd, void *buf, unsigned int cnt)
3699 #ifdef PERL_MSVCRT_READFIX
3700 return _fixed_read(fd, buf, cnt);
3702 return read(fd, buf, cnt);
3707 win32_write(int fd, const void *buf, unsigned int cnt)
3709 return write(fd, buf, cnt);
3713 win32_mkdir(const char *dir, int mode)
3716 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3720 win32_rmdir(const char *dir)
3723 return rmdir(PerlDir_mapA(dir));
3727 win32_chdir(const char *dir)
3738 win32_access(const char *path, int mode)
3741 return access(PerlDir_mapA(path), mode);
3745 win32_chmod(const char *path, int mode)
3748 return chmod(PerlDir_mapA(path), mode);
3753 create_command_line(char *cname, STRLEN clen, const char * const *args)
3760 bool bat_file = FALSE;
3761 bool cmd_shell = FALSE;
3762 bool dumb_shell = FALSE;
3763 bool extra_quotes = FALSE;
3764 bool quote_next = FALSE;
3767 cname = (char*)args[0];
3769 /* The NT cmd.exe shell has the following peculiarity that needs to be
3770 * worked around. It strips a leading and trailing dquote when any
3771 * of the following is true:
3772 * 1. the /S switch was used
3773 * 2. there are more than two dquotes
3774 * 3. there is a special character from this set: &<>()@^|
3775 * 4. no whitespace characters within the two dquotes
3776 * 5. string between two dquotes isn't an executable file
3777 * To work around this, we always add a leading and trailing dquote
3778 * to the string, if the first argument is either "cmd.exe" or "cmd",
3779 * and there were at least two or more arguments passed to cmd.exe
3780 * (not including switches).
3781 * XXX the above rules (from "cmd /?") don't seem to be applied
3782 * always, making for the convolutions below :-(
3786 clen = strlen(cname);
3789 && (stricmp(&cname[clen-4], ".bat") == 0
3790 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3797 char *exe = strrchr(cname, '/');
3798 char *exe2 = strrchr(cname, '\\');
3805 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3809 else if (stricmp(exe, "command.com") == 0
3810 || stricmp(exe, "command") == 0)
3817 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3818 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3819 STRLEN curlen = strlen(arg);
3820 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3821 len += 2; /* assume quoting needed (worst case) */
3823 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3825 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3828 Newx(cmd, len, char);
3831 if (bat_file && !IsWin95()) {
3833 extra_quotes = TRUE;
3836 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3838 STRLEN curlen = strlen(arg);
3840 /* we want to protect empty arguments and ones with spaces with
3841 * dquotes, but only if they aren't already there */
3846 else if (quote_next) {
3847 /* see if it really is multiple arguments pretending to
3848 * be one and force a set of quotes around it */
3849 if (*find_next_space(arg))
3852 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3854 while (i < curlen) {
3855 if (isSPACE(arg[i])) {
3858 else if (arg[i] == '"') {
3882 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3883 && stricmp(arg+curlen-2, "/c") == 0)
3885 /* is there a next argument? */
3886 if (args[index+1]) {
3887 /* are there two or more next arguments? */
3888 if (args[index+2]) {
3890 extra_quotes = TRUE;
3893 /* single argument, force quoting if it has spaces */
3909 qualified_path(const char *cmd)
3913 char *fullcmd, *curfullcmd;
3919 fullcmd = (char*)cmd;
3921 if (*fullcmd == '/' || *fullcmd == '\\')
3928 pathstr = PerlEnv_getenv("PATH");
3930 /* worst case: PATH is a single directory; we need additional space
3931 * to append "/", ".exe" and trailing "\0" */
3932 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3933 curfullcmd = fullcmd;
3938 /* start by appending the name to the current prefix */
3939 strcpy(curfullcmd, cmd);
3940 curfullcmd += cmdlen;
3942 /* if it doesn't end with '.', or has no extension, try adding
3943 * a trailing .exe first */
3944 if (cmd[cmdlen-1] != '.'
3945 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3947 strcpy(curfullcmd, ".exe");
3948 res = GetFileAttributes(fullcmd);
3949 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3954 /* that failed, try the bare name */
3955 res = GetFileAttributes(fullcmd);
3956 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3959 /* quit if no other path exists, or if cmd already has path */
3960 if (!pathstr || !*pathstr || has_slash)
3963 /* skip leading semis */
3964 while (*pathstr == ';')
3967 /* build a new prefix from scratch */
3968 curfullcmd = fullcmd;
3969 while (*pathstr && *pathstr != ';') {
3970 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3971 pathstr++; /* skip initial '"' */
3972 while (*pathstr && *pathstr != '"') {
3973 *curfullcmd++ = *pathstr++;
3976 pathstr++; /* skip trailing '"' */
3979 *curfullcmd++ = *pathstr++;
3983 pathstr++; /* skip trailing semi */
3984 if (curfullcmd > fullcmd /* append a dir separator */
3985 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3987 *curfullcmd++ = '\\';
3995 /* The following are just place holders.
3996 * Some hosts may provide and environment that the OS is
3997 * not tracking, therefore, these host must provide that
3998 * environment and the current directory to CreateProcess
4002 win32_get_childenv(void)
4008 win32_free_childenv(void* d)
4013 win32_clearenv(void)
4015 char *envv = GetEnvironmentStrings();
4019 char *end = strchr(cur,'=');
4020 if (end && end != cur) {
4022 SetEnvironmentVariable(cur, NULL);
4024 cur = end + strlen(end+1)+2;
4026 else if ((len = strlen(cur)))
4029 FreeEnvironmentStrings(envv);
4033 win32_get_childdir(void)
4037 char szfilename[MAX_PATH+1];
4039 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4040 Newx(ptr, strlen(szfilename)+1, char);
4041 strcpy(ptr, szfilename);
4046 win32_free_childdir(char* d)
4053 /* XXX this needs to be made more compatible with the spawnvp()
4054 * provided by the various RTLs. In particular, searching for
4055 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4056 * This doesn't significantly affect perl itself, because we
4057 * always invoke things using PERL5SHELL if a direct attempt to
4058 * spawn the executable fails.
4060 * XXX splitting and rejoining the commandline between do_aspawn()
4061 * and win32_spawnvp() could also be avoided.
4065 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4067 #ifdef USE_RTL_SPAWNVP
4068 return spawnvp(mode, cmdname, (char * const *)argv);
4075 STARTUPINFO StartupInfo;
4076 PROCESS_INFORMATION ProcessInformation;
4079 char *fullcmd = NULL;
4080 char *cname = (char *)cmdname;
4084 clen = strlen(cname);
4085 /* if command name contains dquotes, must remove them */
4086 if (strchr(cname, '"')) {
4088 Newx(cname,clen+1,char);
4101 cmd = create_command_line(cname, clen, argv);
4103 env = PerlEnv_get_childenv();
4104 dir = PerlEnv_get_childdir();
4107 case P_NOWAIT: /* asynch + remember result */
4108 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4113 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4116 create |= CREATE_NEW_PROCESS_GROUP;
4119 case P_WAIT: /* synchronous execution */
4121 default: /* invalid mode */
4126 memset(&StartupInfo,0,sizeof(StartupInfo));
4127 StartupInfo.cb = sizeof(StartupInfo);
4128 memset(&tbl,0,sizeof(tbl));
4129 PerlEnv_get_child_IO(&tbl);
4130 StartupInfo.dwFlags = tbl.dwFlags;
4131 StartupInfo.dwX = tbl.dwX;
4132 StartupInfo.dwY = tbl.dwY;
4133 StartupInfo.dwXSize = tbl.dwXSize;
4134 StartupInfo.dwYSize = tbl.dwYSize;
4135 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4136 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4137 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4138 StartupInfo.wShowWindow = tbl.wShowWindow;
4139 StartupInfo.hStdInput = tbl.childStdIn;
4140 StartupInfo.hStdOutput = tbl.childStdOut;
4141 StartupInfo.hStdError = tbl.childStdErr;
4142 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4143 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4144 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4146 create |= CREATE_NEW_CONSOLE;
4149 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4151 if (w32_use_showwindow) {
4152 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4153 StartupInfo.wShowWindow = w32_showwindow;
4156 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4159 if (!CreateProcess(cname, /* search PATH to find executable */
4160 cmd, /* executable, and its arguments */
4161 NULL, /* process attributes */
4162 NULL, /* thread attributes */
4163 TRUE, /* inherit handles */
4164 create, /* creation flags */
4165 (LPVOID)env, /* inherit environment */
4166 dir, /* inherit cwd */
4168 &ProcessInformation))
4170 /* initial NULL argument to CreateProcess() does a PATH
4171 * search, but it always first looks in the directory
4172 * where the current process was started, which behavior
4173 * is undesirable for backward compatibility. So we
4174 * jump through our own hoops by picking out the path
4175 * we really want it to use. */
4177 fullcmd = qualified_path(cname);
4179 if (cname != cmdname)
4182 DEBUG_p(PerlIO_printf(Perl_debug_log,
4183 "Retrying [%s] with same args\n",
4193 if (mode == P_NOWAIT) {
4194 /* asynchronous spawn -- store handle, return PID */
4195 ret = (int)ProcessInformation.dwProcessId;
4196 if (IsWin95() && ret < 0)
4199 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4200 w32_child_pids[w32_num_children] = (DWORD)ret;
4205 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4206 /* FIXME: if msgwait returned due to message perhaps forward the
4207 "signal" to the process
4209 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4211 CloseHandle(ProcessInformation.hProcess);
4214 CloseHandle(ProcessInformation.hThread);
4217 PerlEnv_free_childenv(env);
4218 PerlEnv_free_childdir(dir);
4220 if (cname != cmdname)
4227 win32_execv(const char *cmdname, const char *const *argv)
4231 /* if this is a pseudo-forked child, we just want to spawn
4232 * the new program, and return */
4234 # ifdef __BORLANDC__
4235 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4237 return spawnv(P_WAIT, cmdname, argv);
4241 return execv(cmdname, (char *const *)argv);
4243 return execv(cmdname, argv);
4248 win32_execvp(const char *cmdname, const char *const *argv)
4252 /* if this is a pseudo-forked child, we just want to spawn
4253 * the new program, and return */
4254 if (w32_pseudo_id) {
4255 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4265 return execvp(cmdname, (char *const *)argv);
4267 return execvp(cmdname, argv);
4272 win32_perror(const char *str)
4278 win32_setbuf(FILE *pf, char *buf)
4284 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4286 return setvbuf(pf, buf, type, size);
4290 win32_flushall(void)
4296 win32_fcloseall(void)
4302 win32_fgets(char *s, int n, FILE *pf)
4304 return fgets(s, n, pf);
4314 win32_fgetc(FILE *pf)
4320 win32_putc(int c, FILE *pf)
4326 win32_puts(const char *s)
4338 win32_putchar(int c)
4345 #ifndef USE_PERL_SBRK
4347 static char *committed = NULL; /* XXX threadead */
4348 static char *base = NULL; /* XXX threadead */
4349 static char *reserved = NULL; /* XXX threadead */
4350 static char *brk = NULL; /* XXX threadead */
4351 static DWORD pagesize = 0; /* XXX threadead */
4354 sbrk(ptrdiff_t need)
4359 GetSystemInfo(&info);
4360 /* Pretend page size is larger so we don't perpetually
4361 * call the OS to commit just one page ...
4363 pagesize = info.dwPageSize << 3;
4365 if (brk+need >= reserved)
4367 DWORD size = brk+need-reserved;
4369 char *prev_committed = NULL;
4370 if (committed && reserved && committed < reserved)
4372 /* Commit last of previous chunk cannot span allocations */
4373 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4376 /* Remember where we committed from in case we want to decommit later */
4377 prev_committed = committed;
4378 committed = reserved;
4381 /* Reserve some (more) space
4382 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4383 * this is only address space not memory...
4384 * Note this is a little sneaky, 1st call passes NULL as reserved
4385 * so lets system choose where we start, subsequent calls pass
4386 * the old end address so ask for a contiguous block
4389 if (size < 64*1024*1024)
4390 size = 64*1024*1024;
4391 size = ((size + pagesize - 1) / pagesize) * pagesize;
4392 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4395 reserved = addr+size;
4405 /* The existing block could not be extended far enough, so decommit
4406 * anything that was just committed above and start anew */
4409 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4412 reserved = base = committed = brk = NULL;
4423 if (brk > committed)
4425 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4427 if (committed+size > reserved)
4428 size = reserved-committed;
4429 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4442 win32_malloc(size_t size)
4444 return malloc(size);
4448 win32_calloc(size_t numitems, size_t size)
4450 return calloc(numitems,size);
4454 win32_realloc(void *block, size_t size)
4456 return realloc(block,size);
4460 win32_free(void *block)
4467 win32_open_osfhandle(intptr_t handle, int flags)
4469 #ifdef USE_FIXED_OSFHANDLE
4471 return my_open_osfhandle(handle, flags);
4473 return _open_osfhandle(handle, flags);
4477 win32_get_osfhandle(int fd)
4479 return (intptr_t)_get_osfhandle(fd);
4483 win32_fdupopen(FILE *pf)
4488 int fileno = win32_dup(win32_fileno(pf));
4490 /* open the file in the same mode */
4492 if((pf)->flags & _F_READ) {
4496 else if((pf)->flags & _F_WRIT) {
4500 else if((pf)->flags & _F_RDWR) {
4506 if((pf)->_flag & _IOREAD) {
4510 else if((pf)->_flag & _IOWRT) {
4514 else if((pf)->_flag & _IORW) {
4521 /* it appears that the binmode is attached to the
4522 * file descriptor so binmode files will be handled
4525 pfdup = win32_fdopen(fileno, mode);
4527 /* move the file pointer to the same position */
4528 if (!fgetpos(pf, &pos)) {
4529 fsetpos(pfdup, &pos);
4535 win32_dynaload(const char* filename)
4538 char buf[MAX_PATH+1];
4541 /* LoadLibrary() doesn't recognize forward slashes correctly,
4542 * so turn 'em back. */
4543 first = strchr(filename, '/');
4545 STRLEN len = strlen(filename);
4546 if (len <= MAX_PATH) {
4547 strcpy(buf, filename);
4548 filename = &buf[first - filename];
4550 if (*filename == '/')
4551 *(char*)filename = '\\';
4557 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4560 XS(w32_SetChildShowWindow)
4563 BOOL use_showwindow = w32_use_showwindow;
4564 /* use "unsigned short" because Perl has redefined "WORD" */
4565 unsigned short showwindow = w32_showwindow;
4568 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4570 if (items == 0 || !SvOK(ST(0)))
4571 w32_use_showwindow = FALSE;
4573 w32_use_showwindow = TRUE;
4574 w32_showwindow = (unsigned short)SvIV(ST(0));
4579 ST(0) = sv_2mortal(newSViv(showwindow));
4581 ST(0) = &PL_sv_undef;
4586 Perl_init_os_extras(void)
4589 char *file = __FILE__;
4591 /* Initialize Win32CORE if it has been statically linked. */
4592 void (*pfn_init)(pTHX);
4593 #if defined(__BORLANDC__)
4594 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4595 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4597 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4602 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4606 win32_signal_context(void)
4611 my_perl = PL_curinterp;
4612 PERL_SET_THX(my_perl);
4616 return PL_curinterp;
4622 win32_ctrlhandler(DWORD dwCtrlType)
4625 dTHXa(PERL_GET_SIG_CONTEXT);
4631 switch(dwCtrlType) {
4632 case CTRL_CLOSE_EVENT:
4633 /* A signal that the system sends to all processes attached to a console when
4634 the user closes the console (either by choosing the Close command from the
4635 console window's System menu, or by choosing the End Task command from the
4638 if (do_raise(aTHX_ 1)) /* SIGHUP */
4639 sig_terminate(aTHX_ 1);
4643 /* A CTRL+c signal was received */
4644 if (do_raise(aTHX_ SIGINT))
4645 sig_terminate(aTHX_ SIGINT);
4648 case CTRL_BREAK_EVENT:
4649 /* A CTRL+BREAK signal was received */
4650 if (do_raise(aTHX_ SIGBREAK))
4651 sig_terminate(aTHX_ SIGBREAK);
4654 case CTRL_LOGOFF_EVENT:
4655 /* A signal that the system sends to all console processes when a user is logging
4656 off. This signal does not indicate which user is logging off, so no
4657 assumptions can be made.
4660 case CTRL_SHUTDOWN_EVENT:
4661 /* A signal that the system sends to all console processes when the system is
4664 if (do_raise(aTHX_ SIGTERM))
4665 sig_terminate(aTHX_ SIGTERM);
4674 #ifdef SET_INVALID_PARAMETER_HANDLER
4675 # include <crtdbg.h>
4686 /* win32_ansipath() requires Windows 2000 or later */
4690 /* fetch Unicode version of PATH */
4692 wide_path = win32_malloc(len*sizeof(WCHAR));
4694 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4698 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4703 /* convert to ANSI pathnames */
4704 wide_dir = wide_path;
4707 WCHAR *sep = wcschr(wide_dir, ';');
4715 /* remove quotes around pathname */
4716 if (*wide_dir == '"')
4718 wide_len = wcslen(wide_dir);
4719 if (wide_len && wide_dir[wide_len-1] == '"')
4720 wide_dir[wide_len-1] = '\0';
4722 /* append ansi_dir to ansi_path */
4723 ansi_dir = win32_ansipath(wide_dir);
4724 ansi_len = strlen(ansi_dir);
4726 size_t newlen = len + 1 + ansi_len;
4727 ansi_path = win32_realloc(ansi_path, newlen+1);
4730 ansi_path[len] = ';';
4731 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4736 ansi_path = win32_malloc(5+len+1);
4739 memcpy(ansi_path, "PATH=", 5);
4740 memcpy(ansi_path+5, ansi_dir, len+1);
4743 win32_free(ansi_dir);
4748 /* Update C RTL environ array. This will only have full effect if
4749 * perl_parse() is later called with `environ` as the `env` argument.
4750 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4752 * We do have to ansify() the PATH before Perl has been fully
4753 * initialized because S_find_script() uses the PATH when perl
4754 * is being invoked with the -S option. This happens before %ENV
4755 * is initialized in S_init_postdump_symbols().
4757 * XXX Is this a bug? Should S_find_script() use the environment
4758 * XXX passed in the `env` arg to parse_perl()?
4761 /* Keep system environment in sync because S_init_postdump_symbols()
4762 * will not call mg_set() if it initializes %ENV from `environ`.
4764 SetEnvironmentVariableA("PATH", ansi_path+5);
4765 /* We are intentionally leaking the ansi_path string here because
4766 * the Borland runtime library puts it directly into the environ
4767 * array. The Microsoft runtime library seems to make a copy,
4768 * but will leak the copy should it be replaced again later.
4769 * Since this code is only called once during PERL_SYS_INIT this
4770 * shouldn't really matter.
4773 win32_free(wide_path);
4777 Perl_win32_init(int *argcp, char ***argvp)
4781 #ifdef SET_INVALID_PARAMETER_HANDLER
4782 _invalid_parameter_handler oldHandler, newHandler;
4783 newHandler = my_invalid_parameter_handler;
4784 oldHandler = _set_invalid_parameter_handler(newHandler);
4785 _CrtSetReportMode(_CRT_ASSERT, 0);
4787 /* Disable floating point errors, Perl will trap the ones we
4788 * care about. VC++ RTL defaults to switching these off
4789 * already, but the Borland RTL doesn't. Since we don't
4790 * want to be at the vendor's whim on the default, we set
4791 * it explicitly here.
4793 #if !defined(_ALPHA_) && !defined(__GNUC__)
4794 _control87(MCW_EM, MCW_EM);
4798 module = GetModuleHandle("ntdll.dll");
4800 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4803 module = GetModuleHandle("kernel32.dll");
4805 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4806 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4807 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4810 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4811 GetVersionEx(&g_osver);
4817 Perl_win32_term(void)
4827 win32_get_child_IO(child_IO_table* ptbl)
4829 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4830 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4831 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4835 win32_signal(int sig, Sighandler_t subcode)
4838 if (sig < SIG_SIZE) {
4839 int save_errno = errno;
4840 Sighandler_t result = signal(sig, subcode);
4841 if (result == SIG_ERR) {
4842 result = w32_sighandler[sig];
4845 w32_sighandler[sig] = subcode;
4854 /* The PerlMessageWindowClass's WindowProc */
4856 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4858 return win32_process_message(hwnd, msg, wParam, lParam) ?
4859 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4862 /* we use a message filter hook to process thread messages, passing any
4863 * messages that we don't process on to the rest of the hook chain
4864 * Anyone else writing a message loop that wants to play nicely with perl
4866 * CallMsgFilter(&msg, MSGF_***);
4867 * between their GetMessage and DispatchMessage calls. */
4869 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4870 LPMSG pmsg = (LPMSG)lParam;
4872 /* we'll process it if code says we're allowed, and it's a thread message */
4873 if (code >= 0 && pmsg->hwnd == NULL
4874 && win32_process_message(pmsg->hwnd, pmsg->message,
4875 pmsg->wParam, pmsg->lParam))
4880 /* XXX: MSDN says that hhk is ignored, but we should really use the
4881 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4882 return CallNextHookEx(NULL, code, wParam, lParam);
4885 /* The real message handler. Can be called with
4886 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4887 * that it processes */
4889 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4891 /* BEWARE. The context retrieved using dTHX; is the context of the
4892 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4893 * up to and including WM_CREATE. If it ever happens that you need the
4894 * 'child' context before this, then it needs to be passed into
4895 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4896 * from the lparam of CreateWindow(). It could then be stored/retrieved
4897 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4898 * the dTHX calls here. */
4899 /* XXX For now it is assumed that the overhead of the dTHX; for what
4900 * are relativley infrequent code-paths, is better than the added
4901 * complexity of getting the correct context passed into
4902 * win32_create_message_window() */
4907 case WM_USER_MESSAGE: {
4908 long child = find_pseudo_pid((int)wParam);
4911 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4918 case WM_USER_KILL: {
4920 /* We use WM_USER_KILL to fake kill() with other signals */
4921 int sig = (int)wParam;
4922 if (do_raise(aTHX_ sig))
4923 sig_terminate(aTHX_ sig);
4930 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4931 if (w32_timerid && w32_timerid==(UINT)wParam) {
4932 KillTimer(w32_message_hwnd, w32_timerid);
4935 /* Now fake a call to signal handler */
4936 if (do_raise(aTHX_ 14))
4937 sig_terminate(aTHX_ 14);
4949 /* Above or other stuff may have set a signal flag, and we may not have
4950 * been called from win32_async_check() (e.g. some other GUI's message
4951 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4952 * handler that die's, and the message loop that calls here is wrapped
4953 * in an eval, then you may well end up with orphaned windows - signals
4954 * are dispatched by win32_async_check() */
4960 win32_create_message_window_class(void)
4962 /* create the window class for "message only" windows */
4966 wc.lpfnWndProc = win32_message_window_proc;
4967 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4968 wc.lpszClassName = "PerlMessageWindowClass";
4970 /* second and subsequent calls will fail, but class
4971 * will already be registered */
4976 win32_create_message_window(void)
4980 /* "message-only" windows have been implemented in Windows 2000 and later.
4981 * On earlier versions we'll continue to post messages to a specific
4982 * thread and use hwnd==NULL. This is brittle when either an embedding
4983 * application or an XS module is also posting messages to hwnd=NULL
4984 * because once removed from the queue they cannot be delivered to the
4985 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4986 * if there is no window handle.
4988 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4989 * documentation to the contrary, however, there is some evidence that
4990 * there may be problems with the implementation on Win98. As it is not
4991 * officially supported we take the cautious route and stick with thread
4992 * messages (hwnd == NULL) on platforms prior to Win2k.
4995 win32_create_message_window_class();
4997 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4998 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5001 /* If we din't create a window for any reason, then we'll use thread
5002 * messages for our signalling, so we install a hook which
5003 * is called by CallMsgFilter in win32_async_check(), or any other
5004 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5005 * that use OLE, etc. */
5007 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5008 NULL, GetCurrentThreadId());
5014 #ifdef HAVE_INTERP_INTERN
5017 win32_csighandler(int sig)
5020 dTHXa(PERL_GET_SIG_CONTEXT);
5021 Perl_warn(aTHX_ "Got signal %d",sig);
5026 #if defined(__MINGW32__) && defined(__cplusplus)
5027 #define CAST_HWND__(x) (HWND__*)(x)
5029 #define CAST_HWND__(x) x
5033 Perl_sys_intern_init(pTHX)
5037 w32_perlshell_tokens = NULL;
5038 w32_perlshell_vec = (char**)NULL;
5039 w32_perlshell_items = 0;
5040 w32_fdpid = newAV();
5041 Newx(w32_children, 1, child_tab);
5042 w32_num_children = 0;
5043 # ifdef USE_ITHREADS
5045 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5046 w32_num_pseudo_children = 0;
5049 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5051 for (i=0; i < SIG_SIZE; i++) {
5052 w32_sighandler[i] = SIG_DFL;
5054 # ifdef MULTIPLICITY
5055 if (my_perl == PL_curinterp) {
5059 /* Force C runtime signal stuff to set its console handler */
5060 signal(SIGINT,win32_csighandler);
5061 signal(SIGBREAK,win32_csighandler);
5063 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5064 * flag. This has the side-effect of disabling Ctrl-C events in all
5065 * processes in this group. At least on Windows NT and later we
5066 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5067 * with a NULL handler. This is not valid on Windows 9X.
5070 SetConsoleCtrlHandler(NULL,FALSE);
5072 /* Push our handler on top */
5073 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5078 Perl_sys_intern_clear(pTHX)
5080 Safefree(w32_perlshell_tokens);
5081 Safefree(w32_perlshell_vec);
5082 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5083 Safefree(w32_children);
5085 KillTimer(w32_message_hwnd, w32_timerid);
5088 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5089 DestroyWindow(w32_message_hwnd);
5090 # ifdef MULTIPLICITY
5091 if (my_perl == PL_curinterp) {
5095 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5097 # ifdef USE_ITHREADS
5098 Safefree(w32_pseudo_children);
5102 # ifdef USE_ITHREADS
5105 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5107 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5109 dst->perlshell_tokens = NULL;
5110 dst->perlshell_vec = (char**)NULL;
5111 dst->perlshell_items = 0;
5112 dst->fdpid = newAV();
5113 Newxz(dst->children, 1, child_tab);
5115 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5117 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5118 dst->poll_count = 0;
5119 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5121 # endif /* USE_ITHREADS */
5122 #endif /* HAVE_INTERP_INTERN */