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);
3078 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3080 /* set process id so that it can be returned by perl's open() */
3081 PL_forkprocess = childpid;
3084 /* we have an fd, return a file stream */
3085 return (PerlIO_fdopen(p[parent], (char *)mode));
3088 /* we don't need to check for errors here */
3092 win32_dup2(oldfd, stdfd);
3096 SetStdHandle(nhandle, old_h);
3102 #endif /* USE_RTL_POPEN */
3110 win32_pclose(PerlIO *pf)
3112 #ifdef USE_RTL_POPEN
3116 int childpid, status;
3119 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3122 childpid = SvIVX(sv);
3138 if (win32_waitpid(childpid, &status, 0) == -1)
3143 #endif /* USE_RTL_POPEN */
3149 LPCWSTR lpExistingFileName,
3150 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3153 WCHAR wFullName[MAX_PATH+1];
3154 LPVOID lpContext = NULL;
3155 WIN32_STREAM_ID StreamId;
3156 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3161 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3162 BOOL, BOOL, LPVOID*) =
3163 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3164 BOOL, BOOL, LPVOID*))
3165 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3166 if (pfnBackupWrite == NULL)
3169 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3172 dwLen = (dwLen+1)*sizeof(WCHAR);
3174 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3175 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3176 NULL, OPEN_EXISTING, 0, NULL);
3177 if (handle == INVALID_HANDLE_VALUE)
3180 StreamId.dwStreamId = BACKUP_LINK;
3181 StreamId.dwStreamAttributes = 0;
3182 StreamId.dwStreamNameSize = 0;
3183 #if defined(__BORLANDC__) \
3184 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3185 StreamId.Size.u.HighPart = 0;
3186 StreamId.Size.u.LowPart = dwLen;
3188 StreamId.Size.HighPart = 0;
3189 StreamId.Size.LowPart = dwLen;
3192 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3193 FALSE, FALSE, &lpContext);
3195 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3196 FALSE, FALSE, &lpContext);
3197 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3200 CloseHandle(handle);
3205 win32_link(const char *oldname, const char *newname)
3208 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3209 WCHAR wOldName[MAX_PATH+1];
3210 WCHAR wNewName[MAX_PATH+1];
3213 Perl_croak(aTHX_ PL_no_func, "link");
3215 pfnCreateHardLinkW =
3216 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3217 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3218 if (pfnCreateHardLinkW == NULL)
3219 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3221 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3222 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3223 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3224 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3228 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3233 win32_rename(const char *oname, const char *newname)
3235 char szOldName[MAX_PATH+1];
3236 char szNewName[MAX_PATH+1];
3240 /* XXX despite what the documentation says about MoveFileEx(),
3241 * it doesn't work under Windows95!
3244 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3245 if (stricmp(newname, oname))
3246 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3247 strcpy(szOldName, PerlDir_mapA(oname));
3248 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3250 DWORD err = GetLastError();
3252 case ERROR_BAD_NET_NAME:
3253 case ERROR_BAD_NETPATH:
3254 case ERROR_BAD_PATHNAME:
3255 case ERROR_FILE_NOT_FOUND:
3256 case ERROR_FILENAME_EXCED_RANGE:
3257 case ERROR_INVALID_DRIVE:
3258 case ERROR_NO_MORE_FILES:
3259 case ERROR_PATH_NOT_FOUND:
3272 char szTmpName[MAX_PATH+1];
3273 char dname[MAX_PATH+1];
3274 char *endname = NULL;
3276 DWORD from_attr, to_attr;
3278 strcpy(szOldName, PerlDir_mapA(oname));
3279 strcpy(szNewName, PerlDir_mapA(newname));
3281 /* if oname doesn't exist, do nothing */
3282 from_attr = GetFileAttributes(szOldName);
3283 if (from_attr == 0xFFFFFFFF) {
3288 /* if newname exists, rename it to a temporary name so that we
3289 * don't delete it in case oname happens to be the same file
3290 * (but perhaps accessed via a different path)
3292 to_attr = GetFileAttributes(szNewName);
3293 if (to_attr != 0xFFFFFFFF) {
3294 /* if newname is a directory, we fail
3295 * XXX could overcome this with yet more convoluted logic */
3296 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3300 tmplen = strlen(szNewName);
3301 strcpy(szTmpName,szNewName);
3302 endname = szTmpName+tmplen;
3303 for (; endname > szTmpName ; --endname) {
3304 if (*endname == '/' || *endname == '\\') {
3309 if (endname > szTmpName)
3310 endname = strcpy(dname,szTmpName);
3314 /* get a temporary filename in same directory
3315 * XXX is this really the best we can do? */
3316 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3320 DeleteFile(szTmpName);
3322 retval = rename(szNewName, szTmpName);
3329 /* rename oname to newname */
3330 retval = rename(szOldName, szNewName);
3332 /* if we created a temporary file before ... */
3333 if (endname != NULL) {
3334 /* ...and rename succeeded, delete temporary file/directory */
3336 DeleteFile(szTmpName);
3337 /* else restore it to what it was */
3339 (void)rename(szTmpName, szNewName);
3346 win32_setmode(int fd, int mode)
3348 return setmode(fd, mode);
3352 win32_chsize(int fd, Off_t size)
3354 #if defined(WIN64) || defined(USE_LARGE_FILES)
3356 Off_t cur, end, extend;
3358 cur = win32_tell(fd);
3361 end = win32_lseek(fd, 0, SEEK_END);
3364 extend = size - end;
3368 else if (extend > 0) {
3369 /* must grow the file, padding with nulls */
3371 int oldmode = win32_setmode(fd, O_BINARY);
3373 memset(b, '\0', sizeof(b));
3375 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3376 count = win32_write(fd, b, count);
3377 if ((int)count < 0) {
3381 } while ((extend -= count) > 0);
3382 win32_setmode(fd, oldmode);
3385 /* shrink the file */
3386 win32_lseek(fd, size, SEEK_SET);
3387 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3393 win32_lseek(fd, cur, SEEK_SET);
3396 return chsize(fd, (long)size);
3401 win32_lseek(int fd, Off_t offset, int origin)
3403 #if defined(WIN64) || defined(USE_LARGE_FILES)
3404 #if defined(__BORLANDC__) /* buk */
3406 pos.QuadPart = offset;
3407 pos.LowPart = SetFilePointer(
3408 (HANDLE)_get_osfhandle(fd),
3413 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3417 return pos.QuadPart;
3419 return _lseeki64(fd, offset, origin);
3422 return lseek(fd, (long)offset, origin);
3429 #if defined(WIN64) || defined(USE_LARGE_FILES)
3430 #if defined(__BORLANDC__) /* buk */
3433 pos.LowPart = SetFilePointer(
3434 (HANDLE)_get_osfhandle(fd),
3439 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3443 return pos.QuadPart;
3444 /* return tell(fd); */
3446 return _telli64(fd);
3454 win32_open(const char *path, int flag, ...)
3461 pmode = va_arg(ap, int);
3464 if (stricmp(path, "/dev/null")==0)
3467 return open(PerlDir_mapA(path), flag, pmode);
3470 /* close() that understands socket */
3471 extern int my_close(int); /* in win32sck.c */
3476 return my_close(fd);
3492 win32_dup2(int fd1,int fd2)
3494 return dup2(fd1,fd2);
3497 #ifdef PERL_MSVCRT_READFIX
3499 #define LF 10 /* line feed */
3500 #define CR 13 /* carriage return */
3501 #define CTRLZ 26 /* ctrl-z means eof for text */
3502 #define FOPEN 0x01 /* file handle open */
3503 #define FEOFLAG 0x02 /* end of file has been encountered */
3504 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3505 #define FPIPE 0x08 /* file handle refers to a pipe */
3506 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3507 #define FDEV 0x40 /* file handle refers to device */
3508 #define FTEXT 0x80 /* file handle is in text mode */
3509 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3512 _fixed_read(int fh, void *buf, unsigned cnt)
3514 int bytes_read; /* number of bytes read */
3515 char *buffer; /* buffer to read to */
3516 int os_read; /* bytes read on OS call */
3517 char *p, *q; /* pointers into buffer */
3518 char peekchr; /* peek-ahead character */
3519 ULONG filepos; /* file position after seek */
3520 ULONG dosretval; /* o.s. return value */
3522 /* validate handle */
3523 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3524 !(_osfile(fh) & FOPEN))
3526 /* out of range -- return error */
3528 _doserrno = 0; /* not o.s. error */
3533 * If lockinitflag is FALSE, assume fd is device
3534 * lockinitflag is set to TRUE by open.
3536 if (_pioinfo(fh)->lockinitflag)
3537 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3539 bytes_read = 0; /* nothing read yet */
3540 buffer = (char*)buf;
3542 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3543 /* nothing to read or at EOF, so return 0 read */
3547 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3548 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3550 *buffer++ = _pipech(fh);
3553 _pipech(fh) = LF; /* mark as empty */
3558 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3560 /* ReadFile has reported an error. recognize two special cases.
3562 * 1. map ERROR_ACCESS_DENIED to EBADF
3564 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3565 * means the handle is a read-handle on a pipe for which
3566 * all write-handles have been closed and all data has been
3569 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3570 /* wrong read/write mode should return EBADF, not EACCES */
3572 _doserrno = dosretval;
3576 else if (dosretval == ERROR_BROKEN_PIPE) {
3586 bytes_read += os_read; /* update bytes read */
3588 if (_osfile(fh) & FTEXT) {
3589 /* now must translate CR-LFs to LFs in the buffer */
3591 /* set CRLF flag to indicate LF at beginning of buffer */
3592 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3593 /* _osfile(fh) |= FCRLF; */
3595 /* _osfile(fh) &= ~FCRLF; */
3597 _osfile(fh) &= ~FCRLF;
3599 /* convert chars in the buffer: p is src, q is dest */
3601 while (p < (char *)buf + bytes_read) {
3603 /* if fh is not a device, set ctrl-z flag */
3604 if (!(_osfile(fh) & FDEV))
3605 _osfile(fh) |= FEOFLAG;
3606 break; /* stop translating */
3611 /* *p is CR, so must check next char for LF */
3612 if (p < (char *)buf + bytes_read - 1) {
3615 *q++ = LF; /* convert CR-LF to LF */
3618 *q++ = *p++; /* store char normally */
3621 /* This is the hard part. We found a CR at end of
3622 buffer. We must peek ahead to see if next char
3627 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3628 (LPDWORD)&os_read, NULL))
3629 dosretval = GetLastError();
3631 if (dosretval != 0 || os_read == 0) {
3632 /* couldn't read ahead, store CR */
3636 /* peekchr now has the extra character -- we now
3637 have several possibilities:
3638 1. disk file and char is not LF; just seek back
3640 2. disk file and char is LF; store LF, don't seek back
3641 3. pipe/device and char is LF; store LF.
3642 4. pipe/device and char isn't LF, store CR and
3643 put char in pipe lookahead buffer. */
3644 if (_osfile(fh) & (FDEV|FPIPE)) {
3645 /* non-seekable device */
3650 _pipech(fh) = peekchr;
3655 if (peekchr == LF) {
3656 /* nothing read yet; must make some
3659 /* turn on this flag for tell routine */
3660 _osfile(fh) |= FCRLF;
3663 HANDLE osHandle; /* o.s. handle value */
3665 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3667 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3668 dosretval = GetLastError();
3679 /* we now change bytes_read to reflect the true number of chars
3681 bytes_read = q - (char *)buf;
3685 if (_pioinfo(fh)->lockinitflag)
3686 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3691 #endif /* PERL_MSVCRT_READFIX */
3694 win32_read(int fd, void *buf, unsigned int cnt)
3696 #ifdef PERL_MSVCRT_READFIX
3697 return _fixed_read(fd, buf, cnt);
3699 return read(fd, buf, cnt);
3704 win32_write(int fd, const void *buf, unsigned int cnt)
3706 return write(fd, buf, cnt);
3710 win32_mkdir(const char *dir, int mode)
3713 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3717 win32_rmdir(const char *dir)
3720 return rmdir(PerlDir_mapA(dir));
3724 win32_chdir(const char *dir)
3735 win32_access(const char *path, int mode)
3738 return access(PerlDir_mapA(path), mode);
3742 win32_chmod(const char *path, int mode)
3745 return chmod(PerlDir_mapA(path), mode);
3750 create_command_line(char *cname, STRLEN clen, const char * const *args)
3757 bool bat_file = FALSE;
3758 bool cmd_shell = FALSE;
3759 bool dumb_shell = FALSE;
3760 bool extra_quotes = FALSE;
3761 bool quote_next = FALSE;
3764 cname = (char*)args[0];
3766 /* The NT cmd.exe shell has the following peculiarity that needs to be
3767 * worked around. It strips a leading and trailing dquote when any
3768 * of the following is true:
3769 * 1. the /S switch was used
3770 * 2. there are more than two dquotes
3771 * 3. there is a special character from this set: &<>()@^|
3772 * 4. no whitespace characters within the two dquotes
3773 * 5. string between two dquotes isn't an executable file
3774 * To work around this, we always add a leading and trailing dquote
3775 * to the string, if the first argument is either "cmd.exe" or "cmd",
3776 * and there were at least two or more arguments passed to cmd.exe
3777 * (not including switches).
3778 * XXX the above rules (from "cmd /?") don't seem to be applied
3779 * always, making for the convolutions below :-(
3783 clen = strlen(cname);
3786 && (stricmp(&cname[clen-4], ".bat") == 0
3787 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3794 char *exe = strrchr(cname, '/');
3795 char *exe2 = strrchr(cname, '\\');
3802 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3806 else if (stricmp(exe, "command.com") == 0
3807 || stricmp(exe, "command") == 0)
3814 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3815 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3816 STRLEN curlen = strlen(arg);
3817 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3818 len += 2; /* assume quoting needed (worst case) */
3820 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3822 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3825 Newx(cmd, len, char);
3828 if (bat_file && !IsWin95()) {
3830 extra_quotes = TRUE;
3833 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3835 STRLEN curlen = strlen(arg);
3837 /* we want to protect empty arguments and ones with spaces with
3838 * dquotes, but only if they aren't already there */
3843 else if (quote_next) {
3844 /* see if it really is multiple arguments pretending to
3845 * be one and force a set of quotes around it */
3846 if (*find_next_space(arg))
3849 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3851 while (i < curlen) {
3852 if (isSPACE(arg[i])) {
3855 else if (arg[i] == '"') {
3879 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3880 && stricmp(arg+curlen-2, "/c") == 0)
3882 /* is there a next argument? */
3883 if (args[index+1]) {
3884 /* are there two or more next arguments? */
3885 if (args[index+2]) {
3887 extra_quotes = TRUE;
3890 /* single argument, force quoting if it has spaces */
3906 qualified_path(const char *cmd)
3910 char *fullcmd, *curfullcmd;
3916 fullcmd = (char*)cmd;
3918 if (*fullcmd == '/' || *fullcmd == '\\')
3925 pathstr = PerlEnv_getenv("PATH");
3927 /* worst case: PATH is a single directory; we need additional space
3928 * to append "/", ".exe" and trailing "\0" */
3929 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3930 curfullcmd = fullcmd;
3935 /* start by appending the name to the current prefix */
3936 strcpy(curfullcmd, cmd);
3937 curfullcmd += cmdlen;
3939 /* if it doesn't end with '.', or has no extension, try adding
3940 * a trailing .exe first */
3941 if (cmd[cmdlen-1] != '.'
3942 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3944 strcpy(curfullcmd, ".exe");
3945 res = GetFileAttributes(fullcmd);
3946 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3951 /* that failed, try the bare name */
3952 res = GetFileAttributes(fullcmd);
3953 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3956 /* quit if no other path exists, or if cmd already has path */
3957 if (!pathstr || !*pathstr || has_slash)
3960 /* skip leading semis */
3961 while (*pathstr == ';')
3964 /* build a new prefix from scratch */
3965 curfullcmd = fullcmd;
3966 while (*pathstr && *pathstr != ';') {
3967 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3968 pathstr++; /* skip initial '"' */
3969 while (*pathstr && *pathstr != '"') {
3970 *curfullcmd++ = *pathstr++;
3973 pathstr++; /* skip trailing '"' */
3976 *curfullcmd++ = *pathstr++;
3980 pathstr++; /* skip trailing semi */
3981 if (curfullcmd > fullcmd /* append a dir separator */
3982 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3984 *curfullcmd++ = '\\';
3992 /* The following are just place holders.
3993 * Some hosts may provide and environment that the OS is
3994 * not tracking, therefore, these host must provide that
3995 * environment and the current directory to CreateProcess
3999 win32_get_childenv(void)
4005 win32_free_childenv(void* d)
4010 win32_clearenv(void)
4012 char *envv = GetEnvironmentStrings();
4016 char *end = strchr(cur,'=');
4017 if (end && end != cur) {
4019 SetEnvironmentVariable(cur, NULL);
4021 cur = end + strlen(end+1)+2;
4023 else if ((len = strlen(cur)))
4026 FreeEnvironmentStrings(envv);
4030 win32_get_childdir(void)
4034 char szfilename[MAX_PATH+1];
4036 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4037 Newx(ptr, strlen(szfilename)+1, char);
4038 strcpy(ptr, szfilename);
4043 win32_free_childdir(char* d)
4050 /* XXX this needs to be made more compatible with the spawnvp()
4051 * provided by the various RTLs. In particular, searching for
4052 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4053 * This doesn't significantly affect perl itself, because we
4054 * always invoke things using PERL5SHELL if a direct attempt to
4055 * spawn the executable fails.
4057 * XXX splitting and rejoining the commandline between do_aspawn()
4058 * and win32_spawnvp() could also be avoided.
4062 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4064 #ifdef USE_RTL_SPAWNVP
4065 return spawnvp(mode, cmdname, (char * const *)argv);
4072 STARTUPINFO StartupInfo;
4073 PROCESS_INFORMATION ProcessInformation;
4076 char *fullcmd = NULL;
4077 char *cname = (char *)cmdname;
4081 clen = strlen(cname);
4082 /* if command name contains dquotes, must remove them */
4083 if (strchr(cname, '"')) {
4085 Newx(cname,clen+1,char);
4098 cmd = create_command_line(cname, clen, argv);
4100 env = PerlEnv_get_childenv();
4101 dir = PerlEnv_get_childdir();
4104 case P_NOWAIT: /* asynch + remember result */
4105 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4110 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4113 create |= CREATE_NEW_PROCESS_GROUP;
4116 case P_WAIT: /* synchronous execution */
4118 default: /* invalid mode */
4123 memset(&StartupInfo,0,sizeof(StartupInfo));
4124 StartupInfo.cb = sizeof(StartupInfo);
4125 memset(&tbl,0,sizeof(tbl));
4126 PerlEnv_get_child_IO(&tbl);
4127 StartupInfo.dwFlags = tbl.dwFlags;
4128 StartupInfo.dwX = tbl.dwX;
4129 StartupInfo.dwY = tbl.dwY;
4130 StartupInfo.dwXSize = tbl.dwXSize;
4131 StartupInfo.dwYSize = tbl.dwYSize;
4132 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4133 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4134 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4135 StartupInfo.wShowWindow = tbl.wShowWindow;
4136 StartupInfo.hStdInput = tbl.childStdIn;
4137 StartupInfo.hStdOutput = tbl.childStdOut;
4138 StartupInfo.hStdError = tbl.childStdErr;
4139 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4140 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4141 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4143 create |= CREATE_NEW_CONSOLE;
4146 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4148 if (w32_use_showwindow) {
4149 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4150 StartupInfo.wShowWindow = w32_showwindow;
4153 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4156 if (!CreateProcess(cname, /* search PATH to find executable */
4157 cmd, /* executable, and its arguments */
4158 NULL, /* process attributes */
4159 NULL, /* thread attributes */
4160 TRUE, /* inherit handles */
4161 create, /* creation flags */
4162 (LPVOID)env, /* inherit environment */
4163 dir, /* inherit cwd */
4165 &ProcessInformation))
4167 /* initial NULL argument to CreateProcess() does a PATH
4168 * search, but it always first looks in the directory
4169 * where the current process was started, which behavior
4170 * is undesirable for backward compatibility. So we
4171 * jump through our own hoops by picking out the path
4172 * we really want it to use. */
4174 fullcmd = qualified_path(cname);
4176 if (cname != cmdname)
4179 DEBUG_p(PerlIO_printf(Perl_debug_log,
4180 "Retrying [%s] with same args\n",
4190 if (mode == P_NOWAIT) {
4191 /* asynchronous spawn -- store handle, return PID */
4192 ret = (int)ProcessInformation.dwProcessId;
4193 if (IsWin95() && ret < 0)
4196 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4197 w32_child_pids[w32_num_children] = (DWORD)ret;
4202 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4203 /* FIXME: if msgwait returned due to message perhaps forward the
4204 "signal" to the process
4206 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4208 CloseHandle(ProcessInformation.hProcess);
4211 CloseHandle(ProcessInformation.hThread);
4214 PerlEnv_free_childenv(env);
4215 PerlEnv_free_childdir(dir);
4217 if (cname != cmdname)
4224 win32_execv(const char *cmdname, const char *const *argv)
4228 /* if this is a pseudo-forked child, we just want to spawn
4229 * the new program, and return */
4231 # ifdef __BORLANDC__
4232 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4234 return spawnv(P_WAIT, cmdname, argv);
4238 return execv(cmdname, (char *const *)argv);
4240 return execv(cmdname, argv);
4245 win32_execvp(const char *cmdname, const char *const *argv)
4249 /* if this is a pseudo-forked child, we just want to spawn
4250 * the new program, and return */
4251 if (w32_pseudo_id) {
4252 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4262 return execvp(cmdname, (char *const *)argv);
4264 return execvp(cmdname, argv);
4269 win32_perror(const char *str)
4275 win32_setbuf(FILE *pf, char *buf)
4281 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4283 return setvbuf(pf, buf, type, size);
4287 win32_flushall(void)
4293 win32_fcloseall(void)
4299 win32_fgets(char *s, int n, FILE *pf)
4301 return fgets(s, n, pf);
4311 win32_fgetc(FILE *pf)
4317 win32_putc(int c, FILE *pf)
4323 win32_puts(const char *s)
4335 win32_putchar(int c)
4342 #ifndef USE_PERL_SBRK
4344 static char *committed = NULL; /* XXX threadead */
4345 static char *base = NULL; /* XXX threadead */
4346 static char *reserved = NULL; /* XXX threadead */
4347 static char *brk = NULL; /* XXX threadead */
4348 static DWORD pagesize = 0; /* XXX threadead */
4351 sbrk(ptrdiff_t need)
4356 GetSystemInfo(&info);
4357 /* Pretend page size is larger so we don't perpetually
4358 * call the OS to commit just one page ...
4360 pagesize = info.dwPageSize << 3;
4362 if (brk+need >= reserved)
4364 DWORD size = brk+need-reserved;
4366 char *prev_committed = NULL;
4367 if (committed && reserved && committed < reserved)
4369 /* Commit last of previous chunk cannot span allocations */
4370 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4373 /* Remember where we committed from in case we want to decommit later */
4374 prev_committed = committed;
4375 committed = reserved;
4378 /* Reserve some (more) space
4379 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4380 * this is only address space not memory...
4381 * Note this is a little sneaky, 1st call passes NULL as reserved
4382 * so lets system choose where we start, subsequent calls pass
4383 * the old end address so ask for a contiguous block
4386 if (size < 64*1024*1024)
4387 size = 64*1024*1024;
4388 size = ((size + pagesize - 1) / pagesize) * pagesize;
4389 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4392 reserved = addr+size;
4402 /* The existing block could not be extended far enough, so decommit
4403 * anything that was just committed above and start anew */
4406 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4409 reserved = base = committed = brk = NULL;
4420 if (brk > committed)
4422 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4424 if (committed+size > reserved)
4425 size = reserved-committed;
4426 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4439 win32_malloc(size_t size)
4441 return malloc(size);
4445 win32_calloc(size_t numitems, size_t size)
4447 return calloc(numitems,size);
4451 win32_realloc(void *block, size_t size)
4453 return realloc(block,size);
4457 win32_free(void *block)
4464 win32_open_osfhandle(intptr_t handle, int flags)
4466 #ifdef USE_FIXED_OSFHANDLE
4468 return my_open_osfhandle(handle, flags);
4470 return _open_osfhandle(handle, flags);
4474 win32_get_osfhandle(int fd)
4476 return (intptr_t)_get_osfhandle(fd);
4480 win32_fdupopen(FILE *pf)
4485 int fileno = win32_dup(win32_fileno(pf));
4487 /* open the file in the same mode */
4489 if((pf)->flags & _F_READ) {
4493 else if((pf)->flags & _F_WRIT) {
4497 else if((pf)->flags & _F_RDWR) {
4503 if((pf)->_flag & _IOREAD) {
4507 else if((pf)->_flag & _IOWRT) {
4511 else if((pf)->_flag & _IORW) {
4518 /* it appears that the binmode is attached to the
4519 * file descriptor so binmode files will be handled
4522 pfdup = win32_fdopen(fileno, mode);
4524 /* move the file pointer to the same position */
4525 if (!fgetpos(pf, &pos)) {
4526 fsetpos(pfdup, &pos);
4532 win32_dynaload(const char* filename)
4535 char buf[MAX_PATH+1];
4538 /* LoadLibrary() doesn't recognize forward slashes correctly,
4539 * so turn 'em back. */
4540 first = strchr(filename, '/');
4542 STRLEN len = strlen(filename);
4543 if (len <= MAX_PATH) {
4544 strcpy(buf, filename);
4545 filename = &buf[first - filename];
4547 if (*filename == '/')
4548 *(char*)filename = '\\';
4554 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4557 XS(w32_SetChildShowWindow)
4560 BOOL use_showwindow = w32_use_showwindow;
4561 /* use "unsigned short" because Perl has redefined "WORD" */
4562 unsigned short showwindow = w32_showwindow;
4565 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4567 if (items == 0 || !SvOK(ST(0)))
4568 w32_use_showwindow = FALSE;
4570 w32_use_showwindow = TRUE;
4571 w32_showwindow = (unsigned short)SvIV(ST(0));
4576 ST(0) = sv_2mortal(newSViv(showwindow));
4578 ST(0) = &PL_sv_undef;
4583 Perl_init_os_extras(void)
4586 char *file = __FILE__;
4588 /* Initialize Win32CORE if it has been statically linked. */
4589 void (*pfn_init)(pTHX);
4590 #if defined(__BORLANDC__)
4591 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4592 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4594 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4599 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4603 win32_signal_context(void)
4608 my_perl = PL_curinterp;
4609 PERL_SET_THX(my_perl);
4613 return PL_curinterp;
4619 win32_ctrlhandler(DWORD dwCtrlType)
4622 dTHXa(PERL_GET_SIG_CONTEXT);
4628 switch(dwCtrlType) {
4629 case CTRL_CLOSE_EVENT:
4630 /* A signal that the system sends to all processes attached to a console when
4631 the user closes the console (either by choosing the Close command from the
4632 console window's System menu, or by choosing the End Task command from the
4635 if (do_raise(aTHX_ 1)) /* SIGHUP */
4636 sig_terminate(aTHX_ 1);
4640 /* A CTRL+c signal was received */
4641 if (do_raise(aTHX_ SIGINT))
4642 sig_terminate(aTHX_ SIGINT);
4645 case CTRL_BREAK_EVENT:
4646 /* A CTRL+BREAK signal was received */
4647 if (do_raise(aTHX_ SIGBREAK))
4648 sig_terminate(aTHX_ SIGBREAK);
4651 case CTRL_LOGOFF_EVENT:
4652 /* A signal that the system sends to all console processes when a user is logging
4653 off. This signal does not indicate which user is logging off, so no
4654 assumptions can be made.
4657 case CTRL_SHUTDOWN_EVENT:
4658 /* A signal that the system sends to all console processes when the system is
4661 if (do_raise(aTHX_ SIGTERM))
4662 sig_terminate(aTHX_ SIGTERM);
4671 #ifdef SET_INVALID_PARAMETER_HANDLER
4672 # include <crtdbg.h>
4683 /* win32_ansipath() requires Windows 2000 or later */
4687 /* fetch Unicode version of PATH */
4689 wide_path = win32_malloc(len*sizeof(WCHAR));
4691 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4695 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4700 /* convert to ANSI pathnames */
4701 wide_dir = wide_path;
4704 WCHAR *sep = wcschr(wide_dir, ';');
4712 /* remove quotes around pathname */
4713 if (*wide_dir == '"')
4715 wide_len = wcslen(wide_dir);
4716 if (wide_len && wide_dir[wide_len-1] == '"')
4717 wide_dir[wide_len-1] = '\0';
4719 /* append ansi_dir to ansi_path */
4720 ansi_dir = win32_ansipath(wide_dir);
4721 ansi_len = strlen(ansi_dir);
4723 size_t newlen = len + 1 + ansi_len;
4724 ansi_path = win32_realloc(ansi_path, newlen+1);
4727 ansi_path[len] = ';';
4728 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4733 ansi_path = win32_malloc(5+len+1);
4736 memcpy(ansi_path, "PATH=", 5);
4737 memcpy(ansi_path+5, ansi_dir, len+1);
4740 win32_free(ansi_dir);
4745 /* Update C RTL environ array. This will only have full effect if
4746 * perl_parse() is later called with `environ` as the `env` argument.
4747 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4749 * We do have to ansify() the PATH before Perl has been fully
4750 * initialized because S_find_script() uses the PATH when perl
4751 * is being invoked with the -S option. This happens before %ENV
4752 * is initialized in S_init_postdump_symbols().
4754 * XXX Is this a bug? Should S_find_script() use the environment
4755 * XXX passed in the `env` arg to parse_perl()?
4758 /* Keep system environment in sync because S_init_postdump_symbols()
4759 * will not call mg_set() if it initializes %ENV from `environ`.
4761 SetEnvironmentVariableA("PATH", ansi_path+5);
4762 /* We are intentionally leaking the ansi_path string here because
4763 * the Borland runtime library puts it directly into the environ
4764 * array. The Microsoft runtime library seems to make a copy,
4765 * but will leak the copy should it be replaced again later.
4766 * Since this code is only called once during PERL_SYS_INIT this
4767 * shouldn't really matter.
4770 win32_free(wide_path);
4774 Perl_win32_init(int *argcp, char ***argvp)
4778 #ifdef SET_INVALID_PARAMETER_HANDLER
4779 _invalid_parameter_handler oldHandler, newHandler;
4780 newHandler = my_invalid_parameter_handler;
4781 oldHandler = _set_invalid_parameter_handler(newHandler);
4782 _CrtSetReportMode(_CRT_ASSERT, 0);
4784 /* Disable floating point errors, Perl will trap the ones we
4785 * care about. VC++ RTL defaults to switching these off
4786 * already, but the Borland RTL doesn't. Since we don't
4787 * want to be at the vendor's whim on the default, we set
4788 * it explicitly here.
4790 #if !defined(_ALPHA_) && !defined(__GNUC__)
4791 _control87(MCW_EM, MCW_EM);
4795 module = GetModuleHandle("ntdll.dll");
4797 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4800 module = GetModuleHandle("kernel32.dll");
4802 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4803 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4804 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4807 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4808 GetVersionEx(&g_osver);
4814 Perl_win32_term(void)
4824 win32_get_child_IO(child_IO_table* ptbl)
4826 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4827 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4828 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4832 win32_signal(int sig, Sighandler_t subcode)
4835 if (sig < SIG_SIZE) {
4836 int save_errno = errno;
4837 Sighandler_t result = signal(sig, subcode);
4838 if (result == SIG_ERR) {
4839 result = w32_sighandler[sig];
4842 w32_sighandler[sig] = subcode;
4851 /* The PerlMessageWindowClass's WindowProc */
4853 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4855 return win32_process_message(hwnd, msg, wParam, lParam) ?
4856 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4859 /* we use a message filter hook to process thread messages, passing any
4860 * messages that we don't process on to the rest of the hook chain
4861 * Anyone else writing a message loop that wants to play nicely with perl
4863 * CallMsgFilter(&msg, MSGF_***);
4864 * between their GetMessage and DispatchMessage calls. */
4866 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4867 LPMSG pmsg = (LPMSG)lParam;
4869 /* we'll process it if code says we're allowed, and it's a thread message */
4870 if (code >= 0 && pmsg->hwnd == NULL
4871 && win32_process_message(pmsg->hwnd, pmsg->message,
4872 pmsg->wParam, pmsg->lParam))
4877 /* XXX: MSDN says that hhk is ignored, but we should really use the
4878 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4879 return CallNextHookEx(NULL, code, wParam, lParam);
4882 /* The real message handler. Can be called with
4883 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4884 * that it processes */
4886 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4888 /* BEWARE. The context retrieved using dTHX; is the context of the
4889 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4890 * up to and including WM_CREATE. If it ever happens that you need the
4891 * 'child' context before this, then it needs to be passed into
4892 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4893 * from the lparam of CreateWindow(). It could then be stored/retrieved
4894 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4895 * the dTHX calls here. */
4896 /* XXX For now it is assumed that the overhead of the dTHX; for what
4897 * are relativley infrequent code-paths, is better than the added
4898 * complexity of getting the correct context passed into
4899 * win32_create_message_window() */
4904 case WM_USER_MESSAGE: {
4905 long child = find_pseudo_pid((int)wParam);
4908 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4915 case WM_USER_KILL: {
4917 /* We use WM_USER_KILL to fake kill() with other signals */
4918 int sig = (int)wParam;
4919 if (do_raise(aTHX_ sig))
4920 sig_terminate(aTHX_ sig);
4927 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4928 if (w32_timerid && w32_timerid==(UINT)wParam) {
4929 KillTimer(w32_message_hwnd, w32_timerid);
4932 /* Now fake a call to signal handler */
4933 if (do_raise(aTHX_ 14))
4934 sig_terminate(aTHX_ 14);
4946 /* Above or other stuff may have set a signal flag, and we may not have
4947 * been called from win32_async_check() (e.g. some other GUI's message
4948 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4949 * handler that die's, and the message loop that calls here is wrapped
4950 * in an eval, then you may well end up with orphaned windows - signals
4951 * are dispatched by win32_async_check() */
4957 win32_create_message_window_class(void)
4959 /* create the window class for "message only" windows */
4963 wc.lpfnWndProc = win32_message_window_proc;
4964 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4965 wc.lpszClassName = "PerlMessageWindowClass";
4967 /* second and subsequent calls will fail, but class
4968 * will already be registered */
4973 win32_create_message_window(void)
4977 /* "message-only" windows have been implemented in Windows 2000 and later.
4978 * On earlier versions we'll continue to post messages to a specific
4979 * thread and use hwnd==NULL. This is brittle when either an embedding
4980 * application or an XS module is also posting messages to hwnd=NULL
4981 * because once removed from the queue they cannot be delivered to the
4982 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4983 * if there is no window handle.
4985 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4986 * documentation to the contrary, however, there is some evidence that
4987 * there may be problems with the implementation on Win98. As it is not
4988 * officially supported we take the cautious route and stick with thread
4989 * messages (hwnd == NULL) on platforms prior to Win2k.
4992 win32_create_message_window_class();
4994 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4995 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4998 /* If we din't create a window for any reason, then we'll use thread
4999 * messages for our signalling, so we install a hook which
5000 * is called by CallMsgFilter in win32_async_check(), or any other
5001 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5002 * that use OLE, etc. */
5004 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5005 NULL, GetCurrentThreadId());
5011 #ifdef HAVE_INTERP_INTERN
5014 win32_csighandler(int sig)
5017 dTHXa(PERL_GET_SIG_CONTEXT);
5018 Perl_warn(aTHX_ "Got signal %d",sig);
5023 #if defined(__MINGW32__) && defined(__cplusplus)
5024 #define CAST_HWND__(x) (HWND__*)(x)
5026 #define CAST_HWND__(x) x
5030 Perl_sys_intern_init(pTHX)
5034 w32_perlshell_tokens = NULL;
5035 w32_perlshell_vec = (char**)NULL;
5036 w32_perlshell_items = 0;
5037 w32_fdpid = newAV();
5038 Newx(w32_children, 1, child_tab);
5039 w32_num_children = 0;
5040 # ifdef USE_ITHREADS
5042 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5043 w32_num_pseudo_children = 0;
5046 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5048 for (i=0; i < SIG_SIZE; i++) {
5049 w32_sighandler[i] = SIG_DFL;
5051 # ifdef MULTIPLICITY
5052 if (my_perl == PL_curinterp) {
5056 /* Force C runtime signal stuff to set its console handler */
5057 signal(SIGINT,win32_csighandler);
5058 signal(SIGBREAK,win32_csighandler);
5060 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5061 * flag. This has the side-effect of disabling Ctrl-C events in all
5062 * processes in this group. At least on Windows NT and later we
5063 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5064 * with a NULL handler. This is not valid on Windows 9X.
5067 SetConsoleCtrlHandler(NULL,FALSE);
5069 /* Push our handler on top */
5070 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5075 Perl_sys_intern_clear(pTHX)
5077 Safefree(w32_perlshell_tokens);
5078 Safefree(w32_perlshell_vec);
5079 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5080 Safefree(w32_children);
5082 KillTimer(w32_message_hwnd, w32_timerid);
5085 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5086 DestroyWindow(w32_message_hwnd);
5087 # ifdef MULTIPLICITY
5088 if (my_perl == PL_curinterp) {
5092 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5094 # ifdef USE_ITHREADS
5095 Safefree(w32_pseudo_children);
5099 # ifdef USE_ITHREADS
5102 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5104 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5106 dst->perlshell_tokens = NULL;
5107 dst->perlshell_vec = (char**)NULL;
5108 dst->perlshell_items = 0;
5109 dst->fdpid = newAV();
5110 Newxz(dst->children, 1, child_tab);
5112 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5114 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5115 dst->poll_count = 0;
5116 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5118 # endif /* USE_ITHREADS */
5119 #endif /* HAVE_INTERP_INTERN */