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) {
668 PL_statusvalue = -1; /* >16bits hint for pp_system() */
672 if (ckWARN(WARN_EXEC))
673 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
678 PL_statusvalue = status;
684 /* returns pointer to the next unquoted space or the end of the string */
686 find_next_space(const char *s)
688 bool in_quotes = FALSE;
690 /* ignore doubled backslashes, or backslash+quote */
691 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
694 /* keep track of when we're within quotes */
695 else if (*s == '"') {
697 in_quotes = !in_quotes;
699 /* break it up only at spaces that aren't in quotes */
700 else if (!in_quotes && isSPACE(*s))
709 do_spawn2(pTHX_ const char *cmd, int exectype)
715 BOOL needToTry = TRUE;
718 /* Save an extra exec if possible. See if there are shell
719 * metacharacters in it */
720 if (!has_shell_metachars(cmd)) {
721 Newx(argv, strlen(cmd) / 2 + 2, char*);
722 Newx(cmd2, strlen(cmd) + 1, char);
725 for (s = cmd2; *s;) {
726 while (*s && isSPACE(*s))
730 s = find_next_space(s);
738 status = win32_spawnvp(P_WAIT, argv[0],
739 (const char* const*)argv);
741 case EXECF_SPAWN_NOWAIT:
742 status = win32_spawnvp(P_NOWAIT, argv[0],
743 (const char* const*)argv);
746 status = win32_execvp(argv[0], (const char* const*)argv);
749 if (status != -1 || errno == 0)
759 Newx(argv, w32_perlshell_items + 2, char*);
760 while (++i < w32_perlshell_items)
761 argv[i] = w32_perlshell_vec[i];
762 argv[i++] = (char *)cmd;
766 status = win32_spawnvp(P_WAIT, argv[0],
767 (const char* const*)argv);
769 case EXECF_SPAWN_NOWAIT:
770 status = win32_spawnvp(P_NOWAIT, argv[0],
771 (const char* const*)argv);
774 status = win32_execvp(argv[0], (const char* const*)argv);
780 if (exectype == EXECF_SPAWN_NOWAIT) {
781 PL_statusvalue = -1; /* >16bits hint for pp_system() */
785 if (ckWARN(WARN_EXEC))
786 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
787 (exectype == EXECF_EXEC ? "exec" : "spawn"),
788 cmd, strerror(errno));
793 PL_statusvalue = status;
799 Perl_do_spawn(pTHX_ char *cmd)
801 PERL_ARGS_ASSERT_DO_SPAWN;
803 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
807 Perl_do_spawn_nowait(pTHX_ char *cmd)
809 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
811 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
815 Perl_do_exec(pTHX_ const char *cmd)
817 PERL_ARGS_ASSERT_DO_EXEC;
819 do_spawn2(aTHX_ cmd, EXECF_EXEC);
823 /* The idea here is to read all the directory names into a string table
824 * (separated by nulls) and when one of the other dir functions is called
825 * return the pointer to the current file name.
828 win32_opendir(const char *filename)
834 char scanname[MAX_PATH+3];
836 WIN32_FIND_DATAA aFindData;
837 WIN32_FIND_DATAW wFindData;
839 char buffer[MAX_PATH*2];
842 len = strlen(filename);
846 /* check to see if filename is a directory */
847 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
850 /* Get us a DIR structure */
853 /* Create the search pattern */
854 strcpy(scanname, filename);
856 /* bare drive name means look in cwd for drive */
857 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
858 scanname[len++] = '.';
859 scanname[len++] = '/';
861 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
862 scanname[len++] = '/';
864 scanname[len++] = '*';
865 scanname[len] = '\0';
867 /* do the FindFirstFile call */
869 WCHAR wscanname[sizeof(scanname)];
870 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
871 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
875 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
877 if (dirp->handle == INVALID_HANDLE_VALUE) {
878 DWORD err = GetLastError();
879 /* FindFirstFile() fails on empty drives! */
881 case ERROR_FILE_NOT_FOUND:
883 case ERROR_NO_MORE_FILES:
884 case ERROR_PATH_NOT_FOUND:
887 case ERROR_NOT_ENOUGH_MEMORY:
899 BOOL use_default = FALSE;
900 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
901 wFindData.cFileName, -1,
902 buffer, sizeof(buffer), NULL, &use_default);
903 if (use_default && *wFindData.cAlternateFileName) {
904 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
905 wFindData.cAlternateFileName, -1,
906 buffer, sizeof(buffer), NULL, NULL);
911 ptr = aFindData.cFileName;
913 /* now allocate the first part of the string table for
914 * the filenames that we find.
921 Newx(dirp->start, dirp->size, char);
922 strcpy(dirp->start, ptr);
924 dirp->end = dirp->curr = dirp->start;
930 /* Readdir just returns the current string pointer and bumps the
931 * string pointer to the nDllExport entry.
933 DllExport struct direct *
934 win32_readdir(DIR *dirp)
939 /* first set up the structure to return */
940 len = strlen(dirp->curr);
941 strcpy(dirp->dirstr.d_name, dirp->curr);
942 dirp->dirstr.d_namlen = len;
945 dirp->dirstr.d_ino = dirp->curr - dirp->start;
947 /* Now set up for the next call to readdir */
948 dirp->curr += len + 1;
949 if (dirp->curr >= dirp->end) {
952 WIN32_FIND_DATAA aFindData;
953 char buffer[MAX_PATH*2];
956 /* finding the next file that matches the wildcard
957 * (which should be all of them in this directory!).
960 WIN32_FIND_DATAW wFindData;
961 res = FindNextFileW(dirp->handle, &wFindData);
963 BOOL use_default = FALSE;
964 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
965 wFindData.cFileName, -1,
966 buffer, sizeof(buffer), NULL, &use_default);
967 if (use_default && *wFindData.cAlternateFileName) {
968 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
969 wFindData.cAlternateFileName, -1,
970 buffer, sizeof(buffer), NULL, NULL);
976 res = FindNextFileA(dirp->handle, &aFindData);
977 ptr = aFindData.cFileName;
980 long endpos = dirp->end - dirp->start;
981 long newsize = endpos + strlen(ptr) + 1;
982 /* bump the string table size by enough for the
983 * new name and its null terminator */
984 while (newsize > dirp->size) {
985 long curpos = dirp->curr - dirp->start;
987 Renew(dirp->start, dirp->size, char);
988 dirp->curr = dirp->start + curpos;
990 strcpy(dirp->start + endpos, ptr);
991 dirp->end = dirp->start + newsize;
997 return &(dirp->dirstr);
1003 /* Telldir returns the current string pointer position */
1005 win32_telldir(DIR *dirp)
1007 return (dirp->curr - dirp->start);
1011 /* Seekdir moves the string pointer to a previously saved position
1012 * (returned by telldir).
1015 win32_seekdir(DIR *dirp, long loc)
1017 dirp->curr = dirp->start + loc;
1020 /* Rewinddir resets the string pointer to the start */
1022 win32_rewinddir(DIR *dirp)
1024 dirp->curr = dirp->start;
1027 /* free the memory allocated by opendir */
1029 win32_closedir(DIR *dirp)
1032 if (dirp->handle != INVALID_HANDLE_VALUE)
1033 FindClose(dirp->handle);
1034 Safefree(dirp->start);
1047 * Just pretend that everyone is a superuser. NT will let us know if
1048 * we don\'t really have permission to do something.
1051 #define ROOT_UID ((uid_t)0)
1052 #define ROOT_GID ((gid_t)0)
1081 return (auid == ROOT_UID ? 0 : -1);
1087 return (agid == ROOT_GID ? 0 : -1);
1094 char *buf = w32_getlogin_buffer;
1095 DWORD size = sizeof(w32_getlogin_buffer);
1096 if (GetUserName(buf,&size))
1102 chown(const char *path, uid_t owner, gid_t group)
1109 * XXX this needs strengthening (for PerlIO)
1112 int mkstemp(const char *path)
1115 char buf[MAX_PATH+1];
1119 if (i++ > 10) { /* give up */
1123 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1127 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1137 long child = w32_num_children;
1138 while (--child >= 0) {
1139 if ((int)w32_child_pids[child] == pid)
1146 remove_dead_process(long child)
1150 CloseHandle(w32_child_handles[child]);
1151 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1152 (w32_num_children-child-1), HANDLE);
1153 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1154 (w32_num_children-child-1), DWORD);
1161 find_pseudo_pid(int pid)
1164 long child = w32_num_pseudo_children;
1165 while (--child >= 0) {
1166 if ((int)w32_pseudo_child_pids[child] == pid)
1173 remove_dead_pseudo_process(long child)
1177 CloseHandle(w32_pseudo_child_handles[child]);
1178 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1179 (w32_num_pseudo_children-child-1), HANDLE);
1180 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1181 (w32_num_pseudo_children-child-1), DWORD);
1182 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1183 (w32_num_pseudo_children-child-1), HWND);
1184 w32_num_pseudo_children--;
1190 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1194 /* "Does process exist?" use of kill */
1197 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1202 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1205 default: /* For now be backwards compatible with perl 5.6 */
1207 /* Note that we will only be able to kill processes owned by the
1208 * current process owner, even when we are running as an administrator.
1209 * To kill processes of other owners we would need to set the
1210 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1212 if (TerminateProcess(process_handle, sig))
1219 /* Traverse process tree using ToolHelp functions */
1221 kill_process_tree_toolhelp(DWORD pid, int sig)
1223 HANDLE process_handle;
1224 HANDLE snapshot_handle;
1227 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1228 if (process_handle == NULL)
1231 killed += terminate_process(pid, process_handle, sig);
1233 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1234 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1235 PROCESSENTRY32 entry;
1237 entry.dwSize = sizeof(entry);
1238 if (pfnProcess32First(snapshot_handle, &entry)) {
1240 if (entry.th32ParentProcessID == pid)
1241 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1242 entry.dwSize = sizeof(entry);
1244 while (pfnProcess32Next(snapshot_handle, &entry));
1246 CloseHandle(snapshot_handle);
1248 CloseHandle(process_handle);
1252 /* Traverse process tree using undocumented system information structures.
1253 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1256 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1258 HANDLE process_handle;
1259 SYSTEM_PROCESSES *p = process_info;
1262 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1263 if (process_handle == NULL)
1266 killed += terminate_process(pid, process_handle, sig);
1269 if (p->InheritedFromProcessId == (DWORD)pid)
1270 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1272 if (p->NextEntryDelta == 0)
1275 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1278 CloseHandle(process_handle);
1283 killpg(int pid, int sig)
1285 /* Use "documented" method whenever available */
1286 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1287 return kill_process_tree_toolhelp((DWORD)pid, sig);
1290 /* Fall back to undocumented Windows internals on Windows NT */
1291 if (pfnZwQuerySystemInformation) {
1296 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1297 Newx(buffer, size, char);
1299 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1300 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1309 my_kill(int pid, int sig)
1312 HANDLE process_handle;
1315 return killpg(pid, -sig);
1317 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1318 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1319 if (process_handle != NULL) {
1320 retval = terminate_process(pid, process_handle, sig);
1321 CloseHandle(process_handle);
1327 win32_kill(int pid, int sig)
1333 /* it is a pseudo-forked child */
1334 child = find_pseudo_pid(-pid);
1336 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1337 HANDLE hProcess = w32_pseudo_child_handles[child];
1340 /* "Does process exist?" use of kill */
1344 /* kill -9 style un-graceful exit */
1345 if (TerminateThread(hProcess, sig)) {
1346 remove_dead_pseudo_process(child);
1353 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1354 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1355 /* Yield and wait for the other thread to send us its message_hwnd */
1357 win32_async_check(aTHX);
1358 hwnd = w32_pseudo_child_message_hwnds[child];
1361 if (hwnd != INVALID_HANDLE_VALUE) {
1362 /* We fake signals to pseudo-processes using Win32
1363 * message queue. In Win9X the pids are negative already. */
1364 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1365 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1367 /* It might be us ... */
1376 else if (IsWin95()) {
1384 child = find_pid(pid);
1386 if (my_kill(pid, sig)) {
1388 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1389 exitcode != STILL_ACTIVE)
1391 remove_dead_process(child);
1398 if (my_kill((IsWin95() ? -pid : pid), sig))
1407 win32_stat(const char *path, Stat_t *sbuf)
1410 char buffer[MAX_PATH+1];
1411 int l = strlen(path);
1414 BOOL expect_dir = FALSE;
1416 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1417 GV_NOTQUAL, SVt_PV);
1418 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1421 switch(path[l - 1]) {
1422 /* FindFirstFile() and stat() are buggy with a trailing
1423 * slashes, except for the root directory of a drive */
1426 if (l > sizeof(buffer)) {
1427 errno = ENAMETOOLONG;
1431 strncpy(buffer, path, l);
1432 /* remove additional trailing slashes */
1433 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1435 /* add back slash if we otherwise end up with just a drive letter */
1436 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1443 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1445 if (l == 2 && isALPHA(path[0])) {
1446 buffer[0] = path[0];
1457 path = PerlDir_mapA(path);
1461 /* We must open & close the file once; otherwise file attribute changes */
1462 /* might not yet have propagated to "other" hard links of the same file. */
1463 /* This also gives us an opportunity to determine the number of links. */
1464 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1465 if (handle != INVALID_HANDLE_VALUE) {
1466 BY_HANDLE_FILE_INFORMATION bhi;
1467 if (GetFileInformationByHandle(handle, &bhi))
1468 nlink = bhi.nNumberOfLinks;
1469 CloseHandle(handle);
1473 /* path will be mapped correctly above */
1474 #if defined(WIN64) || defined(USE_LARGE_FILES)
1475 res = _stati64(path, sbuf);
1477 res = stat(path, sbuf);
1479 sbuf->st_nlink = nlink;
1482 /* CRT is buggy on sharenames, so make sure it really isn't.
1483 * XXX using GetFileAttributesEx() will enable us to set
1484 * sbuf->st_*time (but note that's not available on the
1485 * Windows of 1995) */
1486 DWORD r = GetFileAttributesA(path);
1487 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1488 /* sbuf may still contain old garbage since stat() failed */
1489 Zero(sbuf, 1, Stat_t);
1490 sbuf->st_mode = S_IFDIR | S_IREAD;
1492 if (!(r & FILE_ATTRIBUTE_READONLY))
1493 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1498 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1499 && (path[2] == '\\' || path[2] == '/'))
1501 /* The drive can be inaccessible, some _stat()s are buggy */
1502 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1507 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1511 if (S_ISDIR(sbuf->st_mode)) {
1512 /* Ensure the "write" bit is switched off in the mode for
1513 * directories with the read-only attribute set. Borland (at least)
1514 * switches it on for directories, which is technically correct
1515 * (directories are indeed always writable unless denied by DACLs),
1516 * but we want stat() and -w to reflect the state of the read-only
1517 * attribute for symmetry with chmod(). */
1518 DWORD r = GetFileAttributesA(path);
1519 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1520 sbuf->st_mode &= ~S_IWRITE;
1524 if (S_ISDIR(sbuf->st_mode)) {
1525 sbuf->st_mode |= S_IEXEC;
1527 else if (S_ISREG(sbuf->st_mode)) {
1529 if (l >= 4 && path[l-4] == '.') {
1530 const char *e = path + l - 3;
1531 if (strnicmp(e,"exe",3)
1532 && strnicmp(e,"bat",3)
1533 && strnicmp(e,"com",3)
1534 && (IsWin95() || strnicmp(e,"cmd",3)))
1535 sbuf->st_mode &= ~S_IEXEC;
1537 sbuf->st_mode |= S_IEXEC;
1540 sbuf->st_mode &= ~S_IEXEC;
1541 /* Propagate permissions to _group_ and _others_ */
1542 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1543 sbuf->st_mode |= (perms>>3) | (perms>>6);
1550 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1551 #define SKIP_SLASHES(s) \
1553 while (*(s) && isSLASH(*(s))) \
1556 #define COPY_NONSLASHES(d,s) \
1558 while (*(s) && !isSLASH(*(s))) \
1562 /* Find the longname of a given path. path is destructively modified.
1563 * It should have space for at least MAX_PATH characters. */
1565 win32_longpath(char *path)
1567 WIN32_FIND_DATA fdata;
1569 char tmpbuf[MAX_PATH+1];
1570 char *tmpstart = tmpbuf;
1577 if (isALPHA(path[0]) && path[1] == ':') {
1579 *tmpstart++ = path[0];
1583 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1585 *tmpstart++ = path[0];
1586 *tmpstart++ = path[1];
1587 SKIP_SLASHES(start);
1588 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1590 *tmpstart++ = *start++;
1591 SKIP_SLASHES(start);
1592 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1597 /* copy initial slash, if any */
1598 if (isSLASH(*start)) {
1599 *tmpstart++ = *start++;
1601 SKIP_SLASHES(start);
1604 /* FindFirstFile() expands "." and "..", so we need to pass
1605 * those through unmolested */
1607 && (!start[1] || isSLASH(start[1])
1608 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1610 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1615 /* if this is the end, bust outta here */
1619 /* now we're at a non-slash; walk up to next slash */
1620 while (*start && !isSLASH(*start))
1623 /* stop and find full name of component */
1626 fhand = FindFirstFile(path,&fdata);
1628 if (fhand != INVALID_HANDLE_VALUE) {
1629 STRLEN len = strlen(fdata.cFileName);
1630 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1631 strcpy(tmpstart, fdata.cFileName);
1642 /* failed a step, just return without side effects */
1643 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1648 strcpy(path,tmpbuf);
1657 /* Can't use PerlIO to write as it allocates memory */
1658 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1659 PL_no_mem, strlen(PL_no_mem));
1665 /* The win32_ansipath() function takes a Unicode filename and converts it
1666 * into the current Windows codepage. If some characters cannot be mapped,
1667 * then it will convert the short name instead.
1669 * The buffer to the ansi pathname must be freed with win32_free() when it
1670 * it no longer needed.
1672 * The argument to win32_ansipath() must exist before this function is
1673 * called; otherwise there is no way to determine the short path name.
1675 * Ideas for future refinement:
1676 * - Only convert those segments of the path that are not in the current
1677 * codepage, but leave the other segments in their long form.
1678 * - If the resulting name is longer than MAX_PATH, start converting
1679 * additional path segments into short names until the full name
1680 * is shorter than MAX_PATH. Shorten the filename part last!
1683 win32_ansipath(const WCHAR *widename)
1686 BOOL use_default = FALSE;
1687 size_t widelen = wcslen(widename)+1;
1688 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1689 NULL, 0, NULL, NULL);
1690 name = win32_malloc(len);
1694 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1695 name, len, NULL, &use_default);
1697 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1699 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1702 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1704 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1705 NULL, 0, NULL, NULL);
1706 name = win32_realloc(name, len);
1709 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1710 name, len, NULL, NULL);
1711 win32_free(shortname);
1718 win32_getenv(const char *name)
1724 needlen = GetEnvironmentVariableA(name,NULL,0);
1726 curitem = sv_2mortal(newSVpvn("", 0));
1728 SvGROW(curitem, needlen+1);
1729 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1731 } while (needlen >= SvLEN(curitem));
1732 SvCUR_set(curitem, needlen);
1735 /* allow any environment variables that begin with 'PERL'
1736 to be stored in the registry */
1737 if (strncmp(name, "PERL", 4) == 0)
1738 (void)get_regstr(name, &curitem);
1740 if (curitem && SvCUR(curitem))
1741 return SvPVX(curitem);
1747 win32_putenv(const char *name)
1755 Newx(curitem,strlen(name)+1,char);
1756 strcpy(curitem, name);
1757 val = strchr(curitem, '=');
1759 /* The sane way to deal with the environment.
1760 * Has these advantages over putenv() & co.:
1761 * * enables us to store a truly empty value in the
1762 * environment (like in UNIX).
1763 * * we don't have to deal with RTL globals, bugs and leaks.
1765 * Why you may want to enable USE_WIN32_RTL_ENV:
1766 * * environ[] and RTL functions will not reflect changes,
1767 * which might be an issue if extensions want to access
1768 * the env. via RTL. This cuts both ways, since RTL will
1769 * not see changes made by extensions that call the Win32
1770 * functions directly, either.
1774 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1783 filetime_to_clock(PFILETIME ft)
1785 __int64 qw = ft->dwHighDateTime;
1787 qw |= ft->dwLowDateTime;
1788 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1793 win32_times(struct tms *timebuf)
1798 clock_t process_time_so_far = clock();
1799 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1801 timebuf->tms_utime = filetime_to_clock(&user);
1802 timebuf->tms_stime = filetime_to_clock(&kernel);
1803 timebuf->tms_cutime = 0;
1804 timebuf->tms_cstime = 0;
1806 /* That failed - e.g. Win95 fallback to clock() */
1807 timebuf->tms_utime = process_time_so_far;
1808 timebuf->tms_stime = 0;
1809 timebuf->tms_cutime = 0;
1810 timebuf->tms_cstime = 0;
1812 return process_time_so_far;
1815 /* fix utime() so it works on directories in NT */
1817 filetime_from_time(PFILETIME pFileTime, time_t Time)
1819 struct tm *pTM = localtime(&Time);
1820 SYSTEMTIME SystemTime;
1826 SystemTime.wYear = pTM->tm_year + 1900;
1827 SystemTime.wMonth = pTM->tm_mon + 1;
1828 SystemTime.wDay = pTM->tm_mday;
1829 SystemTime.wHour = pTM->tm_hour;
1830 SystemTime.wMinute = pTM->tm_min;
1831 SystemTime.wSecond = pTM->tm_sec;
1832 SystemTime.wMilliseconds = 0;
1834 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1835 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1839 win32_unlink(const char *filename)
1845 filename = PerlDir_mapA(filename);
1846 attrs = GetFileAttributesA(filename);
1847 if (attrs == 0xFFFFFFFF) {
1851 if (attrs & FILE_ATTRIBUTE_READONLY) {
1852 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1853 ret = unlink(filename);
1855 (void)SetFileAttributesA(filename, attrs);
1858 ret = unlink(filename);
1863 win32_utime(const char *filename, struct utimbuf *times)
1870 struct utimbuf TimeBuffer;
1873 filename = PerlDir_mapA(filename);
1874 rc = utime(filename, times);
1876 /* EACCES: path specifies directory or readonly file */
1877 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1880 if (times == NULL) {
1881 times = &TimeBuffer;
1882 time(×->actime);
1883 times->modtime = times->actime;
1886 /* This will (and should) still fail on readonly files */
1887 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1888 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1889 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1890 if (handle == INVALID_HANDLE_VALUE)
1893 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1894 filetime_from_time(&ftAccess, times->actime) &&
1895 filetime_from_time(&ftWrite, times->modtime) &&
1896 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1901 CloseHandle(handle);
1906 unsigned __int64 ft_i64;
1911 #define Const64(x) x##LL
1913 #define Const64(x) x##i64
1915 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1916 #define EPOCH_BIAS Const64(116444736000000000)
1918 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1919 * and appears to be unsupported even by glibc) */
1921 win32_gettimeofday(struct timeval *tp, void *not_used)
1925 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1926 GetSystemTimeAsFileTime(&ft.ft_val);
1928 /* seconds since epoch */
1929 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1931 /* microseconds remaining */
1932 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1938 win32_uname(struct utsname *name)
1940 struct hostent *hep;
1941 STRLEN nodemax = sizeof(name->nodename)-1;
1944 switch (g_osver.dwPlatformId) {
1945 case VER_PLATFORM_WIN32_WINDOWS:
1946 strcpy(name->sysname, "Windows");
1948 case VER_PLATFORM_WIN32_NT:
1949 strcpy(name->sysname, "Windows NT");
1951 case VER_PLATFORM_WIN32s:
1952 strcpy(name->sysname, "Win32s");
1955 strcpy(name->sysname, "Win32 Unknown");
1960 sprintf(name->release, "%d.%d",
1961 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1964 sprintf(name->version, "Build %d",
1965 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1966 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1967 if (g_osver.szCSDVersion[0]) {
1968 char *buf = name->version + strlen(name->version);
1969 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1973 hep = win32_gethostbyname("localhost");
1975 STRLEN len = strlen(hep->h_name);
1976 if (len <= nodemax) {
1977 strcpy(name->nodename, hep->h_name);
1980 strncpy(name->nodename, hep->h_name, nodemax);
1981 name->nodename[nodemax] = '\0';
1986 if (!GetComputerName(name->nodename, &sz))
1987 *name->nodename = '\0';
1990 /* machine (architecture) */
1995 GetSystemInfo(&info);
1997 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1998 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1999 procarch = info.u.s.wProcessorArchitecture;
2001 procarch = info.wProcessorArchitecture;
2004 case PROCESSOR_ARCHITECTURE_INTEL:
2005 arch = "x86"; break;
2006 case PROCESSOR_ARCHITECTURE_MIPS:
2007 arch = "mips"; break;
2008 case PROCESSOR_ARCHITECTURE_ALPHA:
2009 arch = "alpha"; break;
2010 case PROCESSOR_ARCHITECTURE_PPC:
2011 arch = "ppc"; break;
2012 #ifdef PROCESSOR_ARCHITECTURE_SHX
2013 case PROCESSOR_ARCHITECTURE_SHX:
2014 arch = "shx"; break;
2016 #ifdef PROCESSOR_ARCHITECTURE_ARM
2017 case PROCESSOR_ARCHITECTURE_ARM:
2018 arch = "arm"; break;
2020 #ifdef PROCESSOR_ARCHITECTURE_IA64
2021 case PROCESSOR_ARCHITECTURE_IA64:
2022 arch = "ia64"; break;
2024 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2025 case PROCESSOR_ARCHITECTURE_ALPHA64:
2026 arch = "alpha64"; break;
2028 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2029 case PROCESSOR_ARCHITECTURE_MSIL:
2030 arch = "msil"; break;
2032 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2033 case PROCESSOR_ARCHITECTURE_AMD64:
2034 arch = "amd64"; break;
2036 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2037 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2038 arch = "ia32-64"; break;
2040 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2041 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2042 arch = "unknown"; break;
2045 sprintf(name->machine, "unknown(0x%x)", procarch);
2046 arch = name->machine;
2049 if (name->machine != arch)
2050 strcpy(name->machine, arch);
2055 /* Timing related stuff */
2058 do_raise(pTHX_ int sig)
2060 if (sig < SIG_SIZE) {
2061 Sighandler_t handler = w32_sighandler[sig];
2062 if (handler == SIG_IGN) {
2065 else if (handler != SIG_DFL) {
2070 /* Choose correct default behaviour */
2086 /* Tell caller to exit thread/process as approriate */
2091 sig_terminate(pTHX_ int sig)
2093 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2094 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2101 win32_async_check(pTHX)
2104 HWND hwnd = w32_message_hwnd;
2106 /* Reset w32_poll_count before doing anything else, incase we dispatch
2107 * messages that end up calling back into perl */
2110 if (hwnd != INVALID_HANDLE_VALUE) {
2111 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2112 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2117 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2118 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2120 /* re-post a WM_QUIT message (we'll mark it as read later) */
2121 if(msg.message == WM_QUIT) {
2122 PostQuitMessage((int)msg.wParam);
2126 if(!CallMsgFilter(&msg, MSGF_USER))
2128 TranslateMessage(&msg);
2129 DispatchMessage(&msg);
2134 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2135 * This is necessary when we are being called by win32_msgwait() to
2136 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2137 * message over and over. An example how this can happen is when
2138 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2139 * is generating messages before the process terminated.
2141 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2143 /* Above or other stuff may have set a signal flag */
2150 /* This function will not return until the timeout has elapsed, or until
2151 * one of the handles is ready. */
2153 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2155 /* We may need several goes at this - so compute when we stop */
2157 if (timeout != INFINITE) {
2158 ticks = GetTickCount();
2162 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2165 if (result == WAIT_TIMEOUT) {
2166 /* Ran out of time - explicit return of zero to avoid -ve if we
2167 have scheduling issues
2171 if (timeout != INFINITE) {
2172 ticks = GetTickCount();
2174 if (result == WAIT_OBJECT_0 + count) {
2175 /* Message has arrived - check it */
2176 (void)win32_async_check(aTHX);
2179 /* Not timeout or message - one of handles is ready */
2183 /* compute time left to wait */
2184 ticks = timeout - ticks;
2185 /* If we are past the end say zero */
2186 return (ticks > 0) ? ticks : 0;
2190 win32_internal_wait(int *status, DWORD timeout)
2192 /* XXX this wait emulation only knows about processes
2193 * spawned via win32_spawnvp(P_NOWAIT, ...).
2197 DWORD exitcode, waitcode;
2200 if (w32_num_pseudo_children) {
2201 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2202 timeout, &waitcode);
2203 /* Time out here if there are no other children to wait for. */
2204 if (waitcode == WAIT_TIMEOUT) {
2205 if (!w32_num_children) {
2209 else if (waitcode != WAIT_FAILED) {
2210 if (waitcode >= WAIT_ABANDONED_0
2211 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2212 i = waitcode - WAIT_ABANDONED_0;
2214 i = waitcode - WAIT_OBJECT_0;
2215 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2216 *status = (int)((exitcode & 0xff) << 8);
2217 retval = (int)w32_pseudo_child_pids[i];
2218 remove_dead_pseudo_process(i);
2225 if (!w32_num_children) {
2230 /* if a child exists, wait for it to die */
2231 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2232 if (waitcode == WAIT_TIMEOUT) {
2235 if (waitcode != WAIT_FAILED) {
2236 if (waitcode >= WAIT_ABANDONED_0
2237 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2238 i = waitcode - WAIT_ABANDONED_0;
2240 i = waitcode - WAIT_OBJECT_0;
2241 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2242 *status = (int)((exitcode & 0xff) << 8);
2243 retval = (int)w32_child_pids[i];
2244 remove_dead_process(i);
2249 errno = GetLastError();
2254 win32_waitpid(int pid, int *status, int flags)
2257 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2260 if (pid == -1) /* XXX threadid == 1 ? */
2261 return win32_internal_wait(status, timeout);
2264 child = find_pseudo_pid(-pid);
2266 HANDLE hThread = w32_pseudo_child_handles[child];
2268 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2269 if (waitcode == WAIT_TIMEOUT) {
2272 else if (waitcode == WAIT_OBJECT_0) {
2273 if (GetExitCodeThread(hThread, &waitcode)) {
2274 *status = (int)((waitcode & 0xff) << 8);
2275 retval = (int)w32_pseudo_child_pids[child];
2276 remove_dead_pseudo_process(child);
2283 else if (IsWin95()) {
2292 child = find_pid(pid);
2294 hProcess = w32_child_handles[child];
2295 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2296 if (waitcode == WAIT_TIMEOUT) {
2299 else if (waitcode == WAIT_OBJECT_0) {
2300 if (GetExitCodeProcess(hProcess, &waitcode)) {
2301 *status = (int)((waitcode & 0xff) << 8);
2302 retval = (int)w32_child_pids[child];
2303 remove_dead_process(child);
2312 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2313 (IsWin95() ? -pid : pid));
2315 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2316 if (waitcode == WAIT_TIMEOUT) {
2317 CloseHandle(hProcess);
2320 else if (waitcode == WAIT_OBJECT_0) {
2321 if (GetExitCodeProcess(hProcess, &waitcode)) {
2322 *status = (int)((waitcode & 0xff) << 8);
2323 CloseHandle(hProcess);
2327 CloseHandle(hProcess);
2333 return retval >= 0 ? pid : retval;
2337 win32_wait(int *status)
2339 return win32_internal_wait(status, INFINITE);
2342 DllExport unsigned int
2343 win32_sleep(unsigned int t)
2346 /* Win32 times are in ms so *1000 in and /1000 out */
2347 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2350 DllExport unsigned int
2351 win32_alarm(unsigned int sec)
2354 * the 'obvious' implentation is SetTimer() with a callback
2355 * which does whatever receiving SIGALRM would do
2356 * we cannot use SIGALRM even via raise() as it is not
2357 * one of the supported codes in <signal.h>
2361 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2362 w32_message_hwnd = win32_create_message_window();
2365 if (w32_message_hwnd == NULL)
2366 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2369 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2374 KillTimer(w32_message_hwnd, w32_timerid);
2381 #ifdef HAVE_DES_FCRYPT
2382 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2386 win32_crypt(const char *txt, const char *salt)
2389 #ifdef HAVE_DES_FCRYPT
2390 return des_fcrypt(txt, salt, w32_crypt_buffer);
2392 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2397 #ifdef USE_FIXED_OSFHANDLE
2399 #define FOPEN 0x01 /* file handle open */
2400 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2401 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2402 #define FDEV 0x40 /* file handle refers to device */
2403 #define FTEXT 0x80 /* file handle is in text mode */
2406 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2409 * This function allocates a free C Runtime file handle and associates
2410 * it with the Win32 HANDLE specified by the first parameter. This is a
2411 * temperary fix for WIN95's brain damage GetFileType() error on socket
2412 * we just bypass that call for socket
2414 * This works with MSVC++ 4.0+ or GCC/Mingw32
2417 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2418 * int flags - flags to associate with C Runtime file handle.
2421 * returns index of entry in fh, if successful
2422 * return -1, if no free entry is found
2426 *******************************************************************************/
2429 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2430 * this lets sockets work on Win9X with GCC and should fix the problems
2435 /* create an ioinfo entry, kill its handle, and steal the entry */
2440 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2441 int fh = _open_osfhandle((intptr_t)hF, 0);
2445 EnterCriticalSection(&(_pioinfo(fh)->lock));
2450 my_open_osfhandle(intptr_t osfhandle, int flags)
2453 char fileflags; /* _osfile flags */
2455 /* copy relevant flags from second parameter */
2458 if (flags & O_APPEND)
2459 fileflags |= FAPPEND;
2464 if (flags & O_NOINHERIT)
2465 fileflags |= FNOINHERIT;
2467 /* attempt to allocate a C Runtime file handle */
2468 if ((fh = _alloc_osfhnd()) == -1) {
2469 errno = EMFILE; /* too many open files */
2470 _doserrno = 0L; /* not an OS error */
2471 return -1; /* return error to caller */
2474 /* the file is open. now, set the info in _osfhnd array */
2475 _set_osfhnd(fh, osfhandle);
2477 fileflags |= FOPEN; /* mark as open */
2479 _osfile(fh) = fileflags; /* set osfile entry */
2480 LeaveCriticalSection(&_pioinfo(fh)->lock);
2482 return fh; /* return handle */
2485 #endif /* USE_FIXED_OSFHANDLE */
2487 /* simulate flock by locking a range on the file */
2489 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2490 #define LK_LEN 0xffff0000
2493 win32_flock(int fd, int oper)
2501 Perl_croak_nocontext("flock() unimplemented on this platform");
2504 fh = (HANDLE)_get_osfhandle(fd);
2505 memset(&o, 0, sizeof(o));
2508 case LOCK_SH: /* shared lock */
2509 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2511 case LOCK_EX: /* exclusive lock */
2512 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2514 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2515 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2517 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2518 LK_ERR(LockFileEx(fh,
2519 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2520 0, LK_LEN, 0, &o),i);
2522 case LOCK_UN: /* unlock lock */
2523 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2525 default: /* unknown */
2536 * redirected io subsystem for all XS modules
2549 return (&(_environ));
2552 /* the rest are the remapped stdio routines */
2572 win32_ferror(FILE *fp)
2574 return (ferror(fp));
2579 win32_feof(FILE *fp)
2585 * Since the errors returned by the socket error function
2586 * WSAGetLastError() are not known by the library routine strerror
2587 * we have to roll our own.
2591 win32_strerror(int e)
2593 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2594 extern int sys_nerr;
2598 if (e < 0 || e > sys_nerr) {
2603 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2604 w32_strerror_buffer,
2605 sizeof(w32_strerror_buffer), NULL) == 0)
2606 strcpy(w32_strerror_buffer, "Unknown Error");
2608 return w32_strerror_buffer;
2614 win32_str_os_error(void *sv, DWORD dwErr)
2618 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2619 |FORMAT_MESSAGE_IGNORE_INSERTS
2620 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2621 dwErr, 0, (char *)&sMsg, 1, NULL);
2622 /* strip trailing whitespace and period */
2625 --dwLen; /* dwLen doesn't include trailing null */
2626 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2627 if ('.' != sMsg[dwLen])
2632 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2634 dwLen = sprintf(sMsg,
2635 "Unknown error #0x%lX (lookup 0x%lX)",
2636 dwErr, GetLastError());
2640 sv_setpvn((SV*)sv, sMsg, dwLen);
2646 win32_fprintf(FILE *fp, const char *format, ...)
2649 va_start(marker, format); /* Initialize variable arguments. */
2651 return (vfprintf(fp, format, marker));
2655 win32_printf(const char *format, ...)
2658 va_start(marker, format); /* Initialize variable arguments. */
2660 return (vprintf(format, marker));
2664 win32_vfprintf(FILE *fp, const char *format, va_list args)
2666 return (vfprintf(fp, format, args));
2670 win32_vprintf(const char *format, va_list args)
2672 return (vprintf(format, args));
2676 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2678 return fread(buf, size, count, fp);
2682 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2684 return fwrite(buf, size, count, fp);
2687 #define MODE_SIZE 10
2690 win32_fopen(const char *filename, const char *mode)
2698 if (stricmp(filename, "/dev/null")==0)
2701 f = fopen(PerlDir_mapA(filename), mode);
2702 /* avoid buffering headaches for child processes */
2703 if (f && *mode == 'a')
2704 win32_fseek(f, 0, SEEK_END);
2708 #ifndef USE_SOCKETS_AS_HANDLES
2710 #define fdopen my_fdopen
2714 win32_fdopen(int handle, const char *mode)
2718 f = fdopen(handle, (char *) mode);
2719 /* avoid buffering headaches for child processes */
2720 if (f && *mode == 'a')
2721 win32_fseek(f, 0, SEEK_END);
2726 win32_freopen(const char *path, const char *mode, FILE *stream)
2729 if (stricmp(path, "/dev/null")==0)
2732 return freopen(PerlDir_mapA(path), mode, stream);
2736 win32_fclose(FILE *pf)
2738 return my_fclose(pf); /* defined in win32sck.c */
2742 win32_fputs(const char *s,FILE *pf)
2744 return fputs(s, pf);
2748 win32_fputc(int c,FILE *pf)
2754 win32_ungetc(int c,FILE *pf)
2756 return ungetc(c,pf);
2760 win32_getc(FILE *pf)
2766 win32_fileno(FILE *pf)
2772 win32_clearerr(FILE *pf)
2779 win32_fflush(FILE *pf)
2785 win32_ftell(FILE *pf)
2787 #if defined(WIN64) || defined(USE_LARGE_FILES)
2788 #if defined(__BORLANDC__) /* buk */
2789 return win32_tell( fileno( pf ) );
2792 if (fgetpos(pf, &pos))
2802 win32_fseek(FILE *pf, Off_t offset,int origin)
2804 #if defined(WIN64) || defined(USE_LARGE_FILES)
2805 #if defined(__BORLANDC__) /* buk */
2815 if (fgetpos(pf, &pos))
2820 fseek(pf, 0, SEEK_END);
2821 pos = _telli64(fileno(pf));
2830 return fsetpos(pf, &offset);
2833 return fseek(pf, (long)offset, origin);
2838 win32_fgetpos(FILE *pf,fpos_t *p)
2840 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2841 if( win32_tell(fileno(pf)) == -1L ) {
2847 return fgetpos(pf, p);
2852 win32_fsetpos(FILE *pf,const fpos_t *p)
2854 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2855 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2857 return fsetpos(pf, p);
2862 win32_rewind(FILE *pf)
2872 char prefix[MAX_PATH+1];
2873 char filename[MAX_PATH+1];
2874 DWORD len = GetTempPath(MAX_PATH, prefix);
2875 if (len && len < MAX_PATH) {
2876 if (GetTempFileName(prefix, "plx", 0, filename)) {
2877 HANDLE fh = CreateFile(filename,
2878 DELETE | GENERIC_READ | GENERIC_WRITE,
2882 FILE_ATTRIBUTE_NORMAL
2883 | FILE_FLAG_DELETE_ON_CLOSE,
2885 if (fh != INVALID_HANDLE_VALUE) {
2886 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2888 #if defined(__BORLANDC__)
2889 setmode(fd,O_BINARY);
2891 DEBUG_p(PerlIO_printf(Perl_debug_log,
2892 "Created tmpfile=%s\n",filename));
2904 int fd = win32_tmpfd();
2906 return win32_fdopen(fd, "w+b");
2918 win32_fstat(int fd, Stat_t *sbufptr)
2921 /* A file designated by filehandle is not shown as accessible
2922 * for write operations, probably because it is opened for reading.
2925 BY_HANDLE_FILE_INFORMATION bhfi;
2926 #if defined(WIN64) || defined(USE_LARGE_FILES)
2927 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2929 int rc = fstat(fd,&tmp);
2931 sbufptr->st_dev = tmp.st_dev;
2932 sbufptr->st_ino = tmp.st_ino;
2933 sbufptr->st_mode = tmp.st_mode;
2934 sbufptr->st_nlink = tmp.st_nlink;
2935 sbufptr->st_uid = tmp.st_uid;
2936 sbufptr->st_gid = tmp.st_gid;
2937 sbufptr->st_rdev = tmp.st_rdev;
2938 sbufptr->st_size = tmp.st_size;
2939 sbufptr->st_atime = tmp.st_atime;
2940 sbufptr->st_mtime = tmp.st_mtime;
2941 sbufptr->st_ctime = tmp.st_ctime;
2943 int rc = fstat(fd,sbufptr);
2946 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2947 #if defined(WIN64) || defined(USE_LARGE_FILES)
2948 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2950 sbufptr->st_mode &= 0xFE00;
2951 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2952 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2954 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2955 + ((S_IREAD|S_IWRITE) >> 6));
2959 return my_fstat(fd,sbufptr);
2964 win32_pipe(int *pfd, unsigned int size, int mode)
2966 return _pipe(pfd, size, mode);
2970 win32_popenlist(const char *mode, IV narg, SV **args)
2973 Perl_croak(aTHX_ "List form of pipe open not implemented");
2978 * a popen() clone that respects PERL5SHELL
2980 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2984 win32_popen(const char *command, const char *mode)
2986 #ifdef USE_RTL_POPEN
2987 return _popen(command, mode);
2999 /* establish which ends read and write */
3000 if (strchr(mode,'w')) {
3001 stdfd = 0; /* stdin */
3004 nhandle = STD_INPUT_HANDLE;
3006 else if (strchr(mode,'r')) {
3007 stdfd = 1; /* stdout */
3010 nhandle = STD_OUTPUT_HANDLE;
3015 /* set the correct mode */
3016 if (strchr(mode,'b'))
3018 else if (strchr(mode,'t'))
3021 ourmode = _fmode & (O_TEXT | O_BINARY);
3023 /* the child doesn't inherit handles */
3024 ourmode |= O_NOINHERIT;
3026 if (win32_pipe(p, 512, ourmode) == -1)
3029 /* save the old std handle (this needs to happen before the
3030 * dup2(), since that might call SetStdHandle() too) */
3033 old_h = GetStdHandle(nhandle);
3035 /* save current stdfd */
3036 if ((oldfd = win32_dup(stdfd)) == -1)
3039 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3040 /* stdfd will be inherited by the child */
3041 if (win32_dup2(p[child], stdfd) == -1)
3044 /* close the child end in parent */
3045 win32_close(p[child]);
3047 /* set the new std handle (in case dup2() above didn't) */
3048 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3050 /* start the child */
3053 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3056 /* revert stdfd to whatever it was before */
3057 if (win32_dup2(oldfd, stdfd) == -1)
3060 /* close saved handle */
3063 /* restore the old std handle (this needs to happen after the
3064 * dup2(), since that might call SetStdHandle() too */
3066 SetStdHandle(nhandle, old_h);
3072 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3075 /* set process id so that it can be returned by perl's open() */
3076 PL_forkprocess = childpid;
3079 /* we have an fd, return a file stream */
3080 return (PerlIO_fdopen(p[parent], (char *)mode));
3083 /* we don't need to check for errors here */
3087 win32_dup2(oldfd, stdfd);
3091 SetStdHandle(nhandle, old_h);
3097 #endif /* USE_RTL_POPEN */
3105 win32_pclose(PerlIO *pf)
3107 #ifdef USE_RTL_POPEN
3111 int childpid, status;
3115 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3118 childpid = SvIVX(sv);
3136 if (win32_waitpid(childpid, &status, 0) == -1)
3141 #endif /* USE_RTL_POPEN */
3147 LPCWSTR lpExistingFileName,
3148 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3151 WCHAR wFullName[MAX_PATH+1];
3152 LPVOID lpContext = NULL;
3153 WIN32_STREAM_ID StreamId;
3154 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3159 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3160 BOOL, BOOL, LPVOID*) =
3161 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3162 BOOL, BOOL, LPVOID*))
3163 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3164 if (pfnBackupWrite == NULL)
3167 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3170 dwLen = (dwLen+1)*sizeof(WCHAR);
3172 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3173 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3174 NULL, OPEN_EXISTING, 0, NULL);
3175 if (handle == INVALID_HANDLE_VALUE)
3178 StreamId.dwStreamId = BACKUP_LINK;
3179 StreamId.dwStreamAttributes = 0;
3180 StreamId.dwStreamNameSize = 0;
3181 #if defined(__BORLANDC__) \
3182 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3183 StreamId.Size.u.HighPart = 0;
3184 StreamId.Size.u.LowPart = dwLen;
3186 StreamId.Size.HighPart = 0;
3187 StreamId.Size.LowPart = dwLen;
3190 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3191 FALSE, FALSE, &lpContext);
3193 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3194 FALSE, FALSE, &lpContext);
3195 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3198 CloseHandle(handle);
3203 win32_link(const char *oldname, const char *newname)
3206 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3207 WCHAR wOldName[MAX_PATH+1];
3208 WCHAR wNewName[MAX_PATH+1];
3211 Perl_croak(aTHX_ PL_no_func, "link");
3213 pfnCreateHardLinkW =
3214 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3215 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3216 if (pfnCreateHardLinkW == NULL)
3217 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3219 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3220 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3221 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3222 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3226 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3231 win32_rename(const char *oname, const char *newname)
3233 char szOldName[MAX_PATH+1];
3234 char szNewName[MAX_PATH+1];
3238 /* XXX despite what the documentation says about MoveFileEx(),
3239 * it doesn't work under Windows95!
3242 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3243 if (stricmp(newname, oname))
3244 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3245 strcpy(szOldName, PerlDir_mapA(oname));
3246 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3248 DWORD err = GetLastError();
3250 case ERROR_BAD_NET_NAME:
3251 case ERROR_BAD_NETPATH:
3252 case ERROR_BAD_PATHNAME:
3253 case ERROR_FILE_NOT_FOUND:
3254 case ERROR_FILENAME_EXCED_RANGE:
3255 case ERROR_INVALID_DRIVE:
3256 case ERROR_NO_MORE_FILES:
3257 case ERROR_PATH_NOT_FOUND:
3270 char szTmpName[MAX_PATH+1];
3271 char dname[MAX_PATH+1];
3272 char *endname = NULL;
3274 DWORD from_attr, to_attr;
3276 strcpy(szOldName, PerlDir_mapA(oname));
3277 strcpy(szNewName, PerlDir_mapA(newname));
3279 /* if oname doesn't exist, do nothing */
3280 from_attr = GetFileAttributes(szOldName);
3281 if (from_attr == 0xFFFFFFFF) {
3286 /* if newname exists, rename it to a temporary name so that we
3287 * don't delete it in case oname happens to be the same file
3288 * (but perhaps accessed via a different path)
3290 to_attr = GetFileAttributes(szNewName);
3291 if (to_attr != 0xFFFFFFFF) {
3292 /* if newname is a directory, we fail
3293 * XXX could overcome this with yet more convoluted logic */
3294 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3298 tmplen = strlen(szNewName);
3299 strcpy(szTmpName,szNewName);
3300 endname = szTmpName+tmplen;
3301 for (; endname > szTmpName ; --endname) {
3302 if (*endname == '/' || *endname == '\\') {
3307 if (endname > szTmpName)
3308 endname = strcpy(dname,szTmpName);
3312 /* get a temporary filename in same directory
3313 * XXX is this really the best we can do? */
3314 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3318 DeleteFile(szTmpName);
3320 retval = rename(szNewName, szTmpName);
3327 /* rename oname to newname */
3328 retval = rename(szOldName, szNewName);
3330 /* if we created a temporary file before ... */
3331 if (endname != NULL) {
3332 /* ...and rename succeeded, delete temporary file/directory */
3334 DeleteFile(szTmpName);
3335 /* else restore it to what it was */
3337 (void)rename(szTmpName, szNewName);
3344 win32_setmode(int fd, int mode)
3346 return setmode(fd, mode);
3350 win32_chsize(int fd, Off_t size)
3352 #if defined(WIN64) || defined(USE_LARGE_FILES)
3354 Off_t cur, end, extend;
3356 cur = win32_tell(fd);
3359 end = win32_lseek(fd, 0, SEEK_END);
3362 extend = size - end;
3366 else if (extend > 0) {
3367 /* must grow the file, padding with nulls */
3369 int oldmode = win32_setmode(fd, O_BINARY);
3371 memset(b, '\0', sizeof(b));
3373 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3374 count = win32_write(fd, b, count);
3375 if ((int)count < 0) {
3379 } while ((extend -= count) > 0);
3380 win32_setmode(fd, oldmode);
3383 /* shrink the file */
3384 win32_lseek(fd, size, SEEK_SET);
3385 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3391 win32_lseek(fd, cur, SEEK_SET);
3394 return chsize(fd, (long)size);
3399 win32_lseek(int fd, Off_t offset, int origin)
3401 #if defined(WIN64) || defined(USE_LARGE_FILES)
3402 #if defined(__BORLANDC__) /* buk */
3404 pos.QuadPart = offset;
3405 pos.LowPart = SetFilePointer(
3406 (HANDLE)_get_osfhandle(fd),
3411 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3415 return pos.QuadPart;
3417 return _lseeki64(fd, offset, origin);
3420 return lseek(fd, (long)offset, origin);
3427 #if defined(WIN64) || defined(USE_LARGE_FILES)
3428 #if defined(__BORLANDC__) /* buk */
3431 pos.LowPart = SetFilePointer(
3432 (HANDLE)_get_osfhandle(fd),
3437 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3441 return pos.QuadPart;
3442 /* return tell(fd); */
3444 return _telli64(fd);
3452 win32_open(const char *path, int flag, ...)
3459 pmode = va_arg(ap, int);
3462 if (stricmp(path, "/dev/null")==0)
3465 return open(PerlDir_mapA(path), flag, pmode);
3468 /* close() that understands socket */
3469 extern int my_close(int); /* in win32sck.c */
3474 return my_close(fd);
3490 win32_dup2(int fd1,int fd2)
3492 return dup2(fd1,fd2);
3495 #ifdef PERL_MSVCRT_READFIX
3497 #define LF 10 /* line feed */
3498 #define CR 13 /* carriage return */
3499 #define CTRLZ 26 /* ctrl-z means eof for text */
3500 #define FOPEN 0x01 /* file handle open */
3501 #define FEOFLAG 0x02 /* end of file has been encountered */
3502 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3503 #define FPIPE 0x08 /* file handle refers to a pipe */
3504 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3505 #define FDEV 0x40 /* file handle refers to device */
3506 #define FTEXT 0x80 /* file handle is in text mode */
3507 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3510 _fixed_read(int fh, void *buf, unsigned cnt)
3512 int bytes_read; /* number of bytes read */
3513 char *buffer; /* buffer to read to */
3514 int os_read; /* bytes read on OS call */
3515 char *p, *q; /* pointers into buffer */
3516 char peekchr; /* peek-ahead character */
3517 ULONG filepos; /* file position after seek */
3518 ULONG dosretval; /* o.s. return value */
3520 /* validate handle */
3521 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3522 !(_osfile(fh) & FOPEN))
3524 /* out of range -- return error */
3526 _doserrno = 0; /* not o.s. error */
3531 * If lockinitflag is FALSE, assume fd is device
3532 * lockinitflag is set to TRUE by open.
3534 if (_pioinfo(fh)->lockinitflag)
3535 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3537 bytes_read = 0; /* nothing read yet */
3538 buffer = (char*)buf;
3540 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3541 /* nothing to read or at EOF, so return 0 read */
3545 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3546 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3548 *buffer++ = _pipech(fh);
3551 _pipech(fh) = LF; /* mark as empty */
3556 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3558 /* ReadFile has reported an error. recognize two special cases.
3560 * 1. map ERROR_ACCESS_DENIED to EBADF
3562 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3563 * means the handle is a read-handle on a pipe for which
3564 * all write-handles have been closed and all data has been
3567 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3568 /* wrong read/write mode should return EBADF, not EACCES */
3570 _doserrno = dosretval;
3574 else if (dosretval == ERROR_BROKEN_PIPE) {
3584 bytes_read += os_read; /* update bytes read */
3586 if (_osfile(fh) & FTEXT) {
3587 /* now must translate CR-LFs to LFs in the buffer */
3589 /* set CRLF flag to indicate LF at beginning of buffer */
3590 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3591 /* _osfile(fh) |= FCRLF; */
3593 /* _osfile(fh) &= ~FCRLF; */
3595 _osfile(fh) &= ~FCRLF;
3597 /* convert chars in the buffer: p is src, q is dest */
3599 while (p < (char *)buf + bytes_read) {
3601 /* if fh is not a device, set ctrl-z flag */
3602 if (!(_osfile(fh) & FDEV))
3603 _osfile(fh) |= FEOFLAG;
3604 break; /* stop translating */
3609 /* *p is CR, so must check next char for LF */
3610 if (p < (char *)buf + bytes_read - 1) {
3613 *q++ = LF; /* convert CR-LF to LF */
3616 *q++ = *p++; /* store char normally */
3619 /* This is the hard part. We found a CR at end of
3620 buffer. We must peek ahead to see if next char
3625 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3626 (LPDWORD)&os_read, NULL))
3627 dosretval = GetLastError();
3629 if (dosretval != 0 || os_read == 0) {
3630 /* couldn't read ahead, store CR */
3634 /* peekchr now has the extra character -- we now
3635 have several possibilities:
3636 1. disk file and char is not LF; just seek back
3638 2. disk file and char is LF; store LF, don't seek back
3639 3. pipe/device and char is LF; store LF.
3640 4. pipe/device and char isn't LF, store CR and
3641 put char in pipe lookahead buffer. */
3642 if (_osfile(fh) & (FDEV|FPIPE)) {
3643 /* non-seekable device */
3648 _pipech(fh) = peekchr;
3653 if (peekchr == LF) {
3654 /* nothing read yet; must make some
3657 /* turn on this flag for tell routine */
3658 _osfile(fh) |= FCRLF;
3661 HANDLE osHandle; /* o.s. handle value */
3663 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3665 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3666 dosretval = GetLastError();
3677 /* we now change bytes_read to reflect the true number of chars
3679 bytes_read = q - (char *)buf;
3683 if (_pioinfo(fh)->lockinitflag)
3684 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3689 #endif /* PERL_MSVCRT_READFIX */
3692 win32_read(int fd, void *buf, unsigned int cnt)
3694 #ifdef PERL_MSVCRT_READFIX
3695 return _fixed_read(fd, buf, cnt);
3697 return read(fd, buf, cnt);
3702 win32_write(int fd, const void *buf, unsigned int cnt)
3704 return write(fd, buf, cnt);
3708 win32_mkdir(const char *dir, int mode)
3711 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3715 win32_rmdir(const char *dir)
3718 return rmdir(PerlDir_mapA(dir));
3722 win32_chdir(const char *dir)
3733 win32_access(const char *path, int mode)
3736 return access(PerlDir_mapA(path), mode);
3740 win32_chmod(const char *path, int mode)
3743 return chmod(PerlDir_mapA(path), mode);
3748 create_command_line(char *cname, STRLEN clen, const char * const *args)
3755 bool bat_file = FALSE;
3756 bool cmd_shell = FALSE;
3757 bool dumb_shell = FALSE;
3758 bool extra_quotes = FALSE;
3759 bool quote_next = FALSE;
3762 cname = (char*)args[0];
3764 /* The NT cmd.exe shell has the following peculiarity that needs to be
3765 * worked around. It strips a leading and trailing dquote when any
3766 * of the following is true:
3767 * 1. the /S switch was used
3768 * 2. there are more than two dquotes
3769 * 3. there is a special character from this set: &<>()@^|
3770 * 4. no whitespace characters within the two dquotes
3771 * 5. string between two dquotes isn't an executable file
3772 * To work around this, we always add a leading and trailing dquote
3773 * to the string, if the first argument is either "cmd.exe" or "cmd",
3774 * and there were at least two or more arguments passed to cmd.exe
3775 * (not including switches).
3776 * XXX the above rules (from "cmd /?") don't seem to be applied
3777 * always, making for the convolutions below :-(
3781 clen = strlen(cname);
3784 && (stricmp(&cname[clen-4], ".bat") == 0
3785 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3792 char *exe = strrchr(cname, '/');
3793 char *exe2 = strrchr(cname, '\\');
3800 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3804 else if (stricmp(exe, "command.com") == 0
3805 || stricmp(exe, "command") == 0)
3812 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3813 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3814 STRLEN curlen = strlen(arg);
3815 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3816 len += 2; /* assume quoting needed (worst case) */
3818 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3820 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3823 Newx(cmd, len, char);
3826 if (bat_file && !IsWin95()) {
3828 extra_quotes = TRUE;
3831 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3833 STRLEN curlen = strlen(arg);
3835 /* we want to protect empty arguments and ones with spaces with
3836 * dquotes, but only if they aren't already there */
3841 else if (quote_next) {
3842 /* see if it really is multiple arguments pretending to
3843 * be one and force a set of quotes around it */
3844 if (*find_next_space(arg))
3847 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3849 while (i < curlen) {
3850 if (isSPACE(arg[i])) {
3853 else if (arg[i] == '"') {
3877 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3878 && stricmp(arg+curlen-2, "/c") == 0)
3880 /* is there a next argument? */
3881 if (args[index+1]) {
3882 /* are there two or more next arguments? */
3883 if (args[index+2]) {
3885 extra_quotes = TRUE;
3888 /* single argument, force quoting if it has spaces */
3904 qualified_path(const char *cmd)
3908 char *fullcmd, *curfullcmd;
3914 fullcmd = (char*)cmd;
3916 if (*fullcmd == '/' || *fullcmd == '\\')
3923 pathstr = PerlEnv_getenv("PATH");
3925 /* worst case: PATH is a single directory; we need additional space
3926 * to append "/", ".exe" and trailing "\0" */
3927 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3928 curfullcmd = fullcmd;
3933 /* start by appending the name to the current prefix */
3934 strcpy(curfullcmd, cmd);
3935 curfullcmd += cmdlen;
3937 /* if it doesn't end with '.', or has no extension, try adding
3938 * a trailing .exe first */
3939 if (cmd[cmdlen-1] != '.'
3940 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3942 strcpy(curfullcmd, ".exe");
3943 res = GetFileAttributes(fullcmd);
3944 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3949 /* that failed, try the bare name */
3950 res = GetFileAttributes(fullcmd);
3951 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3954 /* quit if no other path exists, or if cmd already has path */
3955 if (!pathstr || !*pathstr || has_slash)
3958 /* skip leading semis */
3959 while (*pathstr == ';')
3962 /* build a new prefix from scratch */
3963 curfullcmd = fullcmd;
3964 while (*pathstr && *pathstr != ';') {
3965 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3966 pathstr++; /* skip initial '"' */
3967 while (*pathstr && *pathstr != '"') {
3968 *curfullcmd++ = *pathstr++;
3971 pathstr++; /* skip trailing '"' */
3974 *curfullcmd++ = *pathstr++;
3978 pathstr++; /* skip trailing semi */
3979 if (curfullcmd > fullcmd /* append a dir separator */
3980 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3982 *curfullcmd++ = '\\';
3990 /* The following are just place holders.
3991 * Some hosts may provide and environment that the OS is
3992 * not tracking, therefore, these host must provide that
3993 * environment and the current directory to CreateProcess
3997 win32_get_childenv(void)
4003 win32_free_childenv(void* d)
4008 win32_clearenv(void)
4010 char *envv = GetEnvironmentStrings();
4014 char *end = strchr(cur,'=');
4015 if (end && end != cur) {
4017 SetEnvironmentVariable(cur, NULL);
4019 cur = end + strlen(end+1)+2;
4021 else if ((len = strlen(cur)))
4024 FreeEnvironmentStrings(envv);
4028 win32_get_childdir(void)
4032 char szfilename[MAX_PATH+1];
4034 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4035 Newx(ptr, strlen(szfilename)+1, char);
4036 strcpy(ptr, szfilename);
4041 win32_free_childdir(char* d)
4048 /* XXX this needs to be made more compatible with the spawnvp()
4049 * provided by the various RTLs. In particular, searching for
4050 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4051 * This doesn't significantly affect perl itself, because we
4052 * always invoke things using PERL5SHELL if a direct attempt to
4053 * spawn the executable fails.
4055 * XXX splitting and rejoining the commandline between do_aspawn()
4056 * and win32_spawnvp() could also be avoided.
4060 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4062 #ifdef USE_RTL_SPAWNVP
4063 return spawnvp(mode, cmdname, (char * const *)argv);
4070 STARTUPINFO StartupInfo;
4071 PROCESS_INFORMATION ProcessInformation;
4074 char *fullcmd = NULL;
4075 char *cname = (char *)cmdname;
4079 clen = strlen(cname);
4080 /* if command name contains dquotes, must remove them */
4081 if (strchr(cname, '"')) {
4083 Newx(cname,clen+1,char);
4096 cmd = create_command_line(cname, clen, argv);
4098 env = PerlEnv_get_childenv();
4099 dir = PerlEnv_get_childdir();
4102 case P_NOWAIT: /* asynch + remember result */
4103 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4108 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4111 create |= CREATE_NEW_PROCESS_GROUP;
4114 case P_WAIT: /* synchronous execution */
4116 default: /* invalid mode */
4121 memset(&StartupInfo,0,sizeof(StartupInfo));
4122 StartupInfo.cb = sizeof(StartupInfo);
4123 memset(&tbl,0,sizeof(tbl));
4124 PerlEnv_get_child_IO(&tbl);
4125 StartupInfo.dwFlags = tbl.dwFlags;
4126 StartupInfo.dwX = tbl.dwX;
4127 StartupInfo.dwY = tbl.dwY;
4128 StartupInfo.dwXSize = tbl.dwXSize;
4129 StartupInfo.dwYSize = tbl.dwYSize;
4130 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4131 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4132 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4133 StartupInfo.wShowWindow = tbl.wShowWindow;
4134 StartupInfo.hStdInput = tbl.childStdIn;
4135 StartupInfo.hStdOutput = tbl.childStdOut;
4136 StartupInfo.hStdError = tbl.childStdErr;
4137 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4138 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4139 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4141 create |= CREATE_NEW_CONSOLE;
4144 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4146 if (w32_use_showwindow) {
4147 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4148 StartupInfo.wShowWindow = w32_showwindow;
4151 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4154 if (!CreateProcess(cname, /* search PATH to find executable */
4155 cmd, /* executable, and its arguments */
4156 NULL, /* process attributes */
4157 NULL, /* thread attributes */
4158 TRUE, /* inherit handles */
4159 create, /* creation flags */
4160 (LPVOID)env, /* inherit environment */
4161 dir, /* inherit cwd */
4163 &ProcessInformation))
4165 /* initial NULL argument to CreateProcess() does a PATH
4166 * search, but it always first looks in the directory
4167 * where the current process was started, which behavior
4168 * is undesirable for backward compatibility. So we
4169 * jump through our own hoops by picking out the path
4170 * we really want it to use. */
4172 fullcmd = qualified_path(cname);
4174 if (cname != cmdname)
4177 DEBUG_p(PerlIO_printf(Perl_debug_log,
4178 "Retrying [%s] with same args\n",
4188 if (mode == P_NOWAIT) {
4189 /* asynchronous spawn -- store handle, return PID */
4190 ret = (int)ProcessInformation.dwProcessId;
4191 if (IsWin95() && ret < 0)
4194 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4195 w32_child_pids[w32_num_children] = (DWORD)ret;
4200 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4201 /* FIXME: if msgwait returned due to message perhaps forward the
4202 "signal" to the process
4204 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4206 CloseHandle(ProcessInformation.hProcess);
4209 CloseHandle(ProcessInformation.hThread);
4212 PerlEnv_free_childenv(env);
4213 PerlEnv_free_childdir(dir);
4215 if (cname != cmdname)
4222 win32_execv(const char *cmdname, const char *const *argv)
4226 /* if this is a pseudo-forked child, we just want to spawn
4227 * the new program, and return */
4229 # ifdef __BORLANDC__
4230 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4232 return spawnv(P_WAIT, cmdname, argv);
4236 return execv(cmdname, (char *const *)argv);
4238 return execv(cmdname, argv);
4243 win32_execvp(const char *cmdname, const char *const *argv)
4247 /* if this is a pseudo-forked child, we just want to spawn
4248 * the new program, and return */
4249 if (w32_pseudo_id) {
4250 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4260 return execvp(cmdname, (char *const *)argv);
4262 return execvp(cmdname, argv);
4267 win32_perror(const char *str)
4273 win32_setbuf(FILE *pf, char *buf)
4279 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4281 return setvbuf(pf, buf, type, size);
4285 win32_flushall(void)
4291 win32_fcloseall(void)
4297 win32_fgets(char *s, int n, FILE *pf)
4299 return fgets(s, n, pf);
4309 win32_fgetc(FILE *pf)
4315 win32_putc(int c, FILE *pf)
4321 win32_puts(const char *s)
4333 win32_putchar(int c)
4340 #ifndef USE_PERL_SBRK
4342 static char *committed = NULL; /* XXX threadead */
4343 static char *base = NULL; /* XXX threadead */
4344 static char *reserved = NULL; /* XXX threadead */
4345 static char *brk = NULL; /* XXX threadead */
4346 static DWORD pagesize = 0; /* XXX threadead */
4349 sbrk(ptrdiff_t need)
4354 GetSystemInfo(&info);
4355 /* Pretend page size is larger so we don't perpetually
4356 * call the OS to commit just one page ...
4358 pagesize = info.dwPageSize << 3;
4360 if (brk+need >= reserved)
4362 DWORD size = brk+need-reserved;
4364 char *prev_committed = NULL;
4365 if (committed && reserved && committed < reserved)
4367 /* Commit last of previous chunk cannot span allocations */
4368 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4371 /* Remember where we committed from in case we want to decommit later */
4372 prev_committed = committed;
4373 committed = reserved;
4376 /* Reserve some (more) space
4377 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4378 * this is only address space not memory...
4379 * Note this is a little sneaky, 1st call passes NULL as reserved
4380 * so lets system choose where we start, subsequent calls pass
4381 * the old end address so ask for a contiguous block
4384 if (size < 64*1024*1024)
4385 size = 64*1024*1024;
4386 size = ((size + pagesize - 1) / pagesize) * pagesize;
4387 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4390 reserved = addr+size;
4400 /* The existing block could not be extended far enough, so decommit
4401 * anything that was just committed above and start anew */
4404 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4407 reserved = base = committed = brk = NULL;
4418 if (brk > committed)
4420 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4422 if (committed+size > reserved)
4423 size = reserved-committed;
4424 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4437 win32_malloc(size_t size)
4439 return malloc(size);
4443 win32_calloc(size_t numitems, size_t size)
4445 return calloc(numitems,size);
4449 win32_realloc(void *block, size_t size)
4451 return realloc(block,size);
4455 win32_free(void *block)
4462 win32_open_osfhandle(intptr_t handle, int flags)
4464 #ifdef USE_FIXED_OSFHANDLE
4466 return my_open_osfhandle(handle, flags);
4468 return _open_osfhandle(handle, flags);
4472 win32_get_osfhandle(int fd)
4474 return (intptr_t)_get_osfhandle(fd);
4478 win32_fdupopen(FILE *pf)
4483 int fileno = win32_dup(win32_fileno(pf));
4485 /* open the file in the same mode */
4487 if((pf)->flags & _F_READ) {
4491 else if((pf)->flags & _F_WRIT) {
4495 else if((pf)->flags & _F_RDWR) {
4501 if((pf)->_flag & _IOREAD) {
4505 else if((pf)->_flag & _IOWRT) {
4509 else if((pf)->_flag & _IORW) {
4516 /* it appears that the binmode is attached to the
4517 * file descriptor so binmode files will be handled
4520 pfdup = win32_fdopen(fileno, mode);
4522 /* move the file pointer to the same position */
4523 if (!fgetpos(pf, &pos)) {
4524 fsetpos(pfdup, &pos);
4530 win32_dynaload(const char* filename)
4533 char buf[MAX_PATH+1];
4536 /* LoadLibrary() doesn't recognize forward slashes correctly,
4537 * so turn 'em back. */
4538 first = strchr(filename, '/');
4540 STRLEN len = strlen(filename);
4541 if (len <= MAX_PATH) {
4542 strcpy(buf, filename);
4543 filename = &buf[first - filename];
4545 if (*filename == '/')
4546 *(char*)filename = '\\';
4552 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4555 XS(w32_SetChildShowWindow)
4558 BOOL use_showwindow = w32_use_showwindow;
4559 /* use "unsigned short" because Perl has redefined "WORD" */
4560 unsigned short showwindow = w32_showwindow;
4563 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4565 if (items == 0 || !SvOK(ST(0)))
4566 w32_use_showwindow = FALSE;
4568 w32_use_showwindow = TRUE;
4569 w32_showwindow = (unsigned short)SvIV(ST(0));
4574 ST(0) = sv_2mortal(newSViv(showwindow));
4576 ST(0) = &PL_sv_undef;
4581 Perl_init_os_extras(void)
4584 char *file = __FILE__;
4586 /* Initialize Win32CORE if it has been statically linked. */
4587 void (*pfn_init)(pTHX);
4588 #if defined(__BORLANDC__)
4589 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4590 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4592 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4597 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4601 win32_signal_context(void)
4606 my_perl = PL_curinterp;
4607 PERL_SET_THX(my_perl);
4611 return PL_curinterp;
4617 win32_ctrlhandler(DWORD dwCtrlType)
4620 dTHXa(PERL_GET_SIG_CONTEXT);
4626 switch(dwCtrlType) {
4627 case CTRL_CLOSE_EVENT:
4628 /* A signal that the system sends to all processes attached to a console when
4629 the user closes the console (either by choosing the Close command from the
4630 console window's System menu, or by choosing the End Task command from the
4633 if (do_raise(aTHX_ 1)) /* SIGHUP */
4634 sig_terminate(aTHX_ 1);
4638 /* A CTRL+c signal was received */
4639 if (do_raise(aTHX_ SIGINT))
4640 sig_terminate(aTHX_ SIGINT);
4643 case CTRL_BREAK_EVENT:
4644 /* A CTRL+BREAK signal was received */
4645 if (do_raise(aTHX_ SIGBREAK))
4646 sig_terminate(aTHX_ SIGBREAK);
4649 case CTRL_LOGOFF_EVENT:
4650 /* A signal that the system sends to all console processes when a user is logging
4651 off. This signal does not indicate which user is logging off, so no
4652 assumptions can be made.
4655 case CTRL_SHUTDOWN_EVENT:
4656 /* A signal that the system sends to all console processes when the system is
4659 if (do_raise(aTHX_ SIGTERM))
4660 sig_terminate(aTHX_ SIGTERM);
4669 #ifdef SET_INVALID_PARAMETER_HANDLER
4670 # include <crtdbg.h>
4681 /* win32_ansipath() requires Windows 2000 or later */
4685 /* fetch Unicode version of PATH */
4687 wide_path = win32_malloc(len*sizeof(WCHAR));
4689 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4693 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4698 /* convert to ANSI pathnames */
4699 wide_dir = wide_path;
4702 WCHAR *sep = wcschr(wide_dir, ';');
4710 /* remove quotes around pathname */
4711 if (*wide_dir == '"')
4713 wide_len = wcslen(wide_dir);
4714 if (wide_len && wide_dir[wide_len-1] == '"')
4715 wide_dir[wide_len-1] = '\0';
4717 /* append ansi_dir to ansi_path */
4718 ansi_dir = win32_ansipath(wide_dir);
4719 ansi_len = strlen(ansi_dir);
4721 size_t newlen = len + 1 + ansi_len;
4722 ansi_path = win32_realloc(ansi_path, newlen+1);
4725 ansi_path[len] = ';';
4726 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4731 ansi_path = win32_malloc(5+len+1);
4734 memcpy(ansi_path, "PATH=", 5);
4735 memcpy(ansi_path+5, ansi_dir, len+1);
4738 win32_free(ansi_dir);
4743 /* Update C RTL environ array. This will only have full effect if
4744 * perl_parse() is later called with `environ` as the `env` argument.
4745 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4747 * We do have to ansify() the PATH before Perl has been fully
4748 * initialized because S_find_script() uses the PATH when perl
4749 * is being invoked with the -S option. This happens before %ENV
4750 * is initialized in S_init_postdump_symbols().
4752 * XXX Is this a bug? Should S_find_script() use the environment
4753 * XXX passed in the `env` arg to parse_perl()?
4756 /* Keep system environment in sync because S_init_postdump_symbols()
4757 * will not call mg_set() if it initializes %ENV from `environ`.
4759 SetEnvironmentVariableA("PATH", ansi_path+5);
4760 /* We are intentionally leaking the ansi_path string here because
4761 * the Borland runtime library puts it directly into the environ
4762 * array. The Microsoft runtime library seems to make a copy,
4763 * but will leak the copy should it be replaced again later.
4764 * Since this code is only called once during PERL_SYS_INIT this
4765 * shouldn't really matter.
4768 win32_free(wide_path);
4772 Perl_win32_init(int *argcp, char ***argvp)
4776 #ifdef SET_INVALID_PARAMETER_HANDLER
4777 _invalid_parameter_handler oldHandler, newHandler;
4778 newHandler = my_invalid_parameter_handler;
4779 oldHandler = _set_invalid_parameter_handler(newHandler);
4780 _CrtSetReportMode(_CRT_ASSERT, 0);
4782 /* Disable floating point errors, Perl will trap the ones we
4783 * care about. VC++ RTL defaults to switching these off
4784 * already, but the Borland RTL doesn't. Since we don't
4785 * want to be at the vendor's whim on the default, we set
4786 * it explicitly here.
4788 #if !defined(_ALPHA_) && !defined(__GNUC__)
4789 _control87(MCW_EM, MCW_EM);
4793 module = GetModuleHandle("ntdll.dll");
4795 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4798 module = GetModuleHandle("kernel32.dll");
4800 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4801 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4802 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4805 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4806 GetVersionEx(&g_osver);
4812 Perl_win32_term(void)
4822 win32_get_child_IO(child_IO_table* ptbl)
4824 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4825 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4826 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4830 win32_signal(int sig, Sighandler_t subcode)
4833 if (sig < SIG_SIZE) {
4834 int save_errno = errno;
4835 Sighandler_t result = signal(sig, subcode);
4836 if (result == SIG_ERR) {
4837 result = w32_sighandler[sig];
4840 w32_sighandler[sig] = subcode;
4849 /* The PerlMessageWindowClass's WindowProc */
4851 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4853 return win32_process_message(hwnd, msg, wParam, lParam) ?
4854 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4857 /* we use a message filter hook to process thread messages, passing any
4858 * messages that we don't process on to the rest of the hook chain
4859 * Anyone else writing a message loop that wants to play nicely with perl
4861 * CallMsgFilter(&msg, MSGF_***);
4862 * between their GetMessage and DispatchMessage calls. */
4864 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4865 LPMSG pmsg = (LPMSG)lParam;
4867 /* we'll process it if code says we're allowed, and it's a thread message */
4868 if (code >= 0 && pmsg->hwnd == NULL
4869 && win32_process_message(pmsg->hwnd, pmsg->message,
4870 pmsg->wParam, pmsg->lParam))
4875 /* XXX: MSDN says that hhk is ignored, but we should really use the
4876 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4877 return CallNextHookEx(NULL, code, wParam, lParam);
4880 /* The real message handler. Can be called with
4881 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4882 * that it processes */
4884 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4886 /* BEWARE. The context retrieved using dTHX; is the context of the
4887 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4888 * up to and including WM_CREATE. If it ever happens that you need the
4889 * 'child' context before this, then it needs to be passed into
4890 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4891 * from the lparam of CreateWindow(). It could then be stored/retrieved
4892 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4893 * the dTHX calls here. */
4894 /* XXX For now it is assumed that the overhead of the dTHX; for what
4895 * are relativley infrequent code-paths, is better than the added
4896 * complexity of getting the correct context passed into
4897 * win32_create_message_window() */
4902 case WM_USER_MESSAGE: {
4903 long child = find_pseudo_pid((int)wParam);
4906 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4913 case WM_USER_KILL: {
4915 /* We use WM_USER_KILL to fake kill() with other signals */
4916 int sig = (int)wParam;
4917 if (do_raise(aTHX_ sig))
4918 sig_terminate(aTHX_ sig);
4925 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4926 if (w32_timerid && w32_timerid==(UINT)wParam) {
4927 KillTimer(w32_message_hwnd, w32_timerid);
4930 /* Now fake a call to signal handler */
4931 if (do_raise(aTHX_ 14))
4932 sig_terminate(aTHX_ 14);
4944 /* Above or other stuff may have set a signal flag, and we may not have
4945 * been called from win32_async_check() (e.g. some other GUI's message
4946 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4947 * handler that die's, and the message loop that calls here is wrapped
4948 * in an eval, then you may well end up with orphaned windows - signals
4949 * are dispatched by win32_async_check() */
4955 win32_create_message_window_class(void)
4957 /* create the window class for "message only" windows */
4961 wc.lpfnWndProc = win32_message_window_proc;
4962 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4963 wc.lpszClassName = "PerlMessageWindowClass";
4965 /* second and subsequent calls will fail, but class
4966 * will already be registered */
4971 win32_create_message_window(void)
4975 /* "message-only" windows have been implemented in Windows 2000 and later.
4976 * On earlier versions we'll continue to post messages to a specific
4977 * thread and use hwnd==NULL. This is brittle when either an embedding
4978 * application or an XS module is also posting messages to hwnd=NULL
4979 * because once removed from the queue they cannot be delivered to the
4980 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4981 * if there is no window handle.
4983 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4984 * documentation to the contrary, however, there is some evidence that
4985 * there may be problems with the implementation on Win98. As it is not
4986 * officially supported we take the cautious route and stick with thread
4987 * messages (hwnd == NULL) on platforms prior to Win2k.
4990 win32_create_message_window_class();
4992 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4993 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4996 /* If we din't create a window for any reason, then we'll use thread
4997 * messages for our signalling, so we install a hook which
4998 * is called by CallMsgFilter in win32_async_check(), or any other
4999 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5000 * that use OLE, etc. */
5002 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5003 NULL, GetCurrentThreadId());
5009 #ifdef HAVE_INTERP_INTERN
5012 win32_csighandler(int sig)
5015 dTHXa(PERL_GET_SIG_CONTEXT);
5016 Perl_warn(aTHX_ "Got signal %d",sig);
5021 #if defined(__MINGW32__) && defined(__cplusplus)
5022 #define CAST_HWND__(x) (HWND__*)(x)
5024 #define CAST_HWND__(x) x
5028 Perl_sys_intern_init(pTHX)
5032 w32_perlshell_tokens = NULL;
5033 w32_perlshell_vec = (char**)NULL;
5034 w32_perlshell_items = 0;
5035 w32_fdpid = newAV();
5036 Newx(w32_children, 1, child_tab);
5037 w32_num_children = 0;
5038 # ifdef USE_ITHREADS
5040 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5041 w32_num_pseudo_children = 0;
5044 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5046 for (i=0; i < SIG_SIZE; i++) {
5047 w32_sighandler[i] = SIG_DFL;
5049 # ifdef MULTIPLICITY
5050 if (my_perl == PL_curinterp) {
5054 /* Force C runtime signal stuff to set its console handler */
5055 signal(SIGINT,win32_csighandler);
5056 signal(SIGBREAK,win32_csighandler);
5058 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5059 * flag. This has the side-effect of disabling Ctrl-C events in all
5060 * processes in this group. At least on Windows NT and later we
5061 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5062 * with a NULL handler. This is not valid on Windows 9X.
5065 SetConsoleCtrlHandler(NULL,FALSE);
5067 /* Push our handler on top */
5068 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5073 Perl_sys_intern_clear(pTHX)
5075 Safefree(w32_perlshell_tokens);
5076 Safefree(w32_perlshell_vec);
5077 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5078 Safefree(w32_children);
5080 KillTimer(w32_message_hwnd, w32_timerid);
5083 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5084 DestroyWindow(w32_message_hwnd);
5085 # ifdef MULTIPLICITY
5086 if (my_perl == PL_curinterp) {
5090 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5092 # ifdef USE_ITHREADS
5093 Safefree(w32_pseudo_children);
5097 # ifdef USE_ITHREADS
5100 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5102 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5104 dst->perlshell_tokens = NULL;
5105 dst->perlshell_vec = (char**)NULL;
5106 dst->perlshell_items = 0;
5107 dst->fdpid = newAV();
5108 Newxz(dst->children, 1, child_tab);
5110 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5112 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5113 dst->poll_count = 0;
5114 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5116 # endif /* USE_ITHREADS */
5117 #endif /* HAVE_INTERP_INTERN */