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
29 #define SystemProcessesAndThreadsInformation 5
31 /* Inline some definitions from the DDK */
42 LARGE_INTEGER CreateTime;
43 LARGE_INTEGER UserTime;
44 LARGE_INTEGER KernelTime;
45 UNICODE_STRING ProcessName;
48 ULONG InheritedFromProcessId;
49 /* Remainder of the structure depends on the Windows version,
50 * but we don't need those additional fields anyways... */
53 /* #include "config.h" */
55 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
63 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 # include <shellapi.h>
67 EXTERN_C LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
71 #define PERL_NO_GET_CONTEXT
77 /* assert.h conflicts with #define of assert in perl.h */
84 #if defined(_MSC_VER) || defined(__MINGW32__)
85 #include <sys/utime.h>
90 /* Mingw32 defaults to globing command line
91 * So we turn it off like this:
96 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
97 /* Mingw32-1.1 is missing some prototypes */
99 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
100 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
101 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
107 #if defined(__BORLANDC__)
109 # define _utimbuf utimbuf
113 #define EXECF_SPAWN 2
114 #define EXECF_SPAWN_NOWAIT 3
116 #if defined(PERL_IMPLICIT_SYS)
117 # undef win32_get_privlib
118 # define win32_get_privlib g_win32_get_privlib
119 # undef win32_get_sitelib
120 # define win32_get_sitelib g_win32_get_sitelib
121 # undef win32_get_vendorlib
122 # define win32_get_vendorlib g_win32_get_vendorlib
124 # define getlogin g_getlogin
127 static void get_shell(void);
128 static long tokenize(const char *str, char **dest, char ***destv);
129 static int do_spawn2(pTHX_ const char *cmd, int exectype);
130 static BOOL has_shell_metachars(const char *ptr);
131 static long filetime_to_clock(PFILETIME ft);
132 static BOOL filetime_from_time(PFILETIME ft, time_t t);
133 static char * get_emd_part(SV **leading, char *trailing, ...);
134 static void remove_dead_process(long deceased);
135 static long find_pid(int pid);
136 static char * qualified_path(const char *cmd);
137 static char * win32_get_xlib(const char *pl, const char *xlib,
138 const char *libname);
141 static void remove_dead_pseudo_process(long child);
142 static long find_pseudo_pid(int pid);
146 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
147 char w32_module_name[MAX_PATH+1];
150 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
152 static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
153 static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
154 static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
155 static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
158 /* Silence STDERR grumblings from Borland's math library. */
160 _matherr(struct _exception *a)
168 void my_invalid_parameter_handler(const wchar_t* expression,
169 const wchar_t* function,
175 wprintf(L"Invalid parameter detected in function %s."
176 L" File: %s Line: %d\n", function, file, line);
177 wprintf(L"Expression: %s\n", expression);
185 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
191 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
195 win32_ansipath(const WCHAR *widename);
198 set_w32_module_name(void)
200 /* this function may be called at DLL_PROCESS_ATTACH time */
202 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
203 ? GetModuleHandle(NULL)
204 : w32_perldll_handle);
206 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
207 osver.dwOSVersionInfoSize = sizeof(osver);
208 GetVersionEx(&osver);
210 if (osver.dwPlatformId == VER_PLATFORM_WIN32_NT) {
211 WCHAR modulename[MAX_PATH];
212 WCHAR fullname[MAX_PATH];
215 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
217 /* Make sure we get an absolute pathname in case the module was loaded
218 * explicitly by LoadLibrary() with a relative path. */
219 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
221 /* remove \\?\ prefix */
222 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
223 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
225 ansi = win32_ansipath(fullname);
226 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
230 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
232 /* remove \\?\ prefix */
233 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
234 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
236 /* try to get full path to binary (which may be mangled when perl is
237 * run from a 16-bit app) */
238 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
239 win32_longpath(w32_module_name);
240 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
243 /* normalize to forward slashes */
244 ptr = w32_module_name;
252 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
254 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
256 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
259 const char *subkey = "Software\\Perl";
263 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
264 if (retval == ERROR_SUCCESS) {
266 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
267 if (retval == ERROR_SUCCESS
268 && (type == REG_SZ || type == REG_EXPAND_SZ))
272 *svp = sv_2mortal(newSVpvn("",0));
273 SvGROW(*svp, datalen);
274 retval = RegQueryValueEx(handle, valuename, 0, NULL,
275 (PBYTE)SvPVX(*svp), &datalen);
276 if (retval == ERROR_SUCCESS) {
278 SvCUR_set(*svp,datalen-1);
286 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
288 get_regstr(const char *valuename, SV **svp)
290 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
292 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
296 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
298 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
302 char mod_name[MAX_PATH+1];
308 va_start(ap, trailing_path);
309 strip = va_arg(ap, char *);
311 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
312 baselen = strlen(base);
314 if (!*w32_module_name) {
315 set_w32_module_name();
317 strcpy(mod_name, w32_module_name);
318 ptr = strrchr(mod_name, '/');
319 while (ptr && strip) {
320 /* look for directories to skip back */
323 ptr = strrchr(mod_name, '/');
324 /* avoid stripping component if there is no slash,
325 * or it doesn't match ... */
326 if (!ptr || stricmp(ptr+1, strip) != 0) {
327 /* ... but not if component matches m|5\.$patchlevel.*| */
328 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
329 && strncmp(strip, base, baselen) == 0
330 && strncmp(ptr+1, base, baselen) == 0))
336 strip = va_arg(ap, char *);
344 strcpy(++ptr, trailing_path);
346 /* only add directory if it exists */
347 if (GetFileAttributes(mod_name) != (DWORD) -1) {
348 /* directory exists */
351 *prev_pathp = sv_2mortal(newSVpvn("",0));
352 else if (SvPVX(*prev_pathp))
353 sv_catpvn(*prev_pathp, ";", 1);
354 sv_catpv(*prev_pathp, mod_name);
355 return SvPVX(*prev_pathp);
362 win32_get_privlib(const char *pl)
365 char *stdlib = "lib";
366 char buffer[MAX_PATH+1];
369 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
370 sprintf(buffer, "%s-%s", stdlib, pl);
371 if (!get_regstr(buffer, &sv))
372 (void)get_regstr(stdlib, &sv);
374 /* $stdlib .= ";$EMD/../../lib" */
375 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
379 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
383 char pathstr[MAX_PATH+1];
387 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
388 sprintf(regstr, "%s-%s", xlib, pl);
389 (void)get_regstr(regstr, &sv1);
392 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
393 sprintf(pathstr, "%s/%s/lib", libname, pl);
394 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
396 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
397 (void)get_regstr(xlib, &sv2);
400 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
401 sprintf(pathstr, "%s/lib", libname);
402 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
411 sv_catpvn(sv1, ";", 1);
418 win32_get_sitelib(const char *pl)
420 return win32_get_xlib(pl, "sitelib", "site");
423 #ifndef PERL_VENDORLIB_NAME
424 # define PERL_VENDORLIB_NAME "vendor"
428 win32_get_vendorlib(const char *pl)
430 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
434 has_shell_metachars(const char *ptr)
440 * Scan string looking for redirection (< or >) or pipe
441 * characters (|) that are not in a quoted string.
442 * Shell variable interpolation (%VAR%) can also happen inside strings.
474 #if !defined(PERL_IMPLICIT_SYS)
475 /* since the current process environment is being updated in util.c
476 * the library functions will get the correct environment
479 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
482 #define fixcmd(x) { \
483 char *pspace = strchr((x),' '); \
486 while (p < pspace) { \
497 PERL_FLUSHALL_FOR_CHILD;
498 return win32_popen(cmd, mode);
502 Perl_my_pclose(pTHX_ PerlIO *fp)
504 return win32_pclose(fp);
508 DllExport unsigned long
511 return (unsigned long)g_osver.dwPlatformId;
521 return -((int)w32_pseudo_id);
524 /* Windows 9x appears to always reports a pid for threads and processes
525 * that has the high bit set. So we treat the lower 31 bits as the
526 * "real" PID for Perl's purposes. */
527 if (IsWin95() && pid < 0)
532 /* Tokenize a string. Words are null-separated, and the list
533 * ends with a doubled null. Any character (except null and
534 * including backslash) may be escaped by preceding it with a
535 * backslash (the backslash will be stripped).
536 * Returns number of words in result buffer.
539 tokenize(const char *str, char **dest, char ***destv)
541 char *retstart = Nullch;
542 char **retvstart = 0;
546 int slen = strlen(str);
548 register char **retv;
549 Newx(ret, slen+2, char);
550 Newx(retv, (slen+3)/2, char*);
558 if (*ret == '\\' && *str)
560 else if (*ret == ' ') {
576 retvstart[items] = Nullch;
589 if (!w32_perlshell_tokens) {
590 /* we don't use COMSPEC here for two reasons:
591 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
592 * uncontrolled unportability of the ensuing scripts.
593 * 2. PERL5SHELL could be set to a shell that may not be fit for
594 * interactive use (which is what most programs look in COMSPEC
597 const char* defaultshell = (IsWinNT()
598 ? "cmd.exe /x/d/c" : "command.com /c");
599 const char *usershell = PerlEnv_getenv("PERL5SHELL");
600 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
601 &w32_perlshell_tokens,
607 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
619 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
621 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
626 while (++mark <= sp) {
627 if (*mark && (str = SvPV_nolen(*mark)))
634 status = win32_spawnvp(flag,
635 (const char*)(really ? SvPV_nolen(really) : argv[0]),
636 (const char* const*)argv);
638 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
639 /* possible shell-builtin, invoke with shell */
641 sh_items = w32_perlshell_items;
643 argv[index+sh_items] = argv[index];
644 while (--sh_items >= 0)
645 argv[sh_items] = w32_perlshell_vec[sh_items];
647 status = win32_spawnvp(flag,
648 (const char*)(really ? SvPV_nolen(really) : argv[0]),
649 (const char* const*)argv);
652 if (flag == P_NOWAIT) {
654 PL_statusvalue = -1; /* >16bits hint for pp_system() */
658 if (ckWARN(WARN_EXEC))
659 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
664 PL_statusvalue = status;
670 /* returns pointer to the next unquoted space or the end of the string */
672 find_next_space(const char *s)
674 bool in_quotes = FALSE;
676 /* ignore doubled backslashes, or backslash+quote */
677 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
680 /* keep track of when we're within quotes */
681 else if (*s == '"') {
683 in_quotes = !in_quotes;
685 /* break it up only at spaces that aren't in quotes */
686 else if (!in_quotes && isSPACE(*s))
695 do_spawn2(pTHX_ const char *cmd, int exectype)
701 BOOL needToTry = TRUE;
704 /* Save an extra exec if possible. See if there are shell
705 * metacharacters in it */
706 if (!has_shell_metachars(cmd)) {
707 Newx(argv, strlen(cmd) / 2 + 2, char*);
708 Newx(cmd2, strlen(cmd) + 1, char);
711 for (s = cmd2; *s;) {
712 while (*s && isSPACE(*s))
716 s = find_next_space(s);
724 status = win32_spawnvp(P_WAIT, argv[0],
725 (const char* const*)argv);
727 case EXECF_SPAWN_NOWAIT:
728 status = win32_spawnvp(P_NOWAIT, argv[0],
729 (const char* const*)argv);
732 status = win32_execvp(argv[0], (const char* const*)argv);
735 if (status != -1 || errno == 0)
745 Newx(argv, w32_perlshell_items + 2, char*);
746 while (++i < w32_perlshell_items)
747 argv[i] = w32_perlshell_vec[i];
748 argv[i++] = (char *)cmd;
752 status = win32_spawnvp(P_WAIT, argv[0],
753 (const char* const*)argv);
755 case EXECF_SPAWN_NOWAIT:
756 status = win32_spawnvp(P_NOWAIT, argv[0],
757 (const char* const*)argv);
760 status = win32_execvp(argv[0], (const char* const*)argv);
766 if (exectype == EXECF_SPAWN_NOWAIT) {
768 PL_statusvalue = -1; /* >16bits hint for pp_system() */
772 if (ckWARN(WARN_EXEC))
773 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
774 (exectype == EXECF_EXEC ? "exec" : "spawn"),
775 cmd, strerror(errno));
780 PL_statusvalue = status;
786 Perl_do_spawn(pTHX_ char *cmd)
788 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
792 Perl_do_spawn_nowait(pTHX_ char *cmd)
794 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
798 Perl_do_exec(pTHX_ const char *cmd)
800 do_spawn2(aTHX_ cmd, EXECF_EXEC);
804 /* The idea here is to read all the directory names into a string table
805 * (separated by nulls) and when one of the other dir functions is called
806 * return the pointer to the current file name.
809 win32_opendir(const char *filename)
815 char scanname[MAX_PATH+3];
817 WIN32_FIND_DATAA aFindData;
818 WIN32_FIND_DATAW wFindData;
820 char buffer[MAX_PATH*2];
823 len = strlen(filename);
827 /* check to see if filename is a directory */
828 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
831 /* Get us a DIR structure */
834 /* Create the search pattern */
835 strcpy(scanname, filename);
837 /* bare drive name means look in cwd for drive */
838 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
839 scanname[len++] = '.';
840 scanname[len++] = '/';
842 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
843 scanname[len++] = '/';
845 scanname[len++] = '*';
846 scanname[len] = '\0';
848 /* do the FindFirstFile call */
850 WCHAR wscanname[sizeof(scanname)];
851 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
852 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
856 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
858 if (dirp->handle == INVALID_HANDLE_VALUE) {
859 DWORD err = GetLastError();
860 /* FindFirstFile() fails on empty drives! */
862 case ERROR_FILE_NOT_FOUND:
864 case ERROR_NO_MORE_FILES:
865 case ERROR_PATH_NOT_FOUND:
868 case ERROR_NOT_ENOUGH_MEMORY:
880 BOOL use_default = FALSE;
881 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
882 wFindData.cFileName, -1,
883 buffer, sizeof(buffer), NULL, &use_default);
884 if (use_default && *wFindData.cAlternateFileName) {
885 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
886 wFindData.cAlternateFileName, -1,
887 buffer, sizeof(buffer), NULL, NULL);
892 ptr = aFindData.cFileName;
894 /* now allocate the first part of the string table for
895 * the filenames that we find.
902 Newx(dirp->start, dirp->size, char);
903 strcpy(dirp->start, ptr);
905 dirp->end = dirp->curr = dirp->start;
911 /* Readdir just returns the current string pointer and bumps the
912 * string pointer to the nDllExport entry.
914 DllExport struct direct *
915 win32_readdir(DIR *dirp)
920 /* first set up the structure to return */
921 len = strlen(dirp->curr);
922 strcpy(dirp->dirstr.d_name, dirp->curr);
923 dirp->dirstr.d_namlen = len;
926 dirp->dirstr.d_ino = dirp->curr - dirp->start;
928 /* Now set up for the next call to readdir */
929 dirp->curr += len + 1;
930 if (dirp->curr >= dirp->end) {
933 WIN32_FIND_DATAA aFindData;
934 char buffer[MAX_PATH*2];
937 /* finding the next file that matches the wildcard
938 * (which should be all of them in this directory!).
941 WIN32_FIND_DATAW wFindData;
942 res = FindNextFileW(dirp->handle, &wFindData);
944 BOOL use_default = FALSE;
945 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
946 wFindData.cFileName, -1,
947 buffer, sizeof(buffer), NULL, &use_default);
948 if (use_default && *wFindData.cAlternateFileName) {
949 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
950 wFindData.cAlternateFileName, -1,
951 buffer, sizeof(buffer), NULL, NULL);
957 res = FindNextFileA(dirp->handle, &aFindData);
958 ptr = aFindData.cFileName;
961 long endpos = dirp->end - dirp->start;
962 long newsize = endpos + strlen(ptr) + 1;
963 /* bump the string table size by enough for the
964 * new name and its null terminator */
965 while (newsize > dirp->size) {
966 long curpos = dirp->curr - dirp->start;
968 Renew(dirp->start, dirp->size, char);
969 dirp->curr = dirp->start + curpos;
971 strcpy(dirp->start + endpos, ptr);
972 dirp->end = dirp->start + newsize;
978 return &(dirp->dirstr);
984 /* Telldir returns the current string pointer position */
986 win32_telldir(DIR *dirp)
988 return (dirp->curr - dirp->start);
992 /* Seekdir moves the string pointer to a previously saved position
993 * (returned by telldir).
996 win32_seekdir(DIR *dirp, long loc)
998 dirp->curr = dirp->start + loc;
1001 /* Rewinddir resets the string pointer to the start */
1003 win32_rewinddir(DIR *dirp)
1005 dirp->curr = dirp->start;
1008 /* free the memory allocated by opendir */
1010 win32_closedir(DIR *dirp)
1013 if (dirp->handle != INVALID_HANDLE_VALUE)
1014 FindClose(dirp->handle);
1015 Safefree(dirp->start);
1028 * Just pretend that everyone is a superuser. NT will let us know if
1029 * we don\'t really have permission to do something.
1032 #define ROOT_UID ((uid_t)0)
1033 #define ROOT_GID ((gid_t)0)
1062 return (auid == ROOT_UID ? 0 : -1);
1068 return (agid == ROOT_GID ? 0 : -1);
1075 char *buf = w32_getlogin_buffer;
1076 DWORD size = sizeof(w32_getlogin_buffer);
1077 if (GetUserName(buf,&size))
1083 chown(const char *path, uid_t owner, gid_t group)
1090 * XXX this needs strengthening (for PerlIO)
1093 int mkstemp(const char *path)
1096 char buf[MAX_PATH+1];
1100 if (i++ > 10) { /* give up */
1104 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1108 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1118 long child = w32_num_children;
1119 while (--child >= 0) {
1120 if ((int)w32_child_pids[child] == pid)
1127 remove_dead_process(long child)
1131 CloseHandle(w32_child_handles[child]);
1132 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1133 (w32_num_children-child-1), HANDLE);
1134 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1135 (w32_num_children-child-1), DWORD);
1142 find_pseudo_pid(int pid)
1145 long child = w32_num_pseudo_children;
1146 while (--child >= 0) {
1147 if ((int)w32_pseudo_child_pids[child] == pid)
1154 remove_dead_pseudo_process(long child)
1158 CloseHandle(w32_pseudo_child_handles[child]);
1159 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1160 (w32_num_pseudo_children-child-1), HANDLE);
1161 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1162 (w32_num_pseudo_children-child-1), DWORD);
1163 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1164 (w32_num_pseudo_children-child-1), HWND);
1165 w32_num_pseudo_children--;
1171 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1175 /* "Does process exist?" use of kill */
1178 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1183 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1186 default: /* For now be backwards compatible with perl 5.6 */
1188 /* Note that we will only be able to kill processes owned by the
1189 * current process owner, even when we are running as an administrator.
1190 * To kill processes of other owners we would need to set the
1191 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1193 if (TerminateProcess(process_handle, sig))
1200 /* Traverse process tree using ToolHelp functions */
1202 kill_process_tree_toolhelp(DWORD pid, int sig)
1204 HANDLE process_handle;
1205 HANDLE snapshot_handle;
1208 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1209 if (process_handle == INVALID_HANDLE_VALUE)
1212 killed += terminate_process(pid, process_handle, sig);
1214 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1215 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1216 PROCESSENTRY32 entry;
1218 entry.dwSize = sizeof(entry);
1219 if (pfnProcess32First(snapshot_handle, &entry)) {
1221 if (entry.th32ParentProcessID == pid)
1222 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1223 entry.dwSize = sizeof(entry);
1225 while (pfnProcess32Next(snapshot_handle, &entry));
1227 CloseHandle(snapshot_handle);
1229 CloseHandle(process_handle);
1233 /* Traverse process tree using undocumented system information structures.
1234 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1237 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1239 HANDLE process_handle;
1240 SYSTEM_PROCESSES *p = process_info;
1243 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1244 if (process_handle == INVALID_HANDLE_VALUE)
1247 killed += terminate_process(pid, process_handle, sig);
1250 if (p->InheritedFromProcessId == (DWORD)pid)
1251 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1253 if (p->NextEntryDelta == 0)
1256 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1259 CloseHandle(process_handle);
1264 killpg(int pid, int sig)
1266 /* Use "documented" method whenever available */
1267 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1268 return kill_process_tree_toolhelp((DWORD)pid, sig);
1271 /* Fall back to undocumented Windows internals on Windows NT */
1272 if (pfnZwQuerySystemInformation) {
1277 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1278 Newx(buffer, size, char);
1280 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1281 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1290 my_kill(int pid, int sig)
1293 HANDLE process_handle;
1296 return killpg(pid, -sig);
1298 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1299 if (process_handle != INVALID_HANDLE_VALUE) {
1300 retval = terminate_process(pid, process_handle, sig);
1301 CloseHandle(process_handle);
1307 win32_kill(int pid, int sig)
1313 /* it is a pseudo-forked child */
1314 child = find_pseudo_pid(-pid);
1316 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1317 HANDLE hProcess = w32_pseudo_child_handles[child];
1320 /* "Does process exist?" use of kill */
1324 /* kill -9 style un-graceful exit */
1325 if (TerminateThread(hProcess, sig)) {
1326 remove_dead_pseudo_process(child);
1333 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1334 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1335 /* Yield and wait for the other thread to send us its message_hwnd */
1337 win32_async_check(aTHX);
1340 if (hwnd != INVALID_HANDLE_VALUE) {
1341 /* We fake signals to pseudo-processes using Win32
1342 * message queue. In Win9X the pids are negative already. */
1343 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1344 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1346 /* It might be us ... */
1355 else if (IsWin95()) {
1363 child = find_pid(pid);
1365 if (my_kill(pid, sig)) {
1367 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1368 exitcode != STILL_ACTIVE)
1370 remove_dead_process(child);
1377 if (my_kill((IsWin95() ? -pid : pid), sig))
1386 win32_stat(const char *path, Stat_t *sbuf)
1389 char buffer[MAX_PATH+1];
1390 int l = strlen(path);
1393 BOOL expect_dir = FALSE;
1395 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1396 GV_NOTQUAL, SVt_PV);
1397 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1400 switch(path[l - 1]) {
1401 /* FindFirstFile() and stat() are buggy with a trailing
1402 * slashes, except for the root directory of a drive */
1405 if (l > sizeof(buffer)) {
1406 errno = ENAMETOOLONG;
1410 strncpy(buffer, path, l);
1411 /* remove additional trailing slashes */
1412 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1414 /* add back slash if we otherwise end up with just a drive letter */
1415 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1422 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1424 if (l == 2 && isALPHA(path[0])) {
1425 buffer[0] = path[0];
1436 path = PerlDir_mapA(path);
1440 /* We must open & close the file once; otherwise file attribute changes */
1441 /* might not yet have propagated to "other" hard links of the same file. */
1442 /* This also gives us an opportunity to determine the number of links. */
1443 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1444 if (handle != INVALID_HANDLE_VALUE) {
1445 BY_HANDLE_FILE_INFORMATION bhi;
1446 if (GetFileInformationByHandle(handle, &bhi))
1447 nlink = bhi.nNumberOfLinks;
1448 CloseHandle(handle);
1452 /* path will be mapped correctly above */
1453 #if defined(WIN64) || defined(USE_LARGE_FILES)
1454 res = _stati64(path, sbuf);
1456 res = stat(path, sbuf);
1458 sbuf->st_nlink = nlink;
1461 /* CRT is buggy on sharenames, so make sure it really isn't.
1462 * XXX using GetFileAttributesEx() will enable us to set
1463 * sbuf->st_*time (but note that's not available on the
1464 * Windows of 1995) */
1465 DWORD r = GetFileAttributesA(path);
1466 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1467 /* sbuf may still contain old garbage since stat() failed */
1468 Zero(sbuf, 1, Stat_t);
1469 sbuf->st_mode = S_IFDIR | S_IREAD;
1471 if (!(r & FILE_ATTRIBUTE_READONLY))
1472 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1477 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1478 && (path[2] == '\\' || path[2] == '/'))
1480 /* The drive can be inaccessible, some _stat()s are buggy */
1481 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1486 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1491 if (S_ISDIR(sbuf->st_mode))
1492 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1493 else if (S_ISREG(sbuf->st_mode)) {
1495 if (l >= 4 && path[l-4] == '.') {
1496 const char *e = path + l - 3;
1497 if (strnicmp(e,"exe",3)
1498 && strnicmp(e,"bat",3)
1499 && strnicmp(e,"com",3)
1500 && (IsWin95() || strnicmp(e,"cmd",3)))
1501 sbuf->st_mode &= ~S_IEXEC;
1503 sbuf->st_mode |= S_IEXEC;
1506 sbuf->st_mode &= ~S_IEXEC;
1507 /* Propagate permissions to _group_ and _others_ */
1508 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1509 sbuf->st_mode |= (perms>>3) | (perms>>6);
1516 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1517 #define SKIP_SLASHES(s) \
1519 while (*(s) && isSLASH(*(s))) \
1522 #define COPY_NONSLASHES(d,s) \
1524 while (*(s) && !isSLASH(*(s))) \
1528 /* Find the longname of a given path. path is destructively modified.
1529 * It should have space for at least MAX_PATH characters. */
1531 win32_longpath(char *path)
1533 WIN32_FIND_DATA fdata;
1535 char tmpbuf[MAX_PATH+1];
1536 char *tmpstart = tmpbuf;
1543 if (isALPHA(path[0]) && path[1] == ':') {
1545 *tmpstart++ = path[0];
1549 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1551 *tmpstart++ = path[0];
1552 *tmpstart++ = path[1];
1553 SKIP_SLASHES(start);
1554 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1556 *tmpstart++ = *start++;
1557 SKIP_SLASHES(start);
1558 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1563 /* copy initial slash, if any */
1564 if (isSLASH(*start)) {
1565 *tmpstart++ = *start++;
1567 SKIP_SLASHES(start);
1570 /* FindFirstFile() expands "." and "..", so we need to pass
1571 * those through unmolested */
1573 && (!start[1] || isSLASH(start[1])
1574 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1576 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1581 /* if this is the end, bust outta here */
1585 /* now we're at a non-slash; walk up to next slash */
1586 while (*start && !isSLASH(*start))
1589 /* stop and find full name of component */
1592 fhand = FindFirstFile(path,&fdata);
1594 if (fhand != INVALID_HANDLE_VALUE) {
1595 STRLEN len = strlen(fdata.cFileName);
1596 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1597 strcpy(tmpstart, fdata.cFileName);
1608 /* failed a step, just return without side effects */
1609 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1614 strcpy(path,tmpbuf);
1623 /* Can't use PerlIO to write as it allocates memory */
1624 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1625 PL_no_mem, strlen(PL_no_mem));
1631 /* The win32_ansipath() function takes a Unicode filename and converts it
1632 * into the current Windows codepage. If some characters cannot be mapped,
1633 * then it will convert the short name instead.
1635 * The buffer to the ansi pathname must be freed with win32_free() when it
1636 * it no longer needed.
1638 * The argument to win32_ansipath() must exist before this function is
1639 * called; otherwise there is no way to determine the short path name.
1641 * Ideas for future refinement:
1642 * - Only convert those segments of the path that are not in the current
1643 * codepage, but leave the other segments in their long form.
1644 * - If the resulting name is longer than MAX_PATH, start converting
1645 * additional path segments into short names until the full name
1646 * is shorter than MAX_PATH. Shorten the filename part last!
1649 win32_ansipath(const WCHAR *widename)
1652 BOOL use_default = FALSE;
1653 size_t widelen = wcslen(widename)+1;
1654 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1655 NULL, 0, NULL, NULL);
1656 name = win32_malloc(len);
1660 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1661 name, len, NULL, &use_default);
1663 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1665 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1668 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1670 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1671 NULL, 0, NULL, NULL);
1672 name = win32_realloc(name, len);
1675 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1676 name, len, NULL, NULL);
1677 win32_free(shortname);
1684 win32_getenv(const char *name)
1688 SV *curitem = Nullsv;
1690 needlen = GetEnvironmentVariableA(name,NULL,0);
1692 curitem = sv_2mortal(newSVpvn("", 0));
1694 SvGROW(curitem, needlen+1);
1695 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1697 } while (needlen >= SvLEN(curitem));
1698 SvCUR_set(curitem, needlen);
1701 /* allow any environment variables that begin with 'PERL'
1702 to be stored in the registry */
1703 if (strncmp(name, "PERL", 4) == 0)
1704 (void)get_regstr(name, &curitem);
1706 if (curitem && SvCUR(curitem))
1707 return SvPVX(curitem);
1713 win32_putenv(const char *name)
1721 Newx(curitem,strlen(name)+1,char);
1722 strcpy(curitem, name);
1723 val = strchr(curitem, '=');
1725 /* The sane way to deal with the environment.
1726 * Has these advantages over putenv() & co.:
1727 * * enables us to store a truly empty value in the
1728 * environment (like in UNIX).
1729 * * we don't have to deal with RTL globals, bugs and leaks.
1731 * Why you may want to enable USE_WIN32_RTL_ENV:
1732 * * environ[] and RTL functions will not reflect changes,
1733 * which might be an issue if extensions want to access
1734 * the env. via RTL. This cuts both ways, since RTL will
1735 * not see changes made by extensions that call the Win32
1736 * functions directly, either.
1740 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1749 filetime_to_clock(PFILETIME ft)
1751 __int64 qw = ft->dwHighDateTime;
1753 qw |= ft->dwLowDateTime;
1754 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1759 win32_times(struct tms *timebuf)
1764 clock_t process_time_so_far = clock();
1765 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1767 timebuf->tms_utime = filetime_to_clock(&user);
1768 timebuf->tms_stime = filetime_to_clock(&kernel);
1769 timebuf->tms_cutime = 0;
1770 timebuf->tms_cstime = 0;
1772 /* That failed - e.g. Win95 fallback to clock() */
1773 timebuf->tms_utime = process_time_so_far;
1774 timebuf->tms_stime = 0;
1775 timebuf->tms_cutime = 0;
1776 timebuf->tms_cstime = 0;
1778 return process_time_so_far;
1781 /* fix utime() so it works on directories in NT */
1783 filetime_from_time(PFILETIME pFileTime, time_t Time)
1785 struct tm *pTM = localtime(&Time);
1786 SYSTEMTIME SystemTime;
1792 SystemTime.wYear = pTM->tm_year + 1900;
1793 SystemTime.wMonth = pTM->tm_mon + 1;
1794 SystemTime.wDay = pTM->tm_mday;
1795 SystemTime.wHour = pTM->tm_hour;
1796 SystemTime.wMinute = pTM->tm_min;
1797 SystemTime.wSecond = pTM->tm_sec;
1798 SystemTime.wMilliseconds = 0;
1800 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1801 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1805 win32_unlink(const char *filename)
1811 filename = PerlDir_mapA(filename);
1812 attrs = GetFileAttributesA(filename);
1813 if (attrs == 0xFFFFFFFF) {
1817 if (attrs & FILE_ATTRIBUTE_READONLY) {
1818 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1819 ret = unlink(filename);
1821 (void)SetFileAttributesA(filename, attrs);
1824 ret = unlink(filename);
1829 win32_utime(const char *filename, struct utimbuf *times)
1836 struct utimbuf TimeBuffer;
1839 filename = PerlDir_mapA(filename);
1840 rc = utime(filename, times);
1842 /* EACCES: path specifies directory or readonly file */
1843 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1846 if (times == NULL) {
1847 times = &TimeBuffer;
1848 time(×->actime);
1849 times->modtime = times->actime;
1852 /* This will (and should) still fail on readonly files */
1853 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1854 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1855 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1856 if (handle == INVALID_HANDLE_VALUE)
1859 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1860 filetime_from_time(&ftAccess, times->actime) &&
1861 filetime_from_time(&ftWrite, times->modtime) &&
1862 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1867 CloseHandle(handle);
1872 unsigned __int64 ft_i64;
1877 #define Const64(x) x##LL
1879 #define Const64(x) x##i64
1881 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1882 #define EPOCH_BIAS Const64(116444736000000000)
1884 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1885 * and appears to be unsupported even by glibc) */
1887 win32_gettimeofday(struct timeval *tp, void *not_used)
1891 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1892 GetSystemTimeAsFileTime(&ft.ft_val);
1894 /* seconds since epoch */
1895 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1897 /* microseconds remaining */
1898 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1904 win32_uname(struct utsname *name)
1906 struct hostent *hep;
1907 STRLEN nodemax = sizeof(name->nodename)-1;
1910 switch (g_osver.dwPlatformId) {
1911 case VER_PLATFORM_WIN32_WINDOWS:
1912 strcpy(name->sysname, "Windows");
1914 case VER_PLATFORM_WIN32_NT:
1915 strcpy(name->sysname, "Windows NT");
1917 case VER_PLATFORM_WIN32s:
1918 strcpy(name->sysname, "Win32s");
1921 strcpy(name->sysname, "Win32 Unknown");
1926 sprintf(name->release, "%d.%d",
1927 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1930 sprintf(name->version, "Build %d",
1931 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1932 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1933 if (g_osver.szCSDVersion[0]) {
1934 char *buf = name->version + strlen(name->version);
1935 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1939 hep = win32_gethostbyname("localhost");
1941 STRLEN len = strlen(hep->h_name);
1942 if (len <= nodemax) {
1943 strcpy(name->nodename, hep->h_name);
1946 strncpy(name->nodename, hep->h_name, nodemax);
1947 name->nodename[nodemax] = '\0';
1952 if (!GetComputerName(name->nodename, &sz))
1953 *name->nodename = '\0';
1956 /* machine (architecture) */
1961 GetSystemInfo(&info);
1963 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1964 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1965 procarch = info.u.s.wProcessorArchitecture;
1967 procarch = info.wProcessorArchitecture;
1970 case PROCESSOR_ARCHITECTURE_INTEL:
1971 arch = "x86"; break;
1972 case PROCESSOR_ARCHITECTURE_MIPS:
1973 arch = "mips"; break;
1974 case PROCESSOR_ARCHITECTURE_ALPHA:
1975 arch = "alpha"; break;
1976 case PROCESSOR_ARCHITECTURE_PPC:
1977 arch = "ppc"; break;
1978 #ifdef PROCESSOR_ARCHITECTURE_SHX
1979 case PROCESSOR_ARCHITECTURE_SHX:
1980 arch = "shx"; break;
1982 #ifdef PROCESSOR_ARCHITECTURE_ARM
1983 case PROCESSOR_ARCHITECTURE_ARM:
1984 arch = "arm"; break;
1986 #ifdef PROCESSOR_ARCHITECTURE_IA64
1987 case PROCESSOR_ARCHITECTURE_IA64:
1988 arch = "ia64"; break;
1990 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1991 case PROCESSOR_ARCHITECTURE_ALPHA64:
1992 arch = "alpha64"; break;
1994 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1995 case PROCESSOR_ARCHITECTURE_MSIL:
1996 arch = "msil"; break;
1998 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1999 case PROCESSOR_ARCHITECTURE_AMD64:
2000 arch = "amd64"; break;
2002 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2003 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2004 arch = "ia32-64"; break;
2006 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2007 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2008 arch = "unknown"; break;
2011 sprintf(name->machine, "unknown(0x%x)", procarch);
2012 arch = name->machine;
2015 if (name->machine != arch)
2016 strcpy(name->machine, arch);
2021 /* Timing related stuff */
2024 do_raise(pTHX_ int sig)
2026 if (sig < SIG_SIZE) {
2027 Sighandler_t handler = w32_sighandler[sig];
2028 if (handler == SIG_IGN) {
2031 else if (handler != SIG_DFL) {
2036 /* Choose correct default behaviour */
2052 /* Tell caller to exit thread/process as approriate */
2057 sig_terminate(pTHX_ int sig)
2059 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2060 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2067 win32_async_check(pTHX)
2070 HWND hwnd = w32_message_hwnd;
2074 if (hwnd == INVALID_HANDLE_VALUE) {
2075 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2076 * This is necessary when we are being called by win32_msgwait() to
2077 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2078 * message over and over. An example how this can happen is when
2079 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2080 * is generating messages before the process terminated.
2082 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2088 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
2089 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2094 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2095 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2097 switch (msg.message) {
2099 case WM_USER_MESSAGE: {
2100 int child = find_pseudo_pid(msg.wParam);
2102 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
2107 case WM_USER_KILL: {
2108 /* We use WM_USER to fake kill() with other signals */
2109 int sig = msg.wParam;
2110 if (do_raise(aTHX_ sig))
2111 sig_terminate(aTHX_ sig);
2116 /* alarm() is a one-shot but SetTimer() repeats so kill it */
2117 if (w32_timerid && w32_timerid==msg.wParam) {
2118 KillTimer(w32_message_hwnd, w32_timerid);
2121 /* Now fake a call to signal handler */
2122 if (do_raise(aTHX_ 14))
2123 sig_terminate(aTHX_ 14);
2130 /* Above or other stuff may have set a signal flag */
2131 if (PL_sig_pending) {
2137 /* This function will not return until the timeout has elapsed, or until
2138 * one of the handles is ready. */
2140 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2142 /* We may need several goes at this - so compute when we stop */
2144 if (timeout != INFINITE) {
2145 ticks = GetTickCount();
2149 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
2152 if (result == WAIT_TIMEOUT) {
2153 /* Ran out of time - explicit return of zero to avoid -ve if we
2154 have scheduling issues
2158 if (timeout != INFINITE) {
2159 ticks = GetTickCount();
2161 if (result == WAIT_OBJECT_0 + count) {
2162 /* Message has arrived - check it */
2163 (void)win32_async_check(aTHX);
2166 /* Not timeout or message - one of handles is ready */
2170 /* compute time left to wait */
2171 ticks = timeout - ticks;
2172 /* If we are past the end say zero */
2173 return (ticks > 0) ? ticks : 0;
2177 win32_internal_wait(int *status, DWORD timeout)
2179 /* XXX this wait emulation only knows about processes
2180 * spawned via win32_spawnvp(P_NOWAIT, ...).
2184 DWORD exitcode, waitcode;
2187 if (w32_num_pseudo_children) {
2188 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2189 timeout, &waitcode);
2190 /* Time out here if there are no other children to wait for. */
2191 if (waitcode == WAIT_TIMEOUT) {
2192 if (!w32_num_children) {
2196 else if (waitcode != WAIT_FAILED) {
2197 if (waitcode >= WAIT_ABANDONED_0
2198 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2199 i = waitcode - WAIT_ABANDONED_0;
2201 i = waitcode - WAIT_OBJECT_0;
2202 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2203 *status = (int)((exitcode & 0xff) << 8);
2204 retval = (int)w32_pseudo_child_pids[i];
2205 remove_dead_pseudo_process(i);
2212 if (!w32_num_children) {
2217 /* if a child exists, wait for it to die */
2218 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2219 if (waitcode == WAIT_TIMEOUT) {
2222 if (waitcode != WAIT_FAILED) {
2223 if (waitcode >= WAIT_ABANDONED_0
2224 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2225 i = waitcode - WAIT_ABANDONED_0;
2227 i = waitcode - WAIT_OBJECT_0;
2228 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2229 *status = (int)((exitcode & 0xff) << 8);
2230 retval = (int)w32_child_pids[i];
2231 remove_dead_process(i);
2236 errno = GetLastError();
2241 win32_waitpid(int pid, int *status, int flags)
2244 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2247 if (pid == -1) /* XXX threadid == 1 ? */
2248 return win32_internal_wait(status, timeout);
2251 child = find_pseudo_pid(-pid);
2253 HANDLE hThread = w32_pseudo_child_handles[child];
2255 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2256 if (waitcode == WAIT_TIMEOUT) {
2259 else if (waitcode == WAIT_OBJECT_0) {
2260 if (GetExitCodeThread(hThread, &waitcode)) {
2261 *status = (int)((waitcode & 0xff) << 8);
2262 retval = (int)w32_pseudo_child_pids[child];
2263 remove_dead_pseudo_process(child);
2270 else if (IsWin95()) {
2279 child = find_pid(pid);
2281 hProcess = w32_child_handles[child];
2282 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2283 if (waitcode == WAIT_TIMEOUT) {
2286 else if (waitcode == WAIT_OBJECT_0) {
2287 if (GetExitCodeProcess(hProcess, &waitcode)) {
2288 *status = (int)((waitcode & 0xff) << 8);
2289 retval = (int)w32_child_pids[child];
2290 remove_dead_process(child);
2299 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2300 (IsWin95() ? -pid : pid));
2302 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2303 if (waitcode == WAIT_TIMEOUT) {
2304 CloseHandle(hProcess);
2307 else if (waitcode == WAIT_OBJECT_0) {
2308 if (GetExitCodeProcess(hProcess, &waitcode)) {
2309 *status = (int)((waitcode & 0xff) << 8);
2310 CloseHandle(hProcess);
2314 CloseHandle(hProcess);
2320 return retval >= 0 ? pid : retval;
2324 win32_wait(int *status)
2326 return win32_internal_wait(status, INFINITE);
2329 DllExport unsigned int
2330 win32_sleep(unsigned int t)
2333 /* Win32 times are in ms so *1000 in and /1000 out */
2334 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2337 DllExport unsigned int
2338 win32_alarm(unsigned int sec)
2341 * the 'obvious' implentation is SetTimer() with a callback
2342 * which does whatever receiving SIGALRM would do
2343 * we cannot use SIGALRM even via raise() as it is not
2344 * one of the supported codes in <signal.h>
2348 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2349 w32_message_hwnd = win32_create_message_window();
2352 if (w32_message_hwnd == NULL)
2353 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2356 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2361 KillTimer(w32_message_hwnd, w32_timerid);
2368 #ifdef HAVE_DES_FCRYPT
2369 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2373 win32_crypt(const char *txt, const char *salt)
2376 #ifdef HAVE_DES_FCRYPT
2377 return des_fcrypt(txt, salt, w32_crypt_buffer);
2379 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2384 #ifdef USE_FIXED_OSFHANDLE
2386 #define FOPEN 0x01 /* file handle open */
2387 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2388 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2389 #define FDEV 0x40 /* file handle refers to device */
2390 #define FTEXT 0x80 /* file handle is in text mode */
2393 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2396 * This function allocates a free C Runtime file handle and associates
2397 * it with the Win32 HANDLE specified by the first parameter. This is a
2398 * temperary fix for WIN95's brain damage GetFileType() error on socket
2399 * we just bypass that call for socket
2401 * This works with MSVC++ 4.0+ or GCC/Mingw32
2404 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2405 * int flags - flags to associate with C Runtime file handle.
2408 * returns index of entry in fh, if successful
2409 * return -1, if no free entry is found
2413 *******************************************************************************/
2416 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2417 * this lets sockets work on Win9X with GCC and should fix the problems
2422 /* create an ioinfo entry, kill its handle, and steal the entry */
2427 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2428 int fh = _open_osfhandle((intptr_t)hF, 0);
2432 EnterCriticalSection(&(_pioinfo(fh)->lock));
2437 my_open_osfhandle(intptr_t osfhandle, int flags)
2440 char fileflags; /* _osfile flags */
2442 /* copy relevant flags from second parameter */
2445 if (flags & O_APPEND)
2446 fileflags |= FAPPEND;
2451 if (flags & O_NOINHERIT)
2452 fileflags |= FNOINHERIT;
2454 /* attempt to allocate a C Runtime file handle */
2455 if ((fh = _alloc_osfhnd()) == -1) {
2456 errno = EMFILE; /* too many open files */
2457 _doserrno = 0L; /* not an OS error */
2458 return -1; /* return error to caller */
2461 /* the file is open. now, set the info in _osfhnd array */
2462 _set_osfhnd(fh, osfhandle);
2464 fileflags |= FOPEN; /* mark as open */
2466 _osfile(fh) = fileflags; /* set osfile entry */
2467 LeaveCriticalSection(&_pioinfo(fh)->lock);
2469 return fh; /* return handle */
2472 #endif /* USE_FIXED_OSFHANDLE */
2474 /* simulate flock by locking a range on the file */
2476 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2477 #define LK_LEN 0xffff0000
2480 win32_flock(int fd, int oper)
2488 Perl_croak_nocontext("flock() unimplemented on this platform");
2491 fh = (HANDLE)_get_osfhandle(fd);
2492 memset(&o, 0, sizeof(o));
2495 case LOCK_SH: /* shared lock */
2496 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2498 case LOCK_EX: /* exclusive lock */
2499 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2501 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2502 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2504 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2505 LK_ERR(LockFileEx(fh,
2506 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2507 0, LK_LEN, 0, &o),i);
2509 case LOCK_UN: /* unlock lock */
2510 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2512 default: /* unknown */
2523 * redirected io subsystem for all XS modules
2536 return (&(_environ));
2539 /* the rest are the remapped stdio routines */
2559 win32_ferror(FILE *fp)
2561 return (ferror(fp));
2566 win32_feof(FILE *fp)
2572 * Since the errors returned by the socket error function
2573 * WSAGetLastError() are not known by the library routine strerror
2574 * we have to roll our own.
2578 win32_strerror(int e)
2580 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2581 extern int sys_nerr;
2585 if (e < 0 || e > sys_nerr) {
2590 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2591 w32_strerror_buffer,
2592 sizeof(w32_strerror_buffer), NULL) == 0)
2593 strcpy(w32_strerror_buffer, "Unknown Error");
2595 return w32_strerror_buffer;
2601 win32_str_os_error(void *sv, DWORD dwErr)
2605 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2606 |FORMAT_MESSAGE_IGNORE_INSERTS
2607 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2608 dwErr, 0, (char *)&sMsg, 1, NULL);
2609 /* strip trailing whitespace and period */
2612 --dwLen; /* dwLen doesn't include trailing null */
2613 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2614 if ('.' != sMsg[dwLen])
2619 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2621 dwLen = sprintf(sMsg,
2622 "Unknown error #0x%lX (lookup 0x%lX)",
2623 dwErr, GetLastError());
2627 sv_setpvn((SV*)sv, sMsg, dwLen);
2633 win32_fprintf(FILE *fp, const char *format, ...)
2636 va_start(marker, format); /* Initialize variable arguments. */
2638 return (vfprintf(fp, format, marker));
2642 win32_printf(const char *format, ...)
2645 va_start(marker, format); /* Initialize variable arguments. */
2647 return (vprintf(format, marker));
2651 win32_vfprintf(FILE *fp, const char *format, va_list args)
2653 return (vfprintf(fp, format, args));
2657 win32_vprintf(const char *format, va_list args)
2659 return (vprintf(format, args));
2663 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2665 return fread(buf, size, count, fp);
2669 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2671 return fwrite(buf, size, count, fp);
2674 #define MODE_SIZE 10
2677 win32_fopen(const char *filename, const char *mode)
2685 if (stricmp(filename, "/dev/null")==0)
2688 f = fopen(PerlDir_mapA(filename), mode);
2689 /* avoid buffering headaches for child processes */
2690 if (f && *mode == 'a')
2691 win32_fseek(f, 0, SEEK_END);
2695 #ifndef USE_SOCKETS_AS_HANDLES
2697 #define fdopen my_fdopen
2701 win32_fdopen(int handle, const char *mode)
2705 f = fdopen(handle, (char *) mode);
2706 /* avoid buffering headaches for child processes */
2707 if (f && *mode == 'a')
2708 win32_fseek(f, 0, SEEK_END);
2713 win32_freopen(const char *path, const char *mode, FILE *stream)
2716 if (stricmp(path, "/dev/null")==0)
2719 return freopen(PerlDir_mapA(path), mode, stream);
2723 win32_fclose(FILE *pf)
2725 return my_fclose(pf); /* defined in win32sck.c */
2729 win32_fputs(const char *s,FILE *pf)
2731 return fputs(s, pf);
2735 win32_fputc(int c,FILE *pf)
2741 win32_ungetc(int c,FILE *pf)
2743 return ungetc(c,pf);
2747 win32_getc(FILE *pf)
2753 win32_fileno(FILE *pf)
2759 win32_clearerr(FILE *pf)
2766 win32_fflush(FILE *pf)
2772 win32_ftell(FILE *pf)
2774 #if defined(WIN64) || defined(USE_LARGE_FILES)
2775 #if defined(__BORLANDC__) /* buk */
2776 return win32_tell( fileno( pf ) );
2779 if (fgetpos(pf, &pos))
2789 win32_fseek(FILE *pf, Off_t offset,int origin)
2791 #if defined(WIN64) || defined(USE_LARGE_FILES)
2792 #if defined(__BORLANDC__) /* buk */
2802 if (fgetpos(pf, &pos))
2807 fseek(pf, 0, SEEK_END);
2808 pos = _telli64(fileno(pf));
2817 return fsetpos(pf, &offset);
2820 return fseek(pf, (long)offset, origin);
2825 win32_fgetpos(FILE *pf,fpos_t *p)
2827 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2828 if( win32_tell(fileno(pf)) == -1L ) {
2834 return fgetpos(pf, p);
2839 win32_fsetpos(FILE *pf,const fpos_t *p)
2841 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2842 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2844 return fsetpos(pf, p);
2849 win32_rewind(FILE *pf)
2859 char prefix[MAX_PATH+1];
2860 char filename[MAX_PATH+1];
2861 DWORD len = GetTempPath(MAX_PATH, prefix);
2862 if (len && len < MAX_PATH) {
2863 if (GetTempFileName(prefix, "plx", 0, filename)) {
2864 HANDLE fh = CreateFile(filename,
2865 DELETE | GENERIC_READ | GENERIC_WRITE,
2869 FILE_ATTRIBUTE_NORMAL
2870 | FILE_FLAG_DELETE_ON_CLOSE,
2872 if (fh != INVALID_HANDLE_VALUE) {
2873 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2875 #if defined(__BORLANDC__)
2876 setmode(fd,O_BINARY);
2878 DEBUG_p(PerlIO_printf(Perl_debug_log,
2879 "Created tmpfile=%s\n",filename));
2891 int fd = win32_tmpfd();
2893 return win32_fdopen(fd, "w+b");
2905 win32_fstat(int fd, Stat_t *sbufptr)
2908 /* A file designated by filehandle is not shown as accessible
2909 * for write operations, probably because it is opened for reading.
2912 BY_HANDLE_FILE_INFORMATION bhfi;
2913 #if defined(WIN64) || defined(USE_LARGE_FILES)
2914 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2916 int rc = fstat(fd,&tmp);
2918 sbufptr->st_dev = tmp.st_dev;
2919 sbufptr->st_ino = tmp.st_ino;
2920 sbufptr->st_mode = tmp.st_mode;
2921 sbufptr->st_nlink = tmp.st_nlink;
2922 sbufptr->st_uid = tmp.st_uid;
2923 sbufptr->st_gid = tmp.st_gid;
2924 sbufptr->st_rdev = tmp.st_rdev;
2925 sbufptr->st_size = tmp.st_size;
2926 sbufptr->st_atime = tmp.st_atime;
2927 sbufptr->st_mtime = tmp.st_mtime;
2928 sbufptr->st_ctime = tmp.st_ctime;
2930 int rc = fstat(fd,sbufptr);
2933 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2934 #if defined(WIN64) || defined(USE_LARGE_FILES)
2935 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2937 sbufptr->st_mode &= 0xFE00;
2938 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2939 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2941 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2942 + ((S_IREAD|S_IWRITE) >> 6));
2946 return my_fstat(fd,sbufptr);
2951 win32_pipe(int *pfd, unsigned int size, int mode)
2953 return _pipe(pfd, size, mode);
2957 win32_popenlist(const char *mode, IV narg, SV **args)
2960 Perl_croak(aTHX_ "List form of pipe open not implemented");
2965 * a popen() clone that respects PERL5SHELL
2967 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2971 win32_popen(const char *command, const char *mode)
2973 #ifdef USE_RTL_POPEN
2974 return _popen(command, mode);
2986 /* establish which ends read and write */
2987 if (strchr(mode,'w')) {
2988 stdfd = 0; /* stdin */
2991 nhandle = STD_INPUT_HANDLE;
2993 else if (strchr(mode,'r')) {
2994 stdfd = 1; /* stdout */
2997 nhandle = STD_OUTPUT_HANDLE;
3002 /* set the correct mode */
3003 if (strchr(mode,'b'))
3005 else if (strchr(mode,'t'))
3008 ourmode = _fmode & (O_TEXT | O_BINARY);
3010 /* the child doesn't inherit handles */
3011 ourmode |= O_NOINHERIT;
3013 if (win32_pipe(p, 512, ourmode) == -1)
3016 /* save the old std handle (this needs to happen before the
3017 * dup2(), since that might call SetStdHandle() too) */
3020 old_h = GetStdHandle(nhandle);
3022 /* save current stdfd */
3023 if ((oldfd = win32_dup(stdfd)) == -1)
3026 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3027 /* stdfd will be inherited by the child */
3028 if (win32_dup2(p[child], stdfd) == -1)
3031 /* close the child end in parent */
3032 win32_close(p[child]);
3034 /* set the new std handle (in case dup2() above didn't) */
3035 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3037 /* start the child */
3040 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3043 /* revert stdfd to whatever it was before */
3044 if (win32_dup2(oldfd, stdfd) == -1)
3047 /* close saved handle */
3050 /* restore the old std handle (this needs to happen after the
3051 * dup2(), since that might call SetStdHandle() too */
3053 SetStdHandle(nhandle, old_h);
3059 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3062 /* set process id so that it can be returned by perl's open() */
3063 PL_forkprocess = childpid;
3066 /* we have an fd, return a file stream */
3067 return (PerlIO_fdopen(p[parent], (char *)mode));
3070 /* we don't need to check for errors here */
3074 win32_dup2(oldfd, stdfd);
3078 SetStdHandle(nhandle, old_h);
3084 #endif /* USE_RTL_POPEN */
3092 win32_pclose(PerlIO *pf)
3094 #ifdef USE_RTL_POPEN
3098 int childpid, status;
3102 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3105 childpid = SvIVX(sv);
3123 if (win32_waitpid(childpid, &status, 0) == -1)
3128 #endif /* USE_RTL_POPEN */
3134 LPCWSTR lpExistingFileName,
3135 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3138 WCHAR wFullName[MAX_PATH+1];
3139 LPVOID lpContext = NULL;
3140 WIN32_STREAM_ID StreamId;
3141 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3146 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3147 BOOL, BOOL, LPVOID*) =
3148 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3149 BOOL, BOOL, LPVOID*))
3150 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3151 if (pfnBackupWrite == NULL)
3154 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3157 dwLen = (dwLen+1)*sizeof(WCHAR);
3159 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3160 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3161 NULL, OPEN_EXISTING, 0, NULL);
3162 if (handle == INVALID_HANDLE_VALUE)
3165 StreamId.dwStreamId = BACKUP_LINK;
3166 StreamId.dwStreamAttributes = 0;
3167 StreamId.dwStreamNameSize = 0;
3168 #if defined(__BORLANDC__) \
3169 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3170 StreamId.Size.u.HighPart = 0;
3171 StreamId.Size.u.LowPart = dwLen;
3173 StreamId.Size.HighPart = 0;
3174 StreamId.Size.LowPart = dwLen;
3177 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3178 FALSE, FALSE, &lpContext);
3180 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3181 FALSE, FALSE, &lpContext);
3182 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3185 CloseHandle(handle);
3190 win32_link(const char *oldname, const char *newname)
3193 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3194 WCHAR wOldName[MAX_PATH+1];
3195 WCHAR wNewName[MAX_PATH+1];
3198 Perl_croak(aTHX_ PL_no_func, "link");
3200 pfnCreateHardLinkW =
3201 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3202 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3203 if (pfnCreateHardLinkW == NULL)
3204 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3206 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3207 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3208 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3209 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3213 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3218 win32_rename(const char *oname, const char *newname)
3220 char szOldName[MAX_PATH+1];
3221 char szNewName[MAX_PATH+1];
3225 /* XXX despite what the documentation says about MoveFileEx(),
3226 * it doesn't work under Windows95!
3229 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3230 if (stricmp(newname, oname))
3231 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3232 strcpy(szOldName, PerlDir_mapA(oname));
3233 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3235 DWORD err = GetLastError();
3237 case ERROR_BAD_NET_NAME:
3238 case ERROR_BAD_NETPATH:
3239 case ERROR_BAD_PATHNAME:
3240 case ERROR_FILE_NOT_FOUND:
3241 case ERROR_FILENAME_EXCED_RANGE:
3242 case ERROR_INVALID_DRIVE:
3243 case ERROR_NO_MORE_FILES:
3244 case ERROR_PATH_NOT_FOUND:
3257 char szTmpName[MAX_PATH+1];
3258 char dname[MAX_PATH+1];
3259 char *endname = Nullch;
3261 DWORD from_attr, to_attr;
3263 strcpy(szOldName, PerlDir_mapA(oname));
3264 strcpy(szNewName, PerlDir_mapA(newname));
3266 /* if oname doesn't exist, do nothing */
3267 from_attr = GetFileAttributes(szOldName);
3268 if (from_attr == 0xFFFFFFFF) {
3273 /* if newname exists, rename it to a temporary name so that we
3274 * don't delete it in case oname happens to be the same file
3275 * (but perhaps accessed via a different path)
3277 to_attr = GetFileAttributes(szNewName);
3278 if (to_attr != 0xFFFFFFFF) {
3279 /* if newname is a directory, we fail
3280 * XXX could overcome this with yet more convoluted logic */
3281 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3285 tmplen = strlen(szNewName);
3286 strcpy(szTmpName,szNewName);
3287 endname = szTmpName+tmplen;
3288 for (; endname > szTmpName ; --endname) {
3289 if (*endname == '/' || *endname == '\\') {
3294 if (endname > szTmpName)
3295 endname = strcpy(dname,szTmpName);
3299 /* get a temporary filename in same directory
3300 * XXX is this really the best we can do? */
3301 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3305 DeleteFile(szTmpName);
3307 retval = rename(szNewName, szTmpName);
3314 /* rename oname to newname */
3315 retval = rename(szOldName, szNewName);
3317 /* if we created a temporary file before ... */
3318 if (endname != Nullch) {
3319 /* ...and rename succeeded, delete temporary file/directory */
3321 DeleteFile(szTmpName);
3322 /* else restore it to what it was */
3324 (void)rename(szTmpName, szNewName);
3331 win32_setmode(int fd, int mode)
3333 return setmode(fd, mode);
3337 win32_chsize(int fd, Off_t size)
3339 #if defined(WIN64) || defined(USE_LARGE_FILES)
3341 Off_t cur, end, extend;
3343 cur = win32_tell(fd);
3346 end = win32_lseek(fd, 0, SEEK_END);
3349 extend = size - end;
3353 else if (extend > 0) {
3354 /* must grow the file, padding with nulls */
3356 int oldmode = win32_setmode(fd, O_BINARY);
3358 memset(b, '\0', sizeof(b));
3360 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3361 count = win32_write(fd, b, count);
3362 if ((int)count < 0) {
3366 } while ((extend -= count) > 0);
3367 win32_setmode(fd, oldmode);
3370 /* shrink the file */
3371 win32_lseek(fd, size, SEEK_SET);
3372 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3378 win32_lseek(fd, cur, SEEK_SET);
3381 return chsize(fd, (long)size);
3386 win32_lseek(int fd, Off_t offset, int origin)
3388 #if defined(WIN64) || defined(USE_LARGE_FILES)
3389 #if defined(__BORLANDC__) /* buk */
3391 pos.QuadPart = offset;
3392 pos.LowPart = SetFilePointer(
3393 (HANDLE)_get_osfhandle(fd),
3398 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3402 return pos.QuadPart;
3404 return _lseeki64(fd, offset, origin);
3407 return lseek(fd, (long)offset, origin);
3414 #if defined(WIN64) || defined(USE_LARGE_FILES)
3415 #if defined(__BORLANDC__) /* buk */
3418 pos.LowPart = SetFilePointer(
3419 (HANDLE)_get_osfhandle(fd),
3424 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3428 return pos.QuadPart;
3429 /* return tell(fd); */
3431 return _telli64(fd);
3439 win32_open(const char *path, int flag, ...)
3446 pmode = va_arg(ap, int);
3449 if (stricmp(path, "/dev/null")==0)
3452 return open(PerlDir_mapA(path), flag, pmode);
3455 /* close() that understands socket */
3456 extern int my_close(int); /* in win32sck.c */
3461 return my_close(fd);
3477 win32_dup2(int fd1,int fd2)
3479 return dup2(fd1,fd2);
3482 #ifdef PERL_MSVCRT_READFIX
3484 #define LF 10 /* line feed */
3485 #define CR 13 /* carriage return */
3486 #define CTRLZ 26 /* ctrl-z means eof for text */
3487 #define FOPEN 0x01 /* file handle open */
3488 #define FEOFLAG 0x02 /* end of file has been encountered */
3489 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3490 #define FPIPE 0x08 /* file handle refers to a pipe */
3491 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3492 #define FDEV 0x40 /* file handle refers to device */
3493 #define FTEXT 0x80 /* file handle is in text mode */
3494 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3497 _fixed_read(int fh, void *buf, unsigned cnt)
3499 int bytes_read; /* number of bytes read */
3500 char *buffer; /* buffer to read to */
3501 int os_read; /* bytes read on OS call */
3502 char *p, *q; /* pointers into buffer */
3503 char peekchr; /* peek-ahead character */
3504 ULONG filepos; /* file position after seek */
3505 ULONG dosretval; /* o.s. return value */
3507 /* validate handle */
3508 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3509 !(_osfile(fh) & FOPEN))
3511 /* out of range -- return error */
3513 _doserrno = 0; /* not o.s. error */
3518 * If lockinitflag is FALSE, assume fd is device
3519 * lockinitflag is set to TRUE by open.
3521 if (_pioinfo(fh)->lockinitflag)
3522 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3524 bytes_read = 0; /* nothing read yet */
3525 buffer = (char*)buf;
3527 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3528 /* nothing to read or at EOF, so return 0 read */
3532 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3533 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3535 *buffer++ = _pipech(fh);
3538 _pipech(fh) = LF; /* mark as empty */
3543 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3545 /* ReadFile has reported an error. recognize two special cases.
3547 * 1. map ERROR_ACCESS_DENIED to EBADF
3549 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3550 * means the handle is a read-handle on a pipe for which
3551 * all write-handles have been closed and all data has been
3554 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3555 /* wrong read/write mode should return EBADF, not EACCES */
3557 _doserrno = dosretval;
3561 else if (dosretval == ERROR_BROKEN_PIPE) {
3571 bytes_read += os_read; /* update bytes read */
3573 if (_osfile(fh) & FTEXT) {
3574 /* now must translate CR-LFs to LFs in the buffer */
3576 /* set CRLF flag to indicate LF at beginning of buffer */
3577 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3578 /* _osfile(fh) |= FCRLF; */
3580 /* _osfile(fh) &= ~FCRLF; */
3582 _osfile(fh) &= ~FCRLF;
3584 /* convert chars in the buffer: p is src, q is dest */
3586 while (p < (char *)buf + bytes_read) {
3588 /* if fh is not a device, set ctrl-z flag */
3589 if (!(_osfile(fh) & FDEV))
3590 _osfile(fh) |= FEOFLAG;
3591 break; /* stop translating */
3596 /* *p is CR, so must check next char for LF */
3597 if (p < (char *)buf + bytes_read - 1) {
3600 *q++ = LF; /* convert CR-LF to LF */
3603 *q++ = *p++; /* store char normally */
3606 /* This is the hard part. We found a CR at end of
3607 buffer. We must peek ahead to see if next char
3612 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3613 (LPDWORD)&os_read, NULL))
3614 dosretval = GetLastError();
3616 if (dosretval != 0 || os_read == 0) {
3617 /* couldn't read ahead, store CR */
3621 /* peekchr now has the extra character -- we now
3622 have several possibilities:
3623 1. disk file and char is not LF; just seek back
3625 2. disk file and char is LF; store LF, don't seek back
3626 3. pipe/device and char is LF; store LF.
3627 4. pipe/device and char isn't LF, store CR and
3628 put char in pipe lookahead buffer. */
3629 if (_osfile(fh) & (FDEV|FPIPE)) {
3630 /* non-seekable device */
3635 _pipech(fh) = peekchr;
3640 if (peekchr == LF) {
3641 /* nothing read yet; must make some
3644 /* turn on this flag for tell routine */
3645 _osfile(fh) |= FCRLF;
3648 HANDLE osHandle; /* o.s. handle value */
3650 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3652 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3653 dosretval = GetLastError();
3664 /* we now change bytes_read to reflect the true number of chars
3666 bytes_read = q - (char *)buf;
3670 if (_pioinfo(fh)->lockinitflag)
3671 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3676 #endif /* PERL_MSVCRT_READFIX */
3679 win32_read(int fd, void *buf, unsigned int cnt)
3681 #ifdef PERL_MSVCRT_READFIX
3682 return _fixed_read(fd, buf, cnt);
3684 return read(fd, buf, cnt);
3689 win32_write(int fd, const void *buf, unsigned int cnt)
3691 return write(fd, buf, cnt);
3695 win32_mkdir(const char *dir, int mode)
3698 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3702 win32_rmdir(const char *dir)
3705 return rmdir(PerlDir_mapA(dir));
3709 win32_chdir(const char *dir)
3720 win32_access(const char *path, int mode)
3723 return access(PerlDir_mapA(path), mode);
3727 win32_chmod(const char *path, int mode)
3730 return chmod(PerlDir_mapA(path), mode);
3735 create_command_line(char *cname, STRLEN clen, const char * const *args)
3742 bool bat_file = FALSE;
3743 bool cmd_shell = FALSE;
3744 bool dumb_shell = FALSE;
3745 bool extra_quotes = FALSE;
3746 bool quote_next = FALSE;
3749 cname = (char*)args[0];
3751 /* The NT cmd.exe shell has the following peculiarity that needs to be
3752 * worked around. It strips a leading and trailing dquote when any
3753 * of the following is true:
3754 * 1. the /S switch was used
3755 * 2. there are more than two dquotes
3756 * 3. there is a special character from this set: &<>()@^|
3757 * 4. no whitespace characters within the two dquotes
3758 * 5. string between two dquotes isn't an executable file
3759 * To work around this, we always add a leading and trailing dquote
3760 * to the string, if the first argument is either "cmd.exe" or "cmd",
3761 * and there were at least two or more arguments passed to cmd.exe
3762 * (not including switches).
3763 * XXX the above rules (from "cmd /?") don't seem to be applied
3764 * always, making for the convolutions below :-(
3768 clen = strlen(cname);
3771 && (stricmp(&cname[clen-4], ".bat") == 0
3772 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3779 char *exe = strrchr(cname, '/');
3780 char *exe2 = strrchr(cname, '\\');
3787 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3791 else if (stricmp(exe, "command.com") == 0
3792 || stricmp(exe, "command") == 0)
3799 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3800 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3801 STRLEN curlen = strlen(arg);
3802 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3803 len += 2; /* assume quoting needed (worst case) */
3805 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3807 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3810 Newx(cmd, len, char);
3813 if (bat_file && !IsWin95()) {
3815 extra_quotes = TRUE;
3818 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3820 STRLEN curlen = strlen(arg);
3822 /* we want to protect empty arguments and ones with spaces with
3823 * dquotes, but only if they aren't already there */
3828 else if (quote_next) {
3829 /* see if it really is multiple arguments pretending to
3830 * be one and force a set of quotes around it */
3831 if (*find_next_space(arg))
3834 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3836 while (i < curlen) {
3837 if (isSPACE(arg[i])) {
3840 else if (arg[i] == '"') {
3864 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3865 && stricmp(arg+curlen-2, "/c") == 0)
3867 /* is there a next argument? */
3868 if (args[index+1]) {
3869 /* are there two or more next arguments? */
3870 if (args[index+2]) {
3872 extra_quotes = TRUE;
3875 /* single argument, force quoting if it has spaces */
3891 qualified_path(const char *cmd)
3895 char *fullcmd, *curfullcmd;
3901 fullcmd = (char*)cmd;
3903 if (*fullcmd == '/' || *fullcmd == '\\')
3910 pathstr = PerlEnv_getenv("PATH");
3912 /* worst case: PATH is a single directory; we need additional space
3913 * to append "/", ".exe" and trailing "\0" */
3914 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3915 curfullcmd = fullcmd;
3920 /* start by appending the name to the current prefix */
3921 strcpy(curfullcmd, cmd);
3922 curfullcmd += cmdlen;
3924 /* if it doesn't end with '.', or has no extension, try adding
3925 * a trailing .exe first */
3926 if (cmd[cmdlen-1] != '.'
3927 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3929 strcpy(curfullcmd, ".exe");
3930 res = GetFileAttributes(fullcmd);
3931 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3936 /* that failed, try the bare name */
3937 res = GetFileAttributes(fullcmd);
3938 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3941 /* quit if no other path exists, or if cmd already has path */
3942 if (!pathstr || !*pathstr || has_slash)
3945 /* skip leading semis */
3946 while (*pathstr == ';')
3949 /* build a new prefix from scratch */
3950 curfullcmd = fullcmd;
3951 while (*pathstr && *pathstr != ';') {
3952 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3953 pathstr++; /* skip initial '"' */
3954 while (*pathstr && *pathstr != '"') {
3955 *curfullcmd++ = *pathstr++;
3958 pathstr++; /* skip trailing '"' */
3961 *curfullcmd++ = *pathstr++;
3965 pathstr++; /* skip trailing semi */
3966 if (curfullcmd > fullcmd /* append a dir separator */
3967 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3969 *curfullcmd++ = '\\';
3977 /* The following are just place holders.
3978 * Some hosts may provide and environment that the OS is
3979 * not tracking, therefore, these host must provide that
3980 * environment and the current directory to CreateProcess
3984 win32_get_childenv(void)
3990 win32_free_childenv(void* d)
3995 win32_clearenv(void)
3997 char *envv = GetEnvironmentStrings();
4001 char *end = strchr(cur,'=');
4002 if (end && end != cur) {
4004 SetEnvironmentVariable(cur, NULL);
4006 cur = end + strlen(end+1)+2;
4008 else if ((len = strlen(cur)))
4011 FreeEnvironmentStrings(envv);
4015 win32_get_childdir(void)
4019 char szfilename[MAX_PATH+1];
4021 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4022 Newx(ptr, strlen(szfilename)+1, char);
4023 strcpy(ptr, szfilename);
4028 win32_free_childdir(char* d)
4035 /* XXX this needs to be made more compatible with the spawnvp()
4036 * provided by the various RTLs. In particular, searching for
4037 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4038 * This doesn't significantly affect perl itself, because we
4039 * always invoke things using PERL5SHELL if a direct attempt to
4040 * spawn the executable fails.
4042 * XXX splitting and rejoining the commandline between do_aspawn()
4043 * and win32_spawnvp() could also be avoided.
4047 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4049 #ifdef USE_RTL_SPAWNVP
4050 return spawnvp(mode, cmdname, (char * const *)argv);
4057 STARTUPINFO StartupInfo;
4058 PROCESS_INFORMATION ProcessInformation;
4061 char *fullcmd = Nullch;
4062 char *cname = (char *)cmdname;
4066 clen = strlen(cname);
4067 /* if command name contains dquotes, must remove them */
4068 if (strchr(cname, '"')) {
4070 Newx(cname,clen+1,char);
4083 cmd = create_command_line(cname, clen, argv);
4085 env = PerlEnv_get_childenv();
4086 dir = PerlEnv_get_childdir();
4089 case P_NOWAIT: /* asynch + remember result */
4090 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4095 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4098 create |= CREATE_NEW_PROCESS_GROUP;
4101 case P_WAIT: /* synchronous execution */
4103 default: /* invalid mode */
4108 memset(&StartupInfo,0,sizeof(StartupInfo));
4109 StartupInfo.cb = sizeof(StartupInfo);
4110 memset(&tbl,0,sizeof(tbl));
4111 PerlEnv_get_child_IO(&tbl);
4112 StartupInfo.dwFlags = tbl.dwFlags;
4113 StartupInfo.dwX = tbl.dwX;
4114 StartupInfo.dwY = tbl.dwY;
4115 StartupInfo.dwXSize = tbl.dwXSize;
4116 StartupInfo.dwYSize = tbl.dwYSize;
4117 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4118 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4119 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4120 StartupInfo.wShowWindow = tbl.wShowWindow;
4121 StartupInfo.hStdInput = tbl.childStdIn;
4122 StartupInfo.hStdOutput = tbl.childStdOut;
4123 StartupInfo.hStdError = tbl.childStdErr;
4124 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4125 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4126 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4128 create |= CREATE_NEW_CONSOLE;
4131 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4133 if (w32_use_showwindow) {
4134 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4135 StartupInfo.wShowWindow = w32_showwindow;
4138 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4141 if (!CreateProcess(cname, /* search PATH to find executable */
4142 cmd, /* executable, and its arguments */
4143 NULL, /* process attributes */
4144 NULL, /* thread attributes */
4145 TRUE, /* inherit handles */
4146 create, /* creation flags */
4147 (LPVOID)env, /* inherit environment */
4148 dir, /* inherit cwd */
4150 &ProcessInformation))
4152 /* initial NULL argument to CreateProcess() does a PATH
4153 * search, but it always first looks in the directory
4154 * where the current process was started, which behavior
4155 * is undesirable for backward compatibility. So we
4156 * jump through our own hoops by picking out the path
4157 * we really want it to use. */
4159 fullcmd = qualified_path(cname);
4161 if (cname != cmdname)
4164 DEBUG_p(PerlIO_printf(Perl_debug_log,
4165 "Retrying [%s] with same args\n",
4175 if (mode == P_NOWAIT) {
4176 /* asynchronous spawn -- store handle, return PID */
4177 ret = (int)ProcessInformation.dwProcessId;
4178 if (IsWin95() && ret < 0)
4181 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4182 w32_child_pids[w32_num_children] = (DWORD)ret;
4187 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4188 /* FIXME: if msgwait returned due to message perhaps forward the
4189 "signal" to the process
4191 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4193 CloseHandle(ProcessInformation.hProcess);
4196 CloseHandle(ProcessInformation.hThread);
4199 PerlEnv_free_childenv(env);
4200 PerlEnv_free_childdir(dir);
4202 if (cname != cmdname)
4209 win32_execv(const char *cmdname, const char *const *argv)
4213 /* if this is a pseudo-forked child, we just want to spawn
4214 * the new program, and return */
4216 # ifdef __BORLANDC__
4217 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4219 return spawnv(P_WAIT, cmdname, argv);
4223 return execv(cmdname, (char *const *)argv);
4225 return execv(cmdname, argv);
4230 win32_execvp(const char *cmdname, const char *const *argv)
4234 /* if this is a pseudo-forked child, we just want to spawn
4235 * the new program, and return */
4236 if (w32_pseudo_id) {
4237 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4247 return execvp(cmdname, (char *const *)argv);
4249 return execvp(cmdname, argv);
4254 win32_perror(const char *str)
4260 win32_setbuf(FILE *pf, char *buf)
4266 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4268 return setvbuf(pf, buf, type, size);
4272 win32_flushall(void)
4278 win32_fcloseall(void)
4284 win32_fgets(char *s, int n, FILE *pf)
4286 return fgets(s, n, pf);
4296 win32_fgetc(FILE *pf)
4302 win32_putc(int c, FILE *pf)
4308 win32_puts(const char *s)
4320 win32_putchar(int c)
4327 #ifndef USE_PERL_SBRK
4329 static char *committed = NULL; /* XXX threadead */
4330 static char *base = NULL; /* XXX threadead */
4331 static char *reserved = NULL; /* XXX threadead */
4332 static char *brk = NULL; /* XXX threadead */
4333 static DWORD pagesize = 0; /* XXX threadead */
4336 sbrk(ptrdiff_t need)
4341 GetSystemInfo(&info);
4342 /* Pretend page size is larger so we don't perpetually
4343 * call the OS to commit just one page ...
4345 pagesize = info.dwPageSize << 3;
4347 if (brk+need >= reserved)
4349 DWORD size = brk+need-reserved;
4351 char *prev_committed = NULL;
4352 if (committed && reserved && committed < reserved)
4354 /* Commit last of previous chunk cannot span allocations */
4355 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4358 /* Remember where we committed from in case we want to decommit later */
4359 prev_committed = committed;
4360 committed = reserved;
4363 /* Reserve some (more) space
4364 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4365 * this is only address space not memory...
4366 * Note this is a little sneaky, 1st call passes NULL as reserved
4367 * so lets system choose where we start, subsequent calls pass
4368 * the old end address so ask for a contiguous block
4371 if (size < 64*1024*1024)
4372 size = 64*1024*1024;
4373 size = ((size + pagesize - 1) / pagesize) * pagesize;
4374 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4377 reserved = addr+size;
4387 /* The existing block could not be extended far enough, so decommit
4388 * anything that was just committed above and start anew */
4391 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4394 reserved = base = committed = brk = NULL;
4405 if (brk > committed)
4407 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4409 if (committed+size > reserved)
4410 size = reserved-committed;
4411 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4424 win32_malloc(size_t size)
4426 return malloc(size);
4430 win32_calloc(size_t numitems, size_t size)
4432 return calloc(numitems,size);
4436 win32_realloc(void *block, size_t size)
4438 return realloc(block,size);
4442 win32_free(void *block)
4449 win32_open_osfhandle(intptr_t handle, int flags)
4451 #ifdef USE_FIXED_OSFHANDLE
4453 return my_open_osfhandle(handle, flags);
4455 return _open_osfhandle(handle, flags);
4459 win32_get_osfhandle(int fd)
4461 return (intptr_t)_get_osfhandle(fd);
4465 win32_fdupopen(FILE *pf)
4470 int fileno = win32_dup(win32_fileno(pf));
4472 /* open the file in the same mode */
4474 if((pf)->flags & _F_READ) {
4478 else if((pf)->flags & _F_WRIT) {
4482 else if((pf)->flags & _F_RDWR) {
4488 if((pf)->_flag & _IOREAD) {
4492 else if((pf)->_flag & _IOWRT) {
4496 else if((pf)->_flag & _IORW) {
4503 /* it appears that the binmode is attached to the
4504 * file descriptor so binmode files will be handled
4507 pfdup = win32_fdopen(fileno, mode);
4509 /* move the file pointer to the same position */
4510 if (!fgetpos(pf, &pos)) {
4511 fsetpos(pfdup, &pos);
4517 win32_dynaload(const char* filename)
4520 char buf[MAX_PATH+1];
4523 /* LoadLibrary() doesn't recognize forward slashes correctly,
4524 * so turn 'em back. */
4525 first = strchr(filename, '/');
4527 STRLEN len = strlen(filename);
4528 if (len <= MAX_PATH) {
4529 strcpy(buf, filename);
4530 filename = &buf[first - filename];
4532 if (*filename == '/')
4533 *(char*)filename = '\\';
4539 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4542 XS(w32_SetChildShowWindow)
4545 BOOL use_showwindow = w32_use_showwindow;
4546 /* use "unsigned short" because Perl has redefined "WORD" */
4547 unsigned short showwindow = w32_showwindow;
4550 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4552 if (items == 0 || !SvOK(ST(0)))
4553 w32_use_showwindow = FALSE;
4555 w32_use_showwindow = TRUE;
4556 w32_showwindow = (unsigned short)SvIV(ST(0));
4561 ST(0) = sv_2mortal(newSViv(showwindow));
4563 ST(0) = &PL_sv_undef;
4568 forward(pTHX_ const char *function)
4571 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
4574 call_pv(function, GIMME_V);
4577 #define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
4580 FORWARD(GetNextAvailDrive)
4581 FORWARD(GetLastError)
4582 FORWARD(SetLastError)
4587 FORWARD(GetOSVersion)
4590 FORWARD(FormatMessage)
4592 FORWARD(GetTickCount)
4593 FORWARD(GetShortPathName)
4594 FORWARD(GetFullPathName)
4595 FORWARD(GetLongPathName)
4599 /* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
4600 * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
4602 /* FORWARD(SetChildShowWindow) */
4607 Perl_init_os_extras(void)
4610 char *file = __FILE__;
4613 /* these names are Activeware compatible */
4614 newXS("Win32::GetCwd", w32_GetCwd, file);
4615 newXS("Win32::SetCwd", w32_SetCwd, file);
4616 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4617 newXS("Win32::GetLastError", w32_GetLastError, file);
4618 newXS("Win32::SetLastError", w32_SetLastError, file);
4619 newXS("Win32::LoginName", w32_LoginName, file);
4620 newXS("Win32::NodeName", w32_NodeName, file);
4621 newXS("Win32::DomainName", w32_DomainName, file);
4622 newXS("Win32::FsType", w32_FsType, file);
4623 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4624 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4625 newXS("Win32::IsWin95", w32_IsWin95, file);
4626 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4627 newXS("Win32::Spawn", w32_Spawn, file);
4628 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4629 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4630 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4631 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4632 newXS("Win32::CopyFile", w32_CopyFile, file);
4633 newXS("Win32::Sleep", w32_Sleep, file);
4634 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4638 win32_signal_context(void)
4643 my_perl = PL_curinterp;
4644 PERL_SET_THX(my_perl);
4648 return PL_curinterp;
4654 win32_ctrlhandler(DWORD dwCtrlType)
4657 dTHXa(PERL_GET_SIG_CONTEXT);
4663 switch(dwCtrlType) {
4664 case CTRL_CLOSE_EVENT:
4665 /* A signal that the system sends to all processes attached to a console when
4666 the user closes the console (either by choosing the Close command from the
4667 console window's System menu, or by choosing the End Task command from the
4670 if (do_raise(aTHX_ 1)) /* SIGHUP */
4671 sig_terminate(aTHX_ 1);
4675 /* A CTRL+c signal was received */
4676 if (do_raise(aTHX_ SIGINT))
4677 sig_terminate(aTHX_ SIGINT);
4680 case CTRL_BREAK_EVENT:
4681 /* A CTRL+BREAK signal was received */
4682 if (do_raise(aTHX_ SIGBREAK))
4683 sig_terminate(aTHX_ SIGBREAK);
4686 case CTRL_LOGOFF_EVENT:
4687 /* A signal that the system sends to all console processes when a user is logging
4688 off. This signal does not indicate which user is logging off, so no
4689 assumptions can be made.
4692 case CTRL_SHUTDOWN_EVENT:
4693 /* A signal that the system sends to all console processes when the system is
4696 if (do_raise(aTHX_ SIGTERM))
4697 sig_terminate(aTHX_ SIGTERM);
4706 #if _MSC_VER >= 1400
4707 # include <crtdbg.h>
4711 Perl_win32_init(int *argcp, char ***argvp)
4715 #if _MSC_VER >= 1400
4716 _invalid_parameter_handler oldHandler, newHandler;
4717 newHandler = my_invalid_parameter_handler;
4718 oldHandler = _set_invalid_parameter_handler(newHandler);
4719 _CrtSetReportMode(_CRT_ASSERT, 0);
4721 /* Disable floating point errors, Perl will trap the ones we
4722 * care about. VC++ RTL defaults to switching these off
4723 * already, but the Borland RTL doesn't. Since we don't
4724 * want to be at the vendor's whim on the default, we set
4725 * it explicitly here.
4727 #if !defined(_ALPHA_) && !defined(__GNUC__)
4728 _control87(MCW_EM, MCW_EM);
4732 module = GetModuleHandle("ntdll.dll");
4734 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4737 module = GetModuleHandle("kernel32.dll");
4739 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4740 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4741 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4746 Perl_win32_term(void)
4756 win32_get_child_IO(child_IO_table* ptbl)
4758 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4759 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4760 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4764 win32_signal(int sig, Sighandler_t subcode)
4767 if (sig < SIG_SIZE) {
4768 int save_errno = errno;
4769 Sighandler_t result = signal(sig, subcode);
4770 if (result == SIG_ERR) {
4771 result = w32_sighandler[sig];
4774 w32_sighandler[sig] = subcode;
4784 #ifdef HAVE_INTERP_INTERN
4789 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
4795 /* there is no Unicode environment on Windows 9X */
4796 osver.dwOSVersionInfoSize = sizeof(osver);
4797 GetVersionEx(&osver);
4798 if (osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS)
4801 /* fetch Unicode version of PATH */
4803 wide_path = win32_malloc(len*sizeof(WCHAR));
4805 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4809 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4814 /* convert to ANSI pathnames */
4815 wide_dir = wide_path;
4818 WCHAR *sep = wcschr(wide_dir, ';');
4826 /* remove quotes around pathname */
4827 if (*wide_dir == '"')
4829 wide_len = wcslen(wide_dir);
4830 if (wide_len && wide_dir[wide_len-1] == '"')
4831 wide_dir[wide_len-1] = '\0';
4833 /* append ansi_dir to ansi_path */
4834 ansi_dir = win32_ansipath(wide_dir);
4835 ansi_len = strlen(ansi_dir);
4837 size_t newlen = len + 1 + ansi_len;
4838 ansi_path = win32_realloc(ansi_path, newlen+1);
4841 ansi_path[len] = ';';
4842 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4847 ansi_path = win32_malloc(5+len+1);
4850 memcpy(ansi_path, "PATH=", 5);
4851 memcpy(ansi_path+5, ansi_dir, len+1);
4854 win32_free(ansi_dir);
4859 /* Update C RTL environ array. This will only have full effect if
4860 * perl_parse() is later called with `environ` as the `env` argument.
4861 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4863 * We do have to ansify() the PATH before Perl has been fully
4864 * initialized because S_find_script() uses the PATH when perl
4865 * is being invoked with the -S option. This happens before %ENV
4866 * is initialized in S_init_postdump_symbols().
4868 * XXX Is this a bug? Should S_find_script() use the environment
4869 * XXX passed in the `env` arg to parse_perl()?
4872 /* Keep system environment in sync because S_init_postdump_symbols()
4873 * will not call mg_set() if it initializes %ENV from `environ`.
4875 SetEnvironmentVariableA("PATH", ansi_path+5);
4876 win32_free(ansi_path);
4878 win32_free(wide_path);
4882 win32_csighandler(int sig)
4885 dTHXa(PERL_GET_SIG_CONTEXT);
4886 Perl_warn(aTHX_ "Got signal %d",sig);
4892 win32_create_message_window()
4894 /* "message-only" windows have been implemented in Windows 2000 and later.
4895 * On earlier versions we'll continue to post messages to a specific
4896 * thread and use hwnd==NULL. This is brittle when either an embedding
4897 * application or an XS module is also posting messages to hwnd=NULL
4898 * because once removed from the queue they cannot be delivered to the
4899 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4900 * if there is no window handle.
4902 if (g_osver.dwMajorVersion < 5)
4905 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4908 #if defined(__MINGW32__) && defined(__cplusplus)
4909 #define CAST_HWND__(x) (HWND__*)(x)
4911 #define CAST_HWND__(x) x
4915 Perl_sys_intern_init(pTHX)
4919 if (g_osver.dwOSVersionInfoSize == 0) {
4920 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4921 GetVersionEx(&g_osver);
4924 w32_perlshell_tokens = Nullch;
4925 w32_perlshell_vec = (char**)NULL;
4926 w32_perlshell_items = 0;
4927 w32_fdpid = newAV();
4928 Newx(w32_children, 1, child_tab);
4929 w32_num_children = 0;
4930 # ifdef USE_ITHREADS
4932 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4933 w32_num_pseudo_children = 0;
4936 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4938 for (i=0; i < SIG_SIZE; i++) {
4939 w32_sighandler[i] = SIG_DFL;
4942 if (my_perl == PL_curinterp) {
4946 /* Force C runtime signal stuff to set its console handler */
4947 signal(SIGINT,win32_csighandler);
4948 signal(SIGBREAK,win32_csighandler);
4949 /* Push our handler on top */
4950 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4957 Perl_sys_intern_clear(pTHX)
4959 Safefree(w32_perlshell_tokens);
4960 Safefree(w32_perlshell_vec);
4961 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4962 Safefree(w32_children);
4964 KillTimer(w32_message_hwnd, w32_timerid);
4967 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4968 DestroyWindow(w32_message_hwnd);
4969 # ifdef MULTIPLICITY
4970 if (my_perl == PL_curinterp) {
4974 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4976 # ifdef USE_ITHREADS
4977 Safefree(w32_pseudo_children);
4981 # ifdef USE_ITHREADS
4984 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4986 dst->perlshell_tokens = Nullch;
4987 dst->perlshell_vec = (char**)NULL;
4988 dst->perlshell_items = 0;
4989 dst->fdpid = newAV();
4990 Newxz(dst->children, 1, child_tab);
4992 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4994 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4995 dst->poll_count = 0;
4996 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4998 # endif /* USE_ITHREADS */
4999 #endif /* HAVE_INTERP_INTERN */
5002 win32_free_argvw(pTHX_ void *ptr)
5004 char** argv = (char**)ptr;
5012 win32_argv2utf8(int argc, char** argv)
5017 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5018 if (lpwStr && argc) {
5020 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5021 Newxz(psz, length, char);
5022 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5025 call_atexit(win32_free_argvw, argv);
5027 GlobalFree((HGLOBAL)lpwStr);