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, char *trailing, ...);
127 static void remove_dead_process(long deceased);
128 static long find_pid(int pid);
129 static char * qualified_path(const char *cmd);
130 static char * win32_get_xlib(const char *pl, const char *xlib,
131 const char *libname);
132 static LRESULT win32_process_message(HWND hwnd, UINT msg,
133 WPARAM wParam, LPARAM lParam);
136 static void remove_dead_pseudo_process(long child);
137 static long find_pseudo_pid(int pid);
141 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
142 char w32_module_name[MAX_PATH+1];
145 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
147 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
148 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
149 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
150 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
153 /* Silence STDERR grumblings from Borland's math library. */
155 _matherr(struct _exception *a)
162 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
163 * parameter handler. This functionality is not available in the
164 * 64-bit compiler from the Platform SDK, which unfortunately also
165 * believes itself to be MSC version 14.
167 * There is no #define related to _set_invalid_parameter_handler(),
168 * but we can check for one of the constants defined for
169 * _set_abort_behavior(), which was introduced into stdlib.h at
173 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
174 # define SET_INVALID_PARAMETER_HANDLER
177 #ifdef SET_INVALID_PARAMETER_HANDLER
178 void my_invalid_parameter_handler(const wchar_t* expression,
179 const wchar_t* function,
185 wprintf(L"Invalid parameter detected in function %s."
186 L" File: %s Line: %d\n", function, file, line);
187 wprintf(L"Expression: %s\n", expression);
195 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
201 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
207 return (g_osver.dwMajorVersion > 4);
211 set_w32_module_name(void)
213 /* this function may be called at DLL_PROCESS_ATTACH time */
215 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
216 ? GetModuleHandle(NULL)
217 : w32_perldll_handle);
219 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
220 osver.dwOSVersionInfoSize = sizeof(osver);
221 GetVersionEx(&osver);
223 if (osver.dwMajorVersion > 4) {
224 WCHAR modulename[MAX_PATH];
225 WCHAR fullname[MAX_PATH];
228 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
230 /* Make sure we get an absolute pathname in case the module was loaded
231 * explicitly by LoadLibrary() with a relative path. */
232 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
234 /* remove \\?\ prefix */
235 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
236 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
238 ansi = win32_ansipath(fullname);
239 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
243 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
245 /* remove \\?\ prefix */
246 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
247 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
249 /* try to get full path to binary (which may be mangled when perl is
250 * run from a 16-bit app) */
251 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
252 win32_longpath(w32_module_name);
253 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
256 /* normalize to forward slashes */
257 ptr = w32_module_name;
265 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
267 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
269 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
272 const char *subkey = "Software\\Perl";
276 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
277 if (retval == ERROR_SUCCESS) {
279 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
280 if (retval == ERROR_SUCCESS
281 && (type == REG_SZ || type == REG_EXPAND_SZ))
285 *svp = sv_2mortal(newSVpvn("",0));
286 SvGROW(*svp, datalen);
287 retval = RegQueryValueEx(handle, valuename, 0, NULL,
288 (PBYTE)SvPVX(*svp), &datalen);
289 if (retval == ERROR_SUCCESS) {
291 SvCUR_set(*svp,datalen-1);
299 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
301 get_regstr(const char *valuename, SV **svp)
303 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
305 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
309 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
311 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
315 char mod_name[MAX_PATH+1];
321 va_start(ap, trailing_path);
322 strip = va_arg(ap, char *);
324 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
325 baselen = strlen(base);
327 if (!*w32_module_name) {
328 set_w32_module_name();
330 strcpy(mod_name, w32_module_name);
331 ptr = strrchr(mod_name, '/');
332 while (ptr && strip) {
333 /* look for directories to skip back */
336 ptr = strrchr(mod_name, '/');
337 /* avoid stripping component if there is no slash,
338 * or it doesn't match ... */
339 if (!ptr || stricmp(ptr+1, strip) != 0) {
340 /* ... but not if component matches m|5\.$patchlevel.*| */
341 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
342 && strncmp(strip, base, baselen) == 0
343 && strncmp(ptr+1, base, baselen) == 0))
349 strip = va_arg(ap, char *);
357 strcpy(++ptr, trailing_path);
359 /* only add directory if it exists */
360 if (GetFileAttributes(mod_name) != (DWORD) -1) {
361 /* directory exists */
364 *prev_pathp = sv_2mortal(newSVpvn("",0));
365 else if (SvPVX(*prev_pathp))
366 sv_catpvn(*prev_pathp, ";", 1);
367 sv_catpv(*prev_pathp, mod_name);
368 return SvPVX(*prev_pathp);
375 win32_get_privlib(const char *pl)
378 char *stdlib = "lib";
379 char buffer[MAX_PATH+1];
382 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
383 sprintf(buffer, "%s-%s", stdlib, pl);
384 if (!get_regstr(buffer, &sv))
385 (void)get_regstr(stdlib, &sv);
387 /* $stdlib .= ";$EMD/../../lib" */
388 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
392 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
396 char pathstr[MAX_PATH+1];
400 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
401 sprintf(regstr, "%s-%s", xlib, pl);
402 (void)get_regstr(regstr, &sv1);
405 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
406 sprintf(pathstr, "%s/%s/lib", libname, pl);
407 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
409 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
410 (void)get_regstr(xlib, &sv2);
413 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
414 sprintf(pathstr, "%s/lib", libname);
415 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
424 sv_catpvn(sv1, ";", 1);
431 win32_get_sitelib(const char *pl)
433 return win32_get_xlib(pl, "sitelib", "site");
436 #ifndef PERL_VENDORLIB_NAME
437 # define PERL_VENDORLIB_NAME "vendor"
441 win32_get_vendorlib(const char *pl)
443 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
447 has_shell_metachars(const char *ptr)
453 * Scan string looking for redirection (< or >) or pipe
454 * characters (|) that are not in a quoted string.
455 * Shell variable interpolation (%VAR%) can also happen inside strings.
487 #if !defined(PERL_IMPLICIT_SYS)
488 /* since the current process environment is being updated in util.c
489 * the library functions will get the correct environment
492 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
495 #define fixcmd(x) { \
496 char *pspace = strchr((x),' '); \
499 while (p < pspace) { \
510 PERL_FLUSHALL_FOR_CHILD;
511 return win32_popen(cmd, mode);
515 Perl_my_pclose(pTHX_ PerlIO *fp)
517 return win32_pclose(fp);
521 DllExport unsigned long
524 return (unsigned long)g_osver.dwPlatformId;
534 return -((int)w32_pseudo_id);
537 /* Windows 9x appears to always reports a pid for threads and processes
538 * that has the high bit set. So we treat the lower 31 bits as the
539 * "real" PID for Perl's purposes. */
540 if (IsWin95() && pid < 0)
545 /* Tokenize a string. Words are null-separated, and the list
546 * ends with a doubled null. Any character (except null and
547 * including backslash) may be escaped by preceding it with a
548 * backslash (the backslash will be stripped).
549 * Returns number of words in result buffer.
552 tokenize(const char *str, char **dest, char ***destv)
554 char *retstart = NULL;
555 char **retvstart = 0;
559 int slen = strlen(str);
561 register char **retv;
562 Newx(ret, slen+2, char);
563 Newx(retv, (slen+3)/2, char*);
571 if (*ret == '\\' && *str)
573 else if (*ret == ' ') {
589 retvstart[items] = NULL;
602 if (!w32_perlshell_tokens) {
603 /* we don't use COMSPEC here for two reasons:
604 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
605 * uncontrolled unportability of the ensuing scripts.
606 * 2. PERL5SHELL could be set to a shell that may not be fit for
607 * interactive use (which is what most programs look in COMSPEC
610 const char* defaultshell = (IsWinNT()
611 ? "cmd.exe /x/d/c" : "command.com /c");
612 const char *usershell = PerlEnv_getenv("PERL5SHELL");
613 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
614 &w32_perlshell_tokens,
620 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
628 PERL_ARGS_ASSERT_DO_ASPAWN;
634 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
636 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
641 while (++mark <= sp) {
642 if (*mark && (str = SvPV_nolen(*mark)))
649 status = win32_spawnvp(flag,
650 (const char*)(really ? SvPV_nolen(really) : argv[0]),
651 (const char* const*)argv);
653 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
654 /* possible shell-builtin, invoke with shell */
656 sh_items = w32_perlshell_items;
658 argv[index+sh_items] = argv[index];
659 while (--sh_items >= 0)
660 argv[sh_items] = w32_perlshell_vec[sh_items];
662 status = win32_spawnvp(flag,
663 (const char*)(really ? SvPV_nolen(really) : argv[0]),
664 (const char* const*)argv);
667 if (flag == P_NOWAIT) {
669 PL_statusvalue = -1; /* >16bits hint for pp_system() */
673 if (ckWARN(WARN_EXEC))
674 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
679 PL_statusvalue = status;
685 /* returns pointer to the next unquoted space or the end of the string */
687 find_next_space(const char *s)
689 bool in_quotes = FALSE;
691 /* ignore doubled backslashes, or backslash+quote */
692 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
695 /* keep track of when we're within quotes */
696 else if (*s == '"') {
698 in_quotes = !in_quotes;
700 /* break it up only at spaces that aren't in quotes */
701 else if (!in_quotes && isSPACE(*s))
710 do_spawn2(pTHX_ const char *cmd, int exectype)
716 BOOL needToTry = TRUE;
719 /* Save an extra exec if possible. See if there are shell
720 * metacharacters in it */
721 if (!has_shell_metachars(cmd)) {
722 Newx(argv, strlen(cmd) / 2 + 2, char*);
723 Newx(cmd2, strlen(cmd) + 1, char);
726 for (s = cmd2; *s;) {
727 while (*s && isSPACE(*s))
731 s = find_next_space(s);
739 status = win32_spawnvp(P_WAIT, argv[0],
740 (const char* const*)argv);
742 case EXECF_SPAWN_NOWAIT:
743 status = win32_spawnvp(P_NOWAIT, argv[0],
744 (const char* const*)argv);
747 status = win32_execvp(argv[0], (const char* const*)argv);
750 if (status != -1 || errno == 0)
760 Newx(argv, w32_perlshell_items + 2, char*);
761 while (++i < w32_perlshell_items)
762 argv[i] = w32_perlshell_vec[i];
763 argv[i++] = (char *)cmd;
767 status = win32_spawnvp(P_WAIT, argv[0],
768 (const char* const*)argv);
770 case EXECF_SPAWN_NOWAIT:
771 status = win32_spawnvp(P_NOWAIT, argv[0],
772 (const char* const*)argv);
775 status = win32_execvp(argv[0], (const char* const*)argv);
781 if (exectype == EXECF_SPAWN_NOWAIT) {
783 PL_statusvalue = -1; /* >16bits hint for pp_system() */
787 if (ckWARN(WARN_EXEC))
788 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
789 (exectype == EXECF_EXEC ? "exec" : "spawn"),
790 cmd, strerror(errno));
795 PL_statusvalue = status;
801 Perl_do_spawn(pTHX_ char *cmd)
803 PERL_ARGS_ASSERT_DO_SPAWN;
805 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
809 Perl_do_spawn_nowait(pTHX_ char *cmd)
811 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
813 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
817 Perl_do_exec(pTHX_ const char *cmd)
819 PERL_ARGS_ASSERT_DO_EXEC;
821 do_spawn2(aTHX_ cmd, EXECF_EXEC);
825 /* The idea here is to read all the directory names into a string table
826 * (separated by nulls) and when one of the other dir functions is called
827 * return the pointer to the current file name.
830 win32_opendir(const char *filename)
836 char scanname[MAX_PATH+3];
838 WIN32_FIND_DATAA aFindData;
839 WIN32_FIND_DATAW wFindData;
841 char buffer[MAX_PATH*2];
844 len = strlen(filename);
848 /* check to see if filename is a directory */
849 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
852 /* Get us a DIR structure */
855 /* Create the search pattern */
856 strcpy(scanname, filename);
858 /* bare drive name means look in cwd for drive */
859 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
860 scanname[len++] = '.';
861 scanname[len++] = '/';
863 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
864 scanname[len++] = '/';
866 scanname[len++] = '*';
867 scanname[len] = '\0';
869 /* do the FindFirstFile call */
871 WCHAR wscanname[sizeof(scanname)];
872 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
873 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
877 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
879 if (dirp->handle == INVALID_HANDLE_VALUE) {
880 DWORD err = GetLastError();
881 /* FindFirstFile() fails on empty drives! */
883 case ERROR_FILE_NOT_FOUND:
885 case ERROR_NO_MORE_FILES:
886 case ERROR_PATH_NOT_FOUND:
889 case ERROR_NOT_ENOUGH_MEMORY:
901 BOOL use_default = FALSE;
902 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
903 wFindData.cFileName, -1,
904 buffer, sizeof(buffer), NULL, &use_default);
905 if (use_default && *wFindData.cAlternateFileName) {
906 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
907 wFindData.cAlternateFileName, -1,
908 buffer, sizeof(buffer), NULL, NULL);
913 ptr = aFindData.cFileName;
915 /* now allocate the first part of the string table for
916 * the filenames that we find.
923 Newx(dirp->start, dirp->size, char);
924 strcpy(dirp->start, ptr);
926 dirp->end = dirp->curr = dirp->start;
932 /* Readdir just returns the current string pointer and bumps the
933 * string pointer to the nDllExport entry.
935 DllExport struct direct *
936 win32_readdir(DIR *dirp)
941 /* first set up the structure to return */
942 len = strlen(dirp->curr);
943 strcpy(dirp->dirstr.d_name, dirp->curr);
944 dirp->dirstr.d_namlen = len;
947 dirp->dirstr.d_ino = dirp->curr - dirp->start;
949 /* Now set up for the next call to readdir */
950 dirp->curr += len + 1;
951 if (dirp->curr >= dirp->end) {
954 WIN32_FIND_DATAA aFindData;
955 char buffer[MAX_PATH*2];
958 /* finding the next file that matches the wildcard
959 * (which should be all of them in this directory!).
962 WIN32_FIND_DATAW wFindData;
963 res = FindNextFileW(dirp->handle, &wFindData);
965 BOOL use_default = FALSE;
966 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
967 wFindData.cFileName, -1,
968 buffer, sizeof(buffer), NULL, &use_default);
969 if (use_default && *wFindData.cAlternateFileName) {
970 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
971 wFindData.cAlternateFileName, -1,
972 buffer, sizeof(buffer), NULL, NULL);
978 res = FindNextFileA(dirp->handle, &aFindData);
979 ptr = aFindData.cFileName;
982 long endpos = dirp->end - dirp->start;
983 long newsize = endpos + strlen(ptr) + 1;
984 /* bump the string table size by enough for the
985 * new name and its null terminator */
986 while (newsize > dirp->size) {
987 long curpos = dirp->curr - dirp->start;
989 Renew(dirp->start, dirp->size, char);
990 dirp->curr = dirp->start + curpos;
992 strcpy(dirp->start + endpos, ptr);
993 dirp->end = dirp->start + newsize;
999 return &(dirp->dirstr);
1005 /* Telldir returns the current string pointer position */
1007 win32_telldir(DIR *dirp)
1009 return (dirp->curr - dirp->start);
1013 /* Seekdir moves the string pointer to a previously saved position
1014 * (returned by telldir).
1017 win32_seekdir(DIR *dirp, long loc)
1019 dirp->curr = dirp->start + loc;
1022 /* Rewinddir resets the string pointer to the start */
1024 win32_rewinddir(DIR *dirp)
1026 dirp->curr = dirp->start;
1029 /* free the memory allocated by opendir */
1031 win32_closedir(DIR *dirp)
1034 if (dirp->handle != INVALID_HANDLE_VALUE)
1035 FindClose(dirp->handle);
1036 Safefree(dirp->start);
1049 * Just pretend that everyone is a superuser. NT will let us know if
1050 * we don\'t really have permission to do something.
1053 #define ROOT_UID ((uid_t)0)
1054 #define ROOT_GID ((gid_t)0)
1083 return (auid == ROOT_UID ? 0 : -1);
1089 return (agid == ROOT_GID ? 0 : -1);
1096 char *buf = w32_getlogin_buffer;
1097 DWORD size = sizeof(w32_getlogin_buffer);
1098 if (GetUserName(buf,&size))
1104 chown(const char *path, uid_t owner, gid_t group)
1111 * XXX this needs strengthening (for PerlIO)
1114 int mkstemp(const char *path)
1117 char buf[MAX_PATH+1];
1121 if (i++ > 10) { /* give up */
1125 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1129 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1139 long child = w32_num_children;
1140 while (--child >= 0) {
1141 if ((int)w32_child_pids[child] == pid)
1148 remove_dead_process(long child)
1152 CloseHandle(w32_child_handles[child]);
1153 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1154 (w32_num_children-child-1), HANDLE);
1155 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1156 (w32_num_children-child-1), DWORD);
1163 find_pseudo_pid(int pid)
1166 long child = w32_num_pseudo_children;
1167 while (--child >= 0) {
1168 if ((int)w32_pseudo_child_pids[child] == pid)
1175 remove_dead_pseudo_process(long child)
1179 CloseHandle(w32_pseudo_child_handles[child]);
1180 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1181 (w32_num_pseudo_children-child-1), HANDLE);
1182 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1183 (w32_num_pseudo_children-child-1), DWORD);
1184 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1185 (w32_num_pseudo_children-child-1), HWND);
1186 w32_num_pseudo_children--;
1192 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1196 /* "Does process exist?" use of kill */
1199 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1204 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1207 default: /* For now be backwards compatible with perl 5.6 */
1209 /* Note that we will only be able to kill processes owned by the
1210 * current process owner, even when we are running as an administrator.
1211 * To kill processes of other owners we would need to set the
1212 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1214 if (TerminateProcess(process_handle, sig))
1221 /* Traverse process tree using ToolHelp functions */
1223 kill_process_tree_toolhelp(DWORD pid, int sig)
1225 HANDLE process_handle;
1226 HANDLE snapshot_handle;
1229 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1230 if (process_handle == NULL)
1233 killed += terminate_process(pid, process_handle, sig);
1235 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1236 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1237 PROCESSENTRY32 entry;
1239 entry.dwSize = sizeof(entry);
1240 if (pfnProcess32First(snapshot_handle, &entry)) {
1242 if (entry.th32ParentProcessID == pid)
1243 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1244 entry.dwSize = sizeof(entry);
1246 while (pfnProcess32Next(snapshot_handle, &entry));
1248 CloseHandle(snapshot_handle);
1250 CloseHandle(process_handle);
1254 /* Traverse process tree using undocumented system information structures.
1255 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1258 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1260 HANDLE process_handle;
1261 SYSTEM_PROCESSES *p = process_info;
1264 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1265 if (process_handle == NULL)
1268 killed += terminate_process(pid, process_handle, sig);
1271 if (p->InheritedFromProcessId == (DWORD)pid)
1272 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1274 if (p->NextEntryDelta == 0)
1277 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1280 CloseHandle(process_handle);
1285 killpg(int pid, int sig)
1287 /* Use "documented" method whenever available */
1288 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1289 return kill_process_tree_toolhelp((DWORD)pid, sig);
1292 /* Fall back to undocumented Windows internals on Windows NT */
1293 if (pfnZwQuerySystemInformation) {
1298 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1299 Newx(buffer, size, char);
1301 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1302 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1311 my_kill(int pid, int sig)
1314 HANDLE process_handle;
1317 return killpg(pid, -sig);
1319 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1320 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1321 if (process_handle != NULL) {
1322 retval = terminate_process(pid, process_handle, sig);
1323 CloseHandle(process_handle);
1329 win32_kill(int pid, int sig)
1335 /* it is a pseudo-forked child */
1336 child = find_pseudo_pid(-pid);
1338 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1339 HANDLE hProcess = w32_pseudo_child_handles[child];
1342 /* "Does process exist?" use of kill */
1346 /* kill -9 style un-graceful exit */
1347 if (TerminateThread(hProcess, sig)) {
1348 remove_dead_pseudo_process(child);
1355 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1356 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1357 /* Yield and wait for the other thread to send us its message_hwnd */
1359 win32_async_check(aTHX);
1360 hwnd = w32_pseudo_child_message_hwnds[child];
1363 if (hwnd != INVALID_HANDLE_VALUE) {
1364 /* We fake signals to pseudo-processes using Win32
1365 * message queue. In Win9X the pids are negative already. */
1366 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1367 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1369 /* It might be us ... */
1378 else if (IsWin95()) {
1386 child = find_pid(pid);
1388 if (my_kill(pid, sig)) {
1390 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1391 exitcode != STILL_ACTIVE)
1393 remove_dead_process(child);
1400 if (my_kill((IsWin95() ? -pid : pid), sig))
1409 win32_stat(const char *path, Stat_t *sbuf)
1412 char buffer[MAX_PATH+1];
1413 int l = strlen(path);
1416 BOOL expect_dir = FALSE;
1418 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1419 GV_NOTQUAL, SVt_PV);
1420 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1423 switch(path[l - 1]) {
1424 /* FindFirstFile() and stat() are buggy with a trailing
1425 * slashes, except for the root directory of a drive */
1428 if (l > sizeof(buffer)) {
1429 errno = ENAMETOOLONG;
1433 strncpy(buffer, path, l);
1434 /* remove additional trailing slashes */
1435 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1437 /* add back slash if we otherwise end up with just a drive letter */
1438 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1445 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1447 if (l == 2 && isALPHA(path[0])) {
1448 buffer[0] = path[0];
1459 path = PerlDir_mapA(path);
1463 /* We must open & close the file once; otherwise file attribute changes */
1464 /* might not yet have propagated to "other" hard links of the same file. */
1465 /* This also gives us an opportunity to determine the number of links. */
1466 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1467 if (handle != INVALID_HANDLE_VALUE) {
1468 BY_HANDLE_FILE_INFORMATION bhi;
1469 if (GetFileInformationByHandle(handle, &bhi))
1470 nlink = bhi.nNumberOfLinks;
1471 CloseHandle(handle);
1475 /* path will be mapped correctly above */
1476 #if defined(WIN64) || defined(USE_LARGE_FILES)
1477 res = _stati64(path, sbuf);
1479 res = stat(path, sbuf);
1481 sbuf->st_nlink = nlink;
1484 /* CRT is buggy on sharenames, so make sure it really isn't.
1485 * XXX using GetFileAttributesEx() will enable us to set
1486 * sbuf->st_*time (but note that's not available on the
1487 * Windows of 1995) */
1488 DWORD r = GetFileAttributesA(path);
1489 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1490 /* sbuf may still contain old garbage since stat() failed */
1491 Zero(sbuf, 1, Stat_t);
1492 sbuf->st_mode = S_IFDIR | S_IREAD;
1494 if (!(r & FILE_ATTRIBUTE_READONLY))
1495 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1500 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1501 && (path[2] == '\\' || path[2] == '/'))
1503 /* The drive can be inaccessible, some _stat()s are buggy */
1504 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1509 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1514 if (S_ISDIR(sbuf->st_mode))
1515 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1516 else if (S_ISREG(sbuf->st_mode)) {
1518 if (l >= 4 && path[l-4] == '.') {
1519 const char *e = path + l - 3;
1520 if (strnicmp(e,"exe",3)
1521 && strnicmp(e,"bat",3)
1522 && strnicmp(e,"com",3)
1523 && (IsWin95() || strnicmp(e,"cmd",3)))
1524 sbuf->st_mode &= ~S_IEXEC;
1526 sbuf->st_mode |= S_IEXEC;
1529 sbuf->st_mode &= ~S_IEXEC;
1530 /* Propagate permissions to _group_ and _others_ */
1531 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1532 sbuf->st_mode |= (perms>>3) | (perms>>6);
1539 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1540 #define SKIP_SLASHES(s) \
1542 while (*(s) && isSLASH(*(s))) \
1545 #define COPY_NONSLASHES(d,s) \
1547 while (*(s) && !isSLASH(*(s))) \
1551 /* Find the longname of a given path. path is destructively modified.
1552 * It should have space for at least MAX_PATH characters. */
1554 win32_longpath(char *path)
1556 WIN32_FIND_DATA fdata;
1558 char tmpbuf[MAX_PATH+1];
1559 char *tmpstart = tmpbuf;
1566 if (isALPHA(path[0]) && path[1] == ':') {
1568 *tmpstart++ = path[0];
1572 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1574 *tmpstart++ = path[0];
1575 *tmpstart++ = path[1];
1576 SKIP_SLASHES(start);
1577 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1579 *tmpstart++ = *start++;
1580 SKIP_SLASHES(start);
1581 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1586 /* copy initial slash, if any */
1587 if (isSLASH(*start)) {
1588 *tmpstart++ = *start++;
1590 SKIP_SLASHES(start);
1593 /* FindFirstFile() expands "." and "..", so we need to pass
1594 * those through unmolested */
1596 && (!start[1] || isSLASH(start[1])
1597 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1599 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1604 /* if this is the end, bust outta here */
1608 /* now we're at a non-slash; walk up to next slash */
1609 while (*start && !isSLASH(*start))
1612 /* stop and find full name of component */
1615 fhand = FindFirstFile(path,&fdata);
1617 if (fhand != INVALID_HANDLE_VALUE) {
1618 STRLEN len = strlen(fdata.cFileName);
1619 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1620 strcpy(tmpstart, fdata.cFileName);
1631 /* failed a step, just return without side effects */
1632 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1637 strcpy(path,tmpbuf);
1646 /* Can't use PerlIO to write as it allocates memory */
1647 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1648 PL_no_mem, strlen(PL_no_mem));
1654 /* The win32_ansipath() function takes a Unicode filename and converts it
1655 * into the current Windows codepage. If some characters cannot be mapped,
1656 * then it will convert the short name instead.
1658 * The buffer to the ansi pathname must be freed with win32_free() when it
1659 * it no longer needed.
1661 * The argument to win32_ansipath() must exist before this function is
1662 * called; otherwise there is no way to determine the short path name.
1664 * Ideas for future refinement:
1665 * - Only convert those segments of the path that are not in the current
1666 * codepage, but leave the other segments in their long form.
1667 * - If the resulting name is longer than MAX_PATH, start converting
1668 * additional path segments into short names until the full name
1669 * is shorter than MAX_PATH. Shorten the filename part last!
1672 win32_ansipath(const WCHAR *widename)
1675 BOOL use_default = FALSE;
1676 size_t widelen = wcslen(widename)+1;
1677 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1678 NULL, 0, NULL, NULL);
1679 name = win32_malloc(len);
1683 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1684 name, len, NULL, &use_default);
1686 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1688 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1691 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1693 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1694 NULL, 0, NULL, NULL);
1695 name = win32_realloc(name, len);
1698 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1699 name, len, NULL, NULL);
1700 win32_free(shortname);
1707 win32_getenv(const char *name)
1713 needlen = GetEnvironmentVariableA(name,NULL,0);
1715 curitem = sv_2mortal(newSVpvn("", 0));
1717 SvGROW(curitem, needlen+1);
1718 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1720 } while (needlen >= SvLEN(curitem));
1721 SvCUR_set(curitem, needlen);
1724 /* allow any environment variables that begin with 'PERL'
1725 to be stored in the registry */
1726 if (strncmp(name, "PERL", 4) == 0)
1727 (void)get_regstr(name, &curitem);
1729 if (curitem && SvCUR(curitem))
1730 return SvPVX(curitem);
1736 win32_putenv(const char *name)
1744 Newx(curitem,strlen(name)+1,char);
1745 strcpy(curitem, name);
1746 val = strchr(curitem, '=');
1748 /* The sane way to deal with the environment.
1749 * Has these advantages over putenv() & co.:
1750 * * enables us to store a truly empty value in the
1751 * environment (like in UNIX).
1752 * * we don't have to deal with RTL globals, bugs and leaks.
1754 * Why you may want to enable USE_WIN32_RTL_ENV:
1755 * * environ[] and RTL functions will not reflect changes,
1756 * which might be an issue if extensions want to access
1757 * the env. via RTL. This cuts both ways, since RTL will
1758 * not see changes made by extensions that call the Win32
1759 * functions directly, either.
1763 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1772 filetime_to_clock(PFILETIME ft)
1774 __int64 qw = ft->dwHighDateTime;
1776 qw |= ft->dwLowDateTime;
1777 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1782 win32_times(struct tms *timebuf)
1787 clock_t process_time_so_far = clock();
1788 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1790 timebuf->tms_utime = filetime_to_clock(&user);
1791 timebuf->tms_stime = filetime_to_clock(&kernel);
1792 timebuf->tms_cutime = 0;
1793 timebuf->tms_cstime = 0;
1795 /* That failed - e.g. Win95 fallback to clock() */
1796 timebuf->tms_utime = process_time_so_far;
1797 timebuf->tms_stime = 0;
1798 timebuf->tms_cutime = 0;
1799 timebuf->tms_cstime = 0;
1801 return process_time_so_far;
1804 /* fix utime() so it works on directories in NT */
1806 filetime_from_time(PFILETIME pFileTime, time_t Time)
1808 struct tm *pTM = localtime(&Time);
1809 SYSTEMTIME SystemTime;
1815 SystemTime.wYear = pTM->tm_year + 1900;
1816 SystemTime.wMonth = pTM->tm_mon + 1;
1817 SystemTime.wDay = pTM->tm_mday;
1818 SystemTime.wHour = pTM->tm_hour;
1819 SystemTime.wMinute = pTM->tm_min;
1820 SystemTime.wSecond = pTM->tm_sec;
1821 SystemTime.wMilliseconds = 0;
1823 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1824 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1828 win32_unlink(const char *filename)
1834 filename = PerlDir_mapA(filename);
1835 attrs = GetFileAttributesA(filename);
1836 if (attrs == 0xFFFFFFFF) {
1840 if (attrs & FILE_ATTRIBUTE_READONLY) {
1841 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1842 ret = unlink(filename);
1844 (void)SetFileAttributesA(filename, attrs);
1847 ret = unlink(filename);
1852 win32_utime(const char *filename, struct utimbuf *times)
1859 struct utimbuf TimeBuffer;
1862 filename = PerlDir_mapA(filename);
1863 rc = utime(filename, times);
1865 /* EACCES: path specifies directory or readonly file */
1866 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1869 if (times == NULL) {
1870 times = &TimeBuffer;
1871 time(×->actime);
1872 times->modtime = times->actime;
1875 /* This will (and should) still fail on readonly files */
1876 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1877 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1878 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1879 if (handle == INVALID_HANDLE_VALUE)
1882 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1883 filetime_from_time(&ftAccess, times->actime) &&
1884 filetime_from_time(&ftWrite, times->modtime) &&
1885 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1890 CloseHandle(handle);
1895 unsigned __int64 ft_i64;
1900 #define Const64(x) x##LL
1902 #define Const64(x) x##i64
1904 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1905 #define EPOCH_BIAS Const64(116444736000000000)
1907 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1908 * and appears to be unsupported even by glibc) */
1910 win32_gettimeofday(struct timeval *tp, void *not_used)
1914 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1915 GetSystemTimeAsFileTime(&ft.ft_val);
1917 /* seconds since epoch */
1918 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1920 /* microseconds remaining */
1921 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1927 win32_uname(struct utsname *name)
1929 struct hostent *hep;
1930 STRLEN nodemax = sizeof(name->nodename)-1;
1933 switch (g_osver.dwPlatformId) {
1934 case VER_PLATFORM_WIN32_WINDOWS:
1935 strcpy(name->sysname, "Windows");
1937 case VER_PLATFORM_WIN32_NT:
1938 strcpy(name->sysname, "Windows NT");
1940 case VER_PLATFORM_WIN32s:
1941 strcpy(name->sysname, "Win32s");
1944 strcpy(name->sysname, "Win32 Unknown");
1949 sprintf(name->release, "%d.%d",
1950 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1953 sprintf(name->version, "Build %d",
1954 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1955 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1956 if (g_osver.szCSDVersion[0]) {
1957 char *buf = name->version + strlen(name->version);
1958 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1962 hep = win32_gethostbyname("localhost");
1964 STRLEN len = strlen(hep->h_name);
1965 if (len <= nodemax) {
1966 strcpy(name->nodename, hep->h_name);
1969 strncpy(name->nodename, hep->h_name, nodemax);
1970 name->nodename[nodemax] = '\0';
1975 if (!GetComputerName(name->nodename, &sz))
1976 *name->nodename = '\0';
1979 /* machine (architecture) */
1984 GetSystemInfo(&info);
1986 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1987 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1988 procarch = info.u.s.wProcessorArchitecture;
1990 procarch = info.wProcessorArchitecture;
1993 case PROCESSOR_ARCHITECTURE_INTEL:
1994 arch = "x86"; break;
1995 case PROCESSOR_ARCHITECTURE_MIPS:
1996 arch = "mips"; break;
1997 case PROCESSOR_ARCHITECTURE_ALPHA:
1998 arch = "alpha"; break;
1999 case PROCESSOR_ARCHITECTURE_PPC:
2000 arch = "ppc"; break;
2001 #ifdef PROCESSOR_ARCHITECTURE_SHX
2002 case PROCESSOR_ARCHITECTURE_SHX:
2003 arch = "shx"; break;
2005 #ifdef PROCESSOR_ARCHITECTURE_ARM
2006 case PROCESSOR_ARCHITECTURE_ARM:
2007 arch = "arm"; break;
2009 #ifdef PROCESSOR_ARCHITECTURE_IA64
2010 case PROCESSOR_ARCHITECTURE_IA64:
2011 arch = "ia64"; break;
2013 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2014 case PROCESSOR_ARCHITECTURE_ALPHA64:
2015 arch = "alpha64"; break;
2017 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2018 case PROCESSOR_ARCHITECTURE_MSIL:
2019 arch = "msil"; break;
2021 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2022 case PROCESSOR_ARCHITECTURE_AMD64:
2023 arch = "amd64"; break;
2025 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2026 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2027 arch = "ia32-64"; break;
2029 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2030 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2031 arch = "unknown"; break;
2034 sprintf(name->machine, "unknown(0x%x)", procarch);
2035 arch = name->machine;
2038 if (name->machine != arch)
2039 strcpy(name->machine, arch);
2044 /* Timing related stuff */
2047 do_raise(pTHX_ int sig)
2049 if (sig < SIG_SIZE) {
2050 Sighandler_t handler = w32_sighandler[sig];
2051 if (handler == SIG_IGN) {
2054 else if (handler != SIG_DFL) {
2059 /* Choose correct default behaviour */
2075 /* Tell caller to exit thread/process as approriate */
2080 sig_terminate(pTHX_ int sig)
2082 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2083 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2090 win32_async_check(pTHX)
2093 HWND hwnd = w32_message_hwnd;
2095 /* Reset w32_poll_count before doing anything else, incase we dispatch
2096 * messages that end up calling back into perl */
2099 if (hwnd != INVALID_HANDLE_VALUE) {
2100 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2101 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2106 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2107 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2109 /* re-post a WM_QUIT message (we'll mark it as read later) */
2110 if(msg.message == WM_QUIT) {
2111 PostQuitMessage((int)msg.wParam);
2115 if(!CallMsgFilter(&msg, MSGF_USER))
2117 TranslateMessage(&msg);
2118 DispatchMessage(&msg);
2123 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2124 * This is necessary when we are being called by win32_msgwait() to
2125 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2126 * message over and over. An example how this can happen is when
2127 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2128 * is generating messages before the process terminated.
2130 while (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD))
2133 /* Above or other stuff may have set a signal flag */
2140 /* This function will not return until the timeout has elapsed, or until
2141 * one of the handles is ready. */
2143 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2145 /* We may need several goes at this - so compute when we stop */
2147 if (timeout != INFINITE) {
2148 ticks = GetTickCount();
2152 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2155 if (result == WAIT_TIMEOUT) {
2156 /* Ran out of time - explicit return of zero to avoid -ve if we
2157 have scheduling issues
2161 if (timeout != INFINITE) {
2162 ticks = GetTickCount();
2164 if (result == WAIT_OBJECT_0 + count) {
2165 /* Message has arrived - check it */
2166 (void)win32_async_check(aTHX);
2169 /* Not timeout or message - one of handles is ready */
2173 /* compute time left to wait */
2174 ticks = timeout - ticks;
2175 /* If we are past the end say zero */
2176 return (ticks > 0) ? ticks : 0;
2180 win32_internal_wait(int *status, DWORD timeout)
2182 /* XXX this wait emulation only knows about processes
2183 * spawned via win32_spawnvp(P_NOWAIT, ...).
2187 DWORD exitcode, waitcode;
2190 if (w32_num_pseudo_children) {
2191 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2192 timeout, &waitcode);
2193 /* Time out here if there are no other children to wait for. */
2194 if (waitcode == WAIT_TIMEOUT) {
2195 if (!w32_num_children) {
2199 else if (waitcode != WAIT_FAILED) {
2200 if (waitcode >= WAIT_ABANDONED_0
2201 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2202 i = waitcode - WAIT_ABANDONED_0;
2204 i = waitcode - WAIT_OBJECT_0;
2205 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2206 *status = (int)((exitcode & 0xff) << 8);
2207 retval = (int)w32_pseudo_child_pids[i];
2208 remove_dead_pseudo_process(i);
2215 if (!w32_num_children) {
2220 /* if a child exists, wait for it to die */
2221 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2222 if (waitcode == WAIT_TIMEOUT) {
2225 if (waitcode != WAIT_FAILED) {
2226 if (waitcode >= WAIT_ABANDONED_0
2227 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2228 i = waitcode - WAIT_ABANDONED_0;
2230 i = waitcode - WAIT_OBJECT_0;
2231 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2232 *status = (int)((exitcode & 0xff) << 8);
2233 retval = (int)w32_child_pids[i];
2234 remove_dead_process(i);
2239 errno = GetLastError();
2244 win32_waitpid(int pid, int *status, int flags)
2247 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2250 if (pid == -1) /* XXX threadid == 1 ? */
2251 return win32_internal_wait(status, timeout);
2254 child = find_pseudo_pid(-pid);
2256 HANDLE hThread = w32_pseudo_child_handles[child];
2258 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2259 if (waitcode == WAIT_TIMEOUT) {
2262 else if (waitcode == WAIT_OBJECT_0) {
2263 if (GetExitCodeThread(hThread, &waitcode)) {
2264 *status = (int)((waitcode & 0xff) << 8);
2265 retval = (int)w32_pseudo_child_pids[child];
2266 remove_dead_pseudo_process(child);
2273 else if (IsWin95()) {
2282 child = find_pid(pid);
2284 hProcess = w32_child_handles[child];
2285 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2286 if (waitcode == WAIT_TIMEOUT) {
2289 else if (waitcode == WAIT_OBJECT_0) {
2290 if (GetExitCodeProcess(hProcess, &waitcode)) {
2291 *status = (int)((waitcode & 0xff) << 8);
2292 retval = (int)w32_child_pids[child];
2293 remove_dead_process(child);
2302 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2303 (IsWin95() ? -pid : pid));
2305 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2306 if (waitcode == WAIT_TIMEOUT) {
2307 CloseHandle(hProcess);
2310 else if (waitcode == WAIT_OBJECT_0) {
2311 if (GetExitCodeProcess(hProcess, &waitcode)) {
2312 *status = (int)((waitcode & 0xff) << 8);
2313 CloseHandle(hProcess);
2317 CloseHandle(hProcess);
2323 return retval >= 0 ? pid : retval;
2327 win32_wait(int *status)
2329 return win32_internal_wait(status, INFINITE);
2332 DllExport unsigned int
2333 win32_sleep(unsigned int t)
2336 /* Win32 times are in ms so *1000 in and /1000 out */
2337 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2340 DllExport unsigned int
2341 win32_alarm(unsigned int sec)
2344 * the 'obvious' implentation is SetTimer() with a callback
2345 * which does whatever receiving SIGALRM would do
2346 * we cannot use SIGALRM even via raise() as it is not
2347 * one of the supported codes in <signal.h>
2351 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2352 w32_message_hwnd = win32_create_message_window();
2355 if (w32_message_hwnd == NULL)
2356 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2359 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2364 KillTimer(w32_message_hwnd, w32_timerid);
2371 #ifdef HAVE_DES_FCRYPT
2372 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2376 win32_crypt(const char *txt, const char *salt)
2379 #ifdef HAVE_DES_FCRYPT
2380 return des_fcrypt(txt, salt, w32_crypt_buffer);
2382 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2387 #ifdef USE_FIXED_OSFHANDLE
2389 #define FOPEN 0x01 /* file handle open */
2390 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2391 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2392 #define FDEV 0x40 /* file handle refers to device */
2393 #define FTEXT 0x80 /* file handle is in text mode */
2396 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2399 * This function allocates a free C Runtime file handle and associates
2400 * it with the Win32 HANDLE specified by the first parameter. This is a
2401 * temperary fix for WIN95's brain damage GetFileType() error on socket
2402 * we just bypass that call for socket
2404 * This works with MSVC++ 4.0+ or GCC/Mingw32
2407 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2408 * int flags - flags to associate with C Runtime file handle.
2411 * returns index of entry in fh, if successful
2412 * return -1, if no free entry is found
2416 *******************************************************************************/
2419 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2420 * this lets sockets work on Win9X with GCC and should fix the problems
2425 /* create an ioinfo entry, kill its handle, and steal the entry */
2430 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2431 int fh = _open_osfhandle((intptr_t)hF, 0);
2435 EnterCriticalSection(&(_pioinfo(fh)->lock));
2440 my_open_osfhandle(intptr_t osfhandle, int flags)
2443 char fileflags; /* _osfile flags */
2445 /* copy relevant flags from second parameter */
2448 if (flags & O_APPEND)
2449 fileflags |= FAPPEND;
2454 if (flags & O_NOINHERIT)
2455 fileflags |= FNOINHERIT;
2457 /* attempt to allocate a C Runtime file handle */
2458 if ((fh = _alloc_osfhnd()) == -1) {
2459 errno = EMFILE; /* too many open files */
2460 _doserrno = 0L; /* not an OS error */
2461 return -1; /* return error to caller */
2464 /* the file is open. now, set the info in _osfhnd array */
2465 _set_osfhnd(fh, osfhandle);
2467 fileflags |= FOPEN; /* mark as open */
2469 _osfile(fh) = fileflags; /* set osfile entry */
2470 LeaveCriticalSection(&_pioinfo(fh)->lock);
2472 return fh; /* return handle */
2475 #endif /* USE_FIXED_OSFHANDLE */
2477 /* simulate flock by locking a range on the file */
2479 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2480 #define LK_LEN 0xffff0000
2483 win32_flock(int fd, int oper)
2491 Perl_croak_nocontext("flock() unimplemented on this platform");
2494 fh = (HANDLE)_get_osfhandle(fd);
2495 memset(&o, 0, sizeof(o));
2498 case LOCK_SH: /* shared lock */
2499 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2501 case LOCK_EX: /* exclusive lock */
2502 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2504 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2505 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2507 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2508 LK_ERR(LockFileEx(fh,
2509 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2510 0, LK_LEN, 0, &o),i);
2512 case LOCK_UN: /* unlock lock */
2513 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2515 default: /* unknown */
2526 * redirected io subsystem for all XS modules
2539 return (&(_environ));
2542 /* the rest are the remapped stdio routines */
2562 win32_ferror(FILE *fp)
2564 return (ferror(fp));
2569 win32_feof(FILE *fp)
2575 * Since the errors returned by the socket error function
2576 * WSAGetLastError() are not known by the library routine strerror
2577 * we have to roll our own.
2581 win32_strerror(int e)
2583 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2584 extern int sys_nerr;
2588 if (e < 0 || e > sys_nerr) {
2593 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2594 w32_strerror_buffer,
2595 sizeof(w32_strerror_buffer), NULL) == 0)
2596 strcpy(w32_strerror_buffer, "Unknown Error");
2598 return w32_strerror_buffer;
2604 win32_str_os_error(void *sv, DWORD dwErr)
2608 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2609 |FORMAT_MESSAGE_IGNORE_INSERTS
2610 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2611 dwErr, 0, (char *)&sMsg, 1, NULL);
2612 /* strip trailing whitespace and period */
2615 --dwLen; /* dwLen doesn't include trailing null */
2616 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2617 if ('.' != sMsg[dwLen])
2622 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2624 dwLen = sprintf(sMsg,
2625 "Unknown error #0x%lX (lookup 0x%lX)",
2626 dwErr, GetLastError());
2630 sv_setpvn((SV*)sv, sMsg, dwLen);
2636 win32_fprintf(FILE *fp, const char *format, ...)
2639 va_start(marker, format); /* Initialize variable arguments. */
2641 return (vfprintf(fp, format, marker));
2645 win32_printf(const char *format, ...)
2648 va_start(marker, format); /* Initialize variable arguments. */
2650 return (vprintf(format, marker));
2654 win32_vfprintf(FILE *fp, const char *format, va_list args)
2656 return (vfprintf(fp, format, args));
2660 win32_vprintf(const char *format, va_list args)
2662 return (vprintf(format, args));
2666 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2668 return fread(buf, size, count, fp);
2672 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2674 return fwrite(buf, size, count, fp);
2677 #define MODE_SIZE 10
2680 win32_fopen(const char *filename, const char *mode)
2688 if (stricmp(filename, "/dev/null")==0)
2691 f = fopen(PerlDir_mapA(filename), mode);
2692 /* avoid buffering headaches for child processes */
2693 if (f && *mode == 'a')
2694 win32_fseek(f, 0, SEEK_END);
2698 #ifndef USE_SOCKETS_AS_HANDLES
2700 #define fdopen my_fdopen
2704 win32_fdopen(int handle, const char *mode)
2708 f = fdopen(handle, (char *) mode);
2709 /* avoid buffering headaches for child processes */
2710 if (f && *mode == 'a')
2711 win32_fseek(f, 0, SEEK_END);
2716 win32_freopen(const char *path, const char *mode, FILE *stream)
2719 if (stricmp(path, "/dev/null")==0)
2722 return freopen(PerlDir_mapA(path), mode, stream);
2726 win32_fclose(FILE *pf)
2728 return my_fclose(pf); /* defined in win32sck.c */
2732 win32_fputs(const char *s,FILE *pf)
2734 return fputs(s, pf);
2738 win32_fputc(int c,FILE *pf)
2744 win32_ungetc(int c,FILE *pf)
2746 return ungetc(c,pf);
2750 win32_getc(FILE *pf)
2756 win32_fileno(FILE *pf)
2762 win32_clearerr(FILE *pf)
2769 win32_fflush(FILE *pf)
2775 win32_ftell(FILE *pf)
2777 #if defined(WIN64) || defined(USE_LARGE_FILES)
2778 #if defined(__BORLANDC__) /* buk */
2779 return win32_tell( fileno( pf ) );
2782 if (fgetpos(pf, &pos))
2792 win32_fseek(FILE *pf, Off_t offset,int origin)
2794 #if defined(WIN64) || defined(USE_LARGE_FILES)
2795 #if defined(__BORLANDC__) /* buk */
2805 if (fgetpos(pf, &pos))
2810 fseek(pf, 0, SEEK_END);
2811 pos = _telli64(fileno(pf));
2820 return fsetpos(pf, &offset);
2823 return fseek(pf, (long)offset, origin);
2828 win32_fgetpos(FILE *pf,fpos_t *p)
2830 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2831 if( win32_tell(fileno(pf)) == -1L ) {
2837 return fgetpos(pf, p);
2842 win32_fsetpos(FILE *pf,const fpos_t *p)
2844 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2845 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2847 return fsetpos(pf, p);
2852 win32_rewind(FILE *pf)
2862 char prefix[MAX_PATH+1];
2863 char filename[MAX_PATH+1];
2864 DWORD len = GetTempPath(MAX_PATH, prefix);
2865 if (len && len < MAX_PATH) {
2866 if (GetTempFileName(prefix, "plx", 0, filename)) {
2867 HANDLE fh = CreateFile(filename,
2868 DELETE | GENERIC_READ | GENERIC_WRITE,
2872 FILE_ATTRIBUTE_NORMAL
2873 | FILE_FLAG_DELETE_ON_CLOSE,
2875 if (fh != INVALID_HANDLE_VALUE) {
2876 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2878 #if defined(__BORLANDC__)
2879 setmode(fd,O_BINARY);
2881 DEBUG_p(PerlIO_printf(Perl_debug_log,
2882 "Created tmpfile=%s\n",filename));
2894 int fd = win32_tmpfd();
2896 return win32_fdopen(fd, "w+b");
2908 win32_fstat(int fd, Stat_t *sbufptr)
2911 /* A file designated by filehandle is not shown as accessible
2912 * for write operations, probably because it is opened for reading.
2915 BY_HANDLE_FILE_INFORMATION bhfi;
2916 #if defined(WIN64) || defined(USE_LARGE_FILES)
2917 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2919 int rc = fstat(fd,&tmp);
2921 sbufptr->st_dev = tmp.st_dev;
2922 sbufptr->st_ino = tmp.st_ino;
2923 sbufptr->st_mode = tmp.st_mode;
2924 sbufptr->st_nlink = tmp.st_nlink;
2925 sbufptr->st_uid = tmp.st_uid;
2926 sbufptr->st_gid = tmp.st_gid;
2927 sbufptr->st_rdev = tmp.st_rdev;
2928 sbufptr->st_size = tmp.st_size;
2929 sbufptr->st_atime = tmp.st_atime;
2930 sbufptr->st_mtime = tmp.st_mtime;
2931 sbufptr->st_ctime = tmp.st_ctime;
2933 int rc = fstat(fd,sbufptr);
2936 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2937 #if defined(WIN64) || defined(USE_LARGE_FILES)
2938 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2940 sbufptr->st_mode &= 0xFE00;
2941 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2942 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2944 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2945 + ((S_IREAD|S_IWRITE) >> 6));
2949 return my_fstat(fd,sbufptr);
2954 win32_pipe(int *pfd, unsigned int size, int mode)
2956 return _pipe(pfd, size, mode);
2960 win32_popenlist(const char *mode, IV narg, SV **args)
2963 Perl_croak(aTHX_ "List form of pipe open not implemented");
2968 * a popen() clone that respects PERL5SHELL
2970 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2974 win32_popen(const char *command, const char *mode)
2976 #ifdef USE_RTL_POPEN
2977 return _popen(command, mode);
2989 /* establish which ends read and write */
2990 if (strchr(mode,'w')) {
2991 stdfd = 0; /* stdin */
2994 nhandle = STD_INPUT_HANDLE;
2996 else if (strchr(mode,'r')) {
2997 stdfd = 1; /* stdout */
3000 nhandle = STD_OUTPUT_HANDLE;
3005 /* set the correct mode */
3006 if (strchr(mode,'b'))
3008 else if (strchr(mode,'t'))
3011 ourmode = _fmode & (O_TEXT | O_BINARY);
3013 /* the child doesn't inherit handles */
3014 ourmode |= O_NOINHERIT;
3016 if (win32_pipe(p, 512, ourmode) == -1)
3019 /* save the old std handle (this needs to happen before the
3020 * dup2(), since that might call SetStdHandle() too) */
3023 old_h = GetStdHandle(nhandle);
3025 /* save current stdfd */
3026 if ((oldfd = win32_dup(stdfd)) == -1)
3029 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3030 /* stdfd will be inherited by the child */
3031 if (win32_dup2(p[child], stdfd) == -1)
3034 /* close the child end in parent */
3035 win32_close(p[child]);
3037 /* set the new std handle (in case dup2() above didn't) */
3038 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3040 /* start the child */
3043 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3046 /* revert stdfd to whatever it was before */
3047 if (win32_dup2(oldfd, stdfd) == -1)
3050 /* close saved handle */
3053 /* restore the old std handle (this needs to happen after the
3054 * dup2(), since that might call SetStdHandle() too */
3056 SetStdHandle(nhandle, old_h);
3062 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3065 /* set process id so that it can be returned by perl's open() */
3066 PL_forkprocess = childpid;
3069 /* we have an fd, return a file stream */
3070 return (PerlIO_fdopen(p[parent], (char *)mode));
3073 /* we don't need to check for errors here */
3077 win32_dup2(oldfd, stdfd);
3081 SetStdHandle(nhandle, old_h);
3087 #endif /* USE_RTL_POPEN */
3095 win32_pclose(PerlIO *pf)
3097 #ifdef USE_RTL_POPEN
3101 int childpid, status;
3105 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3108 childpid = SvIVX(sv);
3126 if (win32_waitpid(childpid, &status, 0) == -1)
3131 #endif /* USE_RTL_POPEN */
3137 LPCWSTR lpExistingFileName,
3138 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3141 WCHAR wFullName[MAX_PATH+1];
3142 LPVOID lpContext = NULL;
3143 WIN32_STREAM_ID StreamId;
3144 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3149 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3150 BOOL, BOOL, LPVOID*) =
3151 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3152 BOOL, BOOL, LPVOID*))
3153 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3154 if (pfnBackupWrite == NULL)
3157 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3160 dwLen = (dwLen+1)*sizeof(WCHAR);
3162 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3163 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3164 NULL, OPEN_EXISTING, 0, NULL);
3165 if (handle == INVALID_HANDLE_VALUE)
3168 StreamId.dwStreamId = BACKUP_LINK;
3169 StreamId.dwStreamAttributes = 0;
3170 StreamId.dwStreamNameSize = 0;
3171 #if defined(__BORLANDC__) \
3172 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3173 StreamId.Size.u.HighPart = 0;
3174 StreamId.Size.u.LowPart = dwLen;
3176 StreamId.Size.HighPart = 0;
3177 StreamId.Size.LowPart = dwLen;
3180 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3181 FALSE, FALSE, &lpContext);
3183 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3184 FALSE, FALSE, &lpContext);
3185 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3188 CloseHandle(handle);
3193 win32_link(const char *oldname, const char *newname)
3196 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3197 WCHAR wOldName[MAX_PATH+1];
3198 WCHAR wNewName[MAX_PATH+1];
3201 Perl_croak(aTHX_ PL_no_func, "link");
3203 pfnCreateHardLinkW =
3204 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3205 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3206 if (pfnCreateHardLinkW == NULL)
3207 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3209 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3210 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3211 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3212 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3216 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3221 win32_rename(const char *oname, const char *newname)
3223 char szOldName[MAX_PATH+1];
3224 char szNewName[MAX_PATH+1];
3228 /* XXX despite what the documentation says about MoveFileEx(),
3229 * it doesn't work under Windows95!
3232 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3233 if (stricmp(newname, oname))
3234 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3235 strcpy(szOldName, PerlDir_mapA(oname));
3236 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3238 DWORD err = GetLastError();
3240 case ERROR_BAD_NET_NAME:
3241 case ERROR_BAD_NETPATH:
3242 case ERROR_BAD_PATHNAME:
3243 case ERROR_FILE_NOT_FOUND:
3244 case ERROR_FILENAME_EXCED_RANGE:
3245 case ERROR_INVALID_DRIVE:
3246 case ERROR_NO_MORE_FILES:
3247 case ERROR_PATH_NOT_FOUND:
3260 char szTmpName[MAX_PATH+1];
3261 char dname[MAX_PATH+1];
3262 char *endname = NULL;
3264 DWORD from_attr, to_attr;
3266 strcpy(szOldName, PerlDir_mapA(oname));
3267 strcpy(szNewName, PerlDir_mapA(newname));
3269 /* if oname doesn't exist, do nothing */
3270 from_attr = GetFileAttributes(szOldName);
3271 if (from_attr == 0xFFFFFFFF) {
3276 /* if newname exists, rename it to a temporary name so that we
3277 * don't delete it in case oname happens to be the same file
3278 * (but perhaps accessed via a different path)
3280 to_attr = GetFileAttributes(szNewName);
3281 if (to_attr != 0xFFFFFFFF) {
3282 /* if newname is a directory, we fail
3283 * XXX could overcome this with yet more convoluted logic */
3284 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3288 tmplen = strlen(szNewName);
3289 strcpy(szTmpName,szNewName);
3290 endname = szTmpName+tmplen;
3291 for (; endname > szTmpName ; --endname) {
3292 if (*endname == '/' || *endname == '\\') {
3297 if (endname > szTmpName)
3298 endname = strcpy(dname,szTmpName);
3302 /* get a temporary filename in same directory
3303 * XXX is this really the best we can do? */
3304 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3308 DeleteFile(szTmpName);
3310 retval = rename(szNewName, szTmpName);
3317 /* rename oname to newname */
3318 retval = rename(szOldName, szNewName);
3320 /* if we created a temporary file before ... */
3321 if (endname != NULL) {
3322 /* ...and rename succeeded, delete temporary file/directory */
3324 DeleteFile(szTmpName);
3325 /* else restore it to what it was */
3327 (void)rename(szTmpName, szNewName);
3334 win32_setmode(int fd, int mode)
3336 return setmode(fd, mode);
3340 win32_chsize(int fd, Off_t size)
3342 #if defined(WIN64) || defined(USE_LARGE_FILES)
3344 Off_t cur, end, extend;
3346 cur = win32_tell(fd);
3349 end = win32_lseek(fd, 0, SEEK_END);
3352 extend = size - end;
3356 else if (extend > 0) {
3357 /* must grow the file, padding with nulls */
3359 int oldmode = win32_setmode(fd, O_BINARY);
3361 memset(b, '\0', sizeof(b));
3363 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3364 count = win32_write(fd, b, count);
3365 if ((int)count < 0) {
3369 } while ((extend -= count) > 0);
3370 win32_setmode(fd, oldmode);
3373 /* shrink the file */
3374 win32_lseek(fd, size, SEEK_SET);
3375 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3381 win32_lseek(fd, cur, SEEK_SET);
3384 return chsize(fd, (long)size);
3389 win32_lseek(int fd, Off_t offset, int origin)
3391 #if defined(WIN64) || defined(USE_LARGE_FILES)
3392 #if defined(__BORLANDC__) /* buk */
3394 pos.QuadPart = offset;
3395 pos.LowPart = SetFilePointer(
3396 (HANDLE)_get_osfhandle(fd),
3401 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3405 return pos.QuadPart;
3407 return _lseeki64(fd, offset, origin);
3410 return lseek(fd, (long)offset, origin);
3417 #if defined(WIN64) || defined(USE_LARGE_FILES)
3418 #if defined(__BORLANDC__) /* buk */
3421 pos.LowPart = SetFilePointer(
3422 (HANDLE)_get_osfhandle(fd),
3427 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3431 return pos.QuadPart;
3432 /* return tell(fd); */
3434 return _telli64(fd);
3442 win32_open(const char *path, int flag, ...)
3449 pmode = va_arg(ap, int);
3452 if (stricmp(path, "/dev/null")==0)
3455 return open(PerlDir_mapA(path), flag, pmode);
3458 /* close() that understands socket */
3459 extern int my_close(int); /* in win32sck.c */
3464 return my_close(fd);
3480 win32_dup2(int fd1,int fd2)
3482 return dup2(fd1,fd2);
3485 #ifdef PERL_MSVCRT_READFIX
3487 #define LF 10 /* line feed */
3488 #define CR 13 /* carriage return */
3489 #define CTRLZ 26 /* ctrl-z means eof for text */
3490 #define FOPEN 0x01 /* file handle open */
3491 #define FEOFLAG 0x02 /* end of file has been encountered */
3492 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3493 #define FPIPE 0x08 /* file handle refers to a pipe */
3494 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3495 #define FDEV 0x40 /* file handle refers to device */
3496 #define FTEXT 0x80 /* file handle is in text mode */
3497 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3500 _fixed_read(int fh, void *buf, unsigned cnt)
3502 int bytes_read; /* number of bytes read */
3503 char *buffer; /* buffer to read to */
3504 int os_read; /* bytes read on OS call */
3505 char *p, *q; /* pointers into buffer */
3506 char peekchr; /* peek-ahead character */
3507 ULONG filepos; /* file position after seek */
3508 ULONG dosretval; /* o.s. return value */
3510 /* validate handle */
3511 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3512 !(_osfile(fh) & FOPEN))
3514 /* out of range -- return error */
3516 _doserrno = 0; /* not o.s. error */
3521 * If lockinitflag is FALSE, assume fd is device
3522 * lockinitflag is set to TRUE by open.
3524 if (_pioinfo(fh)->lockinitflag)
3525 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3527 bytes_read = 0; /* nothing read yet */
3528 buffer = (char*)buf;
3530 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3531 /* nothing to read or at EOF, so return 0 read */
3535 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3536 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3538 *buffer++ = _pipech(fh);
3541 _pipech(fh) = LF; /* mark as empty */
3546 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3548 /* ReadFile has reported an error. recognize two special cases.
3550 * 1. map ERROR_ACCESS_DENIED to EBADF
3552 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3553 * means the handle is a read-handle on a pipe for which
3554 * all write-handles have been closed and all data has been
3557 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3558 /* wrong read/write mode should return EBADF, not EACCES */
3560 _doserrno = dosretval;
3564 else if (dosretval == ERROR_BROKEN_PIPE) {
3574 bytes_read += os_read; /* update bytes read */
3576 if (_osfile(fh) & FTEXT) {
3577 /* now must translate CR-LFs to LFs in the buffer */
3579 /* set CRLF flag to indicate LF at beginning of buffer */
3580 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3581 /* _osfile(fh) |= FCRLF; */
3583 /* _osfile(fh) &= ~FCRLF; */
3585 _osfile(fh) &= ~FCRLF;
3587 /* convert chars in the buffer: p is src, q is dest */
3589 while (p < (char *)buf + bytes_read) {
3591 /* if fh is not a device, set ctrl-z flag */
3592 if (!(_osfile(fh) & FDEV))
3593 _osfile(fh) |= FEOFLAG;
3594 break; /* stop translating */
3599 /* *p is CR, so must check next char for LF */
3600 if (p < (char *)buf + bytes_read - 1) {
3603 *q++ = LF; /* convert CR-LF to LF */
3606 *q++ = *p++; /* store char normally */
3609 /* This is the hard part. We found a CR at end of
3610 buffer. We must peek ahead to see if next char
3615 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3616 (LPDWORD)&os_read, NULL))
3617 dosretval = GetLastError();
3619 if (dosretval != 0 || os_read == 0) {
3620 /* couldn't read ahead, store CR */
3624 /* peekchr now has the extra character -- we now
3625 have several possibilities:
3626 1. disk file and char is not LF; just seek back
3628 2. disk file and char is LF; store LF, don't seek back
3629 3. pipe/device and char is LF; store LF.
3630 4. pipe/device and char isn't LF, store CR and
3631 put char in pipe lookahead buffer. */
3632 if (_osfile(fh) & (FDEV|FPIPE)) {
3633 /* non-seekable device */
3638 _pipech(fh) = peekchr;
3643 if (peekchr == LF) {
3644 /* nothing read yet; must make some
3647 /* turn on this flag for tell routine */
3648 _osfile(fh) |= FCRLF;
3651 HANDLE osHandle; /* o.s. handle value */
3653 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3655 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3656 dosretval = GetLastError();
3667 /* we now change bytes_read to reflect the true number of chars
3669 bytes_read = q - (char *)buf;
3673 if (_pioinfo(fh)->lockinitflag)
3674 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3679 #endif /* PERL_MSVCRT_READFIX */
3682 win32_read(int fd, void *buf, unsigned int cnt)
3684 #ifdef PERL_MSVCRT_READFIX
3685 return _fixed_read(fd, buf, cnt);
3687 return read(fd, buf, cnt);
3692 win32_write(int fd, const void *buf, unsigned int cnt)
3694 return write(fd, buf, cnt);
3698 win32_mkdir(const char *dir, int mode)
3701 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3705 win32_rmdir(const char *dir)
3708 return rmdir(PerlDir_mapA(dir));
3712 win32_chdir(const char *dir)
3723 win32_access(const char *path, int mode)
3726 return access(PerlDir_mapA(path), mode);
3730 win32_chmod(const char *path, int mode)
3733 return chmod(PerlDir_mapA(path), mode);
3738 create_command_line(char *cname, STRLEN clen, const char * const *args)
3745 bool bat_file = FALSE;
3746 bool cmd_shell = FALSE;
3747 bool dumb_shell = FALSE;
3748 bool extra_quotes = FALSE;
3749 bool quote_next = FALSE;
3752 cname = (char*)args[0];
3754 /* The NT cmd.exe shell has the following peculiarity that needs to be
3755 * worked around. It strips a leading and trailing dquote when any
3756 * of the following is true:
3757 * 1. the /S switch was used
3758 * 2. there are more than two dquotes
3759 * 3. there is a special character from this set: &<>()@^|
3760 * 4. no whitespace characters within the two dquotes
3761 * 5. string between two dquotes isn't an executable file
3762 * To work around this, we always add a leading and trailing dquote
3763 * to the string, if the first argument is either "cmd.exe" or "cmd",
3764 * and there were at least two or more arguments passed to cmd.exe
3765 * (not including switches).
3766 * XXX the above rules (from "cmd /?") don't seem to be applied
3767 * always, making for the convolutions below :-(
3771 clen = strlen(cname);
3774 && (stricmp(&cname[clen-4], ".bat") == 0
3775 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3782 char *exe = strrchr(cname, '/');
3783 char *exe2 = strrchr(cname, '\\');
3790 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3794 else if (stricmp(exe, "command.com") == 0
3795 || stricmp(exe, "command") == 0)
3802 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3803 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3804 STRLEN curlen = strlen(arg);
3805 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3806 len += 2; /* assume quoting needed (worst case) */
3808 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3810 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3813 Newx(cmd, len, char);
3816 if (bat_file && !IsWin95()) {
3818 extra_quotes = TRUE;
3821 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3823 STRLEN curlen = strlen(arg);
3825 /* we want to protect empty arguments and ones with spaces with
3826 * dquotes, but only if they aren't already there */
3831 else if (quote_next) {
3832 /* see if it really is multiple arguments pretending to
3833 * be one and force a set of quotes around it */
3834 if (*find_next_space(arg))
3837 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3839 while (i < curlen) {
3840 if (isSPACE(arg[i])) {
3843 else if (arg[i] == '"') {
3867 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3868 && stricmp(arg+curlen-2, "/c") == 0)
3870 /* is there a next argument? */
3871 if (args[index+1]) {
3872 /* are there two or more next arguments? */
3873 if (args[index+2]) {
3875 extra_quotes = TRUE;
3878 /* single argument, force quoting if it has spaces */
3894 qualified_path(const char *cmd)
3898 char *fullcmd, *curfullcmd;
3904 fullcmd = (char*)cmd;
3906 if (*fullcmd == '/' || *fullcmd == '\\')
3913 pathstr = PerlEnv_getenv("PATH");
3915 /* worst case: PATH is a single directory; we need additional space
3916 * to append "/", ".exe" and trailing "\0" */
3917 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3918 curfullcmd = fullcmd;
3923 /* start by appending the name to the current prefix */
3924 strcpy(curfullcmd, cmd);
3925 curfullcmd += cmdlen;
3927 /* if it doesn't end with '.', or has no extension, try adding
3928 * a trailing .exe first */
3929 if (cmd[cmdlen-1] != '.'
3930 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3932 strcpy(curfullcmd, ".exe");
3933 res = GetFileAttributes(fullcmd);
3934 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3939 /* that failed, try the bare name */
3940 res = GetFileAttributes(fullcmd);
3941 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3944 /* quit if no other path exists, or if cmd already has path */
3945 if (!pathstr || !*pathstr || has_slash)
3948 /* skip leading semis */
3949 while (*pathstr == ';')
3952 /* build a new prefix from scratch */
3953 curfullcmd = fullcmd;
3954 while (*pathstr && *pathstr != ';') {
3955 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3956 pathstr++; /* skip initial '"' */
3957 while (*pathstr && *pathstr != '"') {
3958 *curfullcmd++ = *pathstr++;
3961 pathstr++; /* skip trailing '"' */
3964 *curfullcmd++ = *pathstr++;
3968 pathstr++; /* skip trailing semi */
3969 if (curfullcmd > fullcmd /* append a dir separator */
3970 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3972 *curfullcmd++ = '\\';
3980 /* The following are just place holders.
3981 * Some hosts may provide and environment that the OS is
3982 * not tracking, therefore, these host must provide that
3983 * environment and the current directory to CreateProcess
3987 win32_get_childenv(void)
3993 win32_free_childenv(void* d)
3998 win32_clearenv(void)
4000 char *envv = GetEnvironmentStrings();
4004 char *end = strchr(cur,'=');
4005 if (end && end != cur) {
4007 SetEnvironmentVariable(cur, NULL);
4009 cur = end + strlen(end+1)+2;
4011 else if ((len = strlen(cur)))
4014 FreeEnvironmentStrings(envv);
4018 win32_get_childdir(void)
4022 char szfilename[MAX_PATH+1];
4024 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4025 Newx(ptr, strlen(szfilename)+1, char);
4026 strcpy(ptr, szfilename);
4031 win32_free_childdir(char* d)
4038 /* XXX this needs to be made more compatible with the spawnvp()
4039 * provided by the various RTLs. In particular, searching for
4040 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4041 * This doesn't significantly affect perl itself, because we
4042 * always invoke things using PERL5SHELL if a direct attempt to
4043 * spawn the executable fails.
4045 * XXX splitting and rejoining the commandline between do_aspawn()
4046 * and win32_spawnvp() could also be avoided.
4050 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4052 #ifdef USE_RTL_SPAWNVP
4053 return spawnvp(mode, cmdname, (char * const *)argv);
4060 STARTUPINFO StartupInfo;
4061 PROCESS_INFORMATION ProcessInformation;
4064 char *fullcmd = NULL;
4065 char *cname = (char *)cmdname;
4069 clen = strlen(cname);
4070 /* if command name contains dquotes, must remove them */
4071 if (strchr(cname, '"')) {
4073 Newx(cname,clen+1,char);
4086 cmd = create_command_line(cname, clen, argv);
4088 env = PerlEnv_get_childenv();
4089 dir = PerlEnv_get_childdir();
4092 case P_NOWAIT: /* asynch + remember result */
4093 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4098 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4101 create |= CREATE_NEW_PROCESS_GROUP;
4104 case P_WAIT: /* synchronous execution */
4106 default: /* invalid mode */
4111 memset(&StartupInfo,0,sizeof(StartupInfo));
4112 StartupInfo.cb = sizeof(StartupInfo);
4113 memset(&tbl,0,sizeof(tbl));
4114 PerlEnv_get_child_IO(&tbl);
4115 StartupInfo.dwFlags = tbl.dwFlags;
4116 StartupInfo.dwX = tbl.dwX;
4117 StartupInfo.dwY = tbl.dwY;
4118 StartupInfo.dwXSize = tbl.dwXSize;
4119 StartupInfo.dwYSize = tbl.dwYSize;
4120 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4121 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4122 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4123 StartupInfo.wShowWindow = tbl.wShowWindow;
4124 StartupInfo.hStdInput = tbl.childStdIn;
4125 StartupInfo.hStdOutput = tbl.childStdOut;
4126 StartupInfo.hStdError = tbl.childStdErr;
4127 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4128 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4129 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4131 create |= CREATE_NEW_CONSOLE;
4134 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4136 if (w32_use_showwindow) {
4137 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4138 StartupInfo.wShowWindow = w32_showwindow;
4141 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4144 if (!CreateProcess(cname, /* search PATH to find executable */
4145 cmd, /* executable, and its arguments */
4146 NULL, /* process attributes */
4147 NULL, /* thread attributes */
4148 TRUE, /* inherit handles */
4149 create, /* creation flags */
4150 (LPVOID)env, /* inherit environment */
4151 dir, /* inherit cwd */
4153 &ProcessInformation))
4155 /* initial NULL argument to CreateProcess() does a PATH
4156 * search, but it always first looks in the directory
4157 * where the current process was started, which behavior
4158 * is undesirable for backward compatibility. So we
4159 * jump through our own hoops by picking out the path
4160 * we really want it to use. */
4162 fullcmd = qualified_path(cname);
4164 if (cname != cmdname)
4167 DEBUG_p(PerlIO_printf(Perl_debug_log,
4168 "Retrying [%s] with same args\n",
4178 if (mode == P_NOWAIT) {
4179 /* asynchronous spawn -- store handle, return PID */
4180 ret = (int)ProcessInformation.dwProcessId;
4181 if (IsWin95() && ret < 0)
4184 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4185 w32_child_pids[w32_num_children] = (DWORD)ret;
4190 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4191 /* FIXME: if msgwait returned due to message perhaps forward the
4192 "signal" to the process
4194 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4196 CloseHandle(ProcessInformation.hProcess);
4199 CloseHandle(ProcessInformation.hThread);
4202 PerlEnv_free_childenv(env);
4203 PerlEnv_free_childdir(dir);
4205 if (cname != cmdname)
4212 win32_execv(const char *cmdname, const char *const *argv)
4216 /* if this is a pseudo-forked child, we just want to spawn
4217 * the new program, and return */
4219 # ifdef __BORLANDC__
4220 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4222 return spawnv(P_WAIT, cmdname, argv);
4226 return execv(cmdname, (char *const *)argv);
4228 return execv(cmdname, argv);
4233 win32_execvp(const char *cmdname, const char *const *argv)
4237 /* if this is a pseudo-forked child, we just want to spawn
4238 * the new program, and return */
4239 if (w32_pseudo_id) {
4240 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4250 return execvp(cmdname, (char *const *)argv);
4252 return execvp(cmdname, argv);
4257 win32_perror(const char *str)
4263 win32_setbuf(FILE *pf, char *buf)
4269 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4271 return setvbuf(pf, buf, type, size);
4275 win32_flushall(void)
4281 win32_fcloseall(void)
4287 win32_fgets(char *s, int n, FILE *pf)
4289 return fgets(s, n, pf);
4299 win32_fgetc(FILE *pf)
4305 win32_putc(int c, FILE *pf)
4311 win32_puts(const char *s)
4323 win32_putchar(int c)
4330 #ifndef USE_PERL_SBRK
4332 static char *committed = NULL; /* XXX threadead */
4333 static char *base = NULL; /* XXX threadead */
4334 static char *reserved = NULL; /* XXX threadead */
4335 static char *brk = NULL; /* XXX threadead */
4336 static DWORD pagesize = 0; /* XXX threadead */
4339 sbrk(ptrdiff_t need)
4344 GetSystemInfo(&info);
4345 /* Pretend page size is larger so we don't perpetually
4346 * call the OS to commit just one page ...
4348 pagesize = info.dwPageSize << 3;
4350 if (brk+need >= reserved)
4352 DWORD size = brk+need-reserved;
4354 char *prev_committed = NULL;
4355 if (committed && reserved && committed < reserved)
4357 /* Commit last of previous chunk cannot span allocations */
4358 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4361 /* Remember where we committed from in case we want to decommit later */
4362 prev_committed = committed;
4363 committed = reserved;
4366 /* Reserve some (more) space
4367 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4368 * this is only address space not memory...
4369 * Note this is a little sneaky, 1st call passes NULL as reserved
4370 * so lets system choose where we start, subsequent calls pass
4371 * the old end address so ask for a contiguous block
4374 if (size < 64*1024*1024)
4375 size = 64*1024*1024;
4376 size = ((size + pagesize - 1) / pagesize) * pagesize;
4377 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4380 reserved = addr+size;
4390 /* The existing block could not be extended far enough, so decommit
4391 * anything that was just committed above and start anew */
4394 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4397 reserved = base = committed = brk = NULL;
4408 if (brk > committed)
4410 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4412 if (committed+size > reserved)
4413 size = reserved-committed;
4414 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4427 win32_malloc(size_t size)
4429 return malloc(size);
4433 win32_calloc(size_t numitems, size_t size)
4435 return calloc(numitems,size);
4439 win32_realloc(void *block, size_t size)
4441 return realloc(block,size);
4445 win32_free(void *block)
4452 win32_open_osfhandle(intptr_t handle, int flags)
4454 #ifdef USE_FIXED_OSFHANDLE
4456 return my_open_osfhandle(handle, flags);
4458 return _open_osfhandle(handle, flags);
4462 win32_get_osfhandle(int fd)
4464 return (intptr_t)_get_osfhandle(fd);
4468 win32_fdupopen(FILE *pf)
4473 int fileno = win32_dup(win32_fileno(pf));
4475 /* open the file in the same mode */
4477 if((pf)->flags & _F_READ) {
4481 else if((pf)->flags & _F_WRIT) {
4485 else if((pf)->flags & _F_RDWR) {
4491 if((pf)->_flag & _IOREAD) {
4495 else if((pf)->_flag & _IOWRT) {
4499 else if((pf)->_flag & _IORW) {
4506 /* it appears that the binmode is attached to the
4507 * file descriptor so binmode files will be handled
4510 pfdup = win32_fdopen(fileno, mode);
4512 /* move the file pointer to the same position */
4513 if (!fgetpos(pf, &pos)) {
4514 fsetpos(pfdup, &pos);
4520 win32_dynaload(const char* filename)
4523 char buf[MAX_PATH+1];
4526 /* LoadLibrary() doesn't recognize forward slashes correctly,
4527 * so turn 'em back. */
4528 first = strchr(filename, '/');
4530 STRLEN len = strlen(filename);
4531 if (len <= MAX_PATH) {
4532 strcpy(buf, filename);
4533 filename = &buf[first - filename];
4535 if (*filename == '/')
4536 *(char*)filename = '\\';
4542 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4545 XS(w32_SetChildShowWindow)
4548 BOOL use_showwindow = w32_use_showwindow;
4549 /* use "unsigned short" because Perl has redefined "WORD" */
4550 unsigned short showwindow = w32_showwindow;
4553 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4555 if (items == 0 || !SvOK(ST(0)))
4556 w32_use_showwindow = FALSE;
4558 w32_use_showwindow = TRUE;
4559 w32_showwindow = (unsigned short)SvIV(ST(0));
4564 ST(0) = sv_2mortal(newSViv(showwindow));
4566 ST(0) = &PL_sv_undef;
4571 Perl_init_os_extras(void)
4574 char *file = __FILE__;
4576 /* Initialize Win32CORE if it has been statically linked. */
4577 void (*pfn_init)(pTHX);
4578 #if defined(__BORLANDC__)
4579 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4580 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4582 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4587 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4591 win32_signal_context(void)
4596 my_perl = PL_curinterp;
4597 PERL_SET_THX(my_perl);
4601 return PL_curinterp;
4607 win32_ctrlhandler(DWORD dwCtrlType)
4610 dTHXa(PERL_GET_SIG_CONTEXT);
4616 switch(dwCtrlType) {
4617 case CTRL_CLOSE_EVENT:
4618 /* A signal that the system sends to all processes attached to a console when
4619 the user closes the console (either by choosing the Close command from the
4620 console window's System menu, or by choosing the End Task command from the
4623 if (do_raise(aTHX_ 1)) /* SIGHUP */
4624 sig_terminate(aTHX_ 1);
4628 /* A CTRL+c signal was received */
4629 if (do_raise(aTHX_ SIGINT))
4630 sig_terminate(aTHX_ SIGINT);
4633 case CTRL_BREAK_EVENT:
4634 /* A CTRL+BREAK signal was received */
4635 if (do_raise(aTHX_ SIGBREAK))
4636 sig_terminate(aTHX_ SIGBREAK);
4639 case CTRL_LOGOFF_EVENT:
4640 /* A signal that the system sends to all console processes when a user is logging
4641 off. This signal does not indicate which user is logging off, so no
4642 assumptions can be made.
4645 case CTRL_SHUTDOWN_EVENT:
4646 /* A signal that the system sends to all console processes when the system is
4649 if (do_raise(aTHX_ SIGTERM))
4650 sig_terminate(aTHX_ SIGTERM);
4659 #ifdef SET_INVALID_PARAMETER_HANDLER
4660 # include <crtdbg.h>
4671 /* win32_ansipath() requires Windows 2000 or later */
4675 /* fetch Unicode version of PATH */
4677 wide_path = win32_malloc(len*sizeof(WCHAR));
4679 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4683 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4688 /* convert to ANSI pathnames */
4689 wide_dir = wide_path;
4692 WCHAR *sep = wcschr(wide_dir, ';');
4700 /* remove quotes around pathname */
4701 if (*wide_dir == '"')
4703 wide_len = wcslen(wide_dir);
4704 if (wide_len && wide_dir[wide_len-1] == '"')
4705 wide_dir[wide_len-1] = '\0';
4707 /* append ansi_dir to ansi_path */
4708 ansi_dir = win32_ansipath(wide_dir);
4709 ansi_len = strlen(ansi_dir);
4711 size_t newlen = len + 1 + ansi_len;
4712 ansi_path = win32_realloc(ansi_path, newlen+1);
4715 ansi_path[len] = ';';
4716 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4721 ansi_path = win32_malloc(5+len+1);
4724 memcpy(ansi_path, "PATH=", 5);
4725 memcpy(ansi_path+5, ansi_dir, len+1);
4728 win32_free(ansi_dir);
4733 /* Update C RTL environ array. This will only have full effect if
4734 * perl_parse() is later called with `environ` as the `env` argument.
4735 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4737 * We do have to ansify() the PATH before Perl has been fully
4738 * initialized because S_find_script() uses the PATH when perl
4739 * is being invoked with the -S option. This happens before %ENV
4740 * is initialized in S_init_postdump_symbols().
4742 * XXX Is this a bug? Should S_find_script() use the environment
4743 * XXX passed in the `env` arg to parse_perl()?
4746 /* Keep system environment in sync because S_init_postdump_symbols()
4747 * will not call mg_set() if it initializes %ENV from `environ`.
4749 SetEnvironmentVariableA("PATH", ansi_path+5);
4750 /* We are intentionally leaking the ansi_path string here because
4751 * the Borland runtime library puts it directly into the environ
4752 * array. The Microsoft runtime library seems to make a copy,
4753 * but will leak the copy should it be replaced again later.
4754 * Since this code is only called once during PERL_SYS_INIT this
4755 * shouldn't really matter.
4758 win32_free(wide_path);
4762 Perl_win32_init(int *argcp, char ***argvp)
4766 #ifdef SET_INVALID_PARAMETER_HANDLER
4767 _invalid_parameter_handler oldHandler, newHandler;
4768 newHandler = my_invalid_parameter_handler;
4769 oldHandler = _set_invalid_parameter_handler(newHandler);
4770 _CrtSetReportMode(_CRT_ASSERT, 0);
4772 /* Disable floating point errors, Perl will trap the ones we
4773 * care about. VC++ RTL defaults to switching these off
4774 * already, but the Borland RTL doesn't. Since we don't
4775 * want to be at the vendor's whim on the default, we set
4776 * it explicitly here.
4778 #if !defined(_ALPHA_) && !defined(__GNUC__)
4779 _control87(MCW_EM, MCW_EM);
4783 module = GetModuleHandle("ntdll.dll");
4785 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4788 module = GetModuleHandle("kernel32.dll");
4790 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4791 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4792 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4795 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4796 GetVersionEx(&g_osver);
4802 Perl_win32_term(void)
4812 win32_get_child_IO(child_IO_table* ptbl)
4814 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4815 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4816 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4820 win32_signal(int sig, Sighandler_t subcode)
4823 if (sig < SIG_SIZE) {
4824 int save_errno = errno;
4825 Sighandler_t result = signal(sig, subcode);
4826 if (result == SIG_ERR) {
4827 result = w32_sighandler[sig];
4830 w32_sighandler[sig] = subcode;
4839 /* The PerlMessageWindowClass's WindowProc */
4841 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4843 return win32_process_message(hwnd, msg, wParam, lParam) ?
4844 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4847 /* we use a message filter hook to process thread messages, passing any
4848 * messages that we don't process on to the rest of the hook chain
4849 * Anyone else writing a message loop that wants to play nicely with perl
4851 * CallMsgFilter(&msg, MSGF_***);
4852 * between their GetMessage and DispatchMessage calls. */
4854 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4855 LPMSG pmsg = (LPMSG)lParam;
4857 /* we'll process it if code says we're allowed, and it's a thread message */
4858 if (code >= 0 && pmsg->hwnd == NULL
4859 && win32_process_message(pmsg->hwnd, pmsg->message,
4860 pmsg->wParam, pmsg->lParam))
4865 /* XXX: MSDN says that hhk is ignored, but we should really use the
4866 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4867 return CallNextHookEx(NULL, code, wParam, lParam);
4870 /* The real message handler. Can be called with
4871 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4872 * that it processes */
4874 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4876 /* BEWARE. The context retrieved using dTHX; is the context of the
4877 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4878 * up to and including WM_CREATE. If it ever happens that you need the
4879 * 'child' context before this, then it needs to be passed into
4880 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4881 * from the lparam of CreateWindow(). It could then be stored/retrieved
4882 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4883 * the dTHX calls here. */
4884 /* XXX For now it is assumed that the overhead of the dTHX; for what
4885 * are relativley infrequent code-paths, is better than the added
4886 * complexity of getting the correct context passed into
4887 * win32_create_message_window() */
4892 case WM_USER_MESSAGE: {
4893 long child = find_pseudo_pid((int)wParam);
4896 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4903 case WM_USER_KILL: {
4905 /* We use WM_USER_KILL to fake kill() with other signals */
4906 int sig = (int)wParam;
4907 if (do_raise(aTHX_ sig))
4908 sig_terminate(aTHX_ sig);
4915 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4916 if (w32_timerid && w32_timerid==(UINT)wParam) {
4917 KillTimer(w32_message_hwnd, w32_timerid);
4920 /* Now fake a call to signal handler */
4921 if (do_raise(aTHX_ 14))
4922 sig_terminate(aTHX_ 14);
4934 /* Above or other stuff may have set a signal flag, and we may not have
4935 * been called from win32_async_check() (e.g. some other GUI's message
4936 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4937 * handler that die's, and the message loop that calls here is wrapped
4938 * in an eval, then you may well end up with orphaned windows - signals
4939 * are dispatched by win32_async_check() */
4945 win32_create_message_window_class(void)
4947 /* create the window class for "message only" windows */
4951 wc.lpfnWndProc = win32_message_window_proc;
4952 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4953 wc.lpszClassName = "PerlMessageWindowClass";
4955 /* second and subsequent calls will fail, but class
4956 * will already be registered */
4961 win32_create_message_window(void)
4965 /* "message-only" windows have been implemented in Windows 2000 and later.
4966 * On earlier versions we'll continue to post messages to a specific
4967 * thread and use hwnd==NULL. This is brittle when either an embedding
4968 * application or an XS module is also posting messages to hwnd=NULL
4969 * because once removed from the queue they cannot be delivered to the
4970 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4971 * if there is no window handle.
4973 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4974 * documentation to the contrary, however, there is some evidence that
4975 * there may be problems with the implementation on Win98. As it is not
4976 * officially supported we take the cautious route and stick with thread
4977 * messages (hwnd == NULL) on platforms prior to Win2k.
4980 win32_create_message_window_class();
4982 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4983 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4986 /* If we din't create a window for any reason, then we'll use thread
4987 * messages for our signalling, so we install a hook which
4988 * is called by CallMsgFilter in win32_async_check(), or any other
4989 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
4990 * that use OLE, etc. */
4992 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
4993 NULL, GetCurrentThreadId());
4999 #ifdef HAVE_INTERP_INTERN
5002 win32_csighandler(int sig)
5005 dTHXa(PERL_GET_SIG_CONTEXT);
5006 Perl_warn(aTHX_ "Got signal %d",sig);
5011 #if defined(__MINGW32__) && defined(__cplusplus)
5012 #define CAST_HWND__(x) (HWND__*)(x)
5014 #define CAST_HWND__(x) x
5018 Perl_sys_intern_init(pTHX)
5022 w32_perlshell_tokens = NULL;
5023 w32_perlshell_vec = (char**)NULL;
5024 w32_perlshell_items = 0;
5025 w32_fdpid = newAV();
5026 Newx(w32_children, 1, child_tab);
5027 w32_num_children = 0;
5028 # ifdef USE_ITHREADS
5030 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5031 w32_num_pseudo_children = 0;
5034 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5036 for (i=0; i < SIG_SIZE; i++) {
5037 w32_sighandler[i] = SIG_DFL;
5039 # ifdef MULTIPLICITY
5040 if (my_perl == PL_curinterp) {
5044 /* Force C runtime signal stuff to set its console handler */
5045 signal(SIGINT,win32_csighandler);
5046 signal(SIGBREAK,win32_csighandler);
5048 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5049 * flag. This has the side-effect of disabling Ctrl-C events in all
5050 * processes in this group. At least on Windows NT and later we
5051 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5052 * with a NULL handler. This is not valid on Windows 9X.
5055 SetConsoleCtrlHandler(NULL,FALSE);
5057 /* Push our handler on top */
5058 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5063 Perl_sys_intern_clear(pTHX)
5065 Safefree(w32_perlshell_tokens);
5066 Safefree(w32_perlshell_vec);
5067 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5068 Safefree(w32_children);
5070 KillTimer(w32_message_hwnd, w32_timerid);
5073 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5074 DestroyWindow(w32_message_hwnd);
5075 # ifdef MULTIPLICITY
5076 if (my_perl == PL_curinterp) {
5080 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5082 # ifdef USE_ITHREADS
5083 Safefree(w32_pseudo_children);
5087 # ifdef USE_ITHREADS
5090 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5092 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5094 dst->perlshell_tokens = NULL;
5095 dst->perlshell_vec = (char**)NULL;
5096 dst->perlshell_items = 0;
5097 dst->fdpid = newAV();
5098 Newxz(dst->children, 1, child_tab);
5100 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5102 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5103 dst->poll_count = 0;
5104 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5106 # endif /* USE_ITHREADS */
5107 #endif /* HAVE_INTERP_INTERN */