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
1769 * (specifically, see http://support.microsoft.com/kb/235601).
1771 * Why you may want to use the RTL environment handling
1772 * (previously enabled by USE_WIN32_RTL_ENV):
1773 * * environ[] and RTL functions will not reflect changes,
1774 * which might be an issue if extensions want to access
1775 * the env. via RTL. This cuts both ways, since RTL will
1776 * not see changes made by extensions that call the Win32
1777 * functions directly, either.
1781 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1790 filetime_to_clock(PFILETIME ft)
1792 __int64 qw = ft->dwHighDateTime;
1794 qw |= ft->dwLowDateTime;
1795 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1800 win32_times(struct tms *timebuf)
1805 clock_t process_time_so_far = clock();
1806 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1808 timebuf->tms_utime = filetime_to_clock(&user);
1809 timebuf->tms_stime = filetime_to_clock(&kernel);
1810 timebuf->tms_cutime = 0;
1811 timebuf->tms_cstime = 0;
1813 /* That failed - e.g. Win95 fallback to clock() */
1814 timebuf->tms_utime = process_time_so_far;
1815 timebuf->tms_stime = 0;
1816 timebuf->tms_cutime = 0;
1817 timebuf->tms_cstime = 0;
1819 return process_time_so_far;
1822 /* fix utime() so it works on directories in NT */
1824 filetime_from_time(PFILETIME pFileTime, time_t Time)
1826 struct tm *pTM = localtime(&Time);
1827 SYSTEMTIME SystemTime;
1833 SystemTime.wYear = pTM->tm_year + 1900;
1834 SystemTime.wMonth = pTM->tm_mon + 1;
1835 SystemTime.wDay = pTM->tm_mday;
1836 SystemTime.wHour = pTM->tm_hour;
1837 SystemTime.wMinute = pTM->tm_min;
1838 SystemTime.wSecond = pTM->tm_sec;
1839 SystemTime.wMilliseconds = 0;
1841 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1842 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1846 win32_unlink(const char *filename)
1852 filename = PerlDir_mapA(filename);
1853 attrs = GetFileAttributesA(filename);
1854 if (attrs == 0xFFFFFFFF) {
1858 if (attrs & FILE_ATTRIBUTE_READONLY) {
1859 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1860 ret = unlink(filename);
1862 (void)SetFileAttributesA(filename, attrs);
1865 ret = unlink(filename);
1870 win32_utime(const char *filename, struct utimbuf *times)
1877 struct utimbuf TimeBuffer;
1880 filename = PerlDir_mapA(filename);
1881 rc = utime(filename, times);
1883 /* EACCES: path specifies directory or readonly file */
1884 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1887 if (times == NULL) {
1888 times = &TimeBuffer;
1889 time(×->actime);
1890 times->modtime = times->actime;
1893 /* This will (and should) still fail on readonly files */
1894 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1895 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1896 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1897 if (handle == INVALID_HANDLE_VALUE)
1900 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1901 filetime_from_time(&ftAccess, times->actime) &&
1902 filetime_from_time(&ftWrite, times->modtime) &&
1903 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1908 CloseHandle(handle);
1913 unsigned __int64 ft_i64;
1918 #define Const64(x) x##LL
1920 #define Const64(x) x##i64
1922 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1923 #define EPOCH_BIAS Const64(116444736000000000)
1925 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1926 * and appears to be unsupported even by glibc) */
1928 win32_gettimeofday(struct timeval *tp, void *not_used)
1932 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1933 GetSystemTimeAsFileTime(&ft.ft_val);
1935 /* seconds since epoch */
1936 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1938 /* microseconds remaining */
1939 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1945 win32_uname(struct utsname *name)
1947 struct hostent *hep;
1948 STRLEN nodemax = sizeof(name->nodename)-1;
1951 switch (g_osver.dwPlatformId) {
1952 case VER_PLATFORM_WIN32_WINDOWS:
1953 strcpy(name->sysname, "Windows");
1955 case VER_PLATFORM_WIN32_NT:
1956 strcpy(name->sysname, "Windows NT");
1958 case VER_PLATFORM_WIN32s:
1959 strcpy(name->sysname, "Win32s");
1962 strcpy(name->sysname, "Win32 Unknown");
1967 sprintf(name->release, "%d.%d",
1968 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1971 sprintf(name->version, "Build %d",
1972 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1973 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1974 if (g_osver.szCSDVersion[0]) {
1975 char *buf = name->version + strlen(name->version);
1976 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1980 hep = win32_gethostbyname("localhost");
1982 STRLEN len = strlen(hep->h_name);
1983 if (len <= nodemax) {
1984 strcpy(name->nodename, hep->h_name);
1987 strncpy(name->nodename, hep->h_name, nodemax);
1988 name->nodename[nodemax] = '\0';
1993 if (!GetComputerName(name->nodename, &sz))
1994 *name->nodename = '\0';
1997 /* machine (architecture) */
2002 GetSystemInfo(&info);
2004 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2005 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2006 procarch = info.u.s.wProcessorArchitecture;
2008 procarch = info.wProcessorArchitecture;
2011 case PROCESSOR_ARCHITECTURE_INTEL:
2012 arch = "x86"; break;
2013 case PROCESSOR_ARCHITECTURE_MIPS:
2014 arch = "mips"; break;
2015 case PROCESSOR_ARCHITECTURE_ALPHA:
2016 arch = "alpha"; break;
2017 case PROCESSOR_ARCHITECTURE_PPC:
2018 arch = "ppc"; break;
2019 #ifdef PROCESSOR_ARCHITECTURE_SHX
2020 case PROCESSOR_ARCHITECTURE_SHX:
2021 arch = "shx"; break;
2023 #ifdef PROCESSOR_ARCHITECTURE_ARM
2024 case PROCESSOR_ARCHITECTURE_ARM:
2025 arch = "arm"; break;
2027 #ifdef PROCESSOR_ARCHITECTURE_IA64
2028 case PROCESSOR_ARCHITECTURE_IA64:
2029 arch = "ia64"; break;
2031 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2032 case PROCESSOR_ARCHITECTURE_ALPHA64:
2033 arch = "alpha64"; break;
2035 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2036 case PROCESSOR_ARCHITECTURE_MSIL:
2037 arch = "msil"; break;
2039 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2040 case PROCESSOR_ARCHITECTURE_AMD64:
2041 arch = "amd64"; break;
2043 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2044 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2045 arch = "ia32-64"; break;
2047 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2048 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2049 arch = "unknown"; break;
2052 sprintf(name->machine, "unknown(0x%x)", procarch);
2053 arch = name->machine;
2056 if (name->machine != arch)
2057 strcpy(name->machine, arch);
2062 /* Timing related stuff */
2065 do_raise(pTHX_ int sig)
2067 if (sig < SIG_SIZE) {
2068 Sighandler_t handler = w32_sighandler[sig];
2069 if (handler == SIG_IGN) {
2072 else if (handler != SIG_DFL) {
2077 /* Choose correct default behaviour */
2093 /* Tell caller to exit thread/process as approriate */
2098 sig_terminate(pTHX_ int sig)
2100 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2101 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2108 win32_async_check(pTHX)
2111 HWND hwnd = w32_message_hwnd;
2113 /* Reset w32_poll_count before doing anything else, incase we dispatch
2114 * messages that end up calling back into perl */
2117 if (hwnd != INVALID_HANDLE_VALUE) {
2118 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2119 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2124 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2125 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2127 /* re-post a WM_QUIT message (we'll mark it as read later) */
2128 if(msg.message == WM_QUIT) {
2129 PostQuitMessage((int)msg.wParam);
2133 if(!CallMsgFilter(&msg, MSGF_USER))
2135 TranslateMessage(&msg);
2136 DispatchMessage(&msg);
2141 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2142 * This is necessary when we are being called by win32_msgwait() to
2143 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2144 * message over and over. An example how this can happen is when
2145 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2146 * is generating messages before the process terminated.
2148 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2150 /* Above or other stuff may have set a signal flag */
2157 /* This function will not return until the timeout has elapsed, or until
2158 * one of the handles is ready. */
2160 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2162 /* We may need several goes at this - so compute when we stop */
2164 if (timeout != INFINITE) {
2165 ticks = GetTickCount();
2169 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2172 if (result == WAIT_TIMEOUT) {
2173 /* Ran out of time - explicit return of zero to avoid -ve if we
2174 have scheduling issues
2178 if (timeout != INFINITE) {
2179 ticks = GetTickCount();
2181 if (result == WAIT_OBJECT_0 + count) {
2182 /* Message has arrived - check it */
2183 (void)win32_async_check(aTHX);
2186 /* Not timeout or message - one of handles is ready */
2190 /* compute time left to wait */
2191 ticks = timeout - ticks;
2192 /* If we are past the end say zero */
2193 return (ticks > 0) ? ticks : 0;
2197 win32_internal_wait(int *status, DWORD timeout)
2199 /* XXX this wait emulation only knows about processes
2200 * spawned via win32_spawnvp(P_NOWAIT, ...).
2204 DWORD exitcode, waitcode;
2207 if (w32_num_pseudo_children) {
2208 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2209 timeout, &waitcode);
2210 /* Time out here if there are no other children to wait for. */
2211 if (waitcode == WAIT_TIMEOUT) {
2212 if (!w32_num_children) {
2216 else if (waitcode != WAIT_FAILED) {
2217 if (waitcode >= WAIT_ABANDONED_0
2218 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2219 i = waitcode - WAIT_ABANDONED_0;
2221 i = waitcode - WAIT_OBJECT_0;
2222 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2223 *status = (int)((exitcode & 0xff) << 8);
2224 retval = (int)w32_pseudo_child_pids[i];
2225 remove_dead_pseudo_process(i);
2232 if (!w32_num_children) {
2237 /* if a child exists, wait for it to die */
2238 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2239 if (waitcode == WAIT_TIMEOUT) {
2242 if (waitcode != WAIT_FAILED) {
2243 if (waitcode >= WAIT_ABANDONED_0
2244 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2245 i = waitcode - WAIT_ABANDONED_0;
2247 i = waitcode - WAIT_OBJECT_0;
2248 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2249 *status = (int)((exitcode & 0xff) << 8);
2250 retval = (int)w32_child_pids[i];
2251 remove_dead_process(i);
2256 errno = GetLastError();
2261 win32_waitpid(int pid, int *status, int flags)
2264 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2267 if (pid == -1) /* XXX threadid == 1 ? */
2268 return win32_internal_wait(status, timeout);
2271 child = find_pseudo_pid(-pid);
2273 HANDLE hThread = w32_pseudo_child_handles[child];
2275 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2276 if (waitcode == WAIT_TIMEOUT) {
2279 else if (waitcode == WAIT_OBJECT_0) {
2280 if (GetExitCodeThread(hThread, &waitcode)) {
2281 *status = (int)((waitcode & 0xff) << 8);
2282 retval = (int)w32_pseudo_child_pids[child];
2283 remove_dead_pseudo_process(child);
2290 else if (IsWin95()) {
2299 child = find_pid(pid);
2301 hProcess = w32_child_handles[child];
2302 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2303 if (waitcode == WAIT_TIMEOUT) {
2306 else if (waitcode == WAIT_OBJECT_0) {
2307 if (GetExitCodeProcess(hProcess, &waitcode)) {
2308 *status = (int)((waitcode & 0xff) << 8);
2309 retval = (int)w32_child_pids[child];
2310 remove_dead_process(child);
2319 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2320 (IsWin95() ? -pid : pid));
2322 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2323 if (waitcode == WAIT_TIMEOUT) {
2324 CloseHandle(hProcess);
2327 else if (waitcode == WAIT_OBJECT_0) {
2328 if (GetExitCodeProcess(hProcess, &waitcode)) {
2329 *status = (int)((waitcode & 0xff) << 8);
2330 CloseHandle(hProcess);
2334 CloseHandle(hProcess);
2340 return retval >= 0 ? pid : retval;
2344 win32_wait(int *status)
2346 return win32_internal_wait(status, INFINITE);
2349 DllExport unsigned int
2350 win32_sleep(unsigned int t)
2353 /* Win32 times are in ms so *1000 in and /1000 out */
2354 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2357 DllExport unsigned int
2358 win32_alarm(unsigned int sec)
2361 * the 'obvious' implentation is SetTimer() with a callback
2362 * which does whatever receiving SIGALRM would do
2363 * we cannot use SIGALRM even via raise() as it is not
2364 * one of the supported codes in <signal.h>
2368 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2369 w32_message_hwnd = win32_create_message_window();
2372 if (w32_message_hwnd == NULL)
2373 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2376 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2381 KillTimer(w32_message_hwnd, w32_timerid);
2388 #ifdef HAVE_DES_FCRYPT
2389 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2393 win32_crypt(const char *txt, const char *salt)
2396 #ifdef HAVE_DES_FCRYPT
2397 return des_fcrypt(txt, salt, w32_crypt_buffer);
2399 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2404 #ifdef USE_FIXED_OSFHANDLE
2406 #define FOPEN 0x01 /* file handle open */
2407 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2408 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2409 #define FDEV 0x40 /* file handle refers to device */
2410 #define FTEXT 0x80 /* file handle is in text mode */
2413 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2416 * This function allocates a free C Runtime file handle and associates
2417 * it with the Win32 HANDLE specified by the first parameter. This is a
2418 * temperary fix for WIN95's brain damage GetFileType() error on socket
2419 * we just bypass that call for socket
2421 * This works with MSVC++ 4.0+ or GCC/Mingw32
2424 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2425 * int flags - flags to associate with C Runtime file handle.
2428 * returns index of entry in fh, if successful
2429 * return -1, if no free entry is found
2433 *******************************************************************************/
2436 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2437 * this lets sockets work on Win9X with GCC and should fix the problems
2442 /* create an ioinfo entry, kill its handle, and steal the entry */
2447 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2448 int fh = _open_osfhandle((intptr_t)hF, 0);
2452 EnterCriticalSection(&(_pioinfo(fh)->lock));
2457 my_open_osfhandle(intptr_t osfhandle, int flags)
2460 char fileflags; /* _osfile flags */
2462 /* copy relevant flags from second parameter */
2465 if (flags & O_APPEND)
2466 fileflags |= FAPPEND;
2471 if (flags & O_NOINHERIT)
2472 fileflags |= FNOINHERIT;
2474 /* attempt to allocate a C Runtime file handle */
2475 if ((fh = _alloc_osfhnd()) == -1) {
2476 errno = EMFILE; /* too many open files */
2477 _doserrno = 0L; /* not an OS error */
2478 return -1; /* return error to caller */
2481 /* the file is open. now, set the info in _osfhnd array */
2482 _set_osfhnd(fh, osfhandle);
2484 fileflags |= FOPEN; /* mark as open */
2486 _osfile(fh) = fileflags; /* set osfile entry */
2487 LeaveCriticalSection(&_pioinfo(fh)->lock);
2489 return fh; /* return handle */
2492 #endif /* USE_FIXED_OSFHANDLE */
2494 /* simulate flock by locking a range on the file */
2496 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2497 #define LK_LEN 0xffff0000
2500 win32_flock(int fd, int oper)
2508 Perl_croak_nocontext("flock() unimplemented on this platform");
2511 fh = (HANDLE)_get_osfhandle(fd);
2512 memset(&o, 0, sizeof(o));
2515 case LOCK_SH: /* shared lock */
2516 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2518 case LOCK_EX: /* exclusive lock */
2519 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2521 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2522 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2524 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2525 LK_ERR(LockFileEx(fh,
2526 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2527 0, LK_LEN, 0, &o),i);
2529 case LOCK_UN: /* unlock lock */
2530 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2532 default: /* unknown */
2543 * redirected io subsystem for all XS modules
2556 return (&(_environ));
2559 /* the rest are the remapped stdio routines */
2579 win32_ferror(FILE *fp)
2581 return (ferror(fp));
2586 win32_feof(FILE *fp)
2592 * Since the errors returned by the socket error function
2593 * WSAGetLastError() are not known by the library routine strerror
2594 * we have to roll our own.
2598 win32_strerror(int e)
2600 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2601 extern int sys_nerr;
2605 if (e < 0 || e > sys_nerr) {
2610 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2611 w32_strerror_buffer,
2612 sizeof(w32_strerror_buffer), NULL) == 0)
2613 strcpy(w32_strerror_buffer, "Unknown Error");
2615 return w32_strerror_buffer;
2621 win32_str_os_error(void *sv, DWORD dwErr)
2625 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2626 |FORMAT_MESSAGE_IGNORE_INSERTS
2627 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2628 dwErr, 0, (char *)&sMsg, 1, NULL);
2629 /* strip trailing whitespace and period */
2632 --dwLen; /* dwLen doesn't include trailing null */
2633 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2634 if ('.' != sMsg[dwLen])
2639 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2641 dwLen = sprintf(sMsg,
2642 "Unknown error #0x%lX (lookup 0x%lX)",
2643 dwErr, GetLastError());
2647 sv_setpvn((SV*)sv, sMsg, dwLen);
2653 win32_fprintf(FILE *fp, const char *format, ...)
2656 va_start(marker, format); /* Initialize variable arguments. */
2658 return (vfprintf(fp, format, marker));
2662 win32_printf(const char *format, ...)
2665 va_start(marker, format); /* Initialize variable arguments. */
2667 return (vprintf(format, marker));
2671 win32_vfprintf(FILE *fp, const char *format, va_list args)
2673 return (vfprintf(fp, format, args));
2677 win32_vprintf(const char *format, va_list args)
2679 return (vprintf(format, args));
2683 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2685 return fread(buf, size, count, fp);
2689 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2691 return fwrite(buf, size, count, fp);
2694 #define MODE_SIZE 10
2697 win32_fopen(const char *filename, const char *mode)
2705 if (stricmp(filename, "/dev/null")==0)
2708 f = fopen(PerlDir_mapA(filename), mode);
2709 /* avoid buffering headaches for child processes */
2710 if (f && *mode == 'a')
2711 win32_fseek(f, 0, SEEK_END);
2715 #ifndef USE_SOCKETS_AS_HANDLES
2717 #define fdopen my_fdopen
2721 win32_fdopen(int handle, const char *mode)
2725 f = fdopen(handle, (char *) mode);
2726 /* avoid buffering headaches for child processes */
2727 if (f && *mode == 'a')
2728 win32_fseek(f, 0, SEEK_END);
2733 win32_freopen(const char *path, const char *mode, FILE *stream)
2736 if (stricmp(path, "/dev/null")==0)
2739 return freopen(PerlDir_mapA(path), mode, stream);
2743 win32_fclose(FILE *pf)
2745 return my_fclose(pf); /* defined in win32sck.c */
2749 win32_fputs(const char *s,FILE *pf)
2751 return fputs(s, pf);
2755 win32_fputc(int c,FILE *pf)
2761 win32_ungetc(int c,FILE *pf)
2763 return ungetc(c,pf);
2767 win32_getc(FILE *pf)
2773 win32_fileno(FILE *pf)
2779 win32_clearerr(FILE *pf)
2786 win32_fflush(FILE *pf)
2792 win32_ftell(FILE *pf)
2794 #if defined(WIN64) || defined(USE_LARGE_FILES)
2795 #if defined(__BORLANDC__) /* buk */
2796 return win32_tell( fileno( pf ) );
2799 if (fgetpos(pf, &pos))
2809 win32_fseek(FILE *pf, Off_t offset,int origin)
2811 #if defined(WIN64) || defined(USE_LARGE_FILES)
2812 #if defined(__BORLANDC__) /* buk */
2822 if (fgetpos(pf, &pos))
2827 fseek(pf, 0, SEEK_END);
2828 pos = _telli64(fileno(pf));
2837 return fsetpos(pf, &offset);
2840 return fseek(pf, (long)offset, origin);
2845 win32_fgetpos(FILE *pf,fpos_t *p)
2847 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2848 if( win32_tell(fileno(pf)) == -1L ) {
2854 return fgetpos(pf, p);
2859 win32_fsetpos(FILE *pf,const fpos_t *p)
2861 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2862 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2864 return fsetpos(pf, p);
2869 win32_rewind(FILE *pf)
2879 char prefix[MAX_PATH+1];
2880 char filename[MAX_PATH+1];
2881 DWORD len = GetTempPath(MAX_PATH, prefix);
2882 if (len && len < MAX_PATH) {
2883 if (GetTempFileName(prefix, "plx", 0, filename)) {
2884 HANDLE fh = CreateFile(filename,
2885 DELETE | GENERIC_READ | GENERIC_WRITE,
2889 FILE_ATTRIBUTE_NORMAL
2890 | FILE_FLAG_DELETE_ON_CLOSE,
2892 if (fh != INVALID_HANDLE_VALUE) {
2893 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2895 #if defined(__BORLANDC__)
2896 setmode(fd,O_BINARY);
2898 DEBUG_p(PerlIO_printf(Perl_debug_log,
2899 "Created tmpfile=%s\n",filename));
2911 int fd = win32_tmpfd();
2913 return win32_fdopen(fd, "w+b");
2925 win32_fstat(int fd, Stat_t *sbufptr)
2928 /* A file designated by filehandle is not shown as accessible
2929 * for write operations, probably because it is opened for reading.
2932 BY_HANDLE_FILE_INFORMATION bhfi;
2933 #if defined(WIN64) || defined(USE_LARGE_FILES)
2934 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2936 int rc = fstat(fd,&tmp);
2938 sbufptr->st_dev = tmp.st_dev;
2939 sbufptr->st_ino = tmp.st_ino;
2940 sbufptr->st_mode = tmp.st_mode;
2941 sbufptr->st_nlink = tmp.st_nlink;
2942 sbufptr->st_uid = tmp.st_uid;
2943 sbufptr->st_gid = tmp.st_gid;
2944 sbufptr->st_rdev = tmp.st_rdev;
2945 sbufptr->st_size = tmp.st_size;
2946 sbufptr->st_atime = tmp.st_atime;
2947 sbufptr->st_mtime = tmp.st_mtime;
2948 sbufptr->st_ctime = tmp.st_ctime;
2950 int rc = fstat(fd,sbufptr);
2953 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2954 #if defined(WIN64) || defined(USE_LARGE_FILES)
2955 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2957 sbufptr->st_mode &= 0xFE00;
2958 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2959 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2961 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2962 + ((S_IREAD|S_IWRITE) >> 6));
2966 return my_fstat(fd,sbufptr);
2971 win32_pipe(int *pfd, unsigned int size, int mode)
2973 return _pipe(pfd, size, mode);
2977 win32_popenlist(const char *mode, IV narg, SV **args)
2980 Perl_croak(aTHX_ "List form of pipe open not implemented");
2985 * a popen() clone that respects PERL5SHELL
2987 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2991 win32_popen(const char *command, const char *mode)
2993 #ifdef USE_RTL_POPEN
2994 return _popen(command, mode);
3006 /* establish which ends read and write */
3007 if (strchr(mode,'w')) {
3008 stdfd = 0; /* stdin */
3011 nhandle = STD_INPUT_HANDLE;
3013 else if (strchr(mode,'r')) {
3014 stdfd = 1; /* stdout */
3017 nhandle = STD_OUTPUT_HANDLE;
3022 /* set the correct mode */
3023 if (strchr(mode,'b'))
3025 else if (strchr(mode,'t'))
3028 ourmode = _fmode & (O_TEXT | O_BINARY);
3030 /* the child doesn't inherit handles */
3031 ourmode |= O_NOINHERIT;
3033 if (win32_pipe(p, 512, ourmode) == -1)
3036 /* save the old std handle (this needs to happen before the
3037 * dup2(), since that might call SetStdHandle() too) */
3040 old_h = GetStdHandle(nhandle);
3042 /* save current stdfd */
3043 if ((oldfd = win32_dup(stdfd)) == -1)
3046 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3047 /* stdfd will be inherited by the child */
3048 if (win32_dup2(p[child], stdfd) == -1)
3051 /* close the child end in parent */
3052 win32_close(p[child]);
3054 /* set the new std handle (in case dup2() above didn't) */
3055 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3057 /* start the child */
3060 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3063 /* revert stdfd to whatever it was before */
3064 if (win32_dup2(oldfd, stdfd) == -1)
3067 /* close saved handle */
3070 /* restore the old std handle (this needs to happen after the
3071 * dup2(), since that might call SetStdHandle() too */
3073 SetStdHandle(nhandle, old_h);
3079 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3082 /* set process id so that it can be returned by perl's open() */
3083 PL_forkprocess = childpid;
3086 /* we have an fd, return a file stream */
3087 return (PerlIO_fdopen(p[parent], (char *)mode));
3090 /* we don't need to check for errors here */
3094 win32_dup2(oldfd, stdfd);
3098 SetStdHandle(nhandle, old_h);
3104 #endif /* USE_RTL_POPEN */
3112 win32_pclose(PerlIO *pf)
3114 #ifdef USE_RTL_POPEN
3118 int childpid, status;
3122 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3125 childpid = SvIVX(sv);
3143 if (win32_waitpid(childpid, &status, 0) == -1)
3148 #endif /* USE_RTL_POPEN */
3154 LPCWSTR lpExistingFileName,
3155 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3158 WCHAR wFullName[MAX_PATH+1];
3159 LPVOID lpContext = NULL;
3160 WIN32_STREAM_ID StreamId;
3161 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3166 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3167 BOOL, BOOL, LPVOID*) =
3168 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3169 BOOL, BOOL, LPVOID*))
3170 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3171 if (pfnBackupWrite == NULL)
3174 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3177 dwLen = (dwLen+1)*sizeof(WCHAR);
3179 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3180 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3181 NULL, OPEN_EXISTING, 0, NULL);
3182 if (handle == INVALID_HANDLE_VALUE)
3185 StreamId.dwStreamId = BACKUP_LINK;
3186 StreamId.dwStreamAttributes = 0;
3187 StreamId.dwStreamNameSize = 0;
3188 #if defined(__BORLANDC__) \
3189 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3190 StreamId.Size.u.HighPart = 0;
3191 StreamId.Size.u.LowPart = dwLen;
3193 StreamId.Size.HighPart = 0;
3194 StreamId.Size.LowPart = dwLen;
3197 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3198 FALSE, FALSE, &lpContext);
3200 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3201 FALSE, FALSE, &lpContext);
3202 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3205 CloseHandle(handle);
3210 win32_link(const char *oldname, const char *newname)
3213 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3214 WCHAR wOldName[MAX_PATH+1];
3215 WCHAR wNewName[MAX_PATH+1];
3218 Perl_croak(aTHX_ PL_no_func, "link");
3220 pfnCreateHardLinkW =
3221 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3222 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3223 if (pfnCreateHardLinkW == NULL)
3224 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3226 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3227 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3228 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3229 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3233 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3238 win32_rename(const char *oname, const char *newname)
3240 char szOldName[MAX_PATH+1];
3241 char szNewName[MAX_PATH+1];
3245 /* XXX despite what the documentation says about MoveFileEx(),
3246 * it doesn't work under Windows95!
3249 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3250 if (stricmp(newname, oname))
3251 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3252 strcpy(szOldName, PerlDir_mapA(oname));
3253 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3255 DWORD err = GetLastError();
3257 case ERROR_BAD_NET_NAME:
3258 case ERROR_BAD_NETPATH:
3259 case ERROR_BAD_PATHNAME:
3260 case ERROR_FILE_NOT_FOUND:
3261 case ERROR_FILENAME_EXCED_RANGE:
3262 case ERROR_INVALID_DRIVE:
3263 case ERROR_NO_MORE_FILES:
3264 case ERROR_PATH_NOT_FOUND:
3277 char szTmpName[MAX_PATH+1];
3278 char dname[MAX_PATH+1];
3279 char *endname = NULL;
3281 DWORD from_attr, to_attr;
3283 strcpy(szOldName, PerlDir_mapA(oname));
3284 strcpy(szNewName, PerlDir_mapA(newname));
3286 /* if oname doesn't exist, do nothing */
3287 from_attr = GetFileAttributes(szOldName);
3288 if (from_attr == 0xFFFFFFFF) {
3293 /* if newname exists, rename it to a temporary name so that we
3294 * don't delete it in case oname happens to be the same file
3295 * (but perhaps accessed via a different path)
3297 to_attr = GetFileAttributes(szNewName);
3298 if (to_attr != 0xFFFFFFFF) {
3299 /* if newname is a directory, we fail
3300 * XXX could overcome this with yet more convoluted logic */
3301 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3305 tmplen = strlen(szNewName);
3306 strcpy(szTmpName,szNewName);
3307 endname = szTmpName+tmplen;
3308 for (; endname > szTmpName ; --endname) {
3309 if (*endname == '/' || *endname == '\\') {
3314 if (endname > szTmpName)
3315 endname = strcpy(dname,szTmpName);
3319 /* get a temporary filename in same directory
3320 * XXX is this really the best we can do? */
3321 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3325 DeleteFile(szTmpName);
3327 retval = rename(szNewName, szTmpName);
3334 /* rename oname to newname */
3335 retval = rename(szOldName, szNewName);
3337 /* if we created a temporary file before ... */
3338 if (endname != NULL) {
3339 /* ...and rename succeeded, delete temporary file/directory */
3341 DeleteFile(szTmpName);
3342 /* else restore it to what it was */
3344 (void)rename(szTmpName, szNewName);
3351 win32_setmode(int fd, int mode)
3353 return setmode(fd, mode);
3357 win32_chsize(int fd, Off_t size)
3359 #if defined(WIN64) || defined(USE_LARGE_FILES)
3361 Off_t cur, end, extend;
3363 cur = win32_tell(fd);
3366 end = win32_lseek(fd, 0, SEEK_END);
3369 extend = size - end;
3373 else if (extend > 0) {
3374 /* must grow the file, padding with nulls */
3376 int oldmode = win32_setmode(fd, O_BINARY);
3378 memset(b, '\0', sizeof(b));
3380 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3381 count = win32_write(fd, b, count);
3382 if ((int)count < 0) {
3386 } while ((extend -= count) > 0);
3387 win32_setmode(fd, oldmode);
3390 /* shrink the file */
3391 win32_lseek(fd, size, SEEK_SET);
3392 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3398 win32_lseek(fd, cur, SEEK_SET);
3401 return chsize(fd, (long)size);
3406 win32_lseek(int fd, Off_t offset, int origin)
3408 #if defined(WIN64) || defined(USE_LARGE_FILES)
3409 #if defined(__BORLANDC__) /* buk */
3411 pos.QuadPart = offset;
3412 pos.LowPart = SetFilePointer(
3413 (HANDLE)_get_osfhandle(fd),
3418 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3422 return pos.QuadPart;
3424 return _lseeki64(fd, offset, origin);
3427 return lseek(fd, (long)offset, origin);
3434 #if defined(WIN64) || defined(USE_LARGE_FILES)
3435 #if defined(__BORLANDC__) /* buk */
3438 pos.LowPart = SetFilePointer(
3439 (HANDLE)_get_osfhandle(fd),
3444 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3448 return pos.QuadPart;
3449 /* return tell(fd); */
3451 return _telli64(fd);
3459 win32_open(const char *path, int flag, ...)
3466 pmode = va_arg(ap, int);
3469 if (stricmp(path, "/dev/null")==0)
3472 return open(PerlDir_mapA(path), flag, pmode);
3475 /* close() that understands socket */
3476 extern int my_close(int); /* in win32sck.c */
3481 return my_close(fd);
3497 win32_dup2(int fd1,int fd2)
3499 return dup2(fd1,fd2);
3502 #ifdef PERL_MSVCRT_READFIX
3504 #define LF 10 /* line feed */
3505 #define CR 13 /* carriage return */
3506 #define CTRLZ 26 /* ctrl-z means eof for text */
3507 #define FOPEN 0x01 /* file handle open */
3508 #define FEOFLAG 0x02 /* end of file has been encountered */
3509 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3510 #define FPIPE 0x08 /* file handle refers to a pipe */
3511 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3512 #define FDEV 0x40 /* file handle refers to device */
3513 #define FTEXT 0x80 /* file handle is in text mode */
3514 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3517 _fixed_read(int fh, void *buf, unsigned cnt)
3519 int bytes_read; /* number of bytes read */
3520 char *buffer; /* buffer to read to */
3521 int os_read; /* bytes read on OS call */
3522 char *p, *q; /* pointers into buffer */
3523 char peekchr; /* peek-ahead character */
3524 ULONG filepos; /* file position after seek */
3525 ULONG dosretval; /* o.s. return value */
3527 /* validate handle */
3528 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3529 !(_osfile(fh) & FOPEN))
3531 /* out of range -- return error */
3533 _doserrno = 0; /* not o.s. error */
3538 * If lockinitflag is FALSE, assume fd is device
3539 * lockinitflag is set to TRUE by open.
3541 if (_pioinfo(fh)->lockinitflag)
3542 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3544 bytes_read = 0; /* nothing read yet */
3545 buffer = (char*)buf;
3547 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3548 /* nothing to read or at EOF, so return 0 read */
3552 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3553 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3555 *buffer++ = _pipech(fh);
3558 _pipech(fh) = LF; /* mark as empty */
3563 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3565 /* ReadFile has reported an error. recognize two special cases.
3567 * 1. map ERROR_ACCESS_DENIED to EBADF
3569 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3570 * means the handle is a read-handle on a pipe for which
3571 * all write-handles have been closed and all data has been
3574 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3575 /* wrong read/write mode should return EBADF, not EACCES */
3577 _doserrno = dosretval;
3581 else if (dosretval == ERROR_BROKEN_PIPE) {
3591 bytes_read += os_read; /* update bytes read */
3593 if (_osfile(fh) & FTEXT) {
3594 /* now must translate CR-LFs to LFs in the buffer */
3596 /* set CRLF flag to indicate LF at beginning of buffer */
3597 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3598 /* _osfile(fh) |= FCRLF; */
3600 /* _osfile(fh) &= ~FCRLF; */
3602 _osfile(fh) &= ~FCRLF;
3604 /* convert chars in the buffer: p is src, q is dest */
3606 while (p < (char *)buf + bytes_read) {
3608 /* if fh is not a device, set ctrl-z flag */
3609 if (!(_osfile(fh) & FDEV))
3610 _osfile(fh) |= FEOFLAG;
3611 break; /* stop translating */
3616 /* *p is CR, so must check next char for LF */
3617 if (p < (char *)buf + bytes_read - 1) {
3620 *q++ = LF; /* convert CR-LF to LF */
3623 *q++ = *p++; /* store char normally */
3626 /* This is the hard part. We found a CR at end of
3627 buffer. We must peek ahead to see if next char
3632 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3633 (LPDWORD)&os_read, NULL))
3634 dosretval = GetLastError();
3636 if (dosretval != 0 || os_read == 0) {
3637 /* couldn't read ahead, store CR */
3641 /* peekchr now has the extra character -- we now
3642 have several possibilities:
3643 1. disk file and char is not LF; just seek back
3645 2. disk file and char is LF; store LF, don't seek back
3646 3. pipe/device and char is LF; store LF.
3647 4. pipe/device and char isn't LF, store CR and
3648 put char in pipe lookahead buffer. */
3649 if (_osfile(fh) & (FDEV|FPIPE)) {
3650 /* non-seekable device */
3655 _pipech(fh) = peekchr;
3660 if (peekchr == LF) {
3661 /* nothing read yet; must make some
3664 /* turn on this flag for tell routine */
3665 _osfile(fh) |= FCRLF;
3668 HANDLE osHandle; /* o.s. handle value */
3670 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3672 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3673 dosretval = GetLastError();
3684 /* we now change bytes_read to reflect the true number of chars
3686 bytes_read = q - (char *)buf;
3690 if (_pioinfo(fh)->lockinitflag)
3691 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3696 #endif /* PERL_MSVCRT_READFIX */
3699 win32_read(int fd, void *buf, unsigned int cnt)
3701 #ifdef PERL_MSVCRT_READFIX
3702 return _fixed_read(fd, buf, cnt);
3704 return read(fd, buf, cnt);
3709 win32_write(int fd, const void *buf, unsigned int cnt)
3711 return write(fd, buf, cnt);
3715 win32_mkdir(const char *dir, int mode)
3718 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3722 win32_rmdir(const char *dir)
3725 return rmdir(PerlDir_mapA(dir));
3729 win32_chdir(const char *dir)
3740 win32_access(const char *path, int mode)
3743 return access(PerlDir_mapA(path), mode);
3747 win32_chmod(const char *path, int mode)
3750 return chmod(PerlDir_mapA(path), mode);
3755 create_command_line(char *cname, STRLEN clen, const char * const *args)
3762 bool bat_file = FALSE;
3763 bool cmd_shell = FALSE;
3764 bool dumb_shell = FALSE;
3765 bool extra_quotes = FALSE;
3766 bool quote_next = FALSE;
3769 cname = (char*)args[0];
3771 /* The NT cmd.exe shell has the following peculiarity that needs to be
3772 * worked around. It strips a leading and trailing dquote when any
3773 * of the following is true:
3774 * 1. the /S switch was used
3775 * 2. there are more than two dquotes
3776 * 3. there is a special character from this set: &<>()@^|
3777 * 4. no whitespace characters within the two dquotes
3778 * 5. string between two dquotes isn't an executable file
3779 * To work around this, we always add a leading and trailing dquote
3780 * to the string, if the first argument is either "cmd.exe" or "cmd",
3781 * and there were at least two or more arguments passed to cmd.exe
3782 * (not including switches).
3783 * XXX the above rules (from "cmd /?") don't seem to be applied
3784 * always, making for the convolutions below :-(
3788 clen = strlen(cname);
3791 && (stricmp(&cname[clen-4], ".bat") == 0
3792 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3799 char *exe = strrchr(cname, '/');
3800 char *exe2 = strrchr(cname, '\\');
3807 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3811 else if (stricmp(exe, "command.com") == 0
3812 || stricmp(exe, "command") == 0)
3819 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3820 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3821 STRLEN curlen = strlen(arg);
3822 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3823 len += 2; /* assume quoting needed (worst case) */
3825 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3827 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3830 Newx(cmd, len, char);
3833 if (bat_file && !IsWin95()) {
3835 extra_quotes = TRUE;
3838 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3840 STRLEN curlen = strlen(arg);
3842 /* we want to protect empty arguments and ones with spaces with
3843 * dquotes, but only if they aren't already there */
3848 else if (quote_next) {
3849 /* see if it really is multiple arguments pretending to
3850 * be one and force a set of quotes around it */
3851 if (*find_next_space(arg))
3854 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3856 while (i < curlen) {
3857 if (isSPACE(arg[i])) {
3860 else if (arg[i] == '"') {
3884 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3885 && stricmp(arg+curlen-2, "/c") == 0)
3887 /* is there a next argument? */
3888 if (args[index+1]) {
3889 /* are there two or more next arguments? */
3890 if (args[index+2]) {
3892 extra_quotes = TRUE;
3895 /* single argument, force quoting if it has spaces */
3911 qualified_path(const char *cmd)
3915 char *fullcmd, *curfullcmd;
3921 fullcmd = (char*)cmd;
3923 if (*fullcmd == '/' || *fullcmd == '\\')
3930 pathstr = PerlEnv_getenv("PATH");
3932 /* worst case: PATH is a single directory; we need additional space
3933 * to append "/", ".exe" and trailing "\0" */
3934 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3935 curfullcmd = fullcmd;
3940 /* start by appending the name to the current prefix */
3941 strcpy(curfullcmd, cmd);
3942 curfullcmd += cmdlen;
3944 /* if it doesn't end with '.', or has no extension, try adding
3945 * a trailing .exe first */
3946 if (cmd[cmdlen-1] != '.'
3947 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3949 strcpy(curfullcmd, ".exe");
3950 res = GetFileAttributes(fullcmd);
3951 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3956 /* that failed, try the bare name */
3957 res = GetFileAttributes(fullcmd);
3958 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3961 /* quit if no other path exists, or if cmd already has path */
3962 if (!pathstr || !*pathstr || has_slash)
3965 /* skip leading semis */
3966 while (*pathstr == ';')
3969 /* build a new prefix from scratch */
3970 curfullcmd = fullcmd;
3971 while (*pathstr && *pathstr != ';') {
3972 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3973 pathstr++; /* skip initial '"' */
3974 while (*pathstr && *pathstr != '"') {
3975 *curfullcmd++ = *pathstr++;
3978 pathstr++; /* skip trailing '"' */
3981 *curfullcmd++ = *pathstr++;
3985 pathstr++; /* skip trailing semi */
3986 if (curfullcmd > fullcmd /* append a dir separator */
3987 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3989 *curfullcmd++ = '\\';
3997 /* The following are just place holders.
3998 * Some hosts may provide and environment that the OS is
3999 * not tracking, therefore, these host must provide that
4000 * environment and the current directory to CreateProcess
4004 win32_get_childenv(void)
4010 win32_free_childenv(void* d)
4015 win32_clearenv(void)
4017 char *envv = GetEnvironmentStrings();
4021 char *end = strchr(cur,'=');
4022 if (end && end != cur) {
4024 SetEnvironmentVariable(cur, NULL);
4026 cur = end + strlen(end+1)+2;
4028 else if ((len = strlen(cur)))
4031 FreeEnvironmentStrings(envv);
4035 win32_get_childdir(void)
4039 char szfilename[MAX_PATH+1];
4041 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4042 Newx(ptr, strlen(szfilename)+1, char);
4043 strcpy(ptr, szfilename);
4048 win32_free_childdir(char* d)
4055 /* XXX this needs to be made more compatible with the spawnvp()
4056 * provided by the various RTLs. In particular, searching for
4057 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4058 * This doesn't significantly affect perl itself, because we
4059 * always invoke things using PERL5SHELL if a direct attempt to
4060 * spawn the executable fails.
4062 * XXX splitting and rejoining the commandline between do_aspawn()
4063 * and win32_spawnvp() could also be avoided.
4067 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4069 #ifdef USE_RTL_SPAWNVP
4070 return spawnvp(mode, cmdname, (char * const *)argv);
4077 STARTUPINFO StartupInfo;
4078 PROCESS_INFORMATION ProcessInformation;
4081 char *fullcmd = NULL;
4082 char *cname = (char *)cmdname;
4086 clen = strlen(cname);
4087 /* if command name contains dquotes, must remove them */
4088 if (strchr(cname, '"')) {
4090 Newx(cname,clen+1,char);
4103 cmd = create_command_line(cname, clen, argv);
4105 env = PerlEnv_get_childenv();
4106 dir = PerlEnv_get_childdir();
4109 case P_NOWAIT: /* asynch + remember result */
4110 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4115 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4118 create |= CREATE_NEW_PROCESS_GROUP;
4121 case P_WAIT: /* synchronous execution */
4123 default: /* invalid mode */
4128 memset(&StartupInfo,0,sizeof(StartupInfo));
4129 StartupInfo.cb = sizeof(StartupInfo);
4130 memset(&tbl,0,sizeof(tbl));
4131 PerlEnv_get_child_IO(&tbl);
4132 StartupInfo.dwFlags = tbl.dwFlags;
4133 StartupInfo.dwX = tbl.dwX;
4134 StartupInfo.dwY = tbl.dwY;
4135 StartupInfo.dwXSize = tbl.dwXSize;
4136 StartupInfo.dwYSize = tbl.dwYSize;
4137 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4138 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4139 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4140 StartupInfo.wShowWindow = tbl.wShowWindow;
4141 StartupInfo.hStdInput = tbl.childStdIn;
4142 StartupInfo.hStdOutput = tbl.childStdOut;
4143 StartupInfo.hStdError = tbl.childStdErr;
4144 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4145 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4146 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4148 create |= CREATE_NEW_CONSOLE;
4151 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4153 if (w32_use_showwindow) {
4154 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4155 StartupInfo.wShowWindow = w32_showwindow;
4158 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4161 if (!CreateProcess(cname, /* search PATH to find executable */
4162 cmd, /* executable, and its arguments */
4163 NULL, /* process attributes */
4164 NULL, /* thread attributes */
4165 TRUE, /* inherit handles */
4166 create, /* creation flags */
4167 (LPVOID)env, /* inherit environment */
4168 dir, /* inherit cwd */
4170 &ProcessInformation))
4172 /* initial NULL argument to CreateProcess() does a PATH
4173 * search, but it always first looks in the directory
4174 * where the current process was started, which behavior
4175 * is undesirable for backward compatibility. So we
4176 * jump through our own hoops by picking out the path
4177 * we really want it to use. */
4179 fullcmd = qualified_path(cname);
4181 if (cname != cmdname)
4184 DEBUG_p(PerlIO_printf(Perl_debug_log,
4185 "Retrying [%s] with same args\n",
4195 if (mode == P_NOWAIT) {
4196 /* asynchronous spawn -- store handle, return PID */
4197 ret = (int)ProcessInformation.dwProcessId;
4198 if (IsWin95() && ret < 0)
4201 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4202 w32_child_pids[w32_num_children] = (DWORD)ret;
4207 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4208 /* FIXME: if msgwait returned due to message perhaps forward the
4209 "signal" to the process
4211 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4213 CloseHandle(ProcessInformation.hProcess);
4216 CloseHandle(ProcessInformation.hThread);
4219 PerlEnv_free_childenv(env);
4220 PerlEnv_free_childdir(dir);
4222 if (cname != cmdname)
4229 win32_execv(const char *cmdname, const char *const *argv)
4233 /* if this is a pseudo-forked child, we just want to spawn
4234 * the new program, and return */
4236 # ifdef __BORLANDC__
4237 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4239 return spawnv(P_WAIT, cmdname, argv);
4243 return execv(cmdname, (char *const *)argv);
4245 return execv(cmdname, argv);
4250 win32_execvp(const char *cmdname, const char *const *argv)
4254 /* if this is a pseudo-forked child, we just want to spawn
4255 * the new program, and return */
4256 if (w32_pseudo_id) {
4257 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4267 return execvp(cmdname, (char *const *)argv);
4269 return execvp(cmdname, argv);
4274 win32_perror(const char *str)
4280 win32_setbuf(FILE *pf, char *buf)
4286 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4288 return setvbuf(pf, buf, type, size);
4292 win32_flushall(void)
4298 win32_fcloseall(void)
4304 win32_fgets(char *s, int n, FILE *pf)
4306 return fgets(s, n, pf);
4316 win32_fgetc(FILE *pf)
4322 win32_putc(int c, FILE *pf)
4328 win32_puts(const char *s)
4340 win32_putchar(int c)
4347 #ifndef USE_PERL_SBRK
4349 static char *committed = NULL; /* XXX threadead */
4350 static char *base = NULL; /* XXX threadead */
4351 static char *reserved = NULL; /* XXX threadead */
4352 static char *brk = NULL; /* XXX threadead */
4353 static DWORD pagesize = 0; /* XXX threadead */
4356 sbrk(ptrdiff_t need)
4361 GetSystemInfo(&info);
4362 /* Pretend page size is larger so we don't perpetually
4363 * call the OS to commit just one page ...
4365 pagesize = info.dwPageSize << 3;
4367 if (brk+need >= reserved)
4369 DWORD size = brk+need-reserved;
4371 char *prev_committed = NULL;
4372 if (committed && reserved && committed < reserved)
4374 /* Commit last of previous chunk cannot span allocations */
4375 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4378 /* Remember where we committed from in case we want to decommit later */
4379 prev_committed = committed;
4380 committed = reserved;
4383 /* Reserve some (more) space
4384 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4385 * this is only address space not memory...
4386 * Note this is a little sneaky, 1st call passes NULL as reserved
4387 * so lets system choose where we start, subsequent calls pass
4388 * the old end address so ask for a contiguous block
4391 if (size < 64*1024*1024)
4392 size = 64*1024*1024;
4393 size = ((size + pagesize - 1) / pagesize) * pagesize;
4394 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4397 reserved = addr+size;
4407 /* The existing block could not be extended far enough, so decommit
4408 * anything that was just committed above and start anew */
4411 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4414 reserved = base = committed = brk = NULL;
4425 if (brk > committed)
4427 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4429 if (committed+size > reserved)
4430 size = reserved-committed;
4431 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4444 win32_malloc(size_t size)
4446 return malloc(size);
4450 win32_calloc(size_t numitems, size_t size)
4452 return calloc(numitems,size);
4456 win32_realloc(void *block, size_t size)
4458 return realloc(block,size);
4462 win32_free(void *block)
4469 win32_open_osfhandle(intptr_t handle, int flags)
4471 #ifdef USE_FIXED_OSFHANDLE
4473 return my_open_osfhandle(handle, flags);
4475 return _open_osfhandle(handle, flags);
4479 win32_get_osfhandle(int fd)
4481 return (intptr_t)_get_osfhandle(fd);
4485 win32_fdupopen(FILE *pf)
4490 int fileno = win32_dup(win32_fileno(pf));
4492 /* open the file in the same mode */
4494 if((pf)->flags & _F_READ) {
4498 else if((pf)->flags & _F_WRIT) {
4502 else if((pf)->flags & _F_RDWR) {
4508 if((pf)->_flag & _IOREAD) {
4512 else if((pf)->_flag & _IOWRT) {
4516 else if((pf)->_flag & _IORW) {
4523 /* it appears that the binmode is attached to the
4524 * file descriptor so binmode files will be handled
4527 pfdup = win32_fdopen(fileno, mode);
4529 /* move the file pointer to the same position */
4530 if (!fgetpos(pf, &pos)) {
4531 fsetpos(pfdup, &pos);
4537 win32_dynaload(const char* filename)
4540 char buf[MAX_PATH+1];
4543 /* LoadLibrary() doesn't recognize forward slashes correctly,
4544 * so turn 'em back. */
4545 first = strchr(filename, '/');
4547 STRLEN len = strlen(filename);
4548 if (len <= MAX_PATH) {
4549 strcpy(buf, filename);
4550 filename = &buf[first - filename];
4552 if (*filename == '/')
4553 *(char*)filename = '\\';
4559 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4562 XS(w32_SetChildShowWindow)
4565 BOOL use_showwindow = w32_use_showwindow;
4566 /* use "unsigned short" because Perl has redefined "WORD" */
4567 unsigned short showwindow = w32_showwindow;
4570 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4572 if (items == 0 || !SvOK(ST(0)))
4573 w32_use_showwindow = FALSE;
4575 w32_use_showwindow = TRUE;
4576 w32_showwindow = (unsigned short)SvIV(ST(0));
4581 ST(0) = sv_2mortal(newSViv(showwindow));
4583 ST(0) = &PL_sv_undef;
4588 Perl_init_os_extras(void)
4591 char *file = __FILE__;
4593 /* Initialize Win32CORE if it has been statically linked. */
4594 void (*pfn_init)(pTHX);
4595 #if defined(__BORLANDC__)
4596 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4597 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4599 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4604 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4608 win32_signal_context(void)
4613 my_perl = PL_curinterp;
4614 PERL_SET_THX(my_perl);
4618 return PL_curinterp;
4624 win32_ctrlhandler(DWORD dwCtrlType)
4627 dTHXa(PERL_GET_SIG_CONTEXT);
4633 switch(dwCtrlType) {
4634 case CTRL_CLOSE_EVENT:
4635 /* A signal that the system sends to all processes attached to a console when
4636 the user closes the console (either by choosing the Close command from the
4637 console window's System menu, or by choosing the End Task command from the
4640 if (do_raise(aTHX_ 1)) /* SIGHUP */
4641 sig_terminate(aTHX_ 1);
4645 /* A CTRL+c signal was received */
4646 if (do_raise(aTHX_ SIGINT))
4647 sig_terminate(aTHX_ SIGINT);
4650 case CTRL_BREAK_EVENT:
4651 /* A CTRL+BREAK signal was received */
4652 if (do_raise(aTHX_ SIGBREAK))
4653 sig_terminate(aTHX_ SIGBREAK);
4656 case CTRL_LOGOFF_EVENT:
4657 /* A signal that the system sends to all console processes when a user is logging
4658 off. This signal does not indicate which user is logging off, so no
4659 assumptions can be made.
4662 case CTRL_SHUTDOWN_EVENT:
4663 /* A signal that the system sends to all console processes when the system is
4666 if (do_raise(aTHX_ SIGTERM))
4667 sig_terminate(aTHX_ SIGTERM);
4676 #ifdef SET_INVALID_PARAMETER_HANDLER
4677 # include <crtdbg.h>
4688 /* win32_ansipath() requires Windows 2000 or later */
4692 /* fetch Unicode version of PATH */
4694 wide_path = win32_malloc(len*sizeof(WCHAR));
4696 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4700 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4705 /* convert to ANSI pathnames */
4706 wide_dir = wide_path;
4709 WCHAR *sep = wcschr(wide_dir, ';');
4717 /* remove quotes around pathname */
4718 if (*wide_dir == '"')
4720 wide_len = wcslen(wide_dir);
4721 if (wide_len && wide_dir[wide_len-1] == '"')
4722 wide_dir[wide_len-1] = '\0';
4724 /* append ansi_dir to ansi_path */
4725 ansi_dir = win32_ansipath(wide_dir);
4726 ansi_len = strlen(ansi_dir);
4728 size_t newlen = len + 1 + ansi_len;
4729 ansi_path = win32_realloc(ansi_path, newlen+1);
4732 ansi_path[len] = ';';
4733 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4738 ansi_path = win32_malloc(5+len+1);
4741 memcpy(ansi_path, "PATH=", 5);
4742 memcpy(ansi_path+5, ansi_dir, len+1);
4745 win32_free(ansi_dir);
4750 /* Update C RTL environ array. This will only have full effect if
4751 * perl_parse() is later called with `environ` as the `env` argument.
4752 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4754 * We do have to ansify() the PATH before Perl has been fully
4755 * initialized because S_find_script() uses the PATH when perl
4756 * is being invoked with the -S option. This happens before %ENV
4757 * is initialized in S_init_postdump_symbols().
4759 * XXX Is this a bug? Should S_find_script() use the environment
4760 * XXX passed in the `env` arg to parse_perl()?
4763 /* Keep system environment in sync because S_init_postdump_symbols()
4764 * will not call mg_set() if it initializes %ENV from `environ`.
4766 SetEnvironmentVariableA("PATH", ansi_path+5);
4767 /* We are intentionally leaking the ansi_path string here because
4768 * the Borland runtime library puts it directly into the environ
4769 * array. The Microsoft runtime library seems to make a copy,
4770 * but will leak the copy should it be replaced again later.
4771 * Since this code is only called once during PERL_SYS_INIT this
4772 * shouldn't really matter.
4775 win32_free(wide_path);
4779 Perl_win32_init(int *argcp, char ***argvp)
4783 #ifdef SET_INVALID_PARAMETER_HANDLER
4784 _invalid_parameter_handler oldHandler, newHandler;
4785 newHandler = my_invalid_parameter_handler;
4786 oldHandler = _set_invalid_parameter_handler(newHandler);
4787 _CrtSetReportMode(_CRT_ASSERT, 0);
4789 /* Disable floating point errors, Perl will trap the ones we
4790 * care about. VC++ RTL defaults to switching these off
4791 * already, but the Borland RTL doesn't. Since we don't
4792 * want to be at the vendor's whim on the default, we set
4793 * it explicitly here.
4795 #if !defined(_ALPHA_) && !defined(__GNUC__)
4796 _control87(MCW_EM, MCW_EM);
4800 module = GetModuleHandle("ntdll.dll");
4802 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4805 module = GetModuleHandle("kernel32.dll");
4807 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4808 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4809 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4812 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4813 GetVersionEx(&g_osver);
4819 Perl_win32_term(void)
4829 win32_get_child_IO(child_IO_table* ptbl)
4831 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4832 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4833 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4837 win32_signal(int sig, Sighandler_t subcode)
4840 if (sig < SIG_SIZE) {
4841 int save_errno = errno;
4842 Sighandler_t result = signal(sig, subcode);
4843 if (result == SIG_ERR) {
4844 result = w32_sighandler[sig];
4847 w32_sighandler[sig] = subcode;
4856 /* The PerlMessageWindowClass's WindowProc */
4858 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4860 return win32_process_message(hwnd, msg, wParam, lParam) ?
4861 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4864 /* we use a message filter hook to process thread messages, passing any
4865 * messages that we don't process on to the rest of the hook chain
4866 * Anyone else writing a message loop that wants to play nicely with perl
4868 * CallMsgFilter(&msg, MSGF_***);
4869 * between their GetMessage and DispatchMessage calls. */
4871 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4872 LPMSG pmsg = (LPMSG)lParam;
4874 /* we'll process it if code says we're allowed, and it's a thread message */
4875 if (code >= 0 && pmsg->hwnd == NULL
4876 && win32_process_message(pmsg->hwnd, pmsg->message,
4877 pmsg->wParam, pmsg->lParam))
4882 /* XXX: MSDN says that hhk is ignored, but we should really use the
4883 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4884 return CallNextHookEx(NULL, code, wParam, lParam);
4887 /* The real message handler. Can be called with
4888 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4889 * that it processes */
4891 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4893 /* BEWARE. The context retrieved using dTHX; is the context of the
4894 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4895 * up to and including WM_CREATE. If it ever happens that you need the
4896 * 'child' context before this, then it needs to be passed into
4897 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4898 * from the lparam of CreateWindow(). It could then be stored/retrieved
4899 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4900 * the dTHX calls here. */
4901 /* XXX For now it is assumed that the overhead of the dTHX; for what
4902 * are relativley infrequent code-paths, is better than the added
4903 * complexity of getting the correct context passed into
4904 * win32_create_message_window() */
4909 case WM_USER_MESSAGE: {
4910 long child = find_pseudo_pid((int)wParam);
4913 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4920 case WM_USER_KILL: {
4922 /* We use WM_USER_KILL to fake kill() with other signals */
4923 int sig = (int)wParam;
4924 if (do_raise(aTHX_ sig))
4925 sig_terminate(aTHX_ sig);
4932 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4933 if (w32_timerid && w32_timerid==(UINT)wParam) {
4934 KillTimer(w32_message_hwnd, w32_timerid);
4937 /* Now fake a call to signal handler */
4938 if (do_raise(aTHX_ 14))
4939 sig_terminate(aTHX_ 14);
4951 /* Above or other stuff may have set a signal flag, and we may not have
4952 * been called from win32_async_check() (e.g. some other GUI's message
4953 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4954 * handler that die's, and the message loop that calls here is wrapped
4955 * in an eval, then you may well end up with orphaned windows - signals
4956 * are dispatched by win32_async_check() */
4962 win32_create_message_window_class(void)
4964 /* create the window class for "message only" windows */
4968 wc.lpfnWndProc = win32_message_window_proc;
4969 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4970 wc.lpszClassName = "PerlMessageWindowClass";
4972 /* second and subsequent calls will fail, but class
4973 * will already be registered */
4978 win32_create_message_window(void)
4982 /* "message-only" windows have been implemented in Windows 2000 and later.
4983 * On earlier versions we'll continue to post messages to a specific
4984 * thread and use hwnd==NULL. This is brittle when either an embedding
4985 * application or an XS module is also posting messages to hwnd=NULL
4986 * because once removed from the queue they cannot be delivered to the
4987 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4988 * if there is no window handle.
4990 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4991 * documentation to the contrary, however, there is some evidence that
4992 * there may be problems with the implementation on Win98. As it is not
4993 * officially supported we take the cautious route and stick with thread
4994 * messages (hwnd == NULL) on platforms prior to Win2k.
4997 win32_create_message_window_class();
4999 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
5000 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5003 /* If we din't create a window for any reason, then we'll use thread
5004 * messages for our signalling, so we install a hook which
5005 * is called by CallMsgFilter in win32_async_check(), or any other
5006 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5007 * that use OLE, etc. */
5009 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5010 NULL, GetCurrentThreadId());
5016 #ifdef HAVE_INTERP_INTERN
5019 win32_csighandler(int sig)
5022 dTHXa(PERL_GET_SIG_CONTEXT);
5023 Perl_warn(aTHX_ "Got signal %d",sig);
5028 #if defined(__MINGW32__) && defined(__cplusplus)
5029 #define CAST_HWND__(x) (HWND__*)(x)
5031 #define CAST_HWND__(x) x
5035 Perl_sys_intern_init(pTHX)
5039 w32_perlshell_tokens = NULL;
5040 w32_perlshell_vec = (char**)NULL;
5041 w32_perlshell_items = 0;
5042 w32_fdpid = newAV();
5043 Newx(w32_children, 1, child_tab);
5044 w32_num_children = 0;
5045 # ifdef USE_ITHREADS
5047 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5048 w32_num_pseudo_children = 0;
5051 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5053 for (i=0; i < SIG_SIZE; i++) {
5054 w32_sighandler[i] = SIG_DFL;
5056 # ifdef MULTIPLICITY
5057 if (my_perl == PL_curinterp) {
5061 /* Force C runtime signal stuff to set its console handler */
5062 signal(SIGINT,win32_csighandler);
5063 signal(SIGBREAK,win32_csighandler);
5065 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5066 * flag. This has the side-effect of disabling Ctrl-C events in all
5067 * processes in this group. At least on Windows NT and later we
5068 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5069 * with a NULL handler. This is not valid on Windows 9X.
5072 SetConsoleCtrlHandler(NULL,FALSE);
5074 /* Push our handler on top */
5075 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5080 Perl_sys_intern_clear(pTHX)
5082 Safefree(w32_perlshell_tokens);
5083 Safefree(w32_perlshell_vec);
5084 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5085 Safefree(w32_children);
5087 KillTimer(w32_message_hwnd, w32_timerid);
5090 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5091 DestroyWindow(w32_message_hwnd);
5092 # ifdef MULTIPLICITY
5093 if (my_perl == PL_curinterp) {
5097 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5099 # ifdef USE_ITHREADS
5100 Safefree(w32_pseudo_children);
5104 # ifdef USE_ITHREADS
5107 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5109 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5111 dst->perlshell_tokens = NULL;
5112 dst->perlshell_vec = (char**)NULL;
5113 dst->perlshell_items = 0;
5114 dst->fdpid = newAV();
5115 Newxz(dst->children, 1, child_tab);
5117 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5119 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5120 dst->poll_count = 0;
5121 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5123 # endif /* USE_ITHREADS */
5124 #endif /* HAVE_INTERP_INTERN */