3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
19 # define HWND_MESSAGE ((HWND)-3)
21 #ifndef WC_NO_BEST_FIT_CHARS
22 # define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */
29 #define SystemProcessesAndThreadsInformation 5
31 /* Inline some definitions from the DDK */
42 LARGE_INTEGER CreateTime;
43 LARGE_INTEGER UserTime;
44 LARGE_INTEGER KernelTime;
45 UNICODE_STRING ProcessName;
48 ULONG InheritedFromProcessId;
49 /* Remainder of the structure depends on the Windows version,
50 * but we don't need those additional fields anyways... */
53 /* #include "config.h" */
55 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
64 #define PERL_NO_GET_CONTEXT
70 /* assert.h conflicts with #define of assert in perl.h */
77 #if defined(_MSC_VER) || defined(__MINGW32__)
78 #include <sys/utime.h>
83 /* Mingw32 defaults to globing command line
84 * So we turn it off like this:
89 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
90 /* Mingw32-1.1 is missing some prototypes */
92 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
93 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
94 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
100 #if defined(__BORLANDC__)
102 # define _utimbuf utimbuf
106 #define EXECF_SPAWN 2
107 #define EXECF_SPAWN_NOWAIT 3
109 #if defined(PERL_IMPLICIT_SYS)
110 # undef win32_get_privlib
111 # define win32_get_privlib g_win32_get_privlib
112 # undef win32_get_sitelib
113 # define win32_get_sitelib g_win32_get_sitelib
114 # undef win32_get_vendorlib
115 # define win32_get_vendorlib g_win32_get_vendorlib
117 # define getlogin g_getlogin
120 static void get_shell(void);
121 static long tokenize(const char *str, char **dest, char ***destv);
122 static int do_spawn2(pTHX_ const char *cmd, int exectype);
123 static BOOL has_shell_metachars(const char *ptr);
124 static long filetime_to_clock(PFILETIME ft);
125 static BOOL filetime_from_time(PFILETIME ft, time_t t);
126 static char * get_emd_part(SV **leading, char *trailing, ...);
127 static void remove_dead_process(long deceased);
128 static long find_pid(int pid);
129 static char * qualified_path(const char *cmd);
130 static char * win32_get_xlib(const char *pl, const char *xlib,
131 const char *libname);
132 static LRESULT win32_process_message(HWND hwnd, UINT msg,
133 WPARAM wParam, LPARAM lParam);
136 static void remove_dead_pseudo_process(long child);
137 static long find_pseudo_pid(int pid);
141 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
142 char w32_module_name[MAX_PATH+1];
145 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
147 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
148 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
149 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
150 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
153 /* Silence STDERR grumblings from Borland's math library. */
155 _matherr(struct _exception *a)
162 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
163 * parameter handler. This functionality is not available in the
164 * 64-bit compiler from the Platform SDK, which unfortunately also
165 * believes itself to be MSC version 14.
167 * There is no #define related to _set_invalid_parameter_handler(),
168 * but we can check for one of the constants defined for
169 * _set_abort_behavior(), which was introduced into stdlib.h at
173 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
174 # define SET_INVALID_PARAMETER_HANDLER
177 #ifdef SET_INVALID_PARAMETER_HANDLER
178 void my_invalid_parameter_handler(const wchar_t* expression,
179 const wchar_t* function,
185 wprintf(L"Invalid parameter detected in function %s."
186 L" File: %s Line: %d\n", function, file, line);
187 wprintf(L"Expression: %s\n", expression);
195 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
201 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
207 return (g_osver.dwMajorVersion > 4);
211 set_w32_module_name(void)
213 /* this function may be called at DLL_PROCESS_ATTACH time */
215 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
216 ? GetModuleHandle(NULL)
217 : w32_perldll_handle);
219 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
220 osver.dwOSVersionInfoSize = sizeof(osver);
221 GetVersionEx(&osver);
223 if (osver.dwMajorVersion > 4) {
224 WCHAR modulename[MAX_PATH];
225 WCHAR fullname[MAX_PATH];
228 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
230 /* Make sure we get an absolute pathname in case the module was loaded
231 * explicitly by LoadLibrary() with a relative path. */
232 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
234 /* remove \\?\ prefix */
235 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
236 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
238 ansi = win32_ansipath(fullname);
239 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
243 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
245 /* remove \\?\ prefix */
246 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
247 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
249 /* try to get full path to binary (which may be mangled when perl is
250 * run from a 16-bit app) */
251 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
252 win32_longpath(w32_module_name);
253 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
256 /* normalize to forward slashes */
257 ptr = w32_module_name;
265 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
267 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
269 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
272 const char *subkey = "Software\\Perl";
276 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
277 if (retval == ERROR_SUCCESS) {
279 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
280 if (retval == ERROR_SUCCESS
281 && (type == REG_SZ || type == REG_EXPAND_SZ))
285 *svp = sv_2mortal(newSVpvn("",0));
286 SvGROW(*svp, datalen);
287 retval = RegQueryValueEx(handle, valuename, 0, NULL,
288 (PBYTE)SvPVX(*svp), &datalen);
289 if (retval == ERROR_SUCCESS) {
291 SvCUR_set(*svp,datalen-1);
299 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
301 get_regstr(const char *valuename, SV **svp)
303 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
305 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
309 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
311 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
315 char mod_name[MAX_PATH+1];
321 va_start(ap, trailing_path);
322 strip = va_arg(ap, char *);
324 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
325 baselen = strlen(base);
327 if (!*w32_module_name) {
328 set_w32_module_name();
330 strcpy(mod_name, w32_module_name);
331 ptr = strrchr(mod_name, '/');
332 while (ptr && strip) {
333 /* look for directories to skip back */
336 ptr = strrchr(mod_name, '/');
337 /* avoid stripping component if there is no slash,
338 * or it doesn't match ... */
339 if (!ptr || stricmp(ptr+1, strip) != 0) {
340 /* ... but not if component matches m|5\.$patchlevel.*| */
341 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
342 && strncmp(strip, base, baselen) == 0
343 && strncmp(ptr+1, base, baselen) == 0))
349 strip = va_arg(ap, char *);
357 strcpy(++ptr, trailing_path);
359 /* only add directory if it exists */
360 if (GetFileAttributes(mod_name) != (DWORD) -1) {
361 /* directory exists */
364 *prev_pathp = sv_2mortal(newSVpvn("",0));
365 else if (SvPVX(*prev_pathp))
366 sv_catpvn(*prev_pathp, ";", 1);
367 sv_catpv(*prev_pathp, mod_name);
368 return SvPVX(*prev_pathp);
375 win32_get_privlib(const char *pl)
378 char *stdlib = "lib";
379 char buffer[MAX_PATH+1];
382 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
383 sprintf(buffer, "%s-%s", stdlib, pl);
384 if (!get_regstr(buffer, &sv))
385 (void)get_regstr(stdlib, &sv);
387 /* $stdlib .= ";$EMD/../../lib" */
388 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
392 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
396 char pathstr[MAX_PATH+1];
400 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
401 sprintf(regstr, "%s-%s", xlib, pl);
402 (void)get_regstr(regstr, &sv1);
405 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
406 sprintf(pathstr, "%s/%s/lib", libname, pl);
407 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
409 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
410 (void)get_regstr(xlib, &sv2);
413 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
414 sprintf(pathstr, "%s/lib", libname);
415 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
424 sv_catpvn(sv1, ";", 1);
431 win32_get_sitelib(const char *pl)
433 return win32_get_xlib(pl, "sitelib", "site");
436 #ifndef PERL_VENDORLIB_NAME
437 # define PERL_VENDORLIB_NAME "vendor"
441 win32_get_vendorlib(const char *pl)
443 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
447 has_shell_metachars(const char *ptr)
453 * Scan string looking for redirection (< or >) or pipe
454 * characters (|) that are not in a quoted string.
455 * Shell variable interpolation (%VAR%) can also happen inside strings.
487 #if !defined(PERL_IMPLICIT_SYS)
488 /* since the current process environment is being updated in util.c
489 * the library functions will get the correct environment
492 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
495 #define fixcmd(x) { \
496 char *pspace = strchr((x),' '); \
499 while (p < pspace) { \
510 PERL_FLUSHALL_FOR_CHILD;
511 return win32_popen(cmd, mode);
515 Perl_my_pclose(pTHX_ PerlIO *fp)
517 return win32_pclose(fp);
521 DllExport unsigned long
524 return (unsigned long)g_osver.dwPlatformId;
534 return -((int)w32_pseudo_id);
537 /* Windows 9x appears to always reports a pid for threads and processes
538 * that has the high bit set. So we treat the lower 31 bits as the
539 * "real" PID for Perl's purposes. */
540 if (IsWin95() && pid < 0)
545 /* Tokenize a string. Words are null-separated, and the list
546 * ends with a doubled null. Any character (except null and
547 * including backslash) may be escaped by preceding it with a
548 * backslash (the backslash will be stripped).
549 * Returns number of words in result buffer.
552 tokenize(const char *str, char **dest, char ***destv)
554 char *retstart = NULL;
555 char **retvstart = 0;
559 int slen = strlen(str);
561 register char **retv;
562 Newx(ret, slen+2, char);
563 Newx(retv, (slen+3)/2, char*);
571 if (*ret == '\\' && *str)
573 else if (*ret == ' ') {
589 retvstart[items] = NULL;
602 if (!w32_perlshell_tokens) {
603 /* we don't use COMSPEC here for two reasons:
604 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
605 * uncontrolled unportability of the ensuing scripts.
606 * 2. PERL5SHELL could be set to a shell that may not be fit for
607 * interactive use (which is what most programs look in COMSPEC
610 const char* defaultshell = (IsWinNT()
611 ? "cmd.exe /x/d/c" : "command.com /c");
612 const char *usershell = PerlEnv_getenv("PERL5SHELL");
613 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
614 &w32_perlshell_tokens,
620 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
628 PERL_ARGS_ASSERT_DO_ASPAWN;
634 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
636 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
641 while (++mark <= sp) {
642 if (*mark && (str = SvPV_nolen(*mark)))
649 status = win32_spawnvp(flag,
650 (const char*)(really ? SvPV_nolen(really) : argv[0]),
651 (const char* const*)argv);
653 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
654 /* possible shell-builtin, invoke with shell */
656 sh_items = w32_perlshell_items;
658 argv[index+sh_items] = argv[index];
659 while (--sh_items >= 0)
660 argv[sh_items] = w32_perlshell_vec[sh_items];
662 status = win32_spawnvp(flag,
663 (const char*)(really ? SvPV_nolen(really) : argv[0]),
664 (const char* const*)argv);
667 if (flag == P_NOWAIT) {
669 PL_statusvalue = -1; /* >16bits hint for pp_system() */
673 if (ckWARN(WARN_EXEC))
674 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
679 PL_statusvalue = status;
685 /* returns pointer to the next unquoted space or the end of the string */
687 find_next_space(const char *s)
689 bool in_quotes = FALSE;
691 /* ignore doubled backslashes, or backslash+quote */
692 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
695 /* keep track of when we're within quotes */
696 else if (*s == '"') {
698 in_quotes = !in_quotes;
700 /* break it up only at spaces that aren't in quotes */
701 else if (!in_quotes && isSPACE(*s))
710 do_spawn2(pTHX_ const char *cmd, int exectype)
716 BOOL needToTry = TRUE;
719 /* Save an extra exec if possible. See if there are shell
720 * metacharacters in it */
721 if (!has_shell_metachars(cmd)) {
722 Newx(argv, strlen(cmd) / 2 + 2, char*);
723 Newx(cmd2, strlen(cmd) + 1, char);
726 for (s = cmd2; *s;) {
727 while (*s && isSPACE(*s))
731 s = find_next_space(s);
739 status = win32_spawnvp(P_WAIT, argv[0],
740 (const char* const*)argv);
742 case EXECF_SPAWN_NOWAIT:
743 status = win32_spawnvp(P_NOWAIT, argv[0],
744 (const char* const*)argv);
747 status = win32_execvp(argv[0], (const char* const*)argv);
750 if (status != -1 || errno == 0)
760 Newx(argv, w32_perlshell_items + 2, char*);
761 while (++i < w32_perlshell_items)
762 argv[i] = w32_perlshell_vec[i];
763 argv[i++] = (char *)cmd;
767 status = win32_spawnvp(P_WAIT, argv[0],
768 (const char* const*)argv);
770 case EXECF_SPAWN_NOWAIT:
771 status = win32_spawnvp(P_NOWAIT, argv[0],
772 (const char* const*)argv);
775 status = win32_execvp(argv[0], (const char* const*)argv);
781 if (exectype == EXECF_SPAWN_NOWAIT) {
783 PL_statusvalue = -1; /* >16bits hint for pp_system() */
787 if (ckWARN(WARN_EXEC))
788 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
789 (exectype == EXECF_EXEC ? "exec" : "spawn"),
790 cmd, strerror(errno));
795 PL_statusvalue = status;
801 Perl_do_spawn(pTHX_ char *cmd)
803 PERL_ARGS_ASSERT_DO_SPAWN;
805 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
809 Perl_do_spawn_nowait(pTHX_ char *cmd)
811 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
813 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
817 Perl_do_exec(pTHX_ const char *cmd)
819 PERL_ARGS_ASSERT_DO_EXEC;
821 do_spawn2(aTHX_ cmd, EXECF_EXEC);
825 /* The idea here is to read all the directory names into a string table
826 * (separated by nulls) and when one of the other dir functions is called
827 * return the pointer to the current file name.
830 win32_opendir(const char *filename)
836 char scanname[MAX_PATH+3];
838 WIN32_FIND_DATAA aFindData;
839 WIN32_FIND_DATAW wFindData;
841 char buffer[MAX_PATH*2];
844 len = strlen(filename);
848 /* check to see if filename is a directory */
849 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
852 /* Get us a DIR structure */
855 /* Create the search pattern */
856 strcpy(scanname, filename);
858 /* bare drive name means look in cwd for drive */
859 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
860 scanname[len++] = '.';
861 scanname[len++] = '/';
863 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
864 scanname[len++] = '/';
866 scanname[len++] = '*';
867 scanname[len] = '\0';
869 /* do the FindFirstFile call */
871 WCHAR wscanname[sizeof(scanname)];
872 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
873 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
877 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
879 if (dirp->handle == INVALID_HANDLE_VALUE) {
880 DWORD err = GetLastError();
881 /* FindFirstFile() fails on empty drives! */
883 case ERROR_FILE_NOT_FOUND:
885 case ERROR_NO_MORE_FILES:
886 case ERROR_PATH_NOT_FOUND:
889 case ERROR_NOT_ENOUGH_MEMORY:
901 BOOL use_default = FALSE;
902 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
903 wFindData.cFileName, -1,
904 buffer, sizeof(buffer), NULL, &use_default);
905 if (use_default && *wFindData.cAlternateFileName) {
906 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
907 wFindData.cAlternateFileName, -1,
908 buffer, sizeof(buffer), NULL, NULL);
913 ptr = aFindData.cFileName;
915 /* now allocate the first part of the string table for
916 * the filenames that we find.
923 Newx(dirp->start, dirp->size, char);
924 strcpy(dirp->start, ptr);
926 dirp->end = dirp->curr = dirp->start;
932 /* Readdir just returns the current string pointer and bumps the
933 * string pointer to the nDllExport entry.
935 DllExport struct direct *
936 win32_readdir(DIR *dirp)
941 /* first set up the structure to return */
942 len = strlen(dirp->curr);
943 strcpy(dirp->dirstr.d_name, dirp->curr);
944 dirp->dirstr.d_namlen = len;
947 dirp->dirstr.d_ino = dirp->curr - dirp->start;
949 /* Now set up for the next call to readdir */
950 dirp->curr += len + 1;
951 if (dirp->curr >= dirp->end) {
954 WIN32_FIND_DATAA aFindData;
955 char buffer[MAX_PATH*2];
958 /* finding the next file that matches the wildcard
959 * (which should be all of them in this directory!).
962 WIN32_FIND_DATAW wFindData;
963 res = FindNextFileW(dirp->handle, &wFindData);
965 BOOL use_default = FALSE;
966 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
967 wFindData.cFileName, -1,
968 buffer, sizeof(buffer), NULL, &use_default);
969 if (use_default && *wFindData.cAlternateFileName) {
970 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
971 wFindData.cAlternateFileName, -1,
972 buffer, sizeof(buffer), NULL, NULL);
978 res = FindNextFileA(dirp->handle, &aFindData);
979 ptr = aFindData.cFileName;
982 long endpos = dirp->end - dirp->start;
983 long newsize = endpos + strlen(ptr) + 1;
984 /* bump the string table size by enough for the
985 * new name and its null terminator */
986 while (newsize > dirp->size) {
987 long curpos = dirp->curr - dirp->start;
989 Renew(dirp->start, dirp->size, char);
990 dirp->curr = dirp->start + curpos;
992 strcpy(dirp->start + endpos, ptr);
993 dirp->end = dirp->start + newsize;
999 return &(dirp->dirstr);
1005 /* Telldir returns the current string pointer position */
1007 win32_telldir(DIR *dirp)
1009 return (dirp->curr - dirp->start);
1013 /* Seekdir moves the string pointer to a previously saved position
1014 * (returned by telldir).
1017 win32_seekdir(DIR *dirp, long loc)
1019 dirp->curr = dirp->start + loc;
1022 /* Rewinddir resets the string pointer to the start */
1024 win32_rewinddir(DIR *dirp)
1026 dirp->curr = dirp->start;
1029 /* free the memory allocated by opendir */
1031 win32_closedir(DIR *dirp)
1034 if (dirp->handle != INVALID_HANDLE_VALUE)
1035 FindClose(dirp->handle);
1036 Safefree(dirp->start);
1049 * Just pretend that everyone is a superuser. NT will let us know if
1050 * we don\'t really have permission to do something.
1053 #define ROOT_UID ((uid_t)0)
1054 #define ROOT_GID ((gid_t)0)
1083 return (auid == ROOT_UID ? 0 : -1);
1089 return (agid == ROOT_GID ? 0 : -1);
1096 char *buf = w32_getlogin_buffer;
1097 DWORD size = sizeof(w32_getlogin_buffer);
1098 if (GetUserName(buf,&size))
1104 chown(const char *path, uid_t owner, gid_t group)
1111 * XXX this needs strengthening (for PerlIO)
1114 int mkstemp(const char *path)
1117 char buf[MAX_PATH+1];
1121 if (i++ > 10) { /* give up */
1125 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1129 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1139 long child = w32_num_children;
1140 while (--child >= 0) {
1141 if ((int)w32_child_pids[child] == pid)
1148 remove_dead_process(long child)
1152 CloseHandle(w32_child_handles[child]);
1153 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1154 (w32_num_children-child-1), HANDLE);
1155 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1156 (w32_num_children-child-1), DWORD);
1163 find_pseudo_pid(int pid)
1166 long child = w32_num_pseudo_children;
1167 while (--child >= 0) {
1168 if ((int)w32_pseudo_child_pids[child] == pid)
1175 remove_dead_pseudo_process(long child)
1179 CloseHandle(w32_pseudo_child_handles[child]);
1180 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1181 (w32_num_pseudo_children-child-1), HANDLE);
1182 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1183 (w32_num_pseudo_children-child-1), DWORD);
1184 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1185 (w32_num_pseudo_children-child-1), HWND);
1186 w32_num_pseudo_children--;
1192 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1196 /* "Does process exist?" use of kill */
1199 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1204 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1207 default: /* For now be backwards compatible with perl 5.6 */
1209 /* Note that we will only be able to kill processes owned by the
1210 * current process owner, even when we are running as an administrator.
1211 * To kill processes of other owners we would need to set the
1212 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1214 if (TerminateProcess(process_handle, sig))
1221 /* Traverse process tree using ToolHelp functions */
1223 kill_process_tree_toolhelp(DWORD pid, int sig)
1225 HANDLE process_handle;
1226 HANDLE snapshot_handle;
1229 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1230 if (process_handle == NULL)
1233 killed += terminate_process(pid, process_handle, sig);
1235 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1236 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1237 PROCESSENTRY32 entry;
1239 entry.dwSize = sizeof(entry);
1240 if (pfnProcess32First(snapshot_handle, &entry)) {
1242 if (entry.th32ParentProcessID == pid)
1243 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1244 entry.dwSize = sizeof(entry);
1246 while (pfnProcess32Next(snapshot_handle, &entry));
1248 CloseHandle(snapshot_handle);
1250 CloseHandle(process_handle);
1254 /* Traverse process tree using undocumented system information structures.
1255 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1258 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1260 HANDLE process_handle;
1261 SYSTEM_PROCESSES *p = process_info;
1264 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1265 if (process_handle == NULL)
1268 killed += terminate_process(pid, process_handle, sig);
1271 if (p->InheritedFromProcessId == (DWORD)pid)
1272 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1274 if (p->NextEntryDelta == 0)
1277 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1280 CloseHandle(process_handle);
1285 killpg(int pid, int sig)
1287 /* Use "documented" method whenever available */
1288 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1289 return kill_process_tree_toolhelp((DWORD)pid, sig);
1292 /* Fall back to undocumented Windows internals on Windows NT */
1293 if (pfnZwQuerySystemInformation) {
1298 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1299 Newx(buffer, size, char);
1301 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1302 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1311 my_kill(int pid, int sig)
1314 HANDLE process_handle;
1317 return killpg(pid, -sig);
1319 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1320 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1321 if (process_handle != NULL) {
1322 retval = terminate_process(pid, process_handle, sig);
1323 CloseHandle(process_handle);
1329 win32_kill(int pid, int sig)
1335 /* it is a pseudo-forked child */
1336 child = find_pseudo_pid(-pid);
1338 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1339 HANDLE hProcess = w32_pseudo_child_handles[child];
1342 /* "Does process exist?" use of kill */
1346 /* kill -9 style un-graceful exit */
1347 if (TerminateThread(hProcess, sig)) {
1348 remove_dead_pseudo_process(child);
1355 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1356 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1357 /* Yield and wait for the other thread to send us its message_hwnd */
1359 win32_async_check(aTHX);
1360 hwnd = w32_pseudo_child_message_hwnds[child];
1363 if (hwnd != INVALID_HANDLE_VALUE) {
1364 /* We fake signals to pseudo-processes using Win32
1365 * message queue. In Win9X the pids are negative already. */
1366 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1367 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1369 /* It might be us ... */
1378 else if (IsWin95()) {
1386 child = find_pid(pid);
1388 if (my_kill(pid, sig)) {
1390 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1391 exitcode != STILL_ACTIVE)
1393 remove_dead_process(child);
1400 if (my_kill((IsWin95() ? -pid : pid), sig))
1409 win32_stat(const char *path, Stat_t *sbuf)
1412 char buffer[MAX_PATH+1];
1413 int l = strlen(path);
1416 BOOL expect_dir = FALSE;
1418 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1419 GV_NOTQUAL, SVt_PV);
1420 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1423 switch(path[l - 1]) {
1424 /* FindFirstFile() and stat() are buggy with a trailing
1425 * slashes, except for the root directory of a drive */
1428 if (l > sizeof(buffer)) {
1429 errno = ENAMETOOLONG;
1433 strncpy(buffer, path, l);
1434 /* remove additional trailing slashes */
1435 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1437 /* add back slash if we otherwise end up with just a drive letter */
1438 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1445 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1447 if (l == 2 && isALPHA(path[0])) {
1448 buffer[0] = path[0];
1459 path = PerlDir_mapA(path);
1463 /* We must open & close the file once; otherwise file attribute changes */
1464 /* might not yet have propagated to "other" hard links of the same file. */
1465 /* This also gives us an opportunity to determine the number of links. */
1466 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1467 if (handle != INVALID_HANDLE_VALUE) {
1468 BY_HANDLE_FILE_INFORMATION bhi;
1469 if (GetFileInformationByHandle(handle, &bhi))
1470 nlink = bhi.nNumberOfLinks;
1471 CloseHandle(handle);
1475 /* path will be mapped correctly above */
1476 #if defined(WIN64) || defined(USE_LARGE_FILES)
1477 res = _stati64(path, sbuf);
1479 res = stat(path, sbuf);
1481 sbuf->st_nlink = nlink;
1484 /* CRT is buggy on sharenames, so make sure it really isn't.
1485 * XXX using GetFileAttributesEx() will enable us to set
1486 * sbuf->st_*time (but note that's not available on the
1487 * Windows of 1995) */
1488 DWORD r = GetFileAttributesA(path);
1489 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1490 /* sbuf may still contain old garbage since stat() failed */
1491 Zero(sbuf, 1, Stat_t);
1492 sbuf->st_mode = S_IFDIR | S_IREAD;
1494 if (!(r & FILE_ATTRIBUTE_READONLY))
1495 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1500 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1501 && (path[2] == '\\' || path[2] == '/'))
1503 /* The drive can be inaccessible, some _stat()s are buggy */
1504 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1509 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1513 if (S_ISDIR(sbuf->st_mode)) {
1514 /* Ensure the "write" bit is switched off in the mode for
1515 * directories with the read-only attribute set. Borland (at least)
1516 * switches it on for directories, which is technically correct
1517 * (directories are indeed always writable unless denied by DACLs),
1518 * but we want stat() and -w to reflect the state of the read-only
1519 * attribute for symmetry with chmod(). */
1520 DWORD r = GetFileAttributesA(path);
1521 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1522 sbuf->st_mode &= ~S_IWRITE;
1526 if (S_ISDIR(sbuf->st_mode)) {
1527 sbuf->st_mode |= S_IEXEC;
1529 else if (S_ISREG(sbuf->st_mode)) {
1531 if (l >= 4 && path[l-4] == '.') {
1532 const char *e = path + l - 3;
1533 if (strnicmp(e,"exe",3)
1534 && strnicmp(e,"bat",3)
1535 && strnicmp(e,"com",3)
1536 && (IsWin95() || strnicmp(e,"cmd",3)))
1537 sbuf->st_mode &= ~S_IEXEC;
1539 sbuf->st_mode |= S_IEXEC;
1542 sbuf->st_mode &= ~S_IEXEC;
1543 /* Propagate permissions to _group_ and _others_ */
1544 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1545 sbuf->st_mode |= (perms>>3) | (perms>>6);
1552 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1553 #define SKIP_SLASHES(s) \
1555 while (*(s) && isSLASH(*(s))) \
1558 #define COPY_NONSLASHES(d,s) \
1560 while (*(s) && !isSLASH(*(s))) \
1564 /* Find the longname of a given path. path is destructively modified.
1565 * It should have space for at least MAX_PATH characters. */
1567 win32_longpath(char *path)
1569 WIN32_FIND_DATA fdata;
1571 char tmpbuf[MAX_PATH+1];
1572 char *tmpstart = tmpbuf;
1579 if (isALPHA(path[0]) && path[1] == ':') {
1581 *tmpstart++ = path[0];
1585 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1587 *tmpstart++ = path[0];
1588 *tmpstart++ = path[1];
1589 SKIP_SLASHES(start);
1590 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1592 *tmpstart++ = *start++;
1593 SKIP_SLASHES(start);
1594 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1599 /* copy initial slash, if any */
1600 if (isSLASH(*start)) {
1601 *tmpstart++ = *start++;
1603 SKIP_SLASHES(start);
1606 /* FindFirstFile() expands "." and "..", so we need to pass
1607 * those through unmolested */
1609 && (!start[1] || isSLASH(start[1])
1610 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1612 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1617 /* if this is the end, bust outta here */
1621 /* now we're at a non-slash; walk up to next slash */
1622 while (*start && !isSLASH(*start))
1625 /* stop and find full name of component */
1628 fhand = FindFirstFile(path,&fdata);
1630 if (fhand != INVALID_HANDLE_VALUE) {
1631 STRLEN len = strlen(fdata.cFileName);
1632 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1633 strcpy(tmpstart, fdata.cFileName);
1644 /* failed a step, just return without side effects */
1645 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1650 strcpy(path,tmpbuf);
1659 /* Can't use PerlIO to write as it allocates memory */
1660 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1661 PL_no_mem, strlen(PL_no_mem));
1667 /* The win32_ansipath() function takes a Unicode filename and converts it
1668 * into the current Windows codepage. If some characters cannot be mapped,
1669 * then it will convert the short name instead.
1671 * The buffer to the ansi pathname must be freed with win32_free() when it
1672 * it no longer needed.
1674 * The argument to win32_ansipath() must exist before this function is
1675 * called; otherwise there is no way to determine the short path name.
1677 * Ideas for future refinement:
1678 * - Only convert those segments of the path that are not in the current
1679 * codepage, but leave the other segments in their long form.
1680 * - If the resulting name is longer than MAX_PATH, start converting
1681 * additional path segments into short names until the full name
1682 * is shorter than MAX_PATH. Shorten the filename part last!
1685 win32_ansipath(const WCHAR *widename)
1688 BOOL use_default = FALSE;
1689 size_t widelen = wcslen(widename)+1;
1690 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1691 NULL, 0, NULL, NULL);
1692 name = win32_malloc(len);
1696 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1697 name, len, NULL, &use_default);
1699 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1701 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1704 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1706 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1707 NULL, 0, NULL, NULL);
1708 name = win32_realloc(name, len);
1711 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1712 name, len, NULL, NULL);
1713 win32_free(shortname);
1720 win32_getenv(const char *name)
1726 needlen = GetEnvironmentVariableA(name,NULL,0);
1728 curitem = sv_2mortal(newSVpvn("", 0));
1730 SvGROW(curitem, needlen+1);
1731 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1733 } while (needlen >= SvLEN(curitem));
1734 SvCUR_set(curitem, needlen);
1737 /* allow any environment variables that begin with 'PERL'
1738 to be stored in the registry */
1739 if (strncmp(name, "PERL", 4) == 0)
1740 (void)get_regstr(name, &curitem);
1742 if (curitem && SvCUR(curitem))
1743 return SvPVX(curitem);
1749 win32_putenv(const char *name)
1757 Newx(curitem,strlen(name)+1,char);
1758 strcpy(curitem, name);
1759 val = strchr(curitem, '=');
1761 /* The sane way to deal with the environment.
1762 * Has these advantages over putenv() & co.:
1763 * * enables us to store a truly empty value in the
1764 * environment (like in UNIX).
1765 * * we don't have to deal with RTL globals, bugs and leaks.
1767 * Why you may want to enable USE_WIN32_RTL_ENV:
1768 * * environ[] and RTL functions will not reflect changes,
1769 * which might be an issue if extensions want to access
1770 * the env. via RTL. This cuts both ways, since RTL will
1771 * not see changes made by extensions that call the Win32
1772 * functions directly, either.
1776 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1785 filetime_to_clock(PFILETIME ft)
1787 __int64 qw = ft->dwHighDateTime;
1789 qw |= ft->dwLowDateTime;
1790 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1795 win32_times(struct tms *timebuf)
1800 clock_t process_time_so_far = clock();
1801 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1803 timebuf->tms_utime = filetime_to_clock(&user);
1804 timebuf->tms_stime = filetime_to_clock(&kernel);
1805 timebuf->tms_cutime = 0;
1806 timebuf->tms_cstime = 0;
1808 /* That failed - e.g. Win95 fallback to clock() */
1809 timebuf->tms_utime = process_time_so_far;
1810 timebuf->tms_stime = 0;
1811 timebuf->tms_cutime = 0;
1812 timebuf->tms_cstime = 0;
1814 return process_time_so_far;
1817 /* fix utime() so it works on directories in NT */
1819 filetime_from_time(PFILETIME pFileTime, time_t Time)
1821 struct tm *pTM = localtime(&Time);
1822 SYSTEMTIME SystemTime;
1828 SystemTime.wYear = pTM->tm_year + 1900;
1829 SystemTime.wMonth = pTM->tm_mon + 1;
1830 SystemTime.wDay = pTM->tm_mday;
1831 SystemTime.wHour = pTM->tm_hour;
1832 SystemTime.wMinute = pTM->tm_min;
1833 SystemTime.wSecond = pTM->tm_sec;
1834 SystemTime.wMilliseconds = 0;
1836 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1837 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1841 win32_unlink(const char *filename)
1847 filename = PerlDir_mapA(filename);
1848 attrs = GetFileAttributesA(filename);
1849 if (attrs == 0xFFFFFFFF) {
1853 if (attrs & FILE_ATTRIBUTE_READONLY) {
1854 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1855 ret = unlink(filename);
1857 (void)SetFileAttributesA(filename, attrs);
1860 ret = unlink(filename);
1865 win32_utime(const char *filename, struct utimbuf *times)
1872 struct utimbuf TimeBuffer;
1875 filename = PerlDir_mapA(filename);
1876 rc = utime(filename, times);
1878 /* EACCES: path specifies directory or readonly file */
1879 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1882 if (times == NULL) {
1883 times = &TimeBuffer;
1884 time(×->actime);
1885 times->modtime = times->actime;
1888 /* This will (and should) still fail on readonly files */
1889 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1890 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1891 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1892 if (handle == INVALID_HANDLE_VALUE)
1895 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1896 filetime_from_time(&ftAccess, times->actime) &&
1897 filetime_from_time(&ftWrite, times->modtime) &&
1898 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1903 CloseHandle(handle);
1908 unsigned __int64 ft_i64;
1913 #define Const64(x) x##LL
1915 #define Const64(x) x##i64
1917 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1918 #define EPOCH_BIAS Const64(116444736000000000)
1920 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1921 * and appears to be unsupported even by glibc) */
1923 win32_gettimeofday(struct timeval *tp, void *not_used)
1927 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1928 GetSystemTimeAsFileTime(&ft.ft_val);
1930 /* seconds since epoch */
1931 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1933 /* microseconds remaining */
1934 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1940 win32_uname(struct utsname *name)
1942 struct hostent *hep;
1943 STRLEN nodemax = sizeof(name->nodename)-1;
1946 switch (g_osver.dwPlatformId) {
1947 case VER_PLATFORM_WIN32_WINDOWS:
1948 strcpy(name->sysname, "Windows");
1950 case VER_PLATFORM_WIN32_NT:
1951 strcpy(name->sysname, "Windows NT");
1953 case VER_PLATFORM_WIN32s:
1954 strcpy(name->sysname, "Win32s");
1957 strcpy(name->sysname, "Win32 Unknown");
1962 sprintf(name->release, "%d.%d",
1963 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1966 sprintf(name->version, "Build %d",
1967 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1968 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1969 if (g_osver.szCSDVersion[0]) {
1970 char *buf = name->version + strlen(name->version);
1971 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1975 hep = win32_gethostbyname("localhost");
1977 STRLEN len = strlen(hep->h_name);
1978 if (len <= nodemax) {
1979 strcpy(name->nodename, hep->h_name);
1982 strncpy(name->nodename, hep->h_name, nodemax);
1983 name->nodename[nodemax] = '\0';
1988 if (!GetComputerName(name->nodename, &sz))
1989 *name->nodename = '\0';
1992 /* machine (architecture) */
1997 GetSystemInfo(&info);
1999 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2000 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2001 procarch = info.u.s.wProcessorArchitecture;
2003 procarch = info.wProcessorArchitecture;
2006 case PROCESSOR_ARCHITECTURE_INTEL:
2007 arch = "x86"; break;
2008 case PROCESSOR_ARCHITECTURE_MIPS:
2009 arch = "mips"; break;
2010 case PROCESSOR_ARCHITECTURE_ALPHA:
2011 arch = "alpha"; break;
2012 case PROCESSOR_ARCHITECTURE_PPC:
2013 arch = "ppc"; break;
2014 #ifdef PROCESSOR_ARCHITECTURE_SHX
2015 case PROCESSOR_ARCHITECTURE_SHX:
2016 arch = "shx"; break;
2018 #ifdef PROCESSOR_ARCHITECTURE_ARM
2019 case PROCESSOR_ARCHITECTURE_ARM:
2020 arch = "arm"; break;
2022 #ifdef PROCESSOR_ARCHITECTURE_IA64
2023 case PROCESSOR_ARCHITECTURE_IA64:
2024 arch = "ia64"; break;
2026 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2027 case PROCESSOR_ARCHITECTURE_ALPHA64:
2028 arch = "alpha64"; break;
2030 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2031 case PROCESSOR_ARCHITECTURE_MSIL:
2032 arch = "msil"; break;
2034 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2035 case PROCESSOR_ARCHITECTURE_AMD64:
2036 arch = "amd64"; break;
2038 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2039 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2040 arch = "ia32-64"; break;
2042 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2043 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2044 arch = "unknown"; break;
2047 sprintf(name->machine, "unknown(0x%x)", procarch);
2048 arch = name->machine;
2051 if (name->machine != arch)
2052 strcpy(name->machine, arch);
2057 /* Timing related stuff */
2060 do_raise(pTHX_ int sig)
2062 if (sig < SIG_SIZE) {
2063 Sighandler_t handler = w32_sighandler[sig];
2064 if (handler == SIG_IGN) {
2067 else if (handler != SIG_DFL) {
2072 /* Choose correct default behaviour */
2088 /* Tell caller to exit thread/process as approriate */
2093 sig_terminate(pTHX_ int sig)
2095 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2096 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2103 win32_async_check(pTHX)
2106 HWND hwnd = w32_message_hwnd;
2108 /* Reset w32_poll_count before doing anything else, incase we dispatch
2109 * messages that end up calling back into perl */
2112 if (hwnd != INVALID_HANDLE_VALUE) {
2113 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2114 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2119 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2120 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2122 /* re-post a WM_QUIT message (we'll mark it as read later) */
2123 if(msg.message == WM_QUIT) {
2124 PostQuitMessage((int)msg.wParam);
2128 if(!CallMsgFilter(&msg, MSGF_USER))
2130 TranslateMessage(&msg);
2131 DispatchMessage(&msg);
2136 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2137 * This is necessary when we are being called by win32_msgwait() to
2138 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2139 * message over and over. An example how this can happen is when
2140 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2141 * is generating messages before the process terminated.
2143 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2145 /* Above or other stuff may have set a signal flag */
2152 /* This function will not return until the timeout has elapsed, or until
2153 * one of the handles is ready. */
2155 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2157 /* We may need several goes at this - so compute when we stop */
2159 if (timeout != INFINITE) {
2160 ticks = GetTickCount();
2164 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2167 if (result == WAIT_TIMEOUT) {
2168 /* Ran out of time - explicit return of zero to avoid -ve if we
2169 have scheduling issues
2173 if (timeout != INFINITE) {
2174 ticks = GetTickCount();
2176 if (result == WAIT_OBJECT_0 + count) {
2177 /* Message has arrived - check it */
2178 (void)win32_async_check(aTHX);
2181 /* Not timeout or message - one of handles is ready */
2185 /* compute time left to wait */
2186 ticks = timeout - ticks;
2187 /* If we are past the end say zero */
2188 return (ticks > 0) ? ticks : 0;
2192 win32_internal_wait(int *status, DWORD timeout)
2194 /* XXX this wait emulation only knows about processes
2195 * spawned via win32_spawnvp(P_NOWAIT, ...).
2199 DWORD exitcode, waitcode;
2202 if (w32_num_pseudo_children) {
2203 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2204 timeout, &waitcode);
2205 /* Time out here if there are no other children to wait for. */
2206 if (waitcode == WAIT_TIMEOUT) {
2207 if (!w32_num_children) {
2211 else if (waitcode != WAIT_FAILED) {
2212 if (waitcode >= WAIT_ABANDONED_0
2213 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2214 i = waitcode - WAIT_ABANDONED_0;
2216 i = waitcode - WAIT_OBJECT_0;
2217 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2218 *status = (int)((exitcode & 0xff) << 8);
2219 retval = (int)w32_pseudo_child_pids[i];
2220 remove_dead_pseudo_process(i);
2227 if (!w32_num_children) {
2232 /* if a child exists, wait for it to die */
2233 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2234 if (waitcode == WAIT_TIMEOUT) {
2237 if (waitcode != WAIT_FAILED) {
2238 if (waitcode >= WAIT_ABANDONED_0
2239 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2240 i = waitcode - WAIT_ABANDONED_0;
2242 i = waitcode - WAIT_OBJECT_0;
2243 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2244 *status = (int)((exitcode & 0xff) << 8);
2245 retval = (int)w32_child_pids[i];
2246 remove_dead_process(i);
2251 errno = GetLastError();
2256 win32_waitpid(int pid, int *status, int flags)
2259 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2262 if (pid == -1) /* XXX threadid == 1 ? */
2263 return win32_internal_wait(status, timeout);
2266 child = find_pseudo_pid(-pid);
2268 HANDLE hThread = w32_pseudo_child_handles[child];
2270 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2271 if (waitcode == WAIT_TIMEOUT) {
2274 else if (waitcode == WAIT_OBJECT_0) {
2275 if (GetExitCodeThread(hThread, &waitcode)) {
2276 *status = (int)((waitcode & 0xff) << 8);
2277 retval = (int)w32_pseudo_child_pids[child];
2278 remove_dead_pseudo_process(child);
2285 else if (IsWin95()) {
2294 child = find_pid(pid);
2296 hProcess = w32_child_handles[child];
2297 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2298 if (waitcode == WAIT_TIMEOUT) {
2301 else if (waitcode == WAIT_OBJECT_0) {
2302 if (GetExitCodeProcess(hProcess, &waitcode)) {
2303 *status = (int)((waitcode & 0xff) << 8);
2304 retval = (int)w32_child_pids[child];
2305 remove_dead_process(child);
2314 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2315 (IsWin95() ? -pid : pid));
2317 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2318 if (waitcode == WAIT_TIMEOUT) {
2319 CloseHandle(hProcess);
2322 else if (waitcode == WAIT_OBJECT_0) {
2323 if (GetExitCodeProcess(hProcess, &waitcode)) {
2324 *status = (int)((waitcode & 0xff) << 8);
2325 CloseHandle(hProcess);
2329 CloseHandle(hProcess);
2335 return retval >= 0 ? pid : retval;
2339 win32_wait(int *status)
2341 return win32_internal_wait(status, INFINITE);
2344 DllExport unsigned int
2345 win32_sleep(unsigned int t)
2348 /* Win32 times are in ms so *1000 in and /1000 out */
2349 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2352 DllExport unsigned int
2353 win32_alarm(unsigned int sec)
2356 * the 'obvious' implentation is SetTimer() with a callback
2357 * which does whatever receiving SIGALRM would do
2358 * we cannot use SIGALRM even via raise() as it is not
2359 * one of the supported codes in <signal.h>
2363 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2364 w32_message_hwnd = win32_create_message_window();
2367 if (w32_message_hwnd == NULL)
2368 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2371 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2376 KillTimer(w32_message_hwnd, w32_timerid);
2383 #ifdef HAVE_DES_FCRYPT
2384 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2388 win32_crypt(const char *txt, const char *salt)
2391 #ifdef HAVE_DES_FCRYPT
2392 return des_fcrypt(txt, salt, w32_crypt_buffer);
2394 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2399 #ifdef USE_FIXED_OSFHANDLE
2401 #define FOPEN 0x01 /* file handle open */
2402 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2403 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2404 #define FDEV 0x40 /* file handle refers to device */
2405 #define FTEXT 0x80 /* file handle is in text mode */
2408 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2411 * This function allocates a free C Runtime file handle and associates
2412 * it with the Win32 HANDLE specified by the first parameter. This is a
2413 * temperary fix for WIN95's brain damage GetFileType() error on socket
2414 * we just bypass that call for socket
2416 * This works with MSVC++ 4.0+ or GCC/Mingw32
2419 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2420 * int flags - flags to associate with C Runtime file handle.
2423 * returns index of entry in fh, if successful
2424 * return -1, if no free entry is found
2428 *******************************************************************************/
2431 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2432 * this lets sockets work on Win9X with GCC and should fix the problems
2437 /* create an ioinfo entry, kill its handle, and steal the entry */
2442 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2443 int fh = _open_osfhandle((intptr_t)hF, 0);
2447 EnterCriticalSection(&(_pioinfo(fh)->lock));
2452 my_open_osfhandle(intptr_t osfhandle, int flags)
2455 char fileflags; /* _osfile flags */
2457 /* copy relevant flags from second parameter */
2460 if (flags & O_APPEND)
2461 fileflags |= FAPPEND;
2466 if (flags & O_NOINHERIT)
2467 fileflags |= FNOINHERIT;
2469 /* attempt to allocate a C Runtime file handle */
2470 if ((fh = _alloc_osfhnd()) == -1) {
2471 errno = EMFILE; /* too many open files */
2472 _doserrno = 0L; /* not an OS error */
2473 return -1; /* return error to caller */
2476 /* the file is open. now, set the info in _osfhnd array */
2477 _set_osfhnd(fh, osfhandle);
2479 fileflags |= FOPEN; /* mark as open */
2481 _osfile(fh) = fileflags; /* set osfile entry */
2482 LeaveCriticalSection(&_pioinfo(fh)->lock);
2484 return fh; /* return handle */
2487 #endif /* USE_FIXED_OSFHANDLE */
2489 /* simulate flock by locking a range on the file */
2491 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2492 #define LK_LEN 0xffff0000
2495 win32_flock(int fd, int oper)
2503 Perl_croak_nocontext("flock() unimplemented on this platform");
2506 fh = (HANDLE)_get_osfhandle(fd);
2507 memset(&o, 0, sizeof(o));
2510 case LOCK_SH: /* shared lock */
2511 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2513 case LOCK_EX: /* exclusive lock */
2514 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2516 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2517 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2519 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2520 LK_ERR(LockFileEx(fh,
2521 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2522 0, LK_LEN, 0, &o),i);
2524 case LOCK_UN: /* unlock lock */
2525 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2527 default: /* unknown */
2538 * redirected io subsystem for all XS modules
2551 return (&(_environ));
2554 /* the rest are the remapped stdio routines */
2574 win32_ferror(FILE *fp)
2576 return (ferror(fp));
2581 win32_feof(FILE *fp)
2587 * Since the errors returned by the socket error function
2588 * WSAGetLastError() are not known by the library routine strerror
2589 * we have to roll our own.
2593 win32_strerror(int e)
2595 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2596 extern int sys_nerr;
2600 if (e < 0 || e > sys_nerr) {
2605 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2606 w32_strerror_buffer,
2607 sizeof(w32_strerror_buffer), NULL) == 0)
2608 strcpy(w32_strerror_buffer, "Unknown Error");
2610 return w32_strerror_buffer;
2616 win32_str_os_error(void *sv, DWORD dwErr)
2620 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2621 |FORMAT_MESSAGE_IGNORE_INSERTS
2622 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2623 dwErr, 0, (char *)&sMsg, 1, NULL);
2624 /* strip trailing whitespace and period */
2627 --dwLen; /* dwLen doesn't include trailing null */
2628 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2629 if ('.' != sMsg[dwLen])
2634 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2636 dwLen = sprintf(sMsg,
2637 "Unknown error #0x%lX (lookup 0x%lX)",
2638 dwErr, GetLastError());
2642 sv_setpvn((SV*)sv, sMsg, dwLen);
2648 win32_fprintf(FILE *fp, const char *format, ...)
2651 va_start(marker, format); /* Initialize variable arguments. */
2653 return (vfprintf(fp, format, marker));
2657 win32_printf(const char *format, ...)
2660 va_start(marker, format); /* Initialize variable arguments. */
2662 return (vprintf(format, marker));
2666 win32_vfprintf(FILE *fp, const char *format, va_list args)
2668 return (vfprintf(fp, format, args));
2672 win32_vprintf(const char *format, va_list args)
2674 return (vprintf(format, args));
2678 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2680 return fread(buf, size, count, fp);
2684 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2686 return fwrite(buf, size, count, fp);
2689 #define MODE_SIZE 10
2692 win32_fopen(const char *filename, const char *mode)
2700 if (stricmp(filename, "/dev/null")==0)
2703 f = fopen(PerlDir_mapA(filename), mode);
2704 /* avoid buffering headaches for child processes */
2705 if (f && *mode == 'a')
2706 win32_fseek(f, 0, SEEK_END);
2710 #ifndef USE_SOCKETS_AS_HANDLES
2712 #define fdopen my_fdopen
2716 win32_fdopen(int handle, const char *mode)
2720 f = fdopen(handle, (char *) mode);
2721 /* avoid buffering headaches for child processes */
2722 if (f && *mode == 'a')
2723 win32_fseek(f, 0, SEEK_END);
2728 win32_freopen(const char *path, const char *mode, FILE *stream)
2731 if (stricmp(path, "/dev/null")==0)
2734 return freopen(PerlDir_mapA(path), mode, stream);
2738 win32_fclose(FILE *pf)
2740 return my_fclose(pf); /* defined in win32sck.c */
2744 win32_fputs(const char *s,FILE *pf)
2746 return fputs(s, pf);
2750 win32_fputc(int c,FILE *pf)
2756 win32_ungetc(int c,FILE *pf)
2758 return ungetc(c,pf);
2762 win32_getc(FILE *pf)
2768 win32_fileno(FILE *pf)
2774 win32_clearerr(FILE *pf)
2781 win32_fflush(FILE *pf)
2787 win32_ftell(FILE *pf)
2789 #if defined(WIN64) || defined(USE_LARGE_FILES)
2790 #if defined(__BORLANDC__) /* buk */
2791 return win32_tell( fileno( pf ) );
2794 if (fgetpos(pf, &pos))
2804 win32_fseek(FILE *pf, Off_t offset,int origin)
2806 #if defined(WIN64) || defined(USE_LARGE_FILES)
2807 #if defined(__BORLANDC__) /* buk */
2817 if (fgetpos(pf, &pos))
2822 fseek(pf, 0, SEEK_END);
2823 pos = _telli64(fileno(pf));
2832 return fsetpos(pf, &offset);
2835 return fseek(pf, (long)offset, origin);
2840 win32_fgetpos(FILE *pf,fpos_t *p)
2842 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2843 if( win32_tell(fileno(pf)) == -1L ) {
2849 return fgetpos(pf, p);
2854 win32_fsetpos(FILE *pf,const fpos_t *p)
2856 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2857 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2859 return fsetpos(pf, p);
2864 win32_rewind(FILE *pf)
2874 char prefix[MAX_PATH+1];
2875 char filename[MAX_PATH+1];
2876 DWORD len = GetTempPath(MAX_PATH, prefix);
2877 if (len && len < MAX_PATH) {
2878 if (GetTempFileName(prefix, "plx", 0, filename)) {
2879 HANDLE fh = CreateFile(filename,
2880 DELETE | GENERIC_READ | GENERIC_WRITE,
2884 FILE_ATTRIBUTE_NORMAL
2885 | FILE_FLAG_DELETE_ON_CLOSE,
2887 if (fh != INVALID_HANDLE_VALUE) {
2888 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2890 #if defined(__BORLANDC__)
2891 setmode(fd,O_BINARY);
2893 DEBUG_p(PerlIO_printf(Perl_debug_log,
2894 "Created tmpfile=%s\n",filename));
2906 int fd = win32_tmpfd();
2908 return win32_fdopen(fd, "w+b");
2920 win32_fstat(int fd, Stat_t *sbufptr)
2923 /* A file designated by filehandle is not shown as accessible
2924 * for write operations, probably because it is opened for reading.
2927 BY_HANDLE_FILE_INFORMATION bhfi;
2928 #if defined(WIN64) || defined(USE_LARGE_FILES)
2929 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2931 int rc = fstat(fd,&tmp);
2933 sbufptr->st_dev = tmp.st_dev;
2934 sbufptr->st_ino = tmp.st_ino;
2935 sbufptr->st_mode = tmp.st_mode;
2936 sbufptr->st_nlink = tmp.st_nlink;
2937 sbufptr->st_uid = tmp.st_uid;
2938 sbufptr->st_gid = tmp.st_gid;
2939 sbufptr->st_rdev = tmp.st_rdev;
2940 sbufptr->st_size = tmp.st_size;
2941 sbufptr->st_atime = tmp.st_atime;
2942 sbufptr->st_mtime = tmp.st_mtime;
2943 sbufptr->st_ctime = tmp.st_ctime;
2945 int rc = fstat(fd,sbufptr);
2948 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2949 #if defined(WIN64) || defined(USE_LARGE_FILES)
2950 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2952 sbufptr->st_mode &= 0xFE00;
2953 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2954 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2956 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2957 + ((S_IREAD|S_IWRITE) >> 6));
2961 return my_fstat(fd,sbufptr);
2966 win32_pipe(int *pfd, unsigned int size, int mode)
2968 return _pipe(pfd, size, mode);
2972 win32_popenlist(const char *mode, IV narg, SV **args)
2975 Perl_croak(aTHX_ "List form of pipe open not implemented");
2980 * a popen() clone that respects PERL5SHELL
2982 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2986 win32_popen(const char *command, const char *mode)
2988 #ifdef USE_RTL_POPEN
2989 return _popen(command, mode);
3001 /* establish which ends read and write */
3002 if (strchr(mode,'w')) {
3003 stdfd = 0; /* stdin */
3006 nhandle = STD_INPUT_HANDLE;
3008 else if (strchr(mode,'r')) {
3009 stdfd = 1; /* stdout */
3012 nhandle = STD_OUTPUT_HANDLE;
3017 /* set the correct mode */
3018 if (strchr(mode,'b'))
3020 else if (strchr(mode,'t'))
3023 ourmode = _fmode & (O_TEXT | O_BINARY);
3025 /* the child doesn't inherit handles */
3026 ourmode |= O_NOINHERIT;
3028 if (win32_pipe(p, 512, ourmode) == -1)
3031 /* save the old std handle (this needs to happen before the
3032 * dup2(), since that might call SetStdHandle() too) */
3035 old_h = GetStdHandle(nhandle);
3037 /* save current stdfd */
3038 if ((oldfd = win32_dup(stdfd)) == -1)
3041 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3042 /* stdfd will be inherited by the child */
3043 if (win32_dup2(p[child], stdfd) == -1)
3046 /* close the child end in parent */
3047 win32_close(p[child]);
3049 /* set the new std handle (in case dup2() above didn't) */
3050 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3052 /* start the child */
3055 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3058 /* revert stdfd to whatever it was before */
3059 if (win32_dup2(oldfd, stdfd) == -1)
3062 /* close saved handle */
3065 /* restore the old std handle (this needs to happen after the
3066 * dup2(), since that might call SetStdHandle() too */
3068 SetStdHandle(nhandle, old_h);
3074 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3077 /* set process id so that it can be returned by perl's open() */
3078 PL_forkprocess = childpid;
3081 /* we have an fd, return a file stream */
3082 return (PerlIO_fdopen(p[parent], (char *)mode));
3085 /* we don't need to check for errors here */
3089 win32_dup2(oldfd, stdfd);
3093 SetStdHandle(nhandle, old_h);
3099 #endif /* USE_RTL_POPEN */
3107 win32_pclose(PerlIO *pf)
3109 #ifdef USE_RTL_POPEN
3113 int childpid, status;
3117 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3120 childpid = SvIVX(sv);
3138 if (win32_waitpid(childpid, &status, 0) == -1)
3143 #endif /* USE_RTL_POPEN */
3149 LPCWSTR lpExistingFileName,
3150 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3153 WCHAR wFullName[MAX_PATH+1];
3154 LPVOID lpContext = NULL;
3155 WIN32_STREAM_ID StreamId;
3156 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3161 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3162 BOOL, BOOL, LPVOID*) =
3163 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3164 BOOL, BOOL, LPVOID*))
3165 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3166 if (pfnBackupWrite == NULL)
3169 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3172 dwLen = (dwLen+1)*sizeof(WCHAR);
3174 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3175 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3176 NULL, OPEN_EXISTING, 0, NULL);
3177 if (handle == INVALID_HANDLE_VALUE)
3180 StreamId.dwStreamId = BACKUP_LINK;
3181 StreamId.dwStreamAttributes = 0;
3182 StreamId.dwStreamNameSize = 0;
3183 #if defined(__BORLANDC__) \
3184 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3185 StreamId.Size.u.HighPart = 0;
3186 StreamId.Size.u.LowPart = dwLen;
3188 StreamId.Size.HighPart = 0;
3189 StreamId.Size.LowPart = dwLen;
3192 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3193 FALSE, FALSE, &lpContext);
3195 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3196 FALSE, FALSE, &lpContext);
3197 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3200 CloseHandle(handle);
3205 win32_link(const char *oldname, const char *newname)
3208 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3209 WCHAR wOldName[MAX_PATH+1];
3210 WCHAR wNewName[MAX_PATH+1];
3213 Perl_croak(aTHX_ PL_no_func, "link");
3215 pfnCreateHardLinkW =
3216 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3217 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3218 if (pfnCreateHardLinkW == NULL)
3219 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3221 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3222 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3223 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3224 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3228 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3233 win32_rename(const char *oname, const char *newname)
3235 char szOldName[MAX_PATH+1];
3236 char szNewName[MAX_PATH+1];
3240 /* XXX despite what the documentation says about MoveFileEx(),
3241 * it doesn't work under Windows95!
3244 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3245 if (stricmp(newname, oname))
3246 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3247 strcpy(szOldName, PerlDir_mapA(oname));
3248 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3250 DWORD err = GetLastError();
3252 case ERROR_BAD_NET_NAME:
3253 case ERROR_BAD_NETPATH:
3254 case ERROR_BAD_PATHNAME:
3255 case ERROR_FILE_NOT_FOUND:
3256 case ERROR_FILENAME_EXCED_RANGE:
3257 case ERROR_INVALID_DRIVE:
3258 case ERROR_NO_MORE_FILES:
3259 case ERROR_PATH_NOT_FOUND:
3272 char szTmpName[MAX_PATH+1];
3273 char dname[MAX_PATH+1];
3274 char *endname = NULL;
3276 DWORD from_attr, to_attr;
3278 strcpy(szOldName, PerlDir_mapA(oname));
3279 strcpy(szNewName, PerlDir_mapA(newname));
3281 /* if oname doesn't exist, do nothing */
3282 from_attr = GetFileAttributes(szOldName);
3283 if (from_attr == 0xFFFFFFFF) {
3288 /* if newname exists, rename it to a temporary name so that we
3289 * don't delete it in case oname happens to be the same file
3290 * (but perhaps accessed via a different path)
3292 to_attr = GetFileAttributes(szNewName);
3293 if (to_attr != 0xFFFFFFFF) {
3294 /* if newname is a directory, we fail
3295 * XXX could overcome this with yet more convoluted logic */
3296 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3300 tmplen = strlen(szNewName);
3301 strcpy(szTmpName,szNewName);
3302 endname = szTmpName+tmplen;
3303 for (; endname > szTmpName ; --endname) {
3304 if (*endname == '/' || *endname == '\\') {
3309 if (endname > szTmpName)
3310 endname = strcpy(dname,szTmpName);
3314 /* get a temporary filename in same directory
3315 * XXX is this really the best we can do? */
3316 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3320 DeleteFile(szTmpName);
3322 retval = rename(szNewName, szTmpName);
3329 /* rename oname to newname */
3330 retval = rename(szOldName, szNewName);
3332 /* if we created a temporary file before ... */
3333 if (endname != NULL) {
3334 /* ...and rename succeeded, delete temporary file/directory */
3336 DeleteFile(szTmpName);
3337 /* else restore it to what it was */
3339 (void)rename(szTmpName, szNewName);
3346 win32_setmode(int fd, int mode)
3348 return setmode(fd, mode);
3352 win32_chsize(int fd, Off_t size)
3354 #if defined(WIN64) || defined(USE_LARGE_FILES)
3356 Off_t cur, end, extend;
3358 cur = win32_tell(fd);
3361 end = win32_lseek(fd, 0, SEEK_END);
3364 extend = size - end;
3368 else if (extend > 0) {
3369 /* must grow the file, padding with nulls */
3371 int oldmode = win32_setmode(fd, O_BINARY);
3373 memset(b, '\0', sizeof(b));
3375 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3376 count = win32_write(fd, b, count);
3377 if ((int)count < 0) {
3381 } while ((extend -= count) > 0);
3382 win32_setmode(fd, oldmode);
3385 /* shrink the file */
3386 win32_lseek(fd, size, SEEK_SET);
3387 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3393 win32_lseek(fd, cur, SEEK_SET);
3396 return chsize(fd, (long)size);
3401 win32_lseek(int fd, Off_t offset, int origin)
3403 #if defined(WIN64) || defined(USE_LARGE_FILES)
3404 #if defined(__BORLANDC__) /* buk */
3406 pos.QuadPart = offset;
3407 pos.LowPart = SetFilePointer(
3408 (HANDLE)_get_osfhandle(fd),
3413 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3417 return pos.QuadPart;
3419 return _lseeki64(fd, offset, origin);
3422 return lseek(fd, (long)offset, origin);
3429 #if defined(WIN64) || defined(USE_LARGE_FILES)
3430 #if defined(__BORLANDC__) /* buk */
3433 pos.LowPart = SetFilePointer(
3434 (HANDLE)_get_osfhandle(fd),
3439 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3443 return pos.QuadPart;
3444 /* return tell(fd); */
3446 return _telli64(fd);
3454 win32_open(const char *path, int flag, ...)
3461 pmode = va_arg(ap, int);
3464 if (stricmp(path, "/dev/null")==0)
3467 return open(PerlDir_mapA(path), flag, pmode);
3470 /* close() that understands socket */
3471 extern int my_close(int); /* in win32sck.c */
3476 return my_close(fd);
3492 win32_dup2(int fd1,int fd2)
3494 return dup2(fd1,fd2);
3497 #ifdef PERL_MSVCRT_READFIX
3499 #define LF 10 /* line feed */
3500 #define CR 13 /* carriage return */
3501 #define CTRLZ 26 /* ctrl-z means eof for text */
3502 #define FOPEN 0x01 /* file handle open */
3503 #define FEOFLAG 0x02 /* end of file has been encountered */
3504 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3505 #define FPIPE 0x08 /* file handle refers to a pipe */
3506 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3507 #define FDEV 0x40 /* file handle refers to device */
3508 #define FTEXT 0x80 /* file handle is in text mode */
3509 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3512 _fixed_read(int fh, void *buf, unsigned cnt)
3514 int bytes_read; /* number of bytes read */
3515 char *buffer; /* buffer to read to */
3516 int os_read; /* bytes read on OS call */
3517 char *p, *q; /* pointers into buffer */
3518 char peekchr; /* peek-ahead character */
3519 ULONG filepos; /* file position after seek */
3520 ULONG dosretval; /* o.s. return value */
3522 /* validate handle */
3523 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3524 !(_osfile(fh) & FOPEN))
3526 /* out of range -- return error */
3528 _doserrno = 0; /* not o.s. error */
3533 * If lockinitflag is FALSE, assume fd is device
3534 * lockinitflag is set to TRUE by open.
3536 if (_pioinfo(fh)->lockinitflag)
3537 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3539 bytes_read = 0; /* nothing read yet */
3540 buffer = (char*)buf;
3542 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3543 /* nothing to read or at EOF, so return 0 read */
3547 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3548 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3550 *buffer++ = _pipech(fh);
3553 _pipech(fh) = LF; /* mark as empty */
3558 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3560 /* ReadFile has reported an error. recognize two special cases.
3562 * 1. map ERROR_ACCESS_DENIED to EBADF
3564 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3565 * means the handle is a read-handle on a pipe for which
3566 * all write-handles have been closed and all data has been
3569 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3570 /* wrong read/write mode should return EBADF, not EACCES */
3572 _doserrno = dosretval;
3576 else if (dosretval == ERROR_BROKEN_PIPE) {
3586 bytes_read += os_read; /* update bytes read */
3588 if (_osfile(fh) & FTEXT) {
3589 /* now must translate CR-LFs to LFs in the buffer */
3591 /* set CRLF flag to indicate LF at beginning of buffer */
3592 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3593 /* _osfile(fh) |= FCRLF; */
3595 /* _osfile(fh) &= ~FCRLF; */
3597 _osfile(fh) &= ~FCRLF;
3599 /* convert chars in the buffer: p is src, q is dest */
3601 while (p < (char *)buf + bytes_read) {
3603 /* if fh is not a device, set ctrl-z flag */
3604 if (!(_osfile(fh) & FDEV))
3605 _osfile(fh) |= FEOFLAG;
3606 break; /* stop translating */
3611 /* *p is CR, so must check next char for LF */
3612 if (p < (char *)buf + bytes_read - 1) {
3615 *q++ = LF; /* convert CR-LF to LF */
3618 *q++ = *p++; /* store char normally */
3621 /* This is the hard part. We found a CR at end of
3622 buffer. We must peek ahead to see if next char
3627 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3628 (LPDWORD)&os_read, NULL))
3629 dosretval = GetLastError();
3631 if (dosretval != 0 || os_read == 0) {
3632 /* couldn't read ahead, store CR */
3636 /* peekchr now has the extra character -- we now
3637 have several possibilities:
3638 1. disk file and char is not LF; just seek back
3640 2. disk file and char is LF; store LF, don't seek back
3641 3. pipe/device and char is LF; store LF.
3642 4. pipe/device and char isn't LF, store CR and
3643 put char in pipe lookahead buffer. */
3644 if (_osfile(fh) & (FDEV|FPIPE)) {
3645 /* non-seekable device */
3650 _pipech(fh) = peekchr;
3655 if (peekchr == LF) {
3656 /* nothing read yet; must make some
3659 /* turn on this flag for tell routine */
3660 _osfile(fh) |= FCRLF;
3663 HANDLE osHandle; /* o.s. handle value */
3665 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3667 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3668 dosretval = GetLastError();
3679 /* we now change bytes_read to reflect the true number of chars
3681 bytes_read = q - (char *)buf;
3685 if (_pioinfo(fh)->lockinitflag)
3686 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3691 #endif /* PERL_MSVCRT_READFIX */
3694 win32_read(int fd, void *buf, unsigned int cnt)
3696 #ifdef PERL_MSVCRT_READFIX
3697 return _fixed_read(fd, buf, cnt);
3699 return read(fd, buf, cnt);
3704 win32_write(int fd, const void *buf, unsigned int cnt)
3706 return write(fd, buf, cnt);
3710 win32_mkdir(const char *dir, int mode)
3713 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3717 win32_rmdir(const char *dir)
3720 return rmdir(PerlDir_mapA(dir));
3724 win32_chdir(const char *dir)
3735 win32_access(const char *path, int mode)
3738 return access(PerlDir_mapA(path), mode);
3742 win32_chmod(const char *path, int mode)
3745 return chmod(PerlDir_mapA(path), mode);
3750 create_command_line(char *cname, STRLEN clen, const char * const *args)
3757 bool bat_file = FALSE;
3758 bool cmd_shell = FALSE;
3759 bool dumb_shell = FALSE;
3760 bool extra_quotes = FALSE;
3761 bool quote_next = FALSE;
3764 cname = (char*)args[0];
3766 /* The NT cmd.exe shell has the following peculiarity that needs to be
3767 * worked around. It strips a leading and trailing dquote when any
3768 * of the following is true:
3769 * 1. the /S switch was used
3770 * 2. there are more than two dquotes
3771 * 3. there is a special character from this set: &<>()@^|
3772 * 4. no whitespace characters within the two dquotes
3773 * 5. string between two dquotes isn't an executable file
3774 * To work around this, we always add a leading and trailing dquote
3775 * to the string, if the first argument is either "cmd.exe" or "cmd",
3776 * and there were at least two or more arguments passed to cmd.exe
3777 * (not including switches).
3778 * XXX the above rules (from "cmd /?") don't seem to be applied
3779 * always, making for the convolutions below :-(
3783 clen = strlen(cname);
3786 && (stricmp(&cname[clen-4], ".bat") == 0
3787 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3794 char *exe = strrchr(cname, '/');
3795 char *exe2 = strrchr(cname, '\\');
3802 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3806 else if (stricmp(exe, "command.com") == 0
3807 || stricmp(exe, "command") == 0)
3814 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3815 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3816 STRLEN curlen = strlen(arg);
3817 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3818 len += 2; /* assume quoting needed (worst case) */
3820 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3822 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3825 Newx(cmd, len, char);
3828 if (bat_file && !IsWin95()) {
3830 extra_quotes = TRUE;
3833 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3835 STRLEN curlen = strlen(arg);
3837 /* we want to protect empty arguments and ones with spaces with
3838 * dquotes, but only if they aren't already there */
3843 else if (quote_next) {
3844 /* see if it really is multiple arguments pretending to
3845 * be one and force a set of quotes around it */
3846 if (*find_next_space(arg))
3849 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3851 while (i < curlen) {
3852 if (isSPACE(arg[i])) {
3855 else if (arg[i] == '"') {
3879 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3880 && stricmp(arg+curlen-2, "/c") == 0)
3882 /* is there a next argument? */
3883 if (args[index+1]) {
3884 /* are there two or more next arguments? */
3885 if (args[index+2]) {
3887 extra_quotes = TRUE;
3890 /* single argument, force quoting if it has spaces */
3906 qualified_path(const char *cmd)
3910 char *fullcmd, *curfullcmd;
3916 fullcmd = (char*)cmd;
3918 if (*fullcmd == '/' || *fullcmd == '\\')
3925 pathstr = PerlEnv_getenv("PATH");
3927 /* worst case: PATH is a single directory; we need additional space
3928 * to append "/", ".exe" and trailing "\0" */
3929 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3930 curfullcmd = fullcmd;
3935 /* start by appending the name to the current prefix */
3936 strcpy(curfullcmd, cmd);
3937 curfullcmd += cmdlen;
3939 /* if it doesn't end with '.', or has no extension, try adding
3940 * a trailing .exe first */
3941 if (cmd[cmdlen-1] != '.'
3942 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3944 strcpy(curfullcmd, ".exe");
3945 res = GetFileAttributes(fullcmd);
3946 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3951 /* that failed, try the bare name */
3952 res = GetFileAttributes(fullcmd);
3953 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3956 /* quit if no other path exists, or if cmd already has path */
3957 if (!pathstr || !*pathstr || has_slash)
3960 /* skip leading semis */
3961 while (*pathstr == ';')
3964 /* build a new prefix from scratch */
3965 curfullcmd = fullcmd;
3966 while (*pathstr && *pathstr != ';') {
3967 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3968 pathstr++; /* skip initial '"' */
3969 while (*pathstr && *pathstr != '"') {
3970 *curfullcmd++ = *pathstr++;
3973 pathstr++; /* skip trailing '"' */
3976 *curfullcmd++ = *pathstr++;
3980 pathstr++; /* skip trailing semi */
3981 if (curfullcmd > fullcmd /* append a dir separator */
3982 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3984 *curfullcmd++ = '\\';
3992 /* The following are just place holders.
3993 * Some hosts may provide and environment that the OS is
3994 * not tracking, therefore, these host must provide that
3995 * environment and the current directory to CreateProcess
3999 win32_get_childenv(void)
4005 win32_free_childenv(void* d)
4010 win32_clearenv(void)
4012 char *envv = GetEnvironmentStrings();
4016 char *end = strchr(cur,'=');
4017 if (end && end != cur) {
4019 SetEnvironmentVariable(cur, NULL);
4021 cur = end + strlen(end+1)+2;
4023 else if ((len = strlen(cur)))
4026 FreeEnvironmentStrings(envv);
4030 win32_get_childdir(void)
4034 char szfilename[MAX_PATH+1];
4036 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4037 Newx(ptr, strlen(szfilename)+1, char);
4038 strcpy(ptr, szfilename);
4043 win32_free_childdir(char* d)
4050 /* XXX this needs to be made more compatible with the spawnvp()
4051 * provided by the various RTLs. In particular, searching for
4052 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4053 * This doesn't significantly affect perl itself, because we
4054 * always invoke things using PERL5SHELL if a direct attempt to
4055 * spawn the executable fails.
4057 * XXX splitting and rejoining the commandline between do_aspawn()
4058 * and win32_spawnvp() could also be avoided.
4062 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4064 #ifdef USE_RTL_SPAWNVP
4065 return spawnvp(mode, cmdname, (char * const *)argv);
4072 STARTUPINFO StartupInfo;
4073 PROCESS_INFORMATION ProcessInformation;
4076 char *fullcmd = NULL;
4077 char *cname = (char *)cmdname;
4081 clen = strlen(cname);
4082 /* if command name contains dquotes, must remove them */
4083 if (strchr(cname, '"')) {
4085 Newx(cname,clen+1,char);
4098 cmd = create_command_line(cname, clen, argv);
4100 env = PerlEnv_get_childenv();
4101 dir = PerlEnv_get_childdir();
4104 case P_NOWAIT: /* asynch + remember result */
4105 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4110 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4113 create |= CREATE_NEW_PROCESS_GROUP;
4116 case P_WAIT: /* synchronous execution */
4118 default: /* invalid mode */
4123 memset(&StartupInfo,0,sizeof(StartupInfo));
4124 StartupInfo.cb = sizeof(StartupInfo);
4125 memset(&tbl,0,sizeof(tbl));
4126 PerlEnv_get_child_IO(&tbl);
4127 StartupInfo.dwFlags = tbl.dwFlags;
4128 StartupInfo.dwX = tbl.dwX;
4129 StartupInfo.dwY = tbl.dwY;
4130 StartupInfo.dwXSize = tbl.dwXSize;
4131 StartupInfo.dwYSize = tbl.dwYSize;
4132 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4133 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4134 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4135 StartupInfo.wShowWindow = tbl.wShowWindow;
4136 StartupInfo.hStdInput = tbl.childStdIn;
4137 StartupInfo.hStdOutput = tbl.childStdOut;
4138 StartupInfo.hStdError = tbl.childStdErr;
4139 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4140 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4141 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4143 create |= CREATE_NEW_CONSOLE;
4146 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4148 if (w32_use_showwindow) {
4149 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4150 StartupInfo.wShowWindow = w32_showwindow;
4153 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4156 if (!CreateProcess(cname, /* search PATH to find executable */
4157 cmd, /* executable, and its arguments */
4158 NULL, /* process attributes */
4159 NULL, /* thread attributes */
4160 TRUE, /* inherit handles */
4161 create, /* creation flags */
4162 (LPVOID)env, /* inherit environment */
4163 dir, /* inherit cwd */
4165 &ProcessInformation))
4167 /* initial NULL argument to CreateProcess() does a PATH
4168 * search, but it always first looks in the directory
4169 * where the current process was started, which behavior
4170 * is undesirable for backward compatibility. So we
4171 * jump through our own hoops by picking out the path
4172 * we really want it to use. */
4174 fullcmd = qualified_path(cname);
4176 if (cname != cmdname)
4179 DEBUG_p(PerlIO_printf(Perl_debug_log,
4180 "Retrying [%s] with same args\n",
4190 if (mode == P_NOWAIT) {
4191 /* asynchronous spawn -- store handle, return PID */
4192 ret = (int)ProcessInformation.dwProcessId;
4193 if (IsWin95() && ret < 0)
4196 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4197 w32_child_pids[w32_num_children] = (DWORD)ret;
4202 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4203 /* FIXME: if msgwait returned due to message perhaps forward the
4204 "signal" to the process
4206 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4208 CloseHandle(ProcessInformation.hProcess);
4211 CloseHandle(ProcessInformation.hThread);
4214 PerlEnv_free_childenv(env);
4215 PerlEnv_free_childdir(dir);
4217 if (cname != cmdname)
4224 win32_execv(const char *cmdname, const char *const *argv)
4228 /* if this is a pseudo-forked child, we just want to spawn
4229 * the new program, and return */
4231 # ifdef __BORLANDC__
4232 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4234 return spawnv(P_WAIT, cmdname, argv);
4238 return execv(cmdname, (char *const *)argv);
4240 return execv(cmdname, argv);
4245 win32_execvp(const char *cmdname, const char *const *argv)
4249 /* if this is a pseudo-forked child, we just want to spawn
4250 * the new program, and return */
4251 if (w32_pseudo_id) {
4252 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4262 return execvp(cmdname, (char *const *)argv);
4264 return execvp(cmdname, argv);
4269 win32_perror(const char *str)
4275 win32_setbuf(FILE *pf, char *buf)
4281 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4283 return setvbuf(pf, buf, type, size);
4287 win32_flushall(void)
4293 win32_fcloseall(void)
4299 win32_fgets(char *s, int n, FILE *pf)
4301 return fgets(s, n, pf);
4311 win32_fgetc(FILE *pf)
4317 win32_putc(int c, FILE *pf)
4323 win32_puts(const char *s)
4335 win32_putchar(int c)
4342 #ifndef USE_PERL_SBRK
4344 static char *committed = NULL; /* XXX threadead */
4345 static char *base = NULL; /* XXX threadead */
4346 static char *reserved = NULL; /* XXX threadead */
4347 static char *brk = NULL; /* XXX threadead */
4348 static DWORD pagesize = 0; /* XXX threadead */
4351 sbrk(ptrdiff_t need)
4356 GetSystemInfo(&info);
4357 /* Pretend page size is larger so we don't perpetually
4358 * call the OS to commit just one page ...
4360 pagesize = info.dwPageSize << 3;
4362 if (brk+need >= reserved)
4364 DWORD size = brk+need-reserved;
4366 char *prev_committed = NULL;
4367 if (committed && reserved && committed < reserved)
4369 /* Commit last of previous chunk cannot span allocations */
4370 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4373 /* Remember where we committed from in case we want to decommit later */
4374 prev_committed = committed;
4375 committed = reserved;
4378 /* Reserve some (more) space
4379 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4380 * this is only address space not memory...
4381 * Note this is a little sneaky, 1st call passes NULL as reserved
4382 * so lets system choose where we start, subsequent calls pass
4383 * the old end address so ask for a contiguous block
4386 if (size < 64*1024*1024)
4387 size = 64*1024*1024;
4388 size = ((size + pagesize - 1) / pagesize) * pagesize;
4389 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4392 reserved = addr+size;
4402 /* The existing block could not be extended far enough, so decommit
4403 * anything that was just committed above and start anew */
4406 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4409 reserved = base = committed = brk = NULL;
4420 if (brk > committed)
4422 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4424 if (committed+size > reserved)
4425 size = reserved-committed;
4426 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4439 win32_malloc(size_t size)
4441 return malloc(size);
4445 win32_calloc(size_t numitems, size_t size)
4447 return calloc(numitems,size);
4451 win32_realloc(void *block, size_t size)
4453 return realloc(block,size);
4457 win32_free(void *block)
4464 win32_open_osfhandle(intptr_t handle, int flags)
4466 #ifdef USE_FIXED_OSFHANDLE
4468 return my_open_osfhandle(handle, flags);
4470 return _open_osfhandle(handle, flags);
4474 win32_get_osfhandle(int fd)
4476 return (intptr_t)_get_osfhandle(fd);
4480 win32_fdupopen(FILE *pf)
4485 int fileno = win32_dup(win32_fileno(pf));
4487 /* open the file in the same mode */
4489 if((pf)->flags & _F_READ) {
4493 else if((pf)->flags & _F_WRIT) {
4497 else if((pf)->flags & _F_RDWR) {
4503 if((pf)->_flag & _IOREAD) {
4507 else if((pf)->_flag & _IOWRT) {
4511 else if((pf)->_flag & _IORW) {
4518 /* it appears that the binmode is attached to the
4519 * file descriptor so binmode files will be handled
4522 pfdup = win32_fdopen(fileno, mode);
4524 /* move the file pointer to the same position */
4525 if (!fgetpos(pf, &pos)) {
4526 fsetpos(pfdup, &pos);
4532 win32_dynaload(const char* filename)
4535 char buf[MAX_PATH+1];
4538 /* LoadLibrary() doesn't recognize forward slashes correctly,
4539 * so turn 'em back. */
4540 first = strchr(filename, '/');
4542 STRLEN len = strlen(filename);
4543 if (len <= MAX_PATH) {
4544 strcpy(buf, filename);
4545 filename = &buf[first - filename];
4547 if (*filename == '/')
4548 *(char*)filename = '\\';
4554 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4557 XS(w32_SetChildShowWindow)
4560 BOOL use_showwindow = w32_use_showwindow;
4561 /* use "unsigned short" because Perl has redefined "WORD" */
4562 unsigned short showwindow = w32_showwindow;
4565 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4567 if (items == 0 || !SvOK(ST(0)))
4568 w32_use_showwindow = FALSE;
4570 w32_use_showwindow = TRUE;
4571 w32_showwindow = (unsigned short)SvIV(ST(0));
4576 ST(0) = sv_2mortal(newSViv(showwindow));
4578 ST(0) = &PL_sv_undef;
4583 Perl_init_os_extras(void)
4586 char *file = __FILE__;
4588 /* Initialize Win32CORE if it has been statically linked. */
4589 void (*pfn_init)(pTHX);
4590 #if defined(__BORLANDC__)
4591 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4592 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4594 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4599 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4603 win32_signal_context(void)
4608 my_perl = PL_curinterp;
4609 PERL_SET_THX(my_perl);
4613 return PL_curinterp;
4619 win32_ctrlhandler(DWORD dwCtrlType)
4622 dTHXa(PERL_GET_SIG_CONTEXT);
4628 switch(dwCtrlType) {
4629 case CTRL_CLOSE_EVENT:
4630 /* A signal that the system sends to all processes attached to a console when
4631 the user closes the console (either by choosing the Close command from the
4632 console window's System menu, or by choosing the End Task command from the
4635 if (do_raise(aTHX_ 1)) /* SIGHUP */
4636 sig_terminate(aTHX_ 1);
4640 /* A CTRL+c signal was received */
4641 if (do_raise(aTHX_ SIGINT))
4642 sig_terminate(aTHX_ SIGINT);
4645 case CTRL_BREAK_EVENT:
4646 /* A CTRL+BREAK signal was received */
4647 if (do_raise(aTHX_ SIGBREAK))
4648 sig_terminate(aTHX_ SIGBREAK);
4651 case CTRL_LOGOFF_EVENT:
4652 /* A signal that the system sends to all console processes when a user is logging
4653 off. This signal does not indicate which user is logging off, so no
4654 assumptions can be made.
4657 case CTRL_SHUTDOWN_EVENT:
4658 /* A signal that the system sends to all console processes when the system is
4661 if (do_raise(aTHX_ SIGTERM))
4662 sig_terminate(aTHX_ SIGTERM);
4671 #ifdef SET_INVALID_PARAMETER_HANDLER
4672 # include <crtdbg.h>
4683 /* win32_ansipath() requires Windows 2000 or later */
4687 /* fetch Unicode version of PATH */
4689 wide_path = win32_malloc(len*sizeof(WCHAR));
4691 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4695 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4700 /* convert to ANSI pathnames */
4701 wide_dir = wide_path;
4704 WCHAR *sep = wcschr(wide_dir, ';');
4712 /* remove quotes around pathname */
4713 if (*wide_dir == '"')
4715 wide_len = wcslen(wide_dir);
4716 if (wide_len && wide_dir[wide_len-1] == '"')
4717 wide_dir[wide_len-1] = '\0';
4719 /* append ansi_dir to ansi_path */
4720 ansi_dir = win32_ansipath(wide_dir);
4721 ansi_len = strlen(ansi_dir);
4723 size_t newlen = len + 1 + ansi_len;
4724 ansi_path = win32_realloc(ansi_path, newlen+1);
4727 ansi_path[len] = ';';
4728 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4733 ansi_path = win32_malloc(5+len+1);
4736 memcpy(ansi_path, "PATH=", 5);
4737 memcpy(ansi_path+5, ansi_dir, len+1);
4740 win32_free(ansi_dir);
4745 /* Update C RTL environ array. This will only have full effect if
4746 * perl_parse() is later called with `environ` as the `env` argument.
4747 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4749 * We do have to ansify() the PATH before Perl has been fully
4750 * initialized because S_find_script() uses the PATH when perl
4751 * is being invoked with the -S option. This happens before %ENV
4752 * is initialized in S_init_postdump_symbols().
4754 * XXX Is this a bug? Should S_find_script() use the environment
4755 * XXX passed in the `env` arg to parse_perl()?
4758 /* Keep system environment in sync because S_init_postdump_symbols()
4759 * will not call mg_set() if it initializes %ENV from `environ`.
4761 SetEnvironmentVariableA("PATH", ansi_path+5);
4762 /* We are intentionally leaking the ansi_path string here because
4763 * the Borland runtime library puts it directly into the environ
4764 * array. The Microsoft runtime library seems to make a copy,
4765 * but will leak the copy should it be replaced again later.
4766 * Since this code is only called once during PERL_SYS_INIT this
4767 * shouldn't really matter.
4770 win32_free(wide_path);
4774 Perl_win32_init(int *argcp, char ***argvp)
4778 #ifdef SET_INVALID_PARAMETER_HANDLER
4779 _invalid_parameter_handler oldHandler, newHandler;
4780 newHandler = my_invalid_parameter_handler;
4781 oldHandler = _set_invalid_parameter_handler(newHandler);
4782 _CrtSetReportMode(_CRT_ASSERT, 0);
4784 /* Disable floating point errors, Perl will trap the ones we
4785 * care about. VC++ RTL defaults to switching these off
4786 * already, but the Borland RTL doesn't. Since we don't
4787 * want to be at the vendor's whim on the default, we set
4788 * it explicitly here.
4790 #if !defined(_ALPHA_) && !defined(__GNUC__)
4791 _control87(MCW_EM, MCW_EM);
4795 module = GetModuleHandle("ntdll.dll");
4797 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4800 module = GetModuleHandle("kernel32.dll");
4802 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4803 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4804 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4807 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4808 GetVersionEx(&g_osver);
4814 Perl_win32_term(void)
4824 win32_get_child_IO(child_IO_table* ptbl)
4826 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4827 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4828 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4832 win32_signal(int sig, Sighandler_t subcode)
4835 if (sig < SIG_SIZE) {
4836 int save_errno = errno;
4837 Sighandler_t result = signal(sig, subcode);
4838 if (result == SIG_ERR) {
4839 result = w32_sighandler[sig];
4842 w32_sighandler[sig] = subcode;
4851 /* The PerlMessageWindowClass's WindowProc */
4853 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4855 return win32_process_message(hwnd, msg, wParam, lParam) ?
4856 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4859 /* we use a message filter hook to process thread messages, passing any
4860 * messages that we don't process on to the rest of the hook chain
4861 * Anyone else writing a message loop that wants to play nicely with perl
4863 * CallMsgFilter(&msg, MSGF_***);
4864 * between their GetMessage and DispatchMessage calls. */
4866 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4867 LPMSG pmsg = (LPMSG)lParam;
4869 /* we'll process it if code says we're allowed, and it's a thread message */
4870 if (code >= 0 && pmsg->hwnd == NULL
4871 && win32_process_message(pmsg->hwnd, pmsg->message,
4872 pmsg->wParam, pmsg->lParam))
4877 /* XXX: MSDN says that hhk is ignored, but we should really use the
4878 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4879 return CallNextHookEx(NULL, code, wParam, lParam);
4882 /* The real message handler. Can be called with
4883 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4884 * that it processes */
4886 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4888 /* BEWARE. The context retrieved using dTHX; is the context of the
4889 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4890 * up to and including WM_CREATE. If it ever happens that you need the
4891 * 'child' context before this, then it needs to be passed into
4892 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4893 * from the lparam of CreateWindow(). It could then be stored/retrieved
4894 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4895 * the dTHX calls here. */
4896 /* XXX For now it is assumed that the overhead of the dTHX; for what
4897 * are relativley infrequent code-paths, is better than the added
4898 * complexity of getting the correct context passed into
4899 * win32_create_message_window() */
4904 case WM_USER_MESSAGE: {
4905 long child = find_pseudo_pid((int)wParam);
4908 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4915 case WM_USER_KILL: {
4917 /* We use WM_USER_KILL to fake kill() with other signals */
4918 int sig = (int)wParam;
4919 if (do_raise(aTHX_ sig))
4920 sig_terminate(aTHX_ sig);
4927 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4928 if (w32_timerid && w32_timerid==(UINT)wParam) {
4929 KillTimer(w32_message_hwnd, w32_timerid);
4932 /* Now fake a call to signal handler */
4933 if (do_raise(aTHX_ 14))
4934 sig_terminate(aTHX_ 14);
4946 /* Above or other stuff may have set a signal flag, and we may not have
4947 * been called from win32_async_check() (e.g. some other GUI's message
4948 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4949 * handler that die's, and the message loop that calls here is wrapped
4950 * in an eval, then you may well end up with orphaned windows - signals
4951 * are dispatched by win32_async_check() */
4957 win32_create_message_window_class(void)
4959 /* create the window class for "message only" windows */
4963 wc.lpfnWndProc = win32_message_window_proc;
4964 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4965 wc.lpszClassName = "PerlMessageWindowClass";
4967 /* second and subsequent calls will fail, but class
4968 * will already be registered */
4973 win32_create_message_window(void)
4977 /* "message-only" windows have been implemented in Windows 2000 and later.
4978 * On earlier versions we'll continue to post messages to a specific
4979 * thread and use hwnd==NULL. This is brittle when either an embedding
4980 * application or an XS module is also posting messages to hwnd=NULL
4981 * because once removed from the queue they cannot be delivered to the
4982 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4983 * if there is no window handle.
4985 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4986 * documentation to the contrary, however, there is some evidence that
4987 * there may be problems with the implementation on Win98. As it is not
4988 * officially supported we take the cautious route and stick with thread
4989 * messages (hwnd == NULL) on platforms prior to Win2k.
4992 win32_create_message_window_class();
4994 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4995 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4998 /* If we din't create a window for any reason, then we'll use thread
4999 * messages for our signalling, so we install a hook which
5000 * is called by CallMsgFilter in win32_async_check(), or any other
5001 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5002 * that use OLE, etc. */
5004 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5005 NULL, GetCurrentThreadId());
5011 #ifdef HAVE_INTERP_INTERN
5014 win32_csighandler(int sig)
5017 dTHXa(PERL_GET_SIG_CONTEXT);
5018 Perl_warn(aTHX_ "Got signal %d",sig);
5023 #if defined(__MINGW32__) && defined(__cplusplus)
5024 #define CAST_HWND__(x) (HWND__*)(x)
5026 #define CAST_HWND__(x) x
5030 Perl_sys_intern_init(pTHX)
5034 w32_perlshell_tokens = NULL;
5035 w32_perlshell_vec = (char**)NULL;
5036 w32_perlshell_items = 0;
5037 w32_fdpid = newAV();
5038 Newx(w32_children, 1, child_tab);
5039 w32_num_children = 0;
5040 # ifdef USE_ITHREADS
5042 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5043 w32_num_pseudo_children = 0;
5046 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5048 for (i=0; i < SIG_SIZE; i++) {
5049 w32_sighandler[i] = SIG_DFL;
5051 # ifdef MULTIPLICITY
5052 if (my_perl == PL_curinterp) {
5056 /* Force C runtime signal stuff to set its console handler */
5057 signal(SIGINT,win32_csighandler);
5058 signal(SIGBREAK,win32_csighandler);
5060 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5061 * flag. This has the side-effect of disabling Ctrl-C events in all
5062 * processes in this group. At least on Windows NT and later we
5063 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5064 * with a NULL handler. This is not valid on Windows 9X.
5067 SetConsoleCtrlHandler(NULL,FALSE);
5069 /* Push our handler on top */
5070 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5075 Perl_sys_intern_clear(pTHX)
5077 Safefree(w32_perlshell_tokens);
5078 Safefree(w32_perlshell_vec);
5079 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5080 Safefree(w32_children);
5082 KillTimer(w32_message_hwnd, w32_timerid);
5085 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5086 DestroyWindow(w32_message_hwnd);
5087 # ifdef MULTIPLICITY
5088 if (my_perl == PL_curinterp) {
5092 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5094 # ifdef USE_ITHREADS
5095 Safefree(w32_pseudo_children);
5099 # ifdef USE_ITHREADS
5102 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5104 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5106 dst->perlshell_tokens = NULL;
5107 dst->perlshell_vec = (char**)NULL;
5108 dst->perlshell_items = 0;
5109 dst->fdpid = newAV();
5110 Newxz(dst->children, 1, child_tab);
5112 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5114 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5115 dst->poll_count = 0;
5116 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5118 # endif /* USE_ITHREADS */
5119 #endif /* HAVE_INTERP_INTERN */