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)
63 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 # include <shellapi.h>
67 EXTERN_C LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
71 #define PERL_NO_GET_CONTEXT
77 /* assert.h conflicts with #define of assert in perl.h */
84 #if defined(_MSC_VER) || defined(__MINGW32__)
85 #include <sys/utime.h>
90 /* Mingw32 defaults to globing command line
91 * So we turn it off like this:
96 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
97 /* Mingw32-1.1 is missing some prototypes */
99 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
100 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
101 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
107 #if defined(__BORLANDC__)
109 # define _utimbuf utimbuf
113 #define EXECF_SPAWN 2
114 #define EXECF_SPAWN_NOWAIT 3
116 #if defined(PERL_IMPLICIT_SYS)
117 # undef win32_get_privlib
118 # define win32_get_privlib g_win32_get_privlib
119 # undef win32_get_sitelib
120 # define win32_get_sitelib g_win32_get_sitelib
121 # undef win32_get_vendorlib
122 # define win32_get_vendorlib g_win32_get_vendorlib
124 # define getlogin g_getlogin
127 static void get_shell(void);
128 static long tokenize(const char *str, char **dest, char ***destv);
129 static int do_spawn2(pTHX_ const char *cmd, int exectype);
130 static BOOL has_shell_metachars(const char *ptr);
131 static long filetime_to_clock(PFILETIME ft);
132 static BOOL filetime_from_time(PFILETIME ft, time_t t);
133 static char * get_emd_part(SV **leading, char *trailing, ...);
134 static void remove_dead_process(long deceased);
135 static long find_pid(int pid);
136 static char * qualified_path(const char *cmd);
137 static char * win32_get_xlib(const char *pl, const char *xlib,
138 const char *libname);
141 static void remove_dead_pseudo_process(long child);
142 static long find_pseudo_pid(int pid);
146 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
147 char w32_module_name[MAX_PATH+1];
150 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
152 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
153 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
154 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
155 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
158 /* Silence STDERR grumblings from Borland's math library. */
160 _matherr(struct _exception *a)
167 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
168 * parameter handler. This functionality is not available in the
169 * 64-bit compiler from the Platform SDK, which unfortunately also
170 * believes itself to be MSC version 14.
172 * There is no #define related to _set_invalid_parameter_handler(),
173 * but we can check for one of the constants defined for
174 * _set_abort_behavior(), which was introduced into stdlib.h at
178 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
179 # define SET_INVALID_PARAMETER_HANDLER
182 #ifdef SET_INVALID_PARAMETER_HANDLER
183 void my_invalid_parameter_handler(const wchar_t* expression,
184 const wchar_t* function,
190 wprintf(L"Invalid parameter detected in function %s."
191 L" File: %s Line: %d\n", function, file, line);
192 wprintf(L"Expression: %s\n", expression);
200 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
206 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
212 return (g_osver.dwMajorVersion > 4);
216 set_w32_module_name(void)
218 /* this function may be called at DLL_PROCESS_ATTACH time */
220 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
221 ? GetModuleHandle(NULL)
222 : w32_perldll_handle);
224 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
225 osver.dwOSVersionInfoSize = sizeof(osver);
226 GetVersionEx(&osver);
228 if (osver.dwMajorVersion > 4) {
229 WCHAR modulename[MAX_PATH];
230 WCHAR fullname[MAX_PATH];
233 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
235 /* Make sure we get an absolute pathname in case the module was loaded
236 * explicitly by LoadLibrary() with a relative path. */
237 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
239 /* remove \\?\ prefix */
240 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
241 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
243 ansi = win32_ansipath(fullname);
244 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
248 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
250 /* remove \\?\ prefix */
251 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
252 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
254 /* try to get full path to binary (which may be mangled when perl is
255 * run from a 16-bit app) */
256 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
257 win32_longpath(w32_module_name);
258 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
261 /* normalize to forward slashes */
262 ptr = w32_module_name;
270 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
272 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
274 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
277 const char *subkey = "Software\\Perl";
281 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
282 if (retval == ERROR_SUCCESS) {
284 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
285 if (retval == ERROR_SUCCESS
286 && (type == REG_SZ || type == REG_EXPAND_SZ))
290 *svp = sv_2mortal(newSVpvn("",0));
291 SvGROW(*svp, datalen);
292 retval = RegQueryValueEx(handle, valuename, 0, NULL,
293 (PBYTE)SvPVX(*svp), &datalen);
294 if (retval == ERROR_SUCCESS) {
296 SvCUR_set(*svp,datalen-1);
304 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
306 get_regstr(const char *valuename, SV **svp)
308 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
310 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
314 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
316 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
320 char mod_name[MAX_PATH+1];
326 va_start(ap, trailing_path);
327 strip = va_arg(ap, char *);
329 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
330 baselen = strlen(base);
332 if (!*w32_module_name) {
333 set_w32_module_name();
335 strcpy(mod_name, w32_module_name);
336 ptr = strrchr(mod_name, '/');
337 while (ptr && strip) {
338 /* look for directories to skip back */
341 ptr = strrchr(mod_name, '/');
342 /* avoid stripping component if there is no slash,
343 * or it doesn't match ... */
344 if (!ptr || stricmp(ptr+1, strip) != 0) {
345 /* ... but not if component matches m|5\.$patchlevel.*| */
346 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
347 && strncmp(strip, base, baselen) == 0
348 && strncmp(ptr+1, base, baselen) == 0))
354 strip = va_arg(ap, char *);
362 strcpy(++ptr, trailing_path);
364 /* only add directory if it exists */
365 if (GetFileAttributes(mod_name) != (DWORD) -1) {
366 /* directory exists */
369 *prev_pathp = sv_2mortal(newSVpvn("",0));
370 else if (SvPVX(*prev_pathp))
371 sv_catpvn(*prev_pathp, ";", 1);
372 sv_catpv(*prev_pathp, mod_name);
373 return SvPVX(*prev_pathp);
380 win32_get_privlib(const char *pl)
383 char *stdlib = "lib";
384 char buffer[MAX_PATH+1];
387 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
388 sprintf(buffer, "%s-%s", stdlib, pl);
389 if (!get_regstr(buffer, &sv))
390 (void)get_regstr(stdlib, &sv);
392 /* $stdlib .= ";$EMD/../../lib" */
393 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
397 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
401 char pathstr[MAX_PATH+1];
405 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
406 sprintf(regstr, "%s-%s", xlib, pl);
407 (void)get_regstr(regstr, &sv1);
410 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
411 sprintf(pathstr, "%s/%s/lib", libname, pl);
412 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
414 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
415 (void)get_regstr(xlib, &sv2);
418 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
419 sprintf(pathstr, "%s/lib", libname);
420 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
429 sv_catpvn(sv1, ";", 1);
436 win32_get_sitelib(const char *pl)
438 return win32_get_xlib(pl, "sitelib", "site");
441 #ifndef PERL_VENDORLIB_NAME
442 # define PERL_VENDORLIB_NAME "vendor"
446 win32_get_vendorlib(const char *pl)
448 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
452 has_shell_metachars(const char *ptr)
458 * Scan string looking for redirection (< or >) or pipe
459 * characters (|) that are not in a quoted string.
460 * Shell variable interpolation (%VAR%) can also happen inside strings.
492 #if !defined(PERL_IMPLICIT_SYS)
493 /* since the current process environment is being updated in util.c
494 * the library functions will get the correct environment
497 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
500 #define fixcmd(x) { \
501 char *pspace = strchr((x),' '); \
504 while (p < pspace) { \
515 PERL_FLUSHALL_FOR_CHILD;
516 return win32_popen(cmd, mode);
520 Perl_my_pclose(pTHX_ PerlIO *fp)
522 return win32_pclose(fp);
526 DllExport unsigned long
529 return (unsigned long)g_osver.dwPlatformId;
539 return -((int)w32_pseudo_id);
542 /* Windows 9x appears to always reports a pid for threads and processes
543 * that has the high bit set. So we treat the lower 31 bits as the
544 * "real" PID for Perl's purposes. */
545 if (IsWin95() && pid < 0)
550 /* Tokenize a string. Words are null-separated, and the list
551 * ends with a doubled null. Any character (except null and
552 * including backslash) may be escaped by preceding it with a
553 * backslash (the backslash will be stripped).
554 * Returns number of words in result buffer.
557 tokenize(const char *str, char **dest, char ***destv)
559 char *retstart = Nullch;
560 char **retvstart = 0;
564 int slen = strlen(str);
566 register char **retv;
567 Newx(ret, slen+2, char);
568 Newx(retv, (slen+3)/2, char*);
576 if (*ret == '\\' && *str)
578 else if (*ret == ' ') {
594 retvstart[items] = Nullch;
607 if (!w32_perlshell_tokens) {
608 /* we don't use COMSPEC here for two reasons:
609 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
610 * uncontrolled unportability of the ensuing scripts.
611 * 2. PERL5SHELL could be set to a shell that may not be fit for
612 * interactive use (which is what most programs look in COMSPEC
615 const char* defaultshell = (IsWinNT()
616 ? "cmd.exe /x/d/c" : "command.com /c");
617 const char *usershell = PerlEnv_getenv("PERL5SHELL");
618 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
619 &w32_perlshell_tokens,
625 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
637 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
639 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
644 while (++mark <= sp) {
645 if (*mark && (str = SvPV_nolen(*mark)))
652 status = win32_spawnvp(flag,
653 (const char*)(really ? SvPV_nolen(really) : argv[0]),
654 (const char* const*)argv);
656 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
657 /* possible shell-builtin, invoke with shell */
659 sh_items = w32_perlshell_items;
661 argv[index+sh_items] = argv[index];
662 while (--sh_items >= 0)
663 argv[sh_items] = w32_perlshell_vec[sh_items];
665 status = win32_spawnvp(flag,
666 (const char*)(really ? SvPV_nolen(really) : argv[0]),
667 (const char* const*)argv);
670 if (flag == P_NOWAIT) {
672 PL_statusvalue = -1; /* >16bits hint for pp_system() */
676 if (ckWARN(WARN_EXEC))
677 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
682 PL_statusvalue = status;
688 /* returns pointer to the next unquoted space or the end of the string */
690 find_next_space(const char *s)
692 bool in_quotes = FALSE;
694 /* ignore doubled backslashes, or backslash+quote */
695 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
698 /* keep track of when we're within quotes */
699 else if (*s == '"') {
701 in_quotes = !in_quotes;
703 /* break it up only at spaces that aren't in quotes */
704 else if (!in_quotes && isSPACE(*s))
713 do_spawn2(pTHX_ const char *cmd, int exectype)
719 BOOL needToTry = TRUE;
722 /* Save an extra exec if possible. See if there are shell
723 * metacharacters in it */
724 if (!has_shell_metachars(cmd)) {
725 Newx(argv, strlen(cmd) / 2 + 2, char*);
726 Newx(cmd2, strlen(cmd) + 1, char);
729 for (s = cmd2; *s;) {
730 while (*s && isSPACE(*s))
734 s = find_next_space(s);
742 status = win32_spawnvp(P_WAIT, argv[0],
743 (const char* const*)argv);
745 case EXECF_SPAWN_NOWAIT:
746 status = win32_spawnvp(P_NOWAIT, argv[0],
747 (const char* const*)argv);
750 status = win32_execvp(argv[0], (const char* const*)argv);
753 if (status != -1 || errno == 0)
763 Newx(argv, w32_perlshell_items + 2, char*);
764 while (++i < w32_perlshell_items)
765 argv[i] = w32_perlshell_vec[i];
766 argv[i++] = (char *)cmd;
770 status = win32_spawnvp(P_WAIT, argv[0],
771 (const char* const*)argv);
773 case EXECF_SPAWN_NOWAIT:
774 status = win32_spawnvp(P_NOWAIT, argv[0],
775 (const char* const*)argv);
778 status = win32_execvp(argv[0], (const char* const*)argv);
784 if (exectype == EXECF_SPAWN_NOWAIT) {
786 PL_statusvalue = -1; /* >16bits hint for pp_system() */
790 if (ckWARN(WARN_EXEC))
791 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
792 (exectype == EXECF_EXEC ? "exec" : "spawn"),
793 cmd, strerror(errno));
798 PL_statusvalue = status;
804 Perl_do_spawn(pTHX_ char *cmd)
806 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
810 Perl_do_spawn_nowait(pTHX_ char *cmd)
812 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
816 Perl_do_exec(pTHX_ const char *cmd)
818 do_spawn2(aTHX_ cmd, EXECF_EXEC);
822 /* The idea here is to read all the directory names into a string table
823 * (separated by nulls) and when one of the other dir functions is called
824 * return the pointer to the current file name.
827 win32_opendir(const char *filename)
833 char scanname[MAX_PATH+3];
835 WIN32_FIND_DATAA aFindData;
836 WIN32_FIND_DATAW wFindData;
838 char buffer[MAX_PATH*2];
841 len = strlen(filename);
845 /* check to see if filename is a directory */
846 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
849 /* Get us a DIR structure */
852 /* Create the search pattern */
853 strcpy(scanname, filename);
855 /* bare drive name means look in cwd for drive */
856 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
857 scanname[len++] = '.';
858 scanname[len++] = '/';
860 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
861 scanname[len++] = '/';
863 scanname[len++] = '*';
864 scanname[len] = '\0';
866 /* do the FindFirstFile call */
868 WCHAR wscanname[sizeof(scanname)];
869 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
870 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
874 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
876 if (dirp->handle == INVALID_HANDLE_VALUE) {
877 DWORD err = GetLastError();
878 /* FindFirstFile() fails on empty drives! */
880 case ERROR_FILE_NOT_FOUND:
882 case ERROR_NO_MORE_FILES:
883 case ERROR_PATH_NOT_FOUND:
886 case ERROR_NOT_ENOUGH_MEMORY:
898 BOOL use_default = FALSE;
899 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
900 wFindData.cFileName, -1,
901 buffer, sizeof(buffer), NULL, &use_default);
902 if (use_default && *wFindData.cAlternateFileName) {
903 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
904 wFindData.cAlternateFileName, -1,
905 buffer, sizeof(buffer), NULL, NULL);
910 ptr = aFindData.cFileName;
912 /* now allocate the first part of the string table for
913 * the filenames that we find.
920 Newx(dirp->start, dirp->size, char);
921 strcpy(dirp->start, ptr);
923 dirp->end = dirp->curr = dirp->start;
929 /* Readdir just returns the current string pointer and bumps the
930 * string pointer to the nDllExport entry.
932 DllExport struct direct *
933 win32_readdir(DIR *dirp)
938 /* first set up the structure to return */
939 len = strlen(dirp->curr);
940 strcpy(dirp->dirstr.d_name, dirp->curr);
941 dirp->dirstr.d_namlen = len;
944 dirp->dirstr.d_ino = dirp->curr - dirp->start;
946 /* Now set up for the next call to readdir */
947 dirp->curr += len + 1;
948 if (dirp->curr >= dirp->end) {
951 WIN32_FIND_DATAA aFindData;
952 char buffer[MAX_PATH*2];
955 /* finding the next file that matches the wildcard
956 * (which should be all of them in this directory!).
959 WIN32_FIND_DATAW wFindData;
960 res = FindNextFileW(dirp->handle, &wFindData);
962 BOOL use_default = FALSE;
963 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
964 wFindData.cFileName, -1,
965 buffer, sizeof(buffer), NULL, &use_default);
966 if (use_default && *wFindData.cAlternateFileName) {
967 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
968 wFindData.cAlternateFileName, -1,
969 buffer, sizeof(buffer), NULL, NULL);
975 res = FindNextFileA(dirp->handle, &aFindData);
976 ptr = aFindData.cFileName;
979 long endpos = dirp->end - dirp->start;
980 long newsize = endpos + strlen(ptr) + 1;
981 /* bump the string table size by enough for the
982 * new name and its null terminator */
983 while (newsize > dirp->size) {
984 long curpos = dirp->curr - dirp->start;
986 Renew(dirp->start, dirp->size, char);
987 dirp->curr = dirp->start + curpos;
989 strcpy(dirp->start + endpos, ptr);
990 dirp->end = dirp->start + newsize;
996 return &(dirp->dirstr);
1002 /* Telldir returns the current string pointer position */
1004 win32_telldir(DIR *dirp)
1006 return (dirp->curr - dirp->start);
1010 /* Seekdir moves the string pointer to a previously saved position
1011 * (returned by telldir).
1014 win32_seekdir(DIR *dirp, long loc)
1016 dirp->curr = dirp->start + loc;
1019 /* Rewinddir resets the string pointer to the start */
1021 win32_rewinddir(DIR *dirp)
1023 dirp->curr = dirp->start;
1026 /* free the memory allocated by opendir */
1028 win32_closedir(DIR *dirp)
1031 if (dirp->handle != INVALID_HANDLE_VALUE)
1032 FindClose(dirp->handle);
1033 Safefree(dirp->start);
1046 * Just pretend that everyone is a superuser. NT will let us know if
1047 * we don\'t really have permission to do something.
1050 #define ROOT_UID ((uid_t)0)
1051 #define ROOT_GID ((gid_t)0)
1080 return (auid == ROOT_UID ? 0 : -1);
1086 return (agid == ROOT_GID ? 0 : -1);
1093 char *buf = w32_getlogin_buffer;
1094 DWORD size = sizeof(w32_getlogin_buffer);
1095 if (GetUserName(buf,&size))
1101 chown(const char *path, uid_t owner, gid_t group)
1108 * XXX this needs strengthening (for PerlIO)
1111 int mkstemp(const char *path)
1114 char buf[MAX_PATH+1];
1118 if (i++ > 10) { /* give up */
1122 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1126 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1136 long child = w32_num_children;
1137 while (--child >= 0) {
1138 if ((int)w32_child_pids[child] == pid)
1145 remove_dead_process(long child)
1149 CloseHandle(w32_child_handles[child]);
1150 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1151 (w32_num_children-child-1), HANDLE);
1152 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1153 (w32_num_children-child-1), DWORD);
1160 find_pseudo_pid(int pid)
1163 long child = w32_num_pseudo_children;
1164 while (--child >= 0) {
1165 if ((int)w32_pseudo_child_pids[child] == pid)
1172 remove_dead_pseudo_process(long child)
1176 CloseHandle(w32_pseudo_child_handles[child]);
1177 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1178 (w32_num_pseudo_children-child-1), HANDLE);
1179 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1180 (w32_num_pseudo_children-child-1), DWORD);
1181 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1182 (w32_num_pseudo_children-child-1), HWND);
1183 w32_num_pseudo_children--;
1189 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1193 /* "Does process exist?" use of kill */
1196 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1201 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1204 default: /* For now be backwards compatible with perl 5.6 */
1206 /* Note that we will only be able to kill processes owned by the
1207 * current process owner, even when we are running as an administrator.
1208 * To kill processes of other owners we would need to set the
1209 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1211 if (TerminateProcess(process_handle, sig))
1218 /* Traverse process tree using ToolHelp functions */
1220 kill_process_tree_toolhelp(DWORD pid, int sig)
1222 HANDLE process_handle;
1223 HANDLE snapshot_handle;
1226 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1227 if (process_handle == NULL)
1230 killed += terminate_process(pid, process_handle, sig);
1232 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1233 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1234 PROCESSENTRY32 entry;
1236 entry.dwSize = sizeof(entry);
1237 if (pfnProcess32First(snapshot_handle, &entry)) {
1239 if (entry.th32ParentProcessID == pid)
1240 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1241 entry.dwSize = sizeof(entry);
1243 while (pfnProcess32Next(snapshot_handle, &entry));
1245 CloseHandle(snapshot_handle);
1247 CloseHandle(process_handle);
1251 /* Traverse process tree using undocumented system information structures.
1252 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1255 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1257 HANDLE process_handle;
1258 SYSTEM_PROCESSES *p = process_info;
1261 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1262 if (process_handle == NULL)
1265 killed += terminate_process(pid, process_handle, sig);
1268 if (p->InheritedFromProcessId == (DWORD)pid)
1269 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1271 if (p->NextEntryDelta == 0)
1274 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1277 CloseHandle(process_handle);
1282 killpg(int pid, int sig)
1284 /* Use "documented" method whenever available */
1285 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1286 return kill_process_tree_toolhelp((DWORD)pid, sig);
1289 /* Fall back to undocumented Windows internals on Windows NT */
1290 if (pfnZwQuerySystemInformation) {
1295 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1296 Newx(buffer, size, char);
1298 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1299 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1308 my_kill(int pid, int sig)
1311 HANDLE process_handle;
1314 return killpg(pid, -sig);
1316 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1317 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1318 if (process_handle != NULL) {
1319 retval = terminate_process(pid, process_handle, sig);
1320 CloseHandle(process_handle);
1326 win32_kill(int pid, int sig)
1332 /* it is a pseudo-forked child */
1333 child = find_pseudo_pid(-pid);
1335 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1336 HANDLE hProcess = w32_pseudo_child_handles[child];
1339 /* "Does process exist?" use of kill */
1343 /* kill -9 style un-graceful exit */
1344 if (TerminateThread(hProcess, sig)) {
1345 remove_dead_pseudo_process(child);
1352 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1353 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1354 /* Yield and wait for the other thread to send us its message_hwnd */
1356 win32_async_check(aTHX);
1357 hwnd = w32_pseudo_child_message_hwnds[child];
1360 if (hwnd != INVALID_HANDLE_VALUE) {
1361 /* We fake signals to pseudo-processes using Win32
1362 * message queue. In Win9X the pids are negative already. */
1363 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1364 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1366 /* It might be us ... */
1375 else if (IsWin95()) {
1383 child = find_pid(pid);
1385 if (my_kill(pid, sig)) {
1387 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1388 exitcode != STILL_ACTIVE)
1390 remove_dead_process(child);
1397 if (my_kill((IsWin95() ? -pid : pid), sig))
1406 win32_stat(const char *path, Stat_t *sbuf)
1409 char buffer[MAX_PATH+1];
1410 int l = strlen(path);
1413 BOOL expect_dir = FALSE;
1415 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1416 GV_NOTQUAL, SVt_PV);
1417 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1420 switch(path[l - 1]) {
1421 /* FindFirstFile() and stat() are buggy with a trailing
1422 * slashes, except for the root directory of a drive */
1425 if (l > sizeof(buffer)) {
1426 errno = ENAMETOOLONG;
1430 strncpy(buffer, path, l);
1431 /* remove additional trailing slashes */
1432 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1434 /* add back slash if we otherwise end up with just a drive letter */
1435 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1442 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1444 if (l == 2 && isALPHA(path[0])) {
1445 buffer[0] = path[0];
1456 path = PerlDir_mapA(path);
1460 /* We must open & close the file once; otherwise file attribute changes */
1461 /* might not yet have propagated to "other" hard links of the same file. */
1462 /* This also gives us an opportunity to determine the number of links. */
1463 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1464 if (handle != INVALID_HANDLE_VALUE) {
1465 BY_HANDLE_FILE_INFORMATION bhi;
1466 if (GetFileInformationByHandle(handle, &bhi))
1467 nlink = bhi.nNumberOfLinks;
1468 CloseHandle(handle);
1472 /* path will be mapped correctly above */
1473 #if defined(WIN64) || defined(USE_LARGE_FILES)
1474 res = _stati64(path, sbuf);
1476 res = stat(path, sbuf);
1478 sbuf->st_nlink = nlink;
1481 /* CRT is buggy on sharenames, so make sure it really isn't.
1482 * XXX using GetFileAttributesEx() will enable us to set
1483 * sbuf->st_*time (but note that's not available on the
1484 * Windows of 1995) */
1485 DWORD r = GetFileAttributesA(path);
1486 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1487 /* sbuf may still contain old garbage since stat() failed */
1488 Zero(sbuf, 1, Stat_t);
1489 sbuf->st_mode = S_IFDIR | S_IREAD;
1491 if (!(r & FILE_ATTRIBUTE_READONLY))
1492 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1497 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1498 && (path[2] == '\\' || path[2] == '/'))
1500 /* The drive can be inaccessible, some _stat()s are buggy */
1501 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1506 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1511 if (S_ISDIR(sbuf->st_mode))
1512 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1513 else if (S_ISREG(sbuf->st_mode)) {
1515 if (l >= 4 && path[l-4] == '.') {
1516 const char *e = path + l - 3;
1517 if (strnicmp(e,"exe",3)
1518 && strnicmp(e,"bat",3)
1519 && strnicmp(e,"com",3)
1520 && (IsWin95() || strnicmp(e,"cmd",3)))
1521 sbuf->st_mode &= ~S_IEXEC;
1523 sbuf->st_mode |= S_IEXEC;
1526 sbuf->st_mode &= ~S_IEXEC;
1527 /* Propagate permissions to _group_ and _others_ */
1528 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1529 sbuf->st_mode |= (perms>>3) | (perms>>6);
1536 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1537 #define SKIP_SLASHES(s) \
1539 while (*(s) && isSLASH(*(s))) \
1542 #define COPY_NONSLASHES(d,s) \
1544 while (*(s) && !isSLASH(*(s))) \
1548 /* Find the longname of a given path. path is destructively modified.
1549 * It should have space for at least MAX_PATH characters. */
1551 win32_longpath(char *path)
1553 WIN32_FIND_DATA fdata;
1555 char tmpbuf[MAX_PATH+1];
1556 char *tmpstart = tmpbuf;
1563 if (isALPHA(path[0]) && path[1] == ':') {
1565 *tmpstart++ = path[0];
1569 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1571 *tmpstart++ = path[0];
1572 *tmpstart++ = path[1];
1573 SKIP_SLASHES(start);
1574 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1576 *tmpstart++ = *start++;
1577 SKIP_SLASHES(start);
1578 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1583 /* copy initial slash, if any */
1584 if (isSLASH(*start)) {
1585 *tmpstart++ = *start++;
1587 SKIP_SLASHES(start);
1590 /* FindFirstFile() expands "." and "..", so we need to pass
1591 * those through unmolested */
1593 && (!start[1] || isSLASH(start[1])
1594 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1596 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1601 /* if this is the end, bust outta here */
1605 /* now we're at a non-slash; walk up to next slash */
1606 while (*start && !isSLASH(*start))
1609 /* stop and find full name of component */
1612 fhand = FindFirstFile(path,&fdata);
1614 if (fhand != INVALID_HANDLE_VALUE) {
1615 STRLEN len = strlen(fdata.cFileName);
1616 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1617 strcpy(tmpstart, fdata.cFileName);
1628 /* failed a step, just return without side effects */
1629 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1634 strcpy(path,tmpbuf);
1643 /* Can't use PerlIO to write as it allocates memory */
1644 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1645 PL_no_mem, strlen(PL_no_mem));
1651 /* The win32_ansipath() function takes a Unicode filename and converts it
1652 * into the current Windows codepage. If some characters cannot be mapped,
1653 * then it will convert the short name instead.
1655 * The buffer to the ansi pathname must be freed with win32_free() when it
1656 * it no longer needed.
1658 * The argument to win32_ansipath() must exist before this function is
1659 * called; otherwise there is no way to determine the short path name.
1661 * Ideas for future refinement:
1662 * - Only convert those segments of the path that are not in the current
1663 * codepage, but leave the other segments in their long form.
1664 * - If the resulting name is longer than MAX_PATH, start converting
1665 * additional path segments into short names until the full name
1666 * is shorter than MAX_PATH. Shorten the filename part last!
1669 win32_ansipath(const WCHAR *widename)
1672 BOOL use_default = FALSE;
1673 size_t widelen = wcslen(widename)+1;
1674 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1675 NULL, 0, NULL, NULL);
1676 name = win32_malloc(len);
1680 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1681 name, len, NULL, &use_default);
1683 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1685 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1688 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1690 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1691 NULL, 0, NULL, NULL);
1692 name = win32_realloc(name, len);
1695 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1696 name, len, NULL, NULL);
1697 win32_free(shortname);
1704 win32_getenv(const char *name)
1708 SV *curitem = Nullsv;
1710 needlen = GetEnvironmentVariableA(name,NULL,0);
1712 curitem = sv_2mortal(newSVpvn("", 0));
1714 SvGROW(curitem, needlen+1);
1715 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1717 } while (needlen >= SvLEN(curitem));
1718 SvCUR_set(curitem, needlen);
1721 /* allow any environment variables that begin with 'PERL'
1722 to be stored in the registry */
1723 if (strncmp(name, "PERL", 4) == 0)
1724 (void)get_regstr(name, &curitem);
1726 if (curitem && SvCUR(curitem))
1727 return SvPVX(curitem);
1733 win32_putenv(const char *name)
1741 Newx(curitem,strlen(name)+1,char);
1742 strcpy(curitem, name);
1743 val = strchr(curitem, '=');
1745 /* The sane way to deal with the environment.
1746 * Has these advantages over putenv() & co.:
1747 * * enables us to store a truly empty value in the
1748 * environment (like in UNIX).
1749 * * we don't have to deal with RTL globals, bugs and leaks.
1751 * Why you may want to enable USE_WIN32_RTL_ENV:
1752 * * environ[] and RTL functions will not reflect changes,
1753 * which might be an issue if extensions want to access
1754 * the env. via RTL. This cuts both ways, since RTL will
1755 * not see changes made by extensions that call the Win32
1756 * functions directly, either.
1760 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1769 filetime_to_clock(PFILETIME ft)
1771 __int64 qw = ft->dwHighDateTime;
1773 qw |= ft->dwLowDateTime;
1774 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1779 win32_times(struct tms *timebuf)
1784 clock_t process_time_so_far = clock();
1785 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1787 timebuf->tms_utime = filetime_to_clock(&user);
1788 timebuf->tms_stime = filetime_to_clock(&kernel);
1789 timebuf->tms_cutime = 0;
1790 timebuf->tms_cstime = 0;
1792 /* That failed - e.g. Win95 fallback to clock() */
1793 timebuf->tms_utime = process_time_so_far;
1794 timebuf->tms_stime = 0;
1795 timebuf->tms_cutime = 0;
1796 timebuf->tms_cstime = 0;
1798 return process_time_so_far;
1801 /* fix utime() so it works on directories in NT */
1803 filetime_from_time(PFILETIME pFileTime, time_t Time)
1805 struct tm *pTM = localtime(&Time);
1806 SYSTEMTIME SystemTime;
1812 SystemTime.wYear = pTM->tm_year + 1900;
1813 SystemTime.wMonth = pTM->tm_mon + 1;
1814 SystemTime.wDay = pTM->tm_mday;
1815 SystemTime.wHour = pTM->tm_hour;
1816 SystemTime.wMinute = pTM->tm_min;
1817 SystemTime.wSecond = pTM->tm_sec;
1818 SystemTime.wMilliseconds = 0;
1820 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1821 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1825 win32_unlink(const char *filename)
1831 filename = PerlDir_mapA(filename);
1832 attrs = GetFileAttributesA(filename);
1833 if (attrs == 0xFFFFFFFF) {
1837 if (attrs & FILE_ATTRIBUTE_READONLY) {
1838 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1839 ret = unlink(filename);
1841 (void)SetFileAttributesA(filename, attrs);
1844 ret = unlink(filename);
1849 win32_utime(const char *filename, struct utimbuf *times)
1856 struct utimbuf TimeBuffer;
1859 filename = PerlDir_mapA(filename);
1860 rc = utime(filename, times);
1862 /* EACCES: path specifies directory or readonly file */
1863 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1866 if (times == NULL) {
1867 times = &TimeBuffer;
1868 time(×->actime);
1869 times->modtime = times->actime;
1872 /* This will (and should) still fail on readonly files */
1873 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1874 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1875 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1876 if (handle == INVALID_HANDLE_VALUE)
1879 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1880 filetime_from_time(&ftAccess, times->actime) &&
1881 filetime_from_time(&ftWrite, times->modtime) &&
1882 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1887 CloseHandle(handle);
1892 unsigned __int64 ft_i64;
1897 #define Const64(x) x##LL
1899 #define Const64(x) x##i64
1901 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1902 #define EPOCH_BIAS Const64(116444736000000000)
1904 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1905 * and appears to be unsupported even by glibc) */
1907 win32_gettimeofday(struct timeval *tp, void *not_used)
1911 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1912 GetSystemTimeAsFileTime(&ft.ft_val);
1914 /* seconds since epoch */
1915 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1917 /* microseconds remaining */
1918 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1924 win32_uname(struct utsname *name)
1926 struct hostent *hep;
1927 STRLEN nodemax = sizeof(name->nodename)-1;
1930 switch (g_osver.dwPlatformId) {
1931 case VER_PLATFORM_WIN32_WINDOWS:
1932 strcpy(name->sysname, "Windows");
1934 case VER_PLATFORM_WIN32_NT:
1935 strcpy(name->sysname, "Windows NT");
1937 case VER_PLATFORM_WIN32s:
1938 strcpy(name->sysname, "Win32s");
1941 strcpy(name->sysname, "Win32 Unknown");
1946 sprintf(name->release, "%d.%d",
1947 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1950 sprintf(name->version, "Build %d",
1951 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1952 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1953 if (g_osver.szCSDVersion[0]) {
1954 char *buf = name->version + strlen(name->version);
1955 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1959 hep = win32_gethostbyname("localhost");
1961 STRLEN len = strlen(hep->h_name);
1962 if (len <= nodemax) {
1963 strcpy(name->nodename, hep->h_name);
1966 strncpy(name->nodename, hep->h_name, nodemax);
1967 name->nodename[nodemax] = '\0';
1972 if (!GetComputerName(name->nodename, &sz))
1973 *name->nodename = '\0';
1976 /* machine (architecture) */
1981 GetSystemInfo(&info);
1983 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1984 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1985 procarch = info.u.s.wProcessorArchitecture;
1987 procarch = info.wProcessorArchitecture;
1990 case PROCESSOR_ARCHITECTURE_INTEL:
1991 arch = "x86"; break;
1992 case PROCESSOR_ARCHITECTURE_MIPS:
1993 arch = "mips"; break;
1994 case PROCESSOR_ARCHITECTURE_ALPHA:
1995 arch = "alpha"; break;
1996 case PROCESSOR_ARCHITECTURE_PPC:
1997 arch = "ppc"; break;
1998 #ifdef PROCESSOR_ARCHITECTURE_SHX
1999 case PROCESSOR_ARCHITECTURE_SHX:
2000 arch = "shx"; break;
2002 #ifdef PROCESSOR_ARCHITECTURE_ARM
2003 case PROCESSOR_ARCHITECTURE_ARM:
2004 arch = "arm"; break;
2006 #ifdef PROCESSOR_ARCHITECTURE_IA64
2007 case PROCESSOR_ARCHITECTURE_IA64:
2008 arch = "ia64"; break;
2010 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2011 case PROCESSOR_ARCHITECTURE_ALPHA64:
2012 arch = "alpha64"; break;
2014 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2015 case PROCESSOR_ARCHITECTURE_MSIL:
2016 arch = "msil"; break;
2018 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2019 case PROCESSOR_ARCHITECTURE_AMD64:
2020 arch = "amd64"; break;
2022 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2023 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2024 arch = "ia32-64"; break;
2026 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2027 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2028 arch = "unknown"; break;
2031 sprintf(name->machine, "unknown(0x%x)", procarch);
2032 arch = name->machine;
2035 if (name->machine != arch)
2036 strcpy(name->machine, arch);
2041 /* Timing related stuff */
2044 do_raise(pTHX_ int sig)
2046 if (sig < SIG_SIZE) {
2047 Sighandler_t handler = w32_sighandler[sig];
2048 if (handler == SIG_IGN) {
2051 else if (handler != SIG_DFL) {
2056 /* Choose correct default behaviour */
2072 /* Tell caller to exit thread/process as approriate */
2077 sig_terminate(pTHX_ int sig)
2079 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2080 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2087 win32_async_check(pTHX)
2090 HWND hwnd = w32_message_hwnd;
2094 if (hwnd == INVALID_HANDLE_VALUE) {
2095 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2096 * This is necessary when we are being called by win32_msgwait() to
2097 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2098 * message over and over. An example how this can happen is when
2099 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2100 * is generating messages before the process terminated.
2102 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2108 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
2109 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2114 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2115 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2117 switch (msg.message) {
2119 case WM_USER_MESSAGE: {
2120 int child = find_pseudo_pid(msg.wParam);
2122 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
2127 case WM_USER_KILL: {
2128 /* We use WM_USER to fake kill() with other signals */
2129 int sig = msg.wParam;
2130 if (do_raise(aTHX_ sig))
2131 sig_terminate(aTHX_ sig);
2136 /* alarm() is a one-shot but SetTimer() repeats so kill it */
2137 if (w32_timerid && w32_timerid==msg.wParam) {
2138 KillTimer(w32_message_hwnd, w32_timerid);
2141 /* Now fake a call to signal handler */
2142 if (do_raise(aTHX_ 14))
2143 sig_terminate(aTHX_ 14);
2150 /* Above or other stuff may have set a signal flag */
2151 if (PL_sig_pending) {
2157 /* This function will not return until the timeout has elapsed, or until
2158 * one of the handles is ready. */
2160 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2162 /* We may need several goes at this - so compute when we stop */
2164 if (timeout != INFINITE) {
2165 ticks = GetTickCount();
2169 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER);
2172 if (result == WAIT_TIMEOUT) {
2173 /* Ran out of time - explicit return of zero to avoid -ve if we
2174 have scheduling issues
2178 if (timeout != INFINITE) {
2179 ticks = GetTickCount();
2181 if (result == WAIT_OBJECT_0 + count) {
2182 /* Message has arrived - check it */
2183 (void)win32_async_check(aTHX);
2186 /* Not timeout or message - one of handles is ready */
2190 /* compute time left to wait */
2191 ticks = timeout - ticks;
2192 /* If we are past the end say zero */
2193 return (ticks > 0) ? ticks : 0;
2197 win32_internal_wait(int *status, DWORD timeout)
2199 /* XXX this wait emulation only knows about processes
2200 * spawned via win32_spawnvp(P_NOWAIT, ...).
2204 DWORD exitcode, waitcode;
2207 if (w32_num_pseudo_children) {
2208 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2209 timeout, &waitcode);
2210 /* Time out here if there are no other children to wait for. */
2211 if (waitcode == WAIT_TIMEOUT) {
2212 if (!w32_num_children) {
2216 else if (waitcode != WAIT_FAILED) {
2217 if (waitcode >= WAIT_ABANDONED_0
2218 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2219 i = waitcode - WAIT_ABANDONED_0;
2221 i = waitcode - WAIT_OBJECT_0;
2222 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2223 *status = (int)((exitcode & 0xff) << 8);
2224 retval = (int)w32_pseudo_child_pids[i];
2225 remove_dead_pseudo_process(i);
2232 if (!w32_num_children) {
2237 /* if a child exists, wait for it to die */
2238 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2239 if (waitcode == WAIT_TIMEOUT) {
2242 if (waitcode != WAIT_FAILED) {
2243 if (waitcode >= WAIT_ABANDONED_0
2244 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2245 i = waitcode - WAIT_ABANDONED_0;
2247 i = waitcode - WAIT_OBJECT_0;
2248 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2249 *status = (int)((exitcode & 0xff) << 8);
2250 retval = (int)w32_child_pids[i];
2251 remove_dead_process(i);
2256 errno = GetLastError();
2261 win32_waitpid(int pid, int *status, int flags)
2264 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2267 if (pid == -1) /* XXX threadid == 1 ? */
2268 return win32_internal_wait(status, timeout);
2271 child = find_pseudo_pid(-pid);
2273 HANDLE hThread = w32_pseudo_child_handles[child];
2275 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2276 if (waitcode == WAIT_TIMEOUT) {
2279 else if (waitcode == WAIT_OBJECT_0) {
2280 if (GetExitCodeThread(hThread, &waitcode)) {
2281 *status = (int)((waitcode & 0xff) << 8);
2282 retval = (int)w32_pseudo_child_pids[child];
2283 remove_dead_pseudo_process(child);
2290 else if (IsWin95()) {
2299 child = find_pid(pid);
2301 hProcess = w32_child_handles[child];
2302 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2303 if (waitcode == WAIT_TIMEOUT) {
2306 else if (waitcode == WAIT_OBJECT_0) {
2307 if (GetExitCodeProcess(hProcess, &waitcode)) {
2308 *status = (int)((waitcode & 0xff) << 8);
2309 retval = (int)w32_child_pids[child];
2310 remove_dead_process(child);
2319 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2320 (IsWin95() ? -pid : pid));
2322 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2323 if (waitcode == WAIT_TIMEOUT) {
2324 CloseHandle(hProcess);
2327 else if (waitcode == WAIT_OBJECT_0) {
2328 if (GetExitCodeProcess(hProcess, &waitcode)) {
2329 *status = (int)((waitcode & 0xff) << 8);
2330 CloseHandle(hProcess);
2334 CloseHandle(hProcess);
2340 return retval >= 0 ? pid : retval;
2344 win32_wait(int *status)
2346 return win32_internal_wait(status, INFINITE);
2349 DllExport unsigned int
2350 win32_sleep(unsigned int t)
2353 /* Win32 times are in ms so *1000 in and /1000 out */
2354 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2357 DllExport unsigned int
2358 win32_alarm(unsigned int sec)
2361 * the 'obvious' implentation is SetTimer() with a callback
2362 * which does whatever receiving SIGALRM would do
2363 * we cannot use SIGALRM even via raise() as it is not
2364 * one of the supported codes in <signal.h>
2368 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2369 w32_message_hwnd = win32_create_message_window();
2372 if (w32_message_hwnd == NULL)
2373 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2376 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2381 KillTimer(w32_message_hwnd, w32_timerid);
2388 #ifdef HAVE_DES_FCRYPT
2389 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2393 win32_crypt(const char *txt, const char *salt)
2396 #ifdef HAVE_DES_FCRYPT
2397 return des_fcrypt(txt, salt, w32_crypt_buffer);
2399 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2404 #ifdef USE_FIXED_OSFHANDLE
2406 #define FOPEN 0x01 /* file handle open */
2407 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2408 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2409 #define FDEV 0x40 /* file handle refers to device */
2410 #define FTEXT 0x80 /* file handle is in text mode */
2413 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2416 * This function allocates a free C Runtime file handle and associates
2417 * it with the Win32 HANDLE specified by the first parameter. This is a
2418 * temperary fix for WIN95's brain damage GetFileType() error on socket
2419 * we just bypass that call for socket
2421 * This works with MSVC++ 4.0+ or GCC/Mingw32
2424 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2425 * int flags - flags to associate with C Runtime file handle.
2428 * returns index of entry in fh, if successful
2429 * return -1, if no free entry is found
2433 *******************************************************************************/
2436 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2437 * this lets sockets work on Win9X with GCC and should fix the problems
2442 /* create an ioinfo entry, kill its handle, and steal the entry */
2447 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2448 int fh = _open_osfhandle((intptr_t)hF, 0);
2452 EnterCriticalSection(&(_pioinfo(fh)->lock));
2457 my_open_osfhandle(intptr_t osfhandle, int flags)
2460 char fileflags; /* _osfile flags */
2462 /* copy relevant flags from second parameter */
2465 if (flags & O_APPEND)
2466 fileflags |= FAPPEND;
2471 if (flags & O_NOINHERIT)
2472 fileflags |= FNOINHERIT;
2474 /* attempt to allocate a C Runtime file handle */
2475 if ((fh = _alloc_osfhnd()) == -1) {
2476 errno = EMFILE; /* too many open files */
2477 _doserrno = 0L; /* not an OS error */
2478 return -1; /* return error to caller */
2481 /* the file is open. now, set the info in _osfhnd array */
2482 _set_osfhnd(fh, osfhandle);
2484 fileflags |= FOPEN; /* mark as open */
2486 _osfile(fh) = fileflags; /* set osfile entry */
2487 LeaveCriticalSection(&_pioinfo(fh)->lock);
2489 return fh; /* return handle */
2492 #endif /* USE_FIXED_OSFHANDLE */
2494 /* simulate flock by locking a range on the file */
2496 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2497 #define LK_LEN 0xffff0000
2500 win32_flock(int fd, int oper)
2508 Perl_croak_nocontext("flock() unimplemented on this platform");
2511 fh = (HANDLE)_get_osfhandle(fd);
2512 memset(&o, 0, sizeof(o));
2515 case LOCK_SH: /* shared lock */
2516 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2518 case LOCK_EX: /* exclusive lock */
2519 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2521 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2522 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2524 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2525 LK_ERR(LockFileEx(fh,
2526 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2527 0, LK_LEN, 0, &o),i);
2529 case LOCK_UN: /* unlock lock */
2530 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2532 default: /* unknown */
2543 * redirected io subsystem for all XS modules
2556 return (&(_environ));
2559 /* the rest are the remapped stdio routines */
2579 win32_ferror(FILE *fp)
2581 return (ferror(fp));
2586 win32_feof(FILE *fp)
2592 * Since the errors returned by the socket error function
2593 * WSAGetLastError() are not known by the library routine strerror
2594 * we have to roll our own.
2598 win32_strerror(int e)
2600 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2601 extern int sys_nerr;
2605 if (e < 0 || e > sys_nerr) {
2610 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2611 w32_strerror_buffer,
2612 sizeof(w32_strerror_buffer), NULL) == 0)
2613 strcpy(w32_strerror_buffer, "Unknown Error");
2615 return w32_strerror_buffer;
2621 win32_str_os_error(void *sv, DWORD dwErr)
2625 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2626 |FORMAT_MESSAGE_IGNORE_INSERTS
2627 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2628 dwErr, 0, (char *)&sMsg, 1, NULL);
2629 /* strip trailing whitespace and period */
2632 --dwLen; /* dwLen doesn't include trailing null */
2633 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2634 if ('.' != sMsg[dwLen])
2639 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2641 dwLen = sprintf(sMsg,
2642 "Unknown error #0x%lX (lookup 0x%lX)",
2643 dwErr, GetLastError());
2647 sv_setpvn((SV*)sv, sMsg, dwLen);
2653 win32_fprintf(FILE *fp, const char *format, ...)
2656 va_start(marker, format); /* Initialize variable arguments. */
2658 return (vfprintf(fp, format, marker));
2662 win32_printf(const char *format, ...)
2665 va_start(marker, format); /* Initialize variable arguments. */
2667 return (vprintf(format, marker));
2671 win32_vfprintf(FILE *fp, const char *format, va_list args)
2673 return (vfprintf(fp, format, args));
2677 win32_vprintf(const char *format, va_list args)
2679 return (vprintf(format, args));
2683 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2685 return fread(buf, size, count, fp);
2689 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2691 return fwrite(buf, size, count, fp);
2694 #define MODE_SIZE 10
2697 win32_fopen(const char *filename, const char *mode)
2705 if (stricmp(filename, "/dev/null")==0)
2708 f = fopen(PerlDir_mapA(filename), mode);
2709 /* avoid buffering headaches for child processes */
2710 if (f && *mode == 'a')
2711 win32_fseek(f, 0, SEEK_END);
2715 #ifndef USE_SOCKETS_AS_HANDLES
2717 #define fdopen my_fdopen
2721 win32_fdopen(int handle, const char *mode)
2725 f = fdopen(handle, (char *) mode);
2726 /* avoid buffering headaches for child processes */
2727 if (f && *mode == 'a')
2728 win32_fseek(f, 0, SEEK_END);
2733 win32_freopen(const char *path, const char *mode, FILE *stream)
2736 if (stricmp(path, "/dev/null")==0)
2739 return freopen(PerlDir_mapA(path), mode, stream);
2743 win32_fclose(FILE *pf)
2745 return my_fclose(pf); /* defined in win32sck.c */
2749 win32_fputs(const char *s,FILE *pf)
2751 return fputs(s, pf);
2755 win32_fputc(int c,FILE *pf)
2761 win32_ungetc(int c,FILE *pf)
2763 return ungetc(c,pf);
2767 win32_getc(FILE *pf)
2773 win32_fileno(FILE *pf)
2779 win32_clearerr(FILE *pf)
2786 win32_fflush(FILE *pf)
2792 win32_ftell(FILE *pf)
2794 #if defined(WIN64) || defined(USE_LARGE_FILES)
2795 #if defined(__BORLANDC__) /* buk */
2796 return win32_tell( fileno( pf ) );
2799 if (fgetpos(pf, &pos))
2809 win32_fseek(FILE *pf, Off_t offset,int origin)
2811 #if defined(WIN64) || defined(USE_LARGE_FILES)
2812 #if defined(__BORLANDC__) /* buk */
2822 if (fgetpos(pf, &pos))
2827 fseek(pf, 0, SEEK_END);
2828 pos = _telli64(fileno(pf));
2837 return fsetpos(pf, &offset);
2840 return fseek(pf, (long)offset, origin);
2845 win32_fgetpos(FILE *pf,fpos_t *p)
2847 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2848 if( win32_tell(fileno(pf)) == -1L ) {
2854 return fgetpos(pf, p);
2859 win32_fsetpos(FILE *pf,const fpos_t *p)
2861 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2862 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2864 return fsetpos(pf, p);
2869 win32_rewind(FILE *pf)
2879 char prefix[MAX_PATH+1];
2880 char filename[MAX_PATH+1];
2881 DWORD len = GetTempPath(MAX_PATH, prefix);
2882 if (len && len < MAX_PATH) {
2883 if (GetTempFileName(prefix, "plx", 0, filename)) {
2884 HANDLE fh = CreateFile(filename,
2885 DELETE | GENERIC_READ | GENERIC_WRITE,
2889 FILE_ATTRIBUTE_NORMAL
2890 | FILE_FLAG_DELETE_ON_CLOSE,
2892 if (fh != INVALID_HANDLE_VALUE) {
2893 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2895 #if defined(__BORLANDC__)
2896 setmode(fd,O_BINARY);
2898 DEBUG_p(PerlIO_printf(Perl_debug_log,
2899 "Created tmpfile=%s\n",filename));
2911 int fd = win32_tmpfd();
2913 return win32_fdopen(fd, "w+b");
2925 win32_fstat(int fd, Stat_t *sbufptr)
2928 /* A file designated by filehandle is not shown as accessible
2929 * for write operations, probably because it is opened for reading.
2932 BY_HANDLE_FILE_INFORMATION bhfi;
2933 #if defined(WIN64) || defined(USE_LARGE_FILES)
2934 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2936 int rc = fstat(fd,&tmp);
2938 sbufptr->st_dev = tmp.st_dev;
2939 sbufptr->st_ino = tmp.st_ino;
2940 sbufptr->st_mode = tmp.st_mode;
2941 sbufptr->st_nlink = tmp.st_nlink;
2942 sbufptr->st_uid = tmp.st_uid;
2943 sbufptr->st_gid = tmp.st_gid;
2944 sbufptr->st_rdev = tmp.st_rdev;
2945 sbufptr->st_size = tmp.st_size;
2946 sbufptr->st_atime = tmp.st_atime;
2947 sbufptr->st_mtime = tmp.st_mtime;
2948 sbufptr->st_ctime = tmp.st_ctime;
2950 int rc = fstat(fd,sbufptr);
2953 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2954 #if defined(WIN64) || defined(USE_LARGE_FILES)
2955 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2957 sbufptr->st_mode &= 0xFE00;
2958 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2959 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2961 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2962 + ((S_IREAD|S_IWRITE) >> 6));
2966 return my_fstat(fd,sbufptr);
2971 win32_pipe(int *pfd, unsigned int size, int mode)
2973 return _pipe(pfd, size, mode);
2977 win32_popenlist(const char *mode, IV narg, SV **args)
2980 Perl_croak(aTHX_ "List form of pipe open not implemented");
2985 * a popen() clone that respects PERL5SHELL
2987 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2991 win32_popen(const char *command, const char *mode)
2993 #ifdef USE_RTL_POPEN
2994 return _popen(command, mode);
3006 /* establish which ends read and write */
3007 if (strchr(mode,'w')) {
3008 stdfd = 0; /* stdin */
3011 nhandle = STD_INPUT_HANDLE;
3013 else if (strchr(mode,'r')) {
3014 stdfd = 1; /* stdout */
3017 nhandle = STD_OUTPUT_HANDLE;
3022 /* set the correct mode */
3023 if (strchr(mode,'b'))
3025 else if (strchr(mode,'t'))
3028 ourmode = _fmode & (O_TEXT | O_BINARY);
3030 /* the child doesn't inherit handles */
3031 ourmode |= O_NOINHERIT;
3033 if (win32_pipe(p, 512, ourmode) == -1)
3036 /* save the old std handle (this needs to happen before the
3037 * dup2(), since that might call SetStdHandle() too) */
3040 old_h = GetStdHandle(nhandle);
3042 /* save current stdfd */
3043 if ((oldfd = win32_dup(stdfd)) == -1)
3046 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3047 /* stdfd will be inherited by the child */
3048 if (win32_dup2(p[child], stdfd) == -1)
3051 /* close the child end in parent */
3052 win32_close(p[child]);
3054 /* set the new std handle (in case dup2() above didn't) */
3055 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3057 /* start the child */
3060 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3063 /* revert stdfd to whatever it was before */
3064 if (win32_dup2(oldfd, stdfd) == -1)
3067 /* close saved handle */
3070 /* restore the old std handle (this needs to happen after the
3071 * dup2(), since that might call SetStdHandle() too */
3073 SetStdHandle(nhandle, old_h);
3079 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3082 /* set process id so that it can be returned by perl's open() */
3083 PL_forkprocess = childpid;
3086 /* we have an fd, return a file stream */
3087 return (PerlIO_fdopen(p[parent], (char *)mode));
3090 /* we don't need to check for errors here */
3094 win32_dup2(oldfd, stdfd);
3098 SetStdHandle(nhandle, old_h);
3104 #endif /* USE_RTL_POPEN */
3112 win32_pclose(PerlIO *pf)
3114 #ifdef USE_RTL_POPEN
3118 int childpid, status;
3122 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3125 childpid = SvIVX(sv);
3143 if (win32_waitpid(childpid, &status, 0) == -1)
3148 #endif /* USE_RTL_POPEN */
3154 LPCWSTR lpExistingFileName,
3155 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3158 WCHAR wFullName[MAX_PATH+1];
3159 LPVOID lpContext = NULL;
3160 WIN32_STREAM_ID StreamId;
3161 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3166 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3167 BOOL, BOOL, LPVOID*) =
3168 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3169 BOOL, BOOL, LPVOID*))
3170 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3171 if (pfnBackupWrite == NULL)
3174 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3177 dwLen = (dwLen+1)*sizeof(WCHAR);
3179 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3180 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3181 NULL, OPEN_EXISTING, 0, NULL);
3182 if (handle == INVALID_HANDLE_VALUE)
3185 StreamId.dwStreamId = BACKUP_LINK;
3186 StreamId.dwStreamAttributes = 0;
3187 StreamId.dwStreamNameSize = 0;
3188 #if defined(__BORLANDC__) \
3189 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3190 StreamId.Size.u.HighPart = 0;
3191 StreamId.Size.u.LowPart = dwLen;
3193 StreamId.Size.HighPart = 0;
3194 StreamId.Size.LowPart = dwLen;
3197 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3198 FALSE, FALSE, &lpContext);
3200 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3201 FALSE, FALSE, &lpContext);
3202 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3205 CloseHandle(handle);
3210 win32_link(const char *oldname, const char *newname)
3213 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3214 WCHAR wOldName[MAX_PATH+1];
3215 WCHAR wNewName[MAX_PATH+1];
3218 Perl_croak(aTHX_ PL_no_func, "link");
3220 pfnCreateHardLinkW =
3221 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3222 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3223 if (pfnCreateHardLinkW == NULL)
3224 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3226 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3227 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3228 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3229 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3233 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3238 win32_rename(const char *oname, const char *newname)
3240 char szOldName[MAX_PATH+1];
3241 char szNewName[MAX_PATH+1];
3245 /* XXX despite what the documentation says about MoveFileEx(),
3246 * it doesn't work under Windows95!
3249 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3250 if (stricmp(newname, oname))
3251 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3252 strcpy(szOldName, PerlDir_mapA(oname));
3253 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3255 DWORD err = GetLastError();
3257 case ERROR_BAD_NET_NAME:
3258 case ERROR_BAD_NETPATH:
3259 case ERROR_BAD_PATHNAME:
3260 case ERROR_FILE_NOT_FOUND:
3261 case ERROR_FILENAME_EXCED_RANGE:
3262 case ERROR_INVALID_DRIVE:
3263 case ERROR_NO_MORE_FILES:
3264 case ERROR_PATH_NOT_FOUND:
3277 char szTmpName[MAX_PATH+1];
3278 char dname[MAX_PATH+1];
3279 char *endname = Nullch;
3281 DWORD from_attr, to_attr;
3283 strcpy(szOldName, PerlDir_mapA(oname));
3284 strcpy(szNewName, PerlDir_mapA(newname));
3286 /* if oname doesn't exist, do nothing */
3287 from_attr = GetFileAttributes(szOldName);
3288 if (from_attr == 0xFFFFFFFF) {
3293 /* if newname exists, rename it to a temporary name so that we
3294 * don't delete it in case oname happens to be the same file
3295 * (but perhaps accessed via a different path)
3297 to_attr = GetFileAttributes(szNewName);
3298 if (to_attr != 0xFFFFFFFF) {
3299 /* if newname is a directory, we fail
3300 * XXX could overcome this with yet more convoluted logic */
3301 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3305 tmplen = strlen(szNewName);
3306 strcpy(szTmpName,szNewName);
3307 endname = szTmpName+tmplen;
3308 for (; endname > szTmpName ; --endname) {
3309 if (*endname == '/' || *endname == '\\') {
3314 if (endname > szTmpName)
3315 endname = strcpy(dname,szTmpName);
3319 /* get a temporary filename in same directory
3320 * XXX is this really the best we can do? */
3321 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3325 DeleteFile(szTmpName);
3327 retval = rename(szNewName, szTmpName);
3334 /* rename oname to newname */
3335 retval = rename(szOldName, szNewName);
3337 /* if we created a temporary file before ... */
3338 if (endname != Nullch) {
3339 /* ...and rename succeeded, delete temporary file/directory */
3341 DeleteFile(szTmpName);
3342 /* else restore it to what it was */
3344 (void)rename(szTmpName, szNewName);
3351 win32_setmode(int fd, int mode)
3353 return setmode(fd, mode);
3357 win32_chsize(int fd, Off_t size)
3359 #if defined(WIN64) || defined(USE_LARGE_FILES)
3361 Off_t cur, end, extend;
3363 cur = win32_tell(fd);
3366 end = win32_lseek(fd, 0, SEEK_END);
3369 extend = size - end;
3373 else if (extend > 0) {
3374 /* must grow the file, padding with nulls */
3376 int oldmode = win32_setmode(fd, O_BINARY);
3378 memset(b, '\0', sizeof(b));
3380 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3381 count = win32_write(fd, b, count);
3382 if ((int)count < 0) {
3386 } while ((extend -= count) > 0);
3387 win32_setmode(fd, oldmode);
3390 /* shrink the file */
3391 win32_lseek(fd, size, SEEK_SET);
3392 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3398 win32_lseek(fd, cur, SEEK_SET);
3401 return chsize(fd, (long)size);
3406 win32_lseek(int fd, Off_t offset, int origin)
3408 #if defined(WIN64) || defined(USE_LARGE_FILES)
3409 #if defined(__BORLANDC__) /* buk */
3411 pos.QuadPart = offset;
3412 pos.LowPart = SetFilePointer(
3413 (HANDLE)_get_osfhandle(fd),
3418 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3422 return pos.QuadPart;
3424 return _lseeki64(fd, offset, origin);
3427 return lseek(fd, (long)offset, origin);
3434 #if defined(WIN64) || defined(USE_LARGE_FILES)
3435 #if defined(__BORLANDC__) /* buk */
3438 pos.LowPart = SetFilePointer(
3439 (HANDLE)_get_osfhandle(fd),
3444 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3448 return pos.QuadPart;
3449 /* return tell(fd); */
3451 return _telli64(fd);
3459 win32_open(const char *path, int flag, ...)
3466 pmode = va_arg(ap, int);
3469 if (stricmp(path, "/dev/null")==0)
3472 return open(PerlDir_mapA(path), flag, pmode);
3475 /* close() that understands socket */
3476 extern int my_close(int); /* in win32sck.c */
3481 return my_close(fd);
3497 win32_dup2(int fd1,int fd2)
3499 return dup2(fd1,fd2);
3502 #ifdef PERL_MSVCRT_READFIX
3504 #define LF 10 /* line feed */
3505 #define CR 13 /* carriage return */
3506 #define CTRLZ 26 /* ctrl-z means eof for text */
3507 #define FOPEN 0x01 /* file handle open */
3508 #define FEOFLAG 0x02 /* end of file has been encountered */
3509 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3510 #define FPIPE 0x08 /* file handle refers to a pipe */
3511 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3512 #define FDEV 0x40 /* file handle refers to device */
3513 #define FTEXT 0x80 /* file handle is in text mode */
3514 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3517 _fixed_read(int fh, void *buf, unsigned cnt)
3519 int bytes_read; /* number of bytes read */
3520 char *buffer; /* buffer to read to */
3521 int os_read; /* bytes read on OS call */
3522 char *p, *q; /* pointers into buffer */
3523 char peekchr; /* peek-ahead character */
3524 ULONG filepos; /* file position after seek */
3525 ULONG dosretval; /* o.s. return value */
3527 /* validate handle */
3528 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3529 !(_osfile(fh) & FOPEN))
3531 /* out of range -- return error */
3533 _doserrno = 0; /* not o.s. error */
3538 * If lockinitflag is FALSE, assume fd is device
3539 * lockinitflag is set to TRUE by open.
3541 if (_pioinfo(fh)->lockinitflag)
3542 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3544 bytes_read = 0; /* nothing read yet */
3545 buffer = (char*)buf;
3547 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3548 /* nothing to read or at EOF, so return 0 read */
3552 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3553 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3555 *buffer++ = _pipech(fh);
3558 _pipech(fh) = LF; /* mark as empty */
3563 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3565 /* ReadFile has reported an error. recognize two special cases.
3567 * 1. map ERROR_ACCESS_DENIED to EBADF
3569 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3570 * means the handle is a read-handle on a pipe for which
3571 * all write-handles have been closed and all data has been
3574 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3575 /* wrong read/write mode should return EBADF, not EACCES */
3577 _doserrno = dosretval;
3581 else if (dosretval == ERROR_BROKEN_PIPE) {
3591 bytes_read += os_read; /* update bytes read */
3593 if (_osfile(fh) & FTEXT) {
3594 /* now must translate CR-LFs to LFs in the buffer */
3596 /* set CRLF flag to indicate LF at beginning of buffer */
3597 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3598 /* _osfile(fh) |= FCRLF; */
3600 /* _osfile(fh) &= ~FCRLF; */
3602 _osfile(fh) &= ~FCRLF;
3604 /* convert chars in the buffer: p is src, q is dest */
3606 while (p < (char *)buf + bytes_read) {
3608 /* if fh is not a device, set ctrl-z flag */
3609 if (!(_osfile(fh) & FDEV))
3610 _osfile(fh) |= FEOFLAG;
3611 break; /* stop translating */
3616 /* *p is CR, so must check next char for LF */
3617 if (p < (char *)buf + bytes_read - 1) {
3620 *q++ = LF; /* convert CR-LF to LF */
3623 *q++ = *p++; /* store char normally */
3626 /* This is the hard part. We found a CR at end of
3627 buffer. We must peek ahead to see if next char
3632 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3633 (LPDWORD)&os_read, NULL))
3634 dosretval = GetLastError();
3636 if (dosretval != 0 || os_read == 0) {
3637 /* couldn't read ahead, store CR */
3641 /* peekchr now has the extra character -- we now
3642 have several possibilities:
3643 1. disk file and char is not LF; just seek back
3645 2. disk file and char is LF; store LF, don't seek back
3646 3. pipe/device and char is LF; store LF.
3647 4. pipe/device and char isn't LF, store CR and
3648 put char in pipe lookahead buffer. */
3649 if (_osfile(fh) & (FDEV|FPIPE)) {
3650 /* non-seekable device */
3655 _pipech(fh) = peekchr;
3660 if (peekchr == LF) {
3661 /* nothing read yet; must make some
3664 /* turn on this flag for tell routine */
3665 _osfile(fh) |= FCRLF;
3668 HANDLE osHandle; /* o.s. handle value */
3670 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3672 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3673 dosretval = GetLastError();
3684 /* we now change bytes_read to reflect the true number of chars
3686 bytes_read = q - (char *)buf;
3690 if (_pioinfo(fh)->lockinitflag)
3691 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3696 #endif /* PERL_MSVCRT_READFIX */
3699 win32_read(int fd, void *buf, unsigned int cnt)
3701 #ifdef PERL_MSVCRT_READFIX
3702 return _fixed_read(fd, buf, cnt);
3704 return read(fd, buf, cnt);
3709 win32_write(int fd, const void *buf, unsigned int cnt)
3711 return write(fd, buf, cnt);
3715 win32_mkdir(const char *dir, int mode)
3718 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3722 win32_rmdir(const char *dir)
3725 return rmdir(PerlDir_mapA(dir));
3729 win32_chdir(const char *dir)
3740 win32_access(const char *path, int mode)
3743 return access(PerlDir_mapA(path), mode);
3747 win32_chmod(const char *path, int mode)
3750 return chmod(PerlDir_mapA(path), mode);
3755 create_command_line(char *cname, STRLEN clen, const char * const *args)
3762 bool bat_file = FALSE;
3763 bool cmd_shell = FALSE;
3764 bool dumb_shell = FALSE;
3765 bool extra_quotes = FALSE;
3766 bool quote_next = FALSE;
3769 cname = (char*)args[0];
3771 /* The NT cmd.exe shell has the following peculiarity that needs to be
3772 * worked around. It strips a leading and trailing dquote when any
3773 * of the following is true:
3774 * 1. the /S switch was used
3775 * 2. there are more than two dquotes
3776 * 3. there is a special character from this set: &<>()@^|
3777 * 4. no whitespace characters within the two dquotes
3778 * 5. string between two dquotes isn't an executable file
3779 * To work around this, we always add a leading and trailing dquote
3780 * to the string, if the first argument is either "cmd.exe" or "cmd",
3781 * and there were at least two or more arguments passed to cmd.exe
3782 * (not including switches).
3783 * XXX the above rules (from "cmd /?") don't seem to be applied
3784 * always, making for the convolutions below :-(
3788 clen = strlen(cname);
3791 && (stricmp(&cname[clen-4], ".bat") == 0
3792 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3799 char *exe = strrchr(cname, '/');
3800 char *exe2 = strrchr(cname, '\\');
3807 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3811 else if (stricmp(exe, "command.com") == 0
3812 || stricmp(exe, "command") == 0)
3819 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3820 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3821 STRLEN curlen = strlen(arg);
3822 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3823 len += 2; /* assume quoting needed (worst case) */
3825 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3827 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3830 Newx(cmd, len, char);
3833 if (bat_file && !IsWin95()) {
3835 extra_quotes = TRUE;
3838 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3840 STRLEN curlen = strlen(arg);
3842 /* we want to protect empty arguments and ones with spaces with
3843 * dquotes, but only if they aren't already there */
3848 else if (quote_next) {
3849 /* see if it really is multiple arguments pretending to
3850 * be one and force a set of quotes around it */
3851 if (*find_next_space(arg))
3854 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3856 while (i < curlen) {
3857 if (isSPACE(arg[i])) {
3860 else if (arg[i] == '"') {
3884 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3885 && stricmp(arg+curlen-2, "/c") == 0)
3887 /* is there a next argument? */
3888 if (args[index+1]) {
3889 /* are there two or more next arguments? */
3890 if (args[index+2]) {
3892 extra_quotes = TRUE;
3895 /* single argument, force quoting if it has spaces */
3911 qualified_path(const char *cmd)
3915 char *fullcmd, *curfullcmd;
3921 fullcmd = (char*)cmd;
3923 if (*fullcmd == '/' || *fullcmd == '\\')
3930 pathstr = PerlEnv_getenv("PATH");
3932 /* worst case: PATH is a single directory; we need additional space
3933 * to append "/", ".exe" and trailing "\0" */
3934 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3935 curfullcmd = fullcmd;
3940 /* start by appending the name to the current prefix */
3941 strcpy(curfullcmd, cmd);
3942 curfullcmd += cmdlen;
3944 /* if it doesn't end with '.', or has no extension, try adding
3945 * a trailing .exe first */
3946 if (cmd[cmdlen-1] != '.'
3947 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3949 strcpy(curfullcmd, ".exe");
3950 res = GetFileAttributes(fullcmd);
3951 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3956 /* that failed, try the bare name */
3957 res = GetFileAttributes(fullcmd);
3958 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3961 /* quit if no other path exists, or if cmd already has path */
3962 if (!pathstr || !*pathstr || has_slash)
3965 /* skip leading semis */
3966 while (*pathstr == ';')
3969 /* build a new prefix from scratch */
3970 curfullcmd = fullcmd;
3971 while (*pathstr && *pathstr != ';') {
3972 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3973 pathstr++; /* skip initial '"' */
3974 while (*pathstr && *pathstr != '"') {
3975 *curfullcmd++ = *pathstr++;
3978 pathstr++; /* skip trailing '"' */
3981 *curfullcmd++ = *pathstr++;
3985 pathstr++; /* skip trailing semi */
3986 if (curfullcmd > fullcmd /* append a dir separator */
3987 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3989 *curfullcmd++ = '\\';
3997 /* The following are just place holders.
3998 * Some hosts may provide and environment that the OS is
3999 * not tracking, therefore, these host must provide that
4000 * environment and the current directory to CreateProcess
4004 win32_get_childenv(void)
4010 win32_free_childenv(void* d)
4015 win32_clearenv(void)
4017 char *envv = GetEnvironmentStrings();
4021 char *end = strchr(cur,'=');
4022 if (end && end != cur) {
4024 SetEnvironmentVariable(cur, NULL);
4026 cur = end + strlen(end+1)+2;
4028 else if ((len = strlen(cur)))
4031 FreeEnvironmentStrings(envv);
4035 win32_get_childdir(void)
4039 char szfilename[MAX_PATH+1];
4041 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4042 Newx(ptr, strlen(szfilename)+1, char);
4043 strcpy(ptr, szfilename);
4048 win32_free_childdir(char* d)
4055 /* XXX this needs to be made more compatible with the spawnvp()
4056 * provided by the various RTLs. In particular, searching for
4057 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4058 * This doesn't significantly affect perl itself, because we
4059 * always invoke things using PERL5SHELL if a direct attempt to
4060 * spawn the executable fails.
4062 * XXX splitting and rejoining the commandline between do_aspawn()
4063 * and win32_spawnvp() could also be avoided.
4067 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4069 #ifdef USE_RTL_SPAWNVP
4070 return spawnvp(mode, cmdname, (char * const *)argv);
4077 STARTUPINFO StartupInfo;
4078 PROCESS_INFORMATION ProcessInformation;
4081 char *fullcmd = Nullch;
4082 char *cname = (char *)cmdname;
4086 clen = strlen(cname);
4087 /* if command name contains dquotes, must remove them */
4088 if (strchr(cname, '"')) {
4090 Newx(cname,clen+1,char);
4103 cmd = create_command_line(cname, clen, argv);
4105 env = PerlEnv_get_childenv();
4106 dir = PerlEnv_get_childdir();
4109 case P_NOWAIT: /* asynch + remember result */
4110 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4115 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4118 create |= CREATE_NEW_PROCESS_GROUP;
4121 case P_WAIT: /* synchronous execution */
4123 default: /* invalid mode */
4128 memset(&StartupInfo,0,sizeof(StartupInfo));
4129 StartupInfo.cb = sizeof(StartupInfo);
4130 memset(&tbl,0,sizeof(tbl));
4131 PerlEnv_get_child_IO(&tbl);
4132 StartupInfo.dwFlags = tbl.dwFlags;
4133 StartupInfo.dwX = tbl.dwX;
4134 StartupInfo.dwY = tbl.dwY;
4135 StartupInfo.dwXSize = tbl.dwXSize;
4136 StartupInfo.dwYSize = tbl.dwYSize;
4137 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4138 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4139 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4140 StartupInfo.wShowWindow = tbl.wShowWindow;
4141 StartupInfo.hStdInput = tbl.childStdIn;
4142 StartupInfo.hStdOutput = tbl.childStdOut;
4143 StartupInfo.hStdError = tbl.childStdErr;
4144 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4145 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4146 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4148 create |= CREATE_NEW_CONSOLE;
4151 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4153 if (w32_use_showwindow) {
4154 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4155 StartupInfo.wShowWindow = w32_showwindow;
4158 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4161 if (!CreateProcess(cname, /* search PATH to find executable */
4162 cmd, /* executable, and its arguments */
4163 NULL, /* process attributes */
4164 NULL, /* thread attributes */
4165 TRUE, /* inherit handles */
4166 create, /* creation flags */
4167 (LPVOID)env, /* inherit environment */
4168 dir, /* inherit cwd */
4170 &ProcessInformation))
4172 /* initial NULL argument to CreateProcess() does a PATH
4173 * search, but it always first looks in the directory
4174 * where the current process was started, which behavior
4175 * is undesirable for backward compatibility. So we
4176 * jump through our own hoops by picking out the path
4177 * we really want it to use. */
4179 fullcmd = qualified_path(cname);
4181 if (cname != cmdname)
4184 DEBUG_p(PerlIO_printf(Perl_debug_log,
4185 "Retrying [%s] with same args\n",
4195 if (mode == P_NOWAIT) {
4196 /* asynchronous spawn -- store handle, return PID */
4197 ret = (int)ProcessInformation.dwProcessId;
4198 if (IsWin95() && ret < 0)
4201 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4202 w32_child_pids[w32_num_children] = (DWORD)ret;
4207 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4208 /* FIXME: if msgwait returned due to message perhaps forward the
4209 "signal" to the process
4211 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4213 CloseHandle(ProcessInformation.hProcess);
4216 CloseHandle(ProcessInformation.hThread);
4219 PerlEnv_free_childenv(env);
4220 PerlEnv_free_childdir(dir);
4222 if (cname != cmdname)
4229 win32_execv(const char *cmdname, const char *const *argv)
4233 /* if this is a pseudo-forked child, we just want to spawn
4234 * the new program, and return */
4236 # ifdef __BORLANDC__
4237 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4239 return spawnv(P_WAIT, cmdname, argv);
4243 return execv(cmdname, (char *const *)argv);
4245 return execv(cmdname, argv);
4250 win32_execvp(const char *cmdname, const char *const *argv)
4254 /* if this is a pseudo-forked child, we just want to spawn
4255 * the new program, and return */
4256 if (w32_pseudo_id) {
4257 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4267 return execvp(cmdname, (char *const *)argv);
4269 return execvp(cmdname, argv);
4274 win32_perror(const char *str)
4280 win32_setbuf(FILE *pf, char *buf)
4286 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4288 return setvbuf(pf, buf, type, size);
4292 win32_flushall(void)
4298 win32_fcloseall(void)
4304 win32_fgets(char *s, int n, FILE *pf)
4306 return fgets(s, n, pf);
4316 win32_fgetc(FILE *pf)
4322 win32_putc(int c, FILE *pf)
4328 win32_puts(const char *s)
4340 win32_putchar(int c)
4347 #ifndef USE_PERL_SBRK
4349 static char *committed = NULL; /* XXX threadead */
4350 static char *base = NULL; /* XXX threadead */
4351 static char *reserved = NULL; /* XXX threadead */
4352 static char *brk = NULL; /* XXX threadead */
4353 static DWORD pagesize = 0; /* XXX threadead */
4356 sbrk(ptrdiff_t need)
4361 GetSystemInfo(&info);
4362 /* Pretend page size is larger so we don't perpetually
4363 * call the OS to commit just one page ...
4365 pagesize = info.dwPageSize << 3;
4367 if (brk+need >= reserved)
4369 DWORD size = brk+need-reserved;
4371 char *prev_committed = NULL;
4372 if (committed && reserved && committed < reserved)
4374 /* Commit last of previous chunk cannot span allocations */
4375 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4378 /* Remember where we committed from in case we want to decommit later */
4379 prev_committed = committed;
4380 committed = reserved;
4383 /* Reserve some (more) space
4384 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4385 * this is only address space not memory...
4386 * Note this is a little sneaky, 1st call passes NULL as reserved
4387 * so lets system choose where we start, subsequent calls pass
4388 * the old end address so ask for a contiguous block
4391 if (size < 64*1024*1024)
4392 size = 64*1024*1024;
4393 size = ((size + pagesize - 1) / pagesize) * pagesize;
4394 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4397 reserved = addr+size;
4407 /* The existing block could not be extended far enough, so decommit
4408 * anything that was just committed above and start anew */
4411 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4414 reserved = base = committed = brk = NULL;
4425 if (brk > committed)
4427 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4429 if (committed+size > reserved)
4430 size = reserved-committed;
4431 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4444 win32_malloc(size_t size)
4446 return malloc(size);
4450 win32_calloc(size_t numitems, size_t size)
4452 return calloc(numitems,size);
4456 win32_realloc(void *block, size_t size)
4458 return realloc(block,size);
4462 win32_free(void *block)
4469 win32_open_osfhandle(intptr_t handle, int flags)
4471 #ifdef USE_FIXED_OSFHANDLE
4473 return my_open_osfhandle(handle, flags);
4475 return _open_osfhandle(handle, flags);
4479 win32_get_osfhandle(int fd)
4481 return (intptr_t)_get_osfhandle(fd);
4485 win32_fdupopen(FILE *pf)
4490 int fileno = win32_dup(win32_fileno(pf));
4492 /* open the file in the same mode */
4494 if((pf)->flags & _F_READ) {
4498 else if((pf)->flags & _F_WRIT) {
4502 else if((pf)->flags & _F_RDWR) {
4508 if((pf)->_flag & _IOREAD) {
4512 else if((pf)->_flag & _IOWRT) {
4516 else if((pf)->_flag & _IORW) {
4523 /* it appears that the binmode is attached to the
4524 * file descriptor so binmode files will be handled
4527 pfdup = win32_fdopen(fileno, mode);
4529 /* move the file pointer to the same position */
4530 if (!fgetpos(pf, &pos)) {
4531 fsetpos(pfdup, &pos);
4537 win32_dynaload(const char* filename)
4540 char buf[MAX_PATH+1];
4543 /* LoadLibrary() doesn't recognize forward slashes correctly,
4544 * so turn 'em back. */
4545 first = strchr(filename, '/');
4547 STRLEN len = strlen(filename);
4548 if (len <= MAX_PATH) {
4549 strcpy(buf, filename);
4550 filename = &buf[first - filename];
4552 if (*filename == '/')
4553 *(char*)filename = '\\';
4559 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4562 XS(w32_SetChildShowWindow)
4565 BOOL use_showwindow = w32_use_showwindow;
4566 /* use "unsigned short" because Perl has redefined "WORD" */
4567 unsigned short showwindow = w32_showwindow;
4570 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4572 if (items == 0 || !SvOK(ST(0)))
4573 w32_use_showwindow = FALSE;
4575 w32_use_showwindow = TRUE;
4576 w32_showwindow = (unsigned short)SvIV(ST(0));
4581 ST(0) = sv_2mortal(newSViv(showwindow));
4583 ST(0) = &PL_sv_undef;
4588 Perl_init_os_extras(void)
4591 char *file = __FILE__;
4595 /* load Win32 CORE stubs, assuming Win32CORE was statically linked */
4596 if ((cv = get_cv("Win32CORE::bootstrap", 0))) {
4599 (void)call_sv((SV *)cv, G_EVAL|G_DISCARD|G_VOID);
4602 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4606 win32_signal_context(void)
4611 my_perl = PL_curinterp;
4612 PERL_SET_THX(my_perl);
4616 return PL_curinterp;
4622 win32_ctrlhandler(DWORD dwCtrlType)
4625 dTHXa(PERL_GET_SIG_CONTEXT);
4631 switch(dwCtrlType) {
4632 case CTRL_CLOSE_EVENT:
4633 /* A signal that the system sends to all processes attached to a console when
4634 the user closes the console (either by choosing the Close command from the
4635 console window's System menu, or by choosing the End Task command from the
4638 if (do_raise(aTHX_ 1)) /* SIGHUP */
4639 sig_terminate(aTHX_ 1);
4643 /* A CTRL+c signal was received */
4644 if (do_raise(aTHX_ SIGINT))
4645 sig_terminate(aTHX_ SIGINT);
4648 case CTRL_BREAK_EVENT:
4649 /* A CTRL+BREAK signal was received */
4650 if (do_raise(aTHX_ SIGBREAK))
4651 sig_terminate(aTHX_ SIGBREAK);
4654 case CTRL_LOGOFF_EVENT:
4655 /* A signal that the system sends to all console processes when a user is logging
4656 off. This signal does not indicate which user is logging off, so no
4657 assumptions can be made.
4660 case CTRL_SHUTDOWN_EVENT:
4661 /* A signal that the system sends to all console processes when the system is
4664 if (do_raise(aTHX_ SIGTERM))
4665 sig_terminate(aTHX_ SIGTERM);
4674 #ifdef SET_INVALID_PARAMETER_HANDLER
4675 # include <crtdbg.h>
4686 /* win32_ansipath() requires Windows 2000 or later */
4690 /* fetch Unicode version of PATH */
4692 wide_path = win32_malloc(len*sizeof(WCHAR));
4694 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4698 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4703 /* convert to ANSI pathnames */
4704 wide_dir = wide_path;
4707 WCHAR *sep = wcschr(wide_dir, ';');
4715 /* remove quotes around pathname */
4716 if (*wide_dir == '"')
4718 wide_len = wcslen(wide_dir);
4719 if (wide_len && wide_dir[wide_len-1] == '"')
4720 wide_dir[wide_len-1] = '\0';
4722 /* append ansi_dir to ansi_path */
4723 ansi_dir = win32_ansipath(wide_dir);
4724 ansi_len = strlen(ansi_dir);
4726 size_t newlen = len + 1 + ansi_len;
4727 ansi_path = win32_realloc(ansi_path, newlen+1);
4730 ansi_path[len] = ';';
4731 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4736 ansi_path = win32_malloc(5+len+1);
4739 memcpy(ansi_path, "PATH=", 5);
4740 memcpy(ansi_path+5, ansi_dir, len+1);
4743 win32_free(ansi_dir);
4748 /* Update C RTL environ array. This will only have full effect if
4749 * perl_parse() is later called with `environ` as the `env` argument.
4750 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4752 * We do have to ansify() the PATH before Perl has been fully
4753 * initialized because S_find_script() uses the PATH when perl
4754 * is being invoked with the -S option. This happens before %ENV
4755 * is initialized in S_init_postdump_symbols().
4757 * XXX Is this a bug? Should S_find_script() use the environment
4758 * XXX passed in the `env` arg to parse_perl()?
4761 /* Keep system environment in sync because S_init_postdump_symbols()
4762 * will not call mg_set() if it initializes %ENV from `environ`.
4764 SetEnvironmentVariableA("PATH", ansi_path+5);
4765 /* We are intentionally leaking the ansi_path string here because
4766 * the Borland runtime library puts it directly into the environ
4767 * array. The Microsoft runtime library seems to make a copy,
4768 * but will leak the copy should it be replaced again later.
4769 * Since this code is only called once during PERL_SYS_INIT this
4770 * shouldn't really matter.
4773 win32_free(wide_path);
4777 Perl_win32_init(int *argcp, char ***argvp)
4781 #ifdef SET_INVALID_PARAMETER_HANDLER
4782 _invalid_parameter_handler oldHandler, newHandler;
4783 newHandler = my_invalid_parameter_handler;
4784 oldHandler = _set_invalid_parameter_handler(newHandler);
4785 _CrtSetReportMode(_CRT_ASSERT, 0);
4787 /* Disable floating point errors, Perl will trap the ones we
4788 * care about. VC++ RTL defaults to switching these off
4789 * already, but the Borland RTL doesn't. Since we don't
4790 * want to be at the vendor's whim on the default, we set
4791 * it explicitly here.
4793 #if !defined(_ALPHA_) && !defined(__GNUC__)
4794 _control87(MCW_EM, MCW_EM);
4798 module = GetModuleHandle("ntdll.dll");
4800 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4803 module = GetModuleHandle("kernel32.dll");
4805 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4806 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4807 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4810 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4811 GetVersionEx(&g_osver);
4817 Perl_win32_term(void)
4827 win32_get_child_IO(child_IO_table* ptbl)
4829 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4830 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4831 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4835 win32_signal(int sig, Sighandler_t subcode)
4838 if (sig < SIG_SIZE) {
4839 int save_errno = errno;
4840 Sighandler_t result = signal(sig, subcode);
4841 if (result == SIG_ERR) {
4842 result = w32_sighandler[sig];
4845 w32_sighandler[sig] = subcode;
4855 #ifdef HAVE_INTERP_INTERN
4858 win32_csighandler(int sig)
4861 dTHXa(PERL_GET_SIG_CONTEXT);
4862 Perl_warn(aTHX_ "Got signal %d",sig);
4868 win32_create_message_window()
4870 /* "message-only" windows have been implemented in Windows 2000 and later.
4871 * On earlier versions we'll continue to post messages to a specific
4872 * thread and use hwnd==NULL. This is brittle when either an embedding
4873 * application or an XS module is also posting messages to hwnd=NULL
4874 * because once removed from the queue they cannot be delivered to the
4875 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4876 * if there is no window handle.
4881 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4884 #if defined(__MINGW32__) && defined(__cplusplus)
4885 #define CAST_HWND__(x) (HWND__*)(x)
4887 #define CAST_HWND__(x) x
4891 Perl_sys_intern_init(pTHX)
4895 w32_perlshell_tokens = Nullch;
4896 w32_perlshell_vec = (char**)NULL;
4897 w32_perlshell_items = 0;
4898 w32_fdpid = newAV();
4899 Newx(w32_children, 1, child_tab);
4900 w32_num_children = 0;
4901 # ifdef USE_ITHREADS
4903 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4904 w32_num_pseudo_children = 0;
4907 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4909 for (i=0; i < SIG_SIZE; i++) {
4910 w32_sighandler[i] = SIG_DFL;
4912 # ifdef MULTIPLICITY
4913 if (my_perl == PL_curinterp) {
4917 /* Force C runtime signal stuff to set its console handler */
4918 signal(SIGINT,win32_csighandler);
4919 signal(SIGBREAK,win32_csighandler);
4921 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4922 * flag. This has the side-effect of disabling Ctrl-C events in all
4923 * processes in this group. At least on Windows NT and later we
4924 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4925 * with a NULL handler. This is not valid on Windows 9X.
4928 SetConsoleCtrlHandler(NULL,FALSE);
4930 /* Push our handler on top */
4931 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4936 Perl_sys_intern_clear(pTHX)
4938 Safefree(w32_perlshell_tokens);
4939 Safefree(w32_perlshell_vec);
4940 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4941 Safefree(w32_children);
4943 KillTimer(w32_message_hwnd, w32_timerid);
4946 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4947 DestroyWindow(w32_message_hwnd);
4948 # ifdef MULTIPLICITY
4949 if (my_perl == PL_curinterp) {
4953 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4955 # ifdef USE_ITHREADS
4956 Safefree(w32_pseudo_children);
4960 # ifdef USE_ITHREADS
4963 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4965 dst->perlshell_tokens = Nullch;
4966 dst->perlshell_vec = (char**)NULL;
4967 dst->perlshell_items = 0;
4968 dst->fdpid = newAV();
4969 Newxz(dst->children, 1, child_tab);
4971 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4973 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4974 dst->poll_count = 0;
4975 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4977 # endif /* USE_ITHREADS */
4978 #endif /* HAVE_INTERP_INTERN */
4981 win32_free_argvw(pTHX_ void *ptr)
4983 char** argv = (char**)ptr;
4991 win32_argv2utf8(int argc, char** argv)
4996 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4997 if (lpwStr && argc) {
4999 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5000 Newxz(psz, length, char);
5001 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5004 call_atexit(win32_free_argvw, argv);
5006 GlobalFree((HGLOBAL)lpwStr);