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 set_w32_module_name(void)
197 /* this function may be called at DLL_PROCESS_ATTACH time */
199 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
200 ? GetModuleHandle(NULL)
201 : w32_perldll_handle);
203 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
204 osver.dwOSVersionInfoSize = sizeof(osver);
205 GetVersionEx(&osver);
207 if (osver.dwPlatformId == VER_PLATFORM_WIN32_NT) {
208 WCHAR modulename[MAX_PATH];
209 WCHAR fullname[MAX_PATH];
212 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
214 /* Make sure we get an absolute pathname in case the module was loaded
215 * explicitly by LoadLibrary() with a relative path. */
216 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
218 /* remove \\?\ prefix */
219 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
220 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
222 ansi = win32_ansipath(fullname);
223 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
227 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
229 /* remove \\?\ prefix */
230 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
231 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
233 /* try to get full path to binary (which may be mangled when perl is
234 * run from a 16-bit app) */
235 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
236 win32_longpath(w32_module_name);
237 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
240 /* normalize to forward slashes */
241 ptr = w32_module_name;
249 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
251 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
253 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
256 const char *subkey = "Software\\Perl";
260 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
261 if (retval == ERROR_SUCCESS) {
263 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
264 if (retval == ERROR_SUCCESS
265 && (type == REG_SZ || type == REG_EXPAND_SZ))
269 *svp = sv_2mortal(newSVpvn("",0));
270 SvGROW(*svp, datalen);
271 retval = RegQueryValueEx(handle, valuename, 0, NULL,
272 (PBYTE)SvPVX(*svp), &datalen);
273 if (retval == ERROR_SUCCESS) {
275 SvCUR_set(*svp,datalen-1);
283 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
285 get_regstr(const char *valuename, SV **svp)
287 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
289 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
293 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
295 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
299 char mod_name[MAX_PATH+1];
305 va_start(ap, trailing_path);
306 strip = va_arg(ap, char *);
308 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
309 baselen = strlen(base);
311 if (!*w32_module_name) {
312 set_w32_module_name();
314 strcpy(mod_name, w32_module_name);
315 ptr = strrchr(mod_name, '/');
316 while (ptr && strip) {
317 /* look for directories to skip back */
320 ptr = strrchr(mod_name, '/');
321 /* avoid stripping component if there is no slash,
322 * or it doesn't match ... */
323 if (!ptr || stricmp(ptr+1, strip) != 0) {
324 /* ... but not if component matches m|5\.$patchlevel.*| */
325 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
326 && strncmp(strip, base, baselen) == 0
327 && strncmp(ptr+1, base, baselen) == 0))
333 strip = va_arg(ap, char *);
341 strcpy(++ptr, trailing_path);
343 /* only add directory if it exists */
344 if (GetFileAttributes(mod_name) != (DWORD) -1) {
345 /* directory exists */
348 *prev_pathp = sv_2mortal(newSVpvn("",0));
349 else if (SvPVX(*prev_pathp))
350 sv_catpvn(*prev_pathp, ";", 1);
351 sv_catpv(*prev_pathp, mod_name);
352 return SvPVX(*prev_pathp);
359 win32_get_privlib(const char *pl)
362 char *stdlib = "lib";
363 char buffer[MAX_PATH+1];
366 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
367 sprintf(buffer, "%s-%s", stdlib, pl);
368 if (!get_regstr(buffer, &sv))
369 (void)get_regstr(stdlib, &sv);
371 /* $stdlib .= ";$EMD/../../lib" */
372 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
376 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
380 char pathstr[MAX_PATH+1];
384 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
385 sprintf(regstr, "%s-%s", xlib, pl);
386 (void)get_regstr(regstr, &sv1);
389 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
390 sprintf(pathstr, "%s/%s/lib", libname, pl);
391 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
393 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
394 (void)get_regstr(xlib, &sv2);
397 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
398 sprintf(pathstr, "%s/lib", libname);
399 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
408 sv_catpvn(sv1, ";", 1);
415 win32_get_sitelib(const char *pl)
417 return win32_get_xlib(pl, "sitelib", "site");
420 #ifndef PERL_VENDORLIB_NAME
421 # define PERL_VENDORLIB_NAME "vendor"
425 win32_get_vendorlib(const char *pl)
427 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
431 has_shell_metachars(const char *ptr)
437 * Scan string looking for redirection (< or >) or pipe
438 * characters (|) that are not in a quoted string.
439 * Shell variable interpolation (%VAR%) can also happen inside strings.
471 #if !defined(PERL_IMPLICIT_SYS)
472 /* since the current process environment is being updated in util.c
473 * the library functions will get the correct environment
476 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
479 #define fixcmd(x) { \
480 char *pspace = strchr((x),' '); \
483 while (p < pspace) { \
494 PERL_FLUSHALL_FOR_CHILD;
495 return win32_popen(cmd, mode);
499 Perl_my_pclose(pTHX_ PerlIO *fp)
501 return win32_pclose(fp);
505 DllExport unsigned long
508 return (unsigned long)g_osver.dwPlatformId;
518 return -((int)w32_pseudo_id);
521 /* Windows 9x appears to always reports a pid for threads and processes
522 * that has the high bit set. So we treat the lower 31 bits as the
523 * "real" PID for Perl's purposes. */
524 if (IsWin95() && pid < 0)
529 /* Tokenize a string. Words are null-separated, and the list
530 * ends with a doubled null. Any character (except null and
531 * including backslash) may be escaped by preceding it with a
532 * backslash (the backslash will be stripped).
533 * Returns number of words in result buffer.
536 tokenize(const char *str, char **dest, char ***destv)
538 char *retstart = Nullch;
539 char **retvstart = 0;
543 int slen = strlen(str);
545 register char **retv;
546 Newx(ret, slen+2, char);
547 Newx(retv, (slen+3)/2, char*);
555 if (*ret == '\\' && *str)
557 else if (*ret == ' ') {
573 retvstart[items] = Nullch;
586 if (!w32_perlshell_tokens) {
587 /* we don't use COMSPEC here for two reasons:
588 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
589 * uncontrolled unportability of the ensuing scripts.
590 * 2. PERL5SHELL could be set to a shell that may not be fit for
591 * interactive use (which is what most programs look in COMSPEC
594 const char* defaultshell = (IsWinNT()
595 ? "cmd.exe /x/d/c" : "command.com /c");
596 const char *usershell = PerlEnv_getenv("PERL5SHELL");
597 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
598 &w32_perlshell_tokens,
604 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
616 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
618 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
623 while (++mark <= sp) {
624 if (*mark && (str = SvPV_nolen(*mark)))
631 status = win32_spawnvp(flag,
632 (const char*)(really ? SvPV_nolen(really) : argv[0]),
633 (const char* const*)argv);
635 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
636 /* possible shell-builtin, invoke with shell */
638 sh_items = w32_perlshell_items;
640 argv[index+sh_items] = argv[index];
641 while (--sh_items >= 0)
642 argv[sh_items] = w32_perlshell_vec[sh_items];
644 status = win32_spawnvp(flag,
645 (const char*)(really ? SvPV_nolen(really) : argv[0]),
646 (const char* const*)argv);
649 if (flag == P_NOWAIT) {
651 PL_statusvalue = -1; /* >16bits hint for pp_system() */
655 if (ckWARN(WARN_EXEC))
656 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
661 PL_statusvalue = status;
667 /* returns pointer to the next unquoted space or the end of the string */
669 find_next_space(const char *s)
671 bool in_quotes = FALSE;
673 /* ignore doubled backslashes, or backslash+quote */
674 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
677 /* keep track of when we're within quotes */
678 else if (*s == '"') {
680 in_quotes = !in_quotes;
682 /* break it up only at spaces that aren't in quotes */
683 else if (!in_quotes && isSPACE(*s))
692 do_spawn2(pTHX_ const char *cmd, int exectype)
698 BOOL needToTry = TRUE;
701 /* Save an extra exec if possible. See if there are shell
702 * metacharacters in it */
703 if (!has_shell_metachars(cmd)) {
704 Newx(argv, strlen(cmd) / 2 + 2, char*);
705 Newx(cmd2, strlen(cmd) + 1, char);
708 for (s = cmd2; *s;) {
709 while (*s && isSPACE(*s))
713 s = find_next_space(s);
721 status = win32_spawnvp(P_WAIT, argv[0],
722 (const char* const*)argv);
724 case EXECF_SPAWN_NOWAIT:
725 status = win32_spawnvp(P_NOWAIT, argv[0],
726 (const char* const*)argv);
729 status = win32_execvp(argv[0], (const char* const*)argv);
732 if (status != -1 || errno == 0)
742 Newx(argv, w32_perlshell_items + 2, char*);
743 while (++i < w32_perlshell_items)
744 argv[i] = w32_perlshell_vec[i];
745 argv[i++] = (char *)cmd;
749 status = win32_spawnvp(P_WAIT, argv[0],
750 (const char* const*)argv);
752 case EXECF_SPAWN_NOWAIT:
753 status = win32_spawnvp(P_NOWAIT, argv[0],
754 (const char* const*)argv);
757 status = win32_execvp(argv[0], (const char* const*)argv);
763 if (exectype == EXECF_SPAWN_NOWAIT) {
765 PL_statusvalue = -1; /* >16bits hint for pp_system() */
769 if (ckWARN(WARN_EXEC))
770 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
771 (exectype == EXECF_EXEC ? "exec" : "spawn"),
772 cmd, strerror(errno));
777 PL_statusvalue = status;
783 Perl_do_spawn(pTHX_ char *cmd)
785 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
789 Perl_do_spawn_nowait(pTHX_ char *cmd)
791 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
795 Perl_do_exec(pTHX_ const char *cmd)
797 do_spawn2(aTHX_ cmd, EXECF_EXEC);
801 /* The idea here is to read all the directory names into a string table
802 * (separated by nulls) and when one of the other dir functions is called
803 * return the pointer to the current file name.
806 win32_opendir(const char *filename)
812 char scanname[MAX_PATH+3];
814 WIN32_FIND_DATAA aFindData;
815 WIN32_FIND_DATAW wFindData;
817 char buffer[MAX_PATH*2];
820 len = strlen(filename);
824 /* check to see if filename is a directory */
825 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
828 /* Get us a DIR structure */
831 /* Create the search pattern */
832 strcpy(scanname, filename);
834 /* bare drive name means look in cwd for drive */
835 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
836 scanname[len++] = '.';
837 scanname[len++] = '/';
839 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
840 scanname[len++] = '/';
842 scanname[len++] = '*';
843 scanname[len] = '\0';
845 /* do the FindFirstFile call */
847 WCHAR wscanname[sizeof(scanname)];
848 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
849 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
853 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
855 if (dirp->handle == INVALID_HANDLE_VALUE) {
856 DWORD err = GetLastError();
857 /* FindFirstFile() fails on empty drives! */
859 case ERROR_FILE_NOT_FOUND:
861 case ERROR_NO_MORE_FILES:
862 case ERROR_PATH_NOT_FOUND:
865 case ERROR_NOT_ENOUGH_MEMORY:
877 BOOL use_default = FALSE;
878 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
879 wFindData.cFileName, -1,
880 buffer, sizeof(buffer), NULL, &use_default);
881 if (use_default && *wFindData.cAlternateFileName) {
882 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
883 wFindData.cAlternateFileName, -1,
884 buffer, sizeof(buffer), NULL, NULL);
889 ptr = aFindData.cFileName;
891 /* now allocate the first part of the string table for
892 * the filenames that we find.
899 Newx(dirp->start, dirp->size, char);
900 strcpy(dirp->start, ptr);
902 dirp->end = dirp->curr = dirp->start;
908 /* Readdir just returns the current string pointer and bumps the
909 * string pointer to the nDllExport entry.
911 DllExport struct direct *
912 win32_readdir(DIR *dirp)
917 /* first set up the structure to return */
918 len = strlen(dirp->curr);
919 strcpy(dirp->dirstr.d_name, dirp->curr);
920 dirp->dirstr.d_namlen = len;
923 dirp->dirstr.d_ino = dirp->curr - dirp->start;
925 /* Now set up for the next call to readdir */
926 dirp->curr += len + 1;
927 if (dirp->curr >= dirp->end) {
930 WIN32_FIND_DATAA aFindData;
931 char buffer[MAX_PATH*2];
934 /* finding the next file that matches the wildcard
935 * (which should be all of them in this directory!).
938 WIN32_FIND_DATAW wFindData;
939 res = FindNextFileW(dirp->handle, &wFindData);
941 BOOL use_default = FALSE;
942 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
943 wFindData.cFileName, -1,
944 buffer, sizeof(buffer), NULL, &use_default);
945 if (use_default && *wFindData.cAlternateFileName) {
946 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
947 wFindData.cAlternateFileName, -1,
948 buffer, sizeof(buffer), NULL, NULL);
954 res = FindNextFileA(dirp->handle, &aFindData);
955 ptr = aFindData.cFileName;
958 long endpos = dirp->end - dirp->start;
959 long newsize = endpos + strlen(ptr) + 1;
960 /* bump the string table size by enough for the
961 * new name and its null terminator */
962 while (newsize > dirp->size) {
963 long curpos = dirp->curr - dirp->start;
965 Renew(dirp->start, dirp->size, char);
966 dirp->curr = dirp->start + curpos;
968 strcpy(dirp->start + endpos, ptr);
969 dirp->end = dirp->start + newsize;
975 return &(dirp->dirstr);
981 /* Telldir returns the current string pointer position */
983 win32_telldir(DIR *dirp)
985 return (dirp->curr - dirp->start);
989 /* Seekdir moves the string pointer to a previously saved position
990 * (returned by telldir).
993 win32_seekdir(DIR *dirp, long loc)
995 dirp->curr = dirp->start + loc;
998 /* Rewinddir resets the string pointer to the start */
1000 win32_rewinddir(DIR *dirp)
1002 dirp->curr = dirp->start;
1005 /* free the memory allocated by opendir */
1007 win32_closedir(DIR *dirp)
1010 if (dirp->handle != INVALID_HANDLE_VALUE)
1011 FindClose(dirp->handle);
1012 Safefree(dirp->start);
1025 * Just pretend that everyone is a superuser. NT will let us know if
1026 * we don\'t really have permission to do something.
1029 #define ROOT_UID ((uid_t)0)
1030 #define ROOT_GID ((gid_t)0)
1059 return (auid == ROOT_UID ? 0 : -1);
1065 return (agid == ROOT_GID ? 0 : -1);
1072 char *buf = w32_getlogin_buffer;
1073 DWORD size = sizeof(w32_getlogin_buffer);
1074 if (GetUserName(buf,&size))
1080 chown(const char *path, uid_t owner, gid_t group)
1087 * XXX this needs strengthening (for PerlIO)
1090 int mkstemp(const char *path)
1093 char buf[MAX_PATH+1];
1097 if (i++ > 10) { /* give up */
1101 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1105 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1115 long child = w32_num_children;
1116 while (--child >= 0) {
1117 if ((int)w32_child_pids[child] == pid)
1124 remove_dead_process(long child)
1128 CloseHandle(w32_child_handles[child]);
1129 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1130 (w32_num_children-child-1), HANDLE);
1131 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1132 (w32_num_children-child-1), DWORD);
1139 find_pseudo_pid(int pid)
1142 long child = w32_num_pseudo_children;
1143 while (--child >= 0) {
1144 if ((int)w32_pseudo_child_pids[child] == pid)
1151 remove_dead_pseudo_process(long child)
1155 CloseHandle(w32_pseudo_child_handles[child]);
1156 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1157 (w32_num_pseudo_children-child-1), HANDLE);
1158 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1159 (w32_num_pseudo_children-child-1), DWORD);
1160 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1161 (w32_num_pseudo_children-child-1), HWND);
1162 w32_num_pseudo_children--;
1168 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1172 /* "Does process exist?" use of kill */
1175 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1180 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1183 default: /* For now be backwards compatible with perl 5.6 */
1185 /* Note that we will only be able to kill processes owned by the
1186 * current process owner, even when we are running as an administrator.
1187 * To kill processes of other owners we would need to set the
1188 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1190 if (TerminateProcess(process_handle, sig))
1197 /* Traverse process tree using ToolHelp functions */
1199 kill_process_tree_toolhelp(DWORD pid, int sig)
1201 HANDLE process_handle;
1202 HANDLE snapshot_handle;
1205 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1206 if (process_handle == INVALID_HANDLE_VALUE)
1209 killed += terminate_process(pid, process_handle, sig);
1211 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1212 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1213 PROCESSENTRY32 entry;
1215 entry.dwSize = sizeof(entry);
1216 if (pfnProcess32First(snapshot_handle, &entry)) {
1218 if (entry.th32ParentProcessID == pid)
1219 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1220 entry.dwSize = sizeof(entry);
1222 while (pfnProcess32Next(snapshot_handle, &entry));
1224 CloseHandle(snapshot_handle);
1226 CloseHandle(process_handle);
1230 /* Traverse process tree using undocumented system information structures.
1231 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1234 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1236 HANDLE process_handle;
1237 SYSTEM_PROCESSES *p = process_info;
1240 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1241 if (process_handle == INVALID_HANDLE_VALUE)
1244 killed += terminate_process(pid, process_handle, sig);
1247 if (p->InheritedFromProcessId == (DWORD)pid)
1248 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1250 if (p->NextEntryDelta == 0)
1253 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1256 CloseHandle(process_handle);
1261 killpg(int pid, int sig)
1263 /* Use "documented" method whenever available */
1264 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1265 return kill_process_tree_toolhelp((DWORD)pid, sig);
1268 /* Fall back to undocumented Windows internals on Windows NT */
1269 if (pfnZwQuerySystemInformation) {
1274 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1275 Newx(buffer, size, char);
1277 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1278 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1287 my_kill(int pid, int sig)
1290 HANDLE process_handle;
1293 return killpg(pid, -sig);
1295 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1296 if (process_handle != INVALID_HANDLE_VALUE) {
1297 retval = terminate_process(pid, process_handle, sig);
1298 CloseHandle(process_handle);
1304 win32_kill(int pid, int sig)
1310 /* it is a pseudo-forked child */
1311 child = find_pseudo_pid(-pid);
1313 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1314 HANDLE hProcess = w32_pseudo_child_handles[child];
1317 /* "Does process exist?" use of kill */
1321 /* kill -9 style un-graceful exit */
1322 if (TerminateThread(hProcess, sig)) {
1323 remove_dead_pseudo_process(child);
1330 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1331 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1332 /* Yield and wait for the other thread to send us its message_hwnd */
1334 win32_async_check(aTHX);
1337 if (hwnd != INVALID_HANDLE_VALUE) {
1338 /* We fake signals to pseudo-processes using Win32
1339 * message queue. In Win9X the pids are negative already. */
1340 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1341 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1343 /* It might be us ... */
1352 else if (IsWin95()) {
1360 child = find_pid(pid);
1362 if (my_kill(pid, sig)) {
1364 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1365 exitcode != STILL_ACTIVE)
1367 remove_dead_process(child);
1374 if (my_kill((IsWin95() ? -pid : pid), sig))
1383 win32_stat(const char *path, Stat_t *sbuf)
1386 char buffer[MAX_PATH+1];
1387 int l = strlen(path);
1390 BOOL expect_dir = FALSE;
1392 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1393 GV_NOTQUAL, SVt_PV);
1394 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1397 switch(path[l - 1]) {
1398 /* FindFirstFile() and stat() are buggy with a trailing
1399 * slashes, except for the root directory of a drive */
1402 if (l > sizeof(buffer)) {
1403 errno = ENAMETOOLONG;
1407 strncpy(buffer, path, l);
1408 /* remove additional trailing slashes */
1409 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1411 /* add back slash if we otherwise end up with just a drive letter */
1412 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1419 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1421 if (l == 2 && isALPHA(path[0])) {
1422 buffer[0] = path[0];
1433 path = PerlDir_mapA(path);
1437 /* We must open & close the file once; otherwise file attribute changes */
1438 /* might not yet have propagated to "other" hard links of the same file. */
1439 /* This also gives us an opportunity to determine the number of links. */
1440 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1441 if (handle != INVALID_HANDLE_VALUE) {
1442 BY_HANDLE_FILE_INFORMATION bhi;
1443 if (GetFileInformationByHandle(handle, &bhi))
1444 nlink = bhi.nNumberOfLinks;
1445 CloseHandle(handle);
1449 /* path will be mapped correctly above */
1450 #if defined(WIN64) || defined(USE_LARGE_FILES)
1451 res = _stati64(path, sbuf);
1453 res = stat(path, sbuf);
1455 sbuf->st_nlink = nlink;
1458 /* CRT is buggy on sharenames, so make sure it really isn't.
1459 * XXX using GetFileAttributesEx() will enable us to set
1460 * sbuf->st_*time (but note that's not available on the
1461 * Windows of 1995) */
1462 DWORD r = GetFileAttributesA(path);
1463 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1464 /* sbuf may still contain old garbage since stat() failed */
1465 Zero(sbuf, 1, Stat_t);
1466 sbuf->st_mode = S_IFDIR | S_IREAD;
1468 if (!(r & FILE_ATTRIBUTE_READONLY))
1469 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1474 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1475 && (path[2] == '\\' || path[2] == '/'))
1477 /* The drive can be inaccessible, some _stat()s are buggy */
1478 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1483 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1488 if (S_ISDIR(sbuf->st_mode))
1489 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1490 else if (S_ISREG(sbuf->st_mode)) {
1492 if (l >= 4 && path[l-4] == '.') {
1493 const char *e = path + l - 3;
1494 if (strnicmp(e,"exe",3)
1495 && strnicmp(e,"bat",3)
1496 && strnicmp(e,"com",3)
1497 && (IsWin95() || strnicmp(e,"cmd",3)))
1498 sbuf->st_mode &= ~S_IEXEC;
1500 sbuf->st_mode |= S_IEXEC;
1503 sbuf->st_mode &= ~S_IEXEC;
1504 /* Propagate permissions to _group_ and _others_ */
1505 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1506 sbuf->st_mode |= (perms>>3) | (perms>>6);
1513 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1514 #define SKIP_SLASHES(s) \
1516 while (*(s) && isSLASH(*(s))) \
1519 #define COPY_NONSLASHES(d,s) \
1521 while (*(s) && !isSLASH(*(s))) \
1525 /* Find the longname of a given path. path is destructively modified.
1526 * It should have space for at least MAX_PATH characters. */
1528 win32_longpath(char *path)
1530 WIN32_FIND_DATA fdata;
1532 char tmpbuf[MAX_PATH+1];
1533 char *tmpstart = tmpbuf;
1540 if (isALPHA(path[0]) && path[1] == ':') {
1542 *tmpstart++ = path[0];
1546 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1548 *tmpstart++ = path[0];
1549 *tmpstart++ = path[1];
1550 SKIP_SLASHES(start);
1551 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1553 *tmpstart++ = *start++;
1554 SKIP_SLASHES(start);
1555 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1560 /* copy initial slash, if any */
1561 if (isSLASH(*start)) {
1562 *tmpstart++ = *start++;
1564 SKIP_SLASHES(start);
1567 /* FindFirstFile() expands "." and "..", so we need to pass
1568 * those through unmolested */
1570 && (!start[1] || isSLASH(start[1])
1571 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1573 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1578 /* if this is the end, bust outta here */
1582 /* now we're at a non-slash; walk up to next slash */
1583 while (*start && !isSLASH(*start))
1586 /* stop and find full name of component */
1589 fhand = FindFirstFile(path,&fdata);
1591 if (fhand != INVALID_HANDLE_VALUE) {
1592 STRLEN len = strlen(fdata.cFileName);
1593 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1594 strcpy(tmpstart, fdata.cFileName);
1605 /* failed a step, just return without side effects */
1606 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1611 strcpy(path,tmpbuf);
1620 /* Can't use PerlIO to write as it allocates memory */
1621 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1622 PL_no_mem, strlen(PL_no_mem));
1628 /* The win32_ansipath() function takes a Unicode filename and converts it
1629 * into the current Windows codepage. If some characters cannot be mapped,
1630 * then it will convert the short name instead.
1632 * The buffer to the ansi pathname must be freed with win32_free() when it
1633 * it no longer needed.
1635 * The argument to win32_ansipath() must exist before this function is
1636 * called; otherwise there is no way to determine the short path name.
1638 * Ideas for future refinement:
1639 * - Only convert those segments of the path that are not in the current
1640 * codepage, but leave the other segments in their long form.
1641 * - If the resulting name is longer than MAX_PATH, start converting
1642 * additional path segments into short names until the full name
1643 * is shorter than MAX_PATH. Shorten the filename part last!
1646 win32_ansipath(const WCHAR *widename)
1649 BOOL use_default = FALSE;
1650 size_t widelen = wcslen(widename)+1;
1651 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1652 NULL, 0, NULL, NULL);
1653 name = win32_malloc(len);
1657 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1658 name, len, NULL, &use_default);
1660 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1662 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1665 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1667 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1668 NULL, 0, NULL, NULL);
1669 name = win32_realloc(name, len);
1672 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1673 name, len, NULL, NULL);
1674 win32_free(shortname);
1681 win32_getenv(const char *name)
1685 SV *curitem = Nullsv;
1687 needlen = GetEnvironmentVariableA(name,NULL,0);
1689 curitem = sv_2mortal(newSVpvn("", 0));
1691 SvGROW(curitem, needlen+1);
1692 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1694 } while (needlen >= SvLEN(curitem));
1695 SvCUR_set(curitem, needlen);
1698 /* allow any environment variables that begin with 'PERL'
1699 to be stored in the registry */
1700 if (strncmp(name, "PERL", 4) == 0)
1701 (void)get_regstr(name, &curitem);
1703 if (curitem && SvCUR(curitem))
1704 return SvPVX(curitem);
1710 win32_putenv(const char *name)
1718 Newx(curitem,strlen(name)+1,char);
1719 strcpy(curitem, name);
1720 val = strchr(curitem, '=');
1722 /* The sane way to deal with the environment.
1723 * Has these advantages over putenv() & co.:
1724 * * enables us to store a truly empty value in the
1725 * environment (like in UNIX).
1726 * * we don't have to deal with RTL globals, bugs and leaks.
1728 * Why you may want to enable USE_WIN32_RTL_ENV:
1729 * * environ[] and RTL functions will not reflect changes,
1730 * which might be an issue if extensions want to access
1731 * the env. via RTL. This cuts both ways, since RTL will
1732 * not see changes made by extensions that call the Win32
1733 * functions directly, either.
1737 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1746 filetime_to_clock(PFILETIME ft)
1748 __int64 qw = ft->dwHighDateTime;
1750 qw |= ft->dwLowDateTime;
1751 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1756 win32_times(struct tms *timebuf)
1761 clock_t process_time_so_far = clock();
1762 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1764 timebuf->tms_utime = filetime_to_clock(&user);
1765 timebuf->tms_stime = filetime_to_clock(&kernel);
1766 timebuf->tms_cutime = 0;
1767 timebuf->tms_cstime = 0;
1769 /* That failed - e.g. Win95 fallback to clock() */
1770 timebuf->tms_utime = process_time_so_far;
1771 timebuf->tms_stime = 0;
1772 timebuf->tms_cutime = 0;
1773 timebuf->tms_cstime = 0;
1775 return process_time_so_far;
1778 /* fix utime() so it works on directories in NT */
1780 filetime_from_time(PFILETIME pFileTime, time_t Time)
1782 struct tm *pTM = localtime(&Time);
1783 SYSTEMTIME SystemTime;
1789 SystemTime.wYear = pTM->tm_year + 1900;
1790 SystemTime.wMonth = pTM->tm_mon + 1;
1791 SystemTime.wDay = pTM->tm_mday;
1792 SystemTime.wHour = pTM->tm_hour;
1793 SystemTime.wMinute = pTM->tm_min;
1794 SystemTime.wSecond = pTM->tm_sec;
1795 SystemTime.wMilliseconds = 0;
1797 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1798 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1802 win32_unlink(const char *filename)
1808 filename = PerlDir_mapA(filename);
1809 attrs = GetFileAttributesA(filename);
1810 if (attrs == 0xFFFFFFFF) {
1814 if (attrs & FILE_ATTRIBUTE_READONLY) {
1815 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1816 ret = unlink(filename);
1818 (void)SetFileAttributesA(filename, attrs);
1821 ret = unlink(filename);
1826 win32_utime(const char *filename, struct utimbuf *times)
1833 struct utimbuf TimeBuffer;
1836 filename = PerlDir_mapA(filename);
1837 rc = utime(filename, times);
1839 /* EACCES: path specifies directory or readonly file */
1840 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1843 if (times == NULL) {
1844 times = &TimeBuffer;
1845 time(×->actime);
1846 times->modtime = times->actime;
1849 /* This will (and should) still fail on readonly files */
1850 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1851 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1852 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1853 if (handle == INVALID_HANDLE_VALUE)
1856 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1857 filetime_from_time(&ftAccess, times->actime) &&
1858 filetime_from_time(&ftWrite, times->modtime) &&
1859 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1864 CloseHandle(handle);
1869 unsigned __int64 ft_i64;
1874 #define Const64(x) x##LL
1876 #define Const64(x) x##i64
1878 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1879 #define EPOCH_BIAS Const64(116444736000000000)
1881 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1882 * and appears to be unsupported even by glibc) */
1884 win32_gettimeofday(struct timeval *tp, void *not_used)
1888 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1889 GetSystemTimeAsFileTime(&ft.ft_val);
1891 /* seconds since epoch */
1892 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1894 /* microseconds remaining */
1895 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1901 win32_uname(struct utsname *name)
1903 struct hostent *hep;
1904 STRLEN nodemax = sizeof(name->nodename)-1;
1907 switch (g_osver.dwPlatformId) {
1908 case VER_PLATFORM_WIN32_WINDOWS:
1909 strcpy(name->sysname, "Windows");
1911 case VER_PLATFORM_WIN32_NT:
1912 strcpy(name->sysname, "Windows NT");
1914 case VER_PLATFORM_WIN32s:
1915 strcpy(name->sysname, "Win32s");
1918 strcpy(name->sysname, "Win32 Unknown");
1923 sprintf(name->release, "%d.%d",
1924 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1927 sprintf(name->version, "Build %d",
1928 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1929 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1930 if (g_osver.szCSDVersion[0]) {
1931 char *buf = name->version + strlen(name->version);
1932 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1936 hep = win32_gethostbyname("localhost");
1938 STRLEN len = strlen(hep->h_name);
1939 if (len <= nodemax) {
1940 strcpy(name->nodename, hep->h_name);
1943 strncpy(name->nodename, hep->h_name, nodemax);
1944 name->nodename[nodemax] = '\0';
1949 if (!GetComputerName(name->nodename, &sz))
1950 *name->nodename = '\0';
1953 /* machine (architecture) */
1958 GetSystemInfo(&info);
1960 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1961 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1962 procarch = info.u.s.wProcessorArchitecture;
1964 procarch = info.wProcessorArchitecture;
1967 case PROCESSOR_ARCHITECTURE_INTEL:
1968 arch = "x86"; break;
1969 case PROCESSOR_ARCHITECTURE_MIPS:
1970 arch = "mips"; break;
1971 case PROCESSOR_ARCHITECTURE_ALPHA:
1972 arch = "alpha"; break;
1973 case PROCESSOR_ARCHITECTURE_PPC:
1974 arch = "ppc"; break;
1975 #ifdef PROCESSOR_ARCHITECTURE_SHX
1976 case PROCESSOR_ARCHITECTURE_SHX:
1977 arch = "shx"; break;
1979 #ifdef PROCESSOR_ARCHITECTURE_ARM
1980 case PROCESSOR_ARCHITECTURE_ARM:
1981 arch = "arm"; break;
1983 #ifdef PROCESSOR_ARCHITECTURE_IA64
1984 case PROCESSOR_ARCHITECTURE_IA64:
1985 arch = "ia64"; break;
1987 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1988 case PROCESSOR_ARCHITECTURE_ALPHA64:
1989 arch = "alpha64"; break;
1991 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1992 case PROCESSOR_ARCHITECTURE_MSIL:
1993 arch = "msil"; break;
1995 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1996 case PROCESSOR_ARCHITECTURE_AMD64:
1997 arch = "amd64"; break;
1999 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2000 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2001 arch = "ia32-64"; break;
2003 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2004 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2005 arch = "unknown"; break;
2008 sprintf(name->machine, "unknown(0x%x)", procarch);
2009 arch = name->machine;
2012 if (name->machine != arch)
2013 strcpy(name->machine, arch);
2018 /* Timing related stuff */
2021 do_raise(pTHX_ int sig)
2023 if (sig < SIG_SIZE) {
2024 Sighandler_t handler = w32_sighandler[sig];
2025 if (handler == SIG_IGN) {
2028 else if (handler != SIG_DFL) {
2033 /* Choose correct default behaviour */
2049 /* Tell caller to exit thread/process as approriate */
2054 sig_terminate(pTHX_ int sig)
2056 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2057 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2064 win32_async_check(pTHX)
2067 HWND hwnd = w32_message_hwnd;
2071 if (hwnd == INVALID_HANDLE_VALUE) {
2072 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2073 * This is necessary when we are being called by win32_msgwait() to
2074 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2075 * message over and over. An example how this can happen is when
2076 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2077 * is generating messages before the process terminated.
2079 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2085 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
2086 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2091 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2092 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2094 switch (msg.message) {
2096 case WM_USER_MESSAGE: {
2097 int child = find_pseudo_pid(msg.wParam);
2099 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
2104 case WM_USER_KILL: {
2105 /* We use WM_USER to fake kill() with other signals */
2106 int sig = msg.wParam;
2107 if (do_raise(aTHX_ sig))
2108 sig_terminate(aTHX_ sig);
2113 /* alarm() is a one-shot but SetTimer() repeats so kill it */
2114 if (w32_timerid && w32_timerid==msg.wParam) {
2115 KillTimer(w32_message_hwnd, w32_timerid);
2118 /* Now fake a call to signal handler */
2119 if (do_raise(aTHX_ 14))
2120 sig_terminate(aTHX_ 14);
2127 /* Above or other stuff may have set a signal flag */
2128 if (PL_sig_pending) {
2134 /* This function will not return until the timeout has elapsed, or until
2135 * one of the handles is ready. */
2137 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2139 /* We may need several goes at this - so compute when we stop */
2141 if (timeout != INFINITE) {
2142 ticks = GetTickCount();
2146 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER);
2149 if (result == WAIT_TIMEOUT) {
2150 /* Ran out of time - explicit return of zero to avoid -ve if we
2151 have scheduling issues
2155 if (timeout != INFINITE) {
2156 ticks = GetTickCount();
2158 if (result == WAIT_OBJECT_0 + count) {
2159 /* Message has arrived - check it */
2160 (void)win32_async_check(aTHX);
2163 /* Not timeout or message - one of handles is ready */
2167 /* compute time left to wait */
2168 ticks = timeout - ticks;
2169 /* If we are past the end say zero */
2170 return (ticks > 0) ? ticks : 0;
2174 win32_internal_wait(int *status, DWORD timeout)
2176 /* XXX this wait emulation only knows about processes
2177 * spawned via win32_spawnvp(P_NOWAIT, ...).
2181 DWORD exitcode, waitcode;
2184 if (w32_num_pseudo_children) {
2185 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2186 timeout, &waitcode);
2187 /* Time out here if there are no other children to wait for. */
2188 if (waitcode == WAIT_TIMEOUT) {
2189 if (!w32_num_children) {
2193 else if (waitcode != WAIT_FAILED) {
2194 if (waitcode >= WAIT_ABANDONED_0
2195 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2196 i = waitcode - WAIT_ABANDONED_0;
2198 i = waitcode - WAIT_OBJECT_0;
2199 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2200 *status = (int)((exitcode & 0xff) << 8);
2201 retval = (int)w32_pseudo_child_pids[i];
2202 remove_dead_pseudo_process(i);
2209 if (!w32_num_children) {
2214 /* if a child exists, wait for it to die */
2215 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2216 if (waitcode == WAIT_TIMEOUT) {
2219 if (waitcode != WAIT_FAILED) {
2220 if (waitcode >= WAIT_ABANDONED_0
2221 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2222 i = waitcode - WAIT_ABANDONED_0;
2224 i = waitcode - WAIT_OBJECT_0;
2225 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2226 *status = (int)((exitcode & 0xff) << 8);
2227 retval = (int)w32_child_pids[i];
2228 remove_dead_process(i);
2233 errno = GetLastError();
2238 win32_waitpid(int pid, int *status, int flags)
2241 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2244 if (pid == -1) /* XXX threadid == 1 ? */
2245 return win32_internal_wait(status, timeout);
2248 child = find_pseudo_pid(-pid);
2250 HANDLE hThread = w32_pseudo_child_handles[child];
2252 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2253 if (waitcode == WAIT_TIMEOUT) {
2256 else if (waitcode == WAIT_OBJECT_0) {
2257 if (GetExitCodeThread(hThread, &waitcode)) {
2258 *status = (int)((waitcode & 0xff) << 8);
2259 retval = (int)w32_pseudo_child_pids[child];
2260 remove_dead_pseudo_process(child);
2267 else if (IsWin95()) {
2276 child = find_pid(pid);
2278 hProcess = w32_child_handles[child];
2279 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2280 if (waitcode == WAIT_TIMEOUT) {
2283 else if (waitcode == WAIT_OBJECT_0) {
2284 if (GetExitCodeProcess(hProcess, &waitcode)) {
2285 *status = (int)((waitcode & 0xff) << 8);
2286 retval = (int)w32_child_pids[child];
2287 remove_dead_process(child);
2296 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2297 (IsWin95() ? -pid : pid));
2299 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2300 if (waitcode == WAIT_TIMEOUT) {
2301 CloseHandle(hProcess);
2304 else if (waitcode == WAIT_OBJECT_0) {
2305 if (GetExitCodeProcess(hProcess, &waitcode)) {
2306 *status = (int)((waitcode & 0xff) << 8);
2307 CloseHandle(hProcess);
2311 CloseHandle(hProcess);
2317 return retval >= 0 ? pid : retval;
2321 win32_wait(int *status)
2323 return win32_internal_wait(status, INFINITE);
2326 DllExport unsigned int
2327 win32_sleep(unsigned int t)
2330 /* Win32 times are in ms so *1000 in and /1000 out */
2331 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2334 DllExport unsigned int
2335 win32_alarm(unsigned int sec)
2338 * the 'obvious' implentation is SetTimer() with a callback
2339 * which does whatever receiving SIGALRM would do
2340 * we cannot use SIGALRM even via raise() as it is not
2341 * one of the supported codes in <signal.h>
2345 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2346 w32_message_hwnd = win32_create_message_window();
2349 if (w32_message_hwnd == NULL)
2350 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2353 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2358 KillTimer(w32_message_hwnd, w32_timerid);
2365 #ifdef HAVE_DES_FCRYPT
2366 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2370 win32_crypt(const char *txt, const char *salt)
2373 #ifdef HAVE_DES_FCRYPT
2374 return des_fcrypt(txt, salt, w32_crypt_buffer);
2376 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2381 #ifdef USE_FIXED_OSFHANDLE
2383 #define FOPEN 0x01 /* file handle open */
2384 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2385 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2386 #define FDEV 0x40 /* file handle refers to device */
2387 #define FTEXT 0x80 /* file handle is in text mode */
2390 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2393 * This function allocates a free C Runtime file handle and associates
2394 * it with the Win32 HANDLE specified by the first parameter. This is a
2395 * temperary fix for WIN95's brain damage GetFileType() error on socket
2396 * we just bypass that call for socket
2398 * This works with MSVC++ 4.0+ or GCC/Mingw32
2401 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2402 * int flags - flags to associate with C Runtime file handle.
2405 * returns index of entry in fh, if successful
2406 * return -1, if no free entry is found
2410 *******************************************************************************/
2413 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2414 * this lets sockets work on Win9X with GCC and should fix the problems
2419 /* create an ioinfo entry, kill its handle, and steal the entry */
2424 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2425 int fh = _open_osfhandle((intptr_t)hF, 0);
2429 EnterCriticalSection(&(_pioinfo(fh)->lock));
2434 my_open_osfhandle(intptr_t osfhandle, int flags)
2437 char fileflags; /* _osfile flags */
2439 /* copy relevant flags from second parameter */
2442 if (flags & O_APPEND)
2443 fileflags |= FAPPEND;
2448 if (flags & O_NOINHERIT)
2449 fileflags |= FNOINHERIT;
2451 /* attempt to allocate a C Runtime file handle */
2452 if ((fh = _alloc_osfhnd()) == -1) {
2453 errno = EMFILE; /* too many open files */
2454 _doserrno = 0L; /* not an OS error */
2455 return -1; /* return error to caller */
2458 /* the file is open. now, set the info in _osfhnd array */
2459 _set_osfhnd(fh, osfhandle);
2461 fileflags |= FOPEN; /* mark as open */
2463 _osfile(fh) = fileflags; /* set osfile entry */
2464 LeaveCriticalSection(&_pioinfo(fh)->lock);
2466 return fh; /* return handle */
2469 #endif /* USE_FIXED_OSFHANDLE */
2471 /* simulate flock by locking a range on the file */
2473 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2474 #define LK_LEN 0xffff0000
2477 win32_flock(int fd, int oper)
2485 Perl_croak_nocontext("flock() unimplemented on this platform");
2488 fh = (HANDLE)_get_osfhandle(fd);
2489 memset(&o, 0, sizeof(o));
2492 case LOCK_SH: /* shared lock */
2493 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2495 case LOCK_EX: /* exclusive lock */
2496 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2498 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2499 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2501 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2502 LK_ERR(LockFileEx(fh,
2503 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2504 0, LK_LEN, 0, &o),i);
2506 case LOCK_UN: /* unlock lock */
2507 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2509 default: /* unknown */
2520 * redirected io subsystem for all XS modules
2533 return (&(_environ));
2536 /* the rest are the remapped stdio routines */
2556 win32_ferror(FILE *fp)
2558 return (ferror(fp));
2563 win32_feof(FILE *fp)
2569 * Since the errors returned by the socket error function
2570 * WSAGetLastError() are not known by the library routine strerror
2571 * we have to roll our own.
2575 win32_strerror(int e)
2577 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2578 extern int sys_nerr;
2582 if (e < 0 || e > sys_nerr) {
2587 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2588 w32_strerror_buffer,
2589 sizeof(w32_strerror_buffer), NULL) == 0)
2590 strcpy(w32_strerror_buffer, "Unknown Error");
2592 return w32_strerror_buffer;
2598 win32_str_os_error(void *sv, DWORD dwErr)
2602 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2603 |FORMAT_MESSAGE_IGNORE_INSERTS
2604 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2605 dwErr, 0, (char *)&sMsg, 1, NULL);
2606 /* strip trailing whitespace and period */
2609 --dwLen; /* dwLen doesn't include trailing null */
2610 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2611 if ('.' != sMsg[dwLen])
2616 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2618 dwLen = sprintf(sMsg,
2619 "Unknown error #0x%lX (lookup 0x%lX)",
2620 dwErr, GetLastError());
2624 sv_setpvn((SV*)sv, sMsg, dwLen);
2630 win32_fprintf(FILE *fp, const char *format, ...)
2633 va_start(marker, format); /* Initialize variable arguments. */
2635 return (vfprintf(fp, format, marker));
2639 win32_printf(const char *format, ...)
2642 va_start(marker, format); /* Initialize variable arguments. */
2644 return (vprintf(format, marker));
2648 win32_vfprintf(FILE *fp, const char *format, va_list args)
2650 return (vfprintf(fp, format, args));
2654 win32_vprintf(const char *format, va_list args)
2656 return (vprintf(format, args));
2660 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2662 return fread(buf, size, count, fp);
2666 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2668 return fwrite(buf, size, count, fp);
2671 #define MODE_SIZE 10
2674 win32_fopen(const char *filename, const char *mode)
2682 if (stricmp(filename, "/dev/null")==0)
2685 f = fopen(PerlDir_mapA(filename), mode);
2686 /* avoid buffering headaches for child processes */
2687 if (f && *mode == 'a')
2688 win32_fseek(f, 0, SEEK_END);
2692 #ifndef USE_SOCKETS_AS_HANDLES
2694 #define fdopen my_fdopen
2698 win32_fdopen(int handle, const char *mode)
2702 f = fdopen(handle, (char *) mode);
2703 /* avoid buffering headaches for child processes */
2704 if (f && *mode == 'a')
2705 win32_fseek(f, 0, SEEK_END);
2710 win32_freopen(const char *path, const char *mode, FILE *stream)
2713 if (stricmp(path, "/dev/null")==0)
2716 return freopen(PerlDir_mapA(path), mode, stream);
2720 win32_fclose(FILE *pf)
2722 return my_fclose(pf); /* defined in win32sck.c */
2726 win32_fputs(const char *s,FILE *pf)
2728 return fputs(s, pf);
2732 win32_fputc(int c,FILE *pf)
2738 win32_ungetc(int c,FILE *pf)
2740 return ungetc(c,pf);
2744 win32_getc(FILE *pf)
2750 win32_fileno(FILE *pf)
2756 win32_clearerr(FILE *pf)
2763 win32_fflush(FILE *pf)
2769 win32_ftell(FILE *pf)
2771 #if defined(WIN64) || defined(USE_LARGE_FILES)
2772 #if defined(__BORLANDC__) /* buk */
2773 return win32_tell( fileno( pf ) );
2776 if (fgetpos(pf, &pos))
2786 win32_fseek(FILE *pf, Off_t offset,int origin)
2788 #if defined(WIN64) || defined(USE_LARGE_FILES)
2789 #if defined(__BORLANDC__) /* buk */
2799 if (fgetpos(pf, &pos))
2804 fseek(pf, 0, SEEK_END);
2805 pos = _telli64(fileno(pf));
2814 return fsetpos(pf, &offset);
2817 return fseek(pf, (long)offset, origin);
2822 win32_fgetpos(FILE *pf,fpos_t *p)
2824 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2825 if( win32_tell(fileno(pf)) == -1L ) {
2831 return fgetpos(pf, p);
2836 win32_fsetpos(FILE *pf,const fpos_t *p)
2838 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2839 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2841 return fsetpos(pf, p);
2846 win32_rewind(FILE *pf)
2856 char prefix[MAX_PATH+1];
2857 char filename[MAX_PATH+1];
2858 DWORD len = GetTempPath(MAX_PATH, prefix);
2859 if (len && len < MAX_PATH) {
2860 if (GetTempFileName(prefix, "plx", 0, filename)) {
2861 HANDLE fh = CreateFile(filename,
2862 DELETE | GENERIC_READ | GENERIC_WRITE,
2866 FILE_ATTRIBUTE_NORMAL
2867 | FILE_FLAG_DELETE_ON_CLOSE,
2869 if (fh != INVALID_HANDLE_VALUE) {
2870 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2872 #if defined(__BORLANDC__)
2873 setmode(fd,O_BINARY);
2875 DEBUG_p(PerlIO_printf(Perl_debug_log,
2876 "Created tmpfile=%s\n",filename));
2888 int fd = win32_tmpfd();
2890 return win32_fdopen(fd, "w+b");
2902 win32_fstat(int fd, Stat_t *sbufptr)
2905 /* A file designated by filehandle is not shown as accessible
2906 * for write operations, probably because it is opened for reading.
2909 BY_HANDLE_FILE_INFORMATION bhfi;
2910 #if defined(WIN64) || defined(USE_LARGE_FILES)
2911 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2913 int rc = fstat(fd,&tmp);
2915 sbufptr->st_dev = tmp.st_dev;
2916 sbufptr->st_ino = tmp.st_ino;
2917 sbufptr->st_mode = tmp.st_mode;
2918 sbufptr->st_nlink = tmp.st_nlink;
2919 sbufptr->st_uid = tmp.st_uid;
2920 sbufptr->st_gid = tmp.st_gid;
2921 sbufptr->st_rdev = tmp.st_rdev;
2922 sbufptr->st_size = tmp.st_size;
2923 sbufptr->st_atime = tmp.st_atime;
2924 sbufptr->st_mtime = tmp.st_mtime;
2925 sbufptr->st_ctime = tmp.st_ctime;
2927 int rc = fstat(fd,sbufptr);
2930 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2931 #if defined(WIN64) || defined(USE_LARGE_FILES)
2932 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2934 sbufptr->st_mode &= 0xFE00;
2935 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2936 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2938 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2939 + ((S_IREAD|S_IWRITE) >> 6));
2943 return my_fstat(fd,sbufptr);
2948 win32_pipe(int *pfd, unsigned int size, int mode)
2950 return _pipe(pfd, size, mode);
2954 win32_popenlist(const char *mode, IV narg, SV **args)
2957 Perl_croak(aTHX_ "List form of pipe open not implemented");
2962 * a popen() clone that respects PERL5SHELL
2964 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2968 win32_popen(const char *command, const char *mode)
2970 #ifdef USE_RTL_POPEN
2971 return _popen(command, mode);
2983 /* establish which ends read and write */
2984 if (strchr(mode,'w')) {
2985 stdfd = 0; /* stdin */
2988 nhandle = STD_INPUT_HANDLE;
2990 else if (strchr(mode,'r')) {
2991 stdfd = 1; /* stdout */
2994 nhandle = STD_OUTPUT_HANDLE;
2999 /* set the correct mode */
3000 if (strchr(mode,'b'))
3002 else if (strchr(mode,'t'))
3005 ourmode = _fmode & (O_TEXT | O_BINARY);
3007 /* the child doesn't inherit handles */
3008 ourmode |= O_NOINHERIT;
3010 if (win32_pipe(p, 512, ourmode) == -1)
3013 /* save the old std handle (this needs to happen before the
3014 * dup2(), since that might call SetStdHandle() too) */
3017 old_h = GetStdHandle(nhandle);
3019 /* save current stdfd */
3020 if ((oldfd = win32_dup(stdfd)) == -1)
3023 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3024 /* stdfd will be inherited by the child */
3025 if (win32_dup2(p[child], stdfd) == -1)
3028 /* close the child end in parent */
3029 win32_close(p[child]);
3031 /* set the new std handle (in case dup2() above didn't) */
3032 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3034 /* start the child */
3037 if ((childpid = do_spawn_nowait((char*)command)) == -1)
3040 /* revert stdfd to whatever it was before */
3041 if (win32_dup2(oldfd, stdfd) == -1)
3044 /* close saved handle */
3047 /* restore the old std handle (this needs to happen after the
3048 * dup2(), since that might call SetStdHandle() too */
3050 SetStdHandle(nhandle, old_h);
3056 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3059 /* set process id so that it can be returned by perl's open() */
3060 PL_forkprocess = childpid;
3063 /* we have an fd, return a file stream */
3064 return (PerlIO_fdopen(p[parent], (char *)mode));
3067 /* we don't need to check for errors here */
3071 win32_dup2(oldfd, stdfd);
3075 SetStdHandle(nhandle, old_h);
3081 #endif /* USE_RTL_POPEN */
3089 win32_pclose(PerlIO *pf)
3091 #ifdef USE_RTL_POPEN
3095 int childpid, status;
3099 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3102 childpid = SvIVX(sv);
3120 if (win32_waitpid(childpid, &status, 0) == -1)
3125 #endif /* USE_RTL_POPEN */
3131 LPCWSTR lpExistingFileName,
3132 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3135 WCHAR wFullName[MAX_PATH+1];
3136 LPVOID lpContext = NULL;
3137 WIN32_STREAM_ID StreamId;
3138 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3143 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3144 BOOL, BOOL, LPVOID*) =
3145 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3146 BOOL, BOOL, LPVOID*))
3147 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3148 if (pfnBackupWrite == NULL)
3151 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3154 dwLen = (dwLen+1)*sizeof(WCHAR);
3156 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3157 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3158 NULL, OPEN_EXISTING, 0, NULL);
3159 if (handle == INVALID_HANDLE_VALUE)
3162 StreamId.dwStreamId = BACKUP_LINK;
3163 StreamId.dwStreamAttributes = 0;
3164 StreamId.dwStreamNameSize = 0;
3165 #if defined(__BORLANDC__) \
3166 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3167 StreamId.Size.u.HighPart = 0;
3168 StreamId.Size.u.LowPart = dwLen;
3170 StreamId.Size.HighPart = 0;
3171 StreamId.Size.LowPart = dwLen;
3174 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3175 FALSE, FALSE, &lpContext);
3177 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3178 FALSE, FALSE, &lpContext);
3179 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3182 CloseHandle(handle);
3187 win32_link(const char *oldname, const char *newname)
3190 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3191 WCHAR wOldName[MAX_PATH+1];
3192 WCHAR wNewName[MAX_PATH+1];
3195 Perl_croak(aTHX_ PL_no_func, "link");
3197 pfnCreateHardLinkW =
3198 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3199 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3200 if (pfnCreateHardLinkW == NULL)
3201 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3203 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3204 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3205 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3206 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3210 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3215 win32_rename(const char *oname, const char *newname)
3217 char szOldName[MAX_PATH+1];
3218 char szNewName[MAX_PATH+1];
3222 /* XXX despite what the documentation says about MoveFileEx(),
3223 * it doesn't work under Windows95!
3226 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3227 if (stricmp(newname, oname))
3228 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3229 strcpy(szOldName, PerlDir_mapA(oname));
3230 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3232 DWORD err = GetLastError();
3234 case ERROR_BAD_NET_NAME:
3235 case ERROR_BAD_NETPATH:
3236 case ERROR_BAD_PATHNAME:
3237 case ERROR_FILE_NOT_FOUND:
3238 case ERROR_FILENAME_EXCED_RANGE:
3239 case ERROR_INVALID_DRIVE:
3240 case ERROR_NO_MORE_FILES:
3241 case ERROR_PATH_NOT_FOUND:
3254 char szTmpName[MAX_PATH+1];
3255 char dname[MAX_PATH+1];
3256 char *endname = Nullch;
3258 DWORD from_attr, to_attr;
3260 strcpy(szOldName, PerlDir_mapA(oname));
3261 strcpy(szNewName, PerlDir_mapA(newname));
3263 /* if oname doesn't exist, do nothing */
3264 from_attr = GetFileAttributes(szOldName);
3265 if (from_attr == 0xFFFFFFFF) {
3270 /* if newname exists, rename it to a temporary name so that we
3271 * don't delete it in case oname happens to be the same file
3272 * (but perhaps accessed via a different path)
3274 to_attr = GetFileAttributes(szNewName);
3275 if (to_attr != 0xFFFFFFFF) {
3276 /* if newname is a directory, we fail
3277 * XXX could overcome this with yet more convoluted logic */
3278 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3282 tmplen = strlen(szNewName);
3283 strcpy(szTmpName,szNewName);
3284 endname = szTmpName+tmplen;
3285 for (; endname > szTmpName ; --endname) {
3286 if (*endname == '/' || *endname == '\\') {
3291 if (endname > szTmpName)
3292 endname = strcpy(dname,szTmpName);
3296 /* get a temporary filename in same directory
3297 * XXX is this really the best we can do? */
3298 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3302 DeleteFile(szTmpName);
3304 retval = rename(szNewName, szTmpName);
3311 /* rename oname to newname */
3312 retval = rename(szOldName, szNewName);
3314 /* if we created a temporary file before ... */
3315 if (endname != Nullch) {
3316 /* ...and rename succeeded, delete temporary file/directory */
3318 DeleteFile(szTmpName);
3319 /* else restore it to what it was */
3321 (void)rename(szTmpName, szNewName);
3328 win32_setmode(int fd, int mode)
3330 return setmode(fd, mode);
3334 win32_chsize(int fd, Off_t size)
3336 #if defined(WIN64) || defined(USE_LARGE_FILES)
3338 Off_t cur, end, extend;
3340 cur = win32_tell(fd);
3343 end = win32_lseek(fd, 0, SEEK_END);
3346 extend = size - end;
3350 else if (extend > 0) {
3351 /* must grow the file, padding with nulls */
3353 int oldmode = win32_setmode(fd, O_BINARY);
3355 memset(b, '\0', sizeof(b));
3357 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3358 count = win32_write(fd, b, count);
3359 if ((int)count < 0) {
3363 } while ((extend -= count) > 0);
3364 win32_setmode(fd, oldmode);
3367 /* shrink the file */
3368 win32_lseek(fd, size, SEEK_SET);
3369 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3375 win32_lseek(fd, cur, SEEK_SET);
3378 return chsize(fd, (long)size);
3383 win32_lseek(int fd, Off_t offset, int origin)
3385 #if defined(WIN64) || defined(USE_LARGE_FILES)
3386 #if defined(__BORLANDC__) /* buk */
3388 pos.QuadPart = offset;
3389 pos.LowPart = SetFilePointer(
3390 (HANDLE)_get_osfhandle(fd),
3395 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3399 return pos.QuadPart;
3401 return _lseeki64(fd, offset, origin);
3404 return lseek(fd, (long)offset, origin);
3411 #if defined(WIN64) || defined(USE_LARGE_FILES)
3412 #if defined(__BORLANDC__) /* buk */
3415 pos.LowPart = SetFilePointer(
3416 (HANDLE)_get_osfhandle(fd),
3421 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3425 return pos.QuadPart;
3426 /* return tell(fd); */
3428 return _telli64(fd);
3436 win32_open(const char *path, int flag, ...)
3443 pmode = va_arg(ap, int);
3446 if (stricmp(path, "/dev/null")==0)
3449 return open(PerlDir_mapA(path), flag, pmode);
3452 /* close() that understands socket */
3453 extern int my_close(int); /* in win32sck.c */
3458 return my_close(fd);
3474 win32_dup2(int fd1,int fd2)
3476 return dup2(fd1,fd2);
3479 #ifdef PERL_MSVCRT_READFIX
3481 #define LF 10 /* line feed */
3482 #define CR 13 /* carriage return */
3483 #define CTRLZ 26 /* ctrl-z means eof for text */
3484 #define FOPEN 0x01 /* file handle open */
3485 #define FEOFLAG 0x02 /* end of file has been encountered */
3486 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3487 #define FPIPE 0x08 /* file handle refers to a pipe */
3488 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3489 #define FDEV 0x40 /* file handle refers to device */
3490 #define FTEXT 0x80 /* file handle is in text mode */
3491 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3494 _fixed_read(int fh, void *buf, unsigned cnt)
3496 int bytes_read; /* number of bytes read */
3497 char *buffer; /* buffer to read to */
3498 int os_read; /* bytes read on OS call */
3499 char *p, *q; /* pointers into buffer */
3500 char peekchr; /* peek-ahead character */
3501 ULONG filepos; /* file position after seek */
3502 ULONG dosretval; /* o.s. return value */
3504 /* validate handle */
3505 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3506 !(_osfile(fh) & FOPEN))
3508 /* out of range -- return error */
3510 _doserrno = 0; /* not o.s. error */
3515 * If lockinitflag is FALSE, assume fd is device
3516 * lockinitflag is set to TRUE by open.
3518 if (_pioinfo(fh)->lockinitflag)
3519 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3521 bytes_read = 0; /* nothing read yet */
3522 buffer = (char*)buf;
3524 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3525 /* nothing to read or at EOF, so return 0 read */
3529 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3530 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3532 *buffer++ = _pipech(fh);
3535 _pipech(fh) = LF; /* mark as empty */
3540 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3542 /* ReadFile has reported an error. recognize two special cases.
3544 * 1. map ERROR_ACCESS_DENIED to EBADF
3546 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3547 * means the handle is a read-handle on a pipe for which
3548 * all write-handles have been closed and all data has been
3551 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3552 /* wrong read/write mode should return EBADF, not EACCES */
3554 _doserrno = dosretval;
3558 else if (dosretval == ERROR_BROKEN_PIPE) {
3568 bytes_read += os_read; /* update bytes read */
3570 if (_osfile(fh) & FTEXT) {
3571 /* now must translate CR-LFs to LFs in the buffer */
3573 /* set CRLF flag to indicate LF at beginning of buffer */
3574 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3575 /* _osfile(fh) |= FCRLF; */
3577 /* _osfile(fh) &= ~FCRLF; */
3579 _osfile(fh) &= ~FCRLF;
3581 /* convert chars in the buffer: p is src, q is dest */
3583 while (p < (char *)buf + bytes_read) {
3585 /* if fh is not a device, set ctrl-z flag */
3586 if (!(_osfile(fh) & FDEV))
3587 _osfile(fh) |= FEOFLAG;
3588 break; /* stop translating */
3593 /* *p is CR, so must check next char for LF */
3594 if (p < (char *)buf + bytes_read - 1) {
3597 *q++ = LF; /* convert CR-LF to LF */
3600 *q++ = *p++; /* store char normally */
3603 /* This is the hard part. We found a CR at end of
3604 buffer. We must peek ahead to see if next char
3609 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3610 (LPDWORD)&os_read, NULL))
3611 dosretval = GetLastError();
3613 if (dosretval != 0 || os_read == 0) {
3614 /* couldn't read ahead, store CR */
3618 /* peekchr now has the extra character -- we now
3619 have several possibilities:
3620 1. disk file and char is not LF; just seek back
3622 2. disk file and char is LF; store LF, don't seek back
3623 3. pipe/device and char is LF; store LF.
3624 4. pipe/device and char isn't LF, store CR and
3625 put char in pipe lookahead buffer. */
3626 if (_osfile(fh) & (FDEV|FPIPE)) {
3627 /* non-seekable device */
3632 _pipech(fh) = peekchr;
3637 if (peekchr == LF) {
3638 /* nothing read yet; must make some
3641 /* turn on this flag for tell routine */
3642 _osfile(fh) |= FCRLF;
3645 HANDLE osHandle; /* o.s. handle value */
3647 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3649 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3650 dosretval = GetLastError();
3661 /* we now change bytes_read to reflect the true number of chars
3663 bytes_read = q - (char *)buf;
3667 if (_pioinfo(fh)->lockinitflag)
3668 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3673 #endif /* PERL_MSVCRT_READFIX */
3676 win32_read(int fd, void *buf, unsigned int cnt)
3678 #ifdef PERL_MSVCRT_READFIX
3679 return _fixed_read(fd, buf, cnt);
3681 return read(fd, buf, cnt);
3686 win32_write(int fd, const void *buf, unsigned int cnt)
3688 return write(fd, buf, cnt);
3692 win32_mkdir(const char *dir, int mode)
3695 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3699 win32_rmdir(const char *dir)
3702 return rmdir(PerlDir_mapA(dir));
3706 win32_chdir(const char *dir)
3717 win32_access(const char *path, int mode)
3720 return access(PerlDir_mapA(path), mode);
3724 win32_chmod(const char *path, int mode)
3727 return chmod(PerlDir_mapA(path), mode);
3732 create_command_line(char *cname, STRLEN clen, const char * const *args)
3739 bool bat_file = FALSE;
3740 bool cmd_shell = FALSE;
3741 bool dumb_shell = FALSE;
3742 bool extra_quotes = FALSE;
3743 bool quote_next = FALSE;
3746 cname = (char*)args[0];
3748 /* The NT cmd.exe shell has the following peculiarity that needs to be
3749 * worked around. It strips a leading and trailing dquote when any
3750 * of the following is true:
3751 * 1. the /S switch was used
3752 * 2. there are more than two dquotes
3753 * 3. there is a special character from this set: &<>()@^|
3754 * 4. no whitespace characters within the two dquotes
3755 * 5. string between two dquotes isn't an executable file
3756 * To work around this, we always add a leading and trailing dquote
3757 * to the string, if the first argument is either "cmd.exe" or "cmd",
3758 * and there were at least two or more arguments passed to cmd.exe
3759 * (not including switches).
3760 * XXX the above rules (from "cmd /?") don't seem to be applied
3761 * always, making for the convolutions below :-(
3765 clen = strlen(cname);
3768 && (stricmp(&cname[clen-4], ".bat") == 0
3769 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3776 char *exe = strrchr(cname, '/');
3777 char *exe2 = strrchr(cname, '\\');
3784 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3788 else if (stricmp(exe, "command.com") == 0
3789 || stricmp(exe, "command") == 0)
3796 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3797 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3798 STRLEN curlen = strlen(arg);
3799 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3800 len += 2; /* assume quoting needed (worst case) */
3802 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3804 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3807 Newx(cmd, len, char);
3810 if (bat_file && !IsWin95()) {
3812 extra_quotes = TRUE;
3815 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3817 STRLEN curlen = strlen(arg);
3819 /* we want to protect empty arguments and ones with spaces with
3820 * dquotes, but only if they aren't already there */
3825 else if (quote_next) {
3826 /* see if it really is multiple arguments pretending to
3827 * be one and force a set of quotes around it */
3828 if (*find_next_space(arg))
3831 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3833 while (i < curlen) {
3834 if (isSPACE(arg[i])) {
3837 else if (arg[i] == '"') {
3861 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3862 && stricmp(arg+curlen-2, "/c") == 0)
3864 /* is there a next argument? */
3865 if (args[index+1]) {
3866 /* are there two or more next arguments? */
3867 if (args[index+2]) {
3869 extra_quotes = TRUE;
3872 /* single argument, force quoting if it has spaces */
3888 qualified_path(const char *cmd)
3892 char *fullcmd, *curfullcmd;
3898 fullcmd = (char*)cmd;
3900 if (*fullcmd == '/' || *fullcmd == '\\')
3907 pathstr = PerlEnv_getenv("PATH");
3909 /* worst case: PATH is a single directory; we need additional space
3910 * to append "/", ".exe" and trailing "\0" */
3911 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3912 curfullcmd = fullcmd;
3917 /* start by appending the name to the current prefix */
3918 strcpy(curfullcmd, cmd);
3919 curfullcmd += cmdlen;
3921 /* if it doesn't end with '.', or has no extension, try adding
3922 * a trailing .exe first */
3923 if (cmd[cmdlen-1] != '.'
3924 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3926 strcpy(curfullcmd, ".exe");
3927 res = GetFileAttributes(fullcmd);
3928 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3933 /* that failed, try the bare name */
3934 res = GetFileAttributes(fullcmd);
3935 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3938 /* quit if no other path exists, or if cmd already has path */
3939 if (!pathstr || !*pathstr || has_slash)
3942 /* skip leading semis */
3943 while (*pathstr == ';')
3946 /* build a new prefix from scratch */
3947 curfullcmd = fullcmd;
3948 while (*pathstr && *pathstr != ';') {
3949 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3950 pathstr++; /* skip initial '"' */
3951 while (*pathstr && *pathstr != '"') {
3952 *curfullcmd++ = *pathstr++;
3955 pathstr++; /* skip trailing '"' */
3958 *curfullcmd++ = *pathstr++;
3962 pathstr++; /* skip trailing semi */
3963 if (curfullcmd > fullcmd /* append a dir separator */
3964 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3966 *curfullcmd++ = '\\';
3974 /* The following are just place holders.
3975 * Some hosts may provide and environment that the OS is
3976 * not tracking, therefore, these host must provide that
3977 * environment and the current directory to CreateProcess
3981 win32_get_childenv(void)
3987 win32_free_childenv(void* d)
3992 win32_clearenv(void)
3994 char *envv = GetEnvironmentStrings();
3998 char *end = strchr(cur,'=');
3999 if (end && end != cur) {
4001 SetEnvironmentVariable(cur, NULL);
4003 cur = end + strlen(end+1)+2;
4005 else if ((len = strlen(cur)))
4008 FreeEnvironmentStrings(envv);
4012 win32_get_childdir(void)
4016 char szfilename[MAX_PATH+1];
4018 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4019 Newx(ptr, strlen(szfilename)+1, char);
4020 strcpy(ptr, szfilename);
4025 win32_free_childdir(char* d)
4032 /* XXX this needs to be made more compatible with the spawnvp()
4033 * provided by the various RTLs. In particular, searching for
4034 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4035 * This doesn't significantly affect perl itself, because we
4036 * always invoke things using PERL5SHELL if a direct attempt to
4037 * spawn the executable fails.
4039 * XXX splitting and rejoining the commandline between do_aspawn()
4040 * and win32_spawnvp() could also be avoided.
4044 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4046 #ifdef USE_RTL_SPAWNVP
4047 return spawnvp(mode, cmdname, (char * const *)argv);
4054 STARTUPINFO StartupInfo;
4055 PROCESS_INFORMATION ProcessInformation;
4058 char *fullcmd = Nullch;
4059 char *cname = (char *)cmdname;
4063 clen = strlen(cname);
4064 /* if command name contains dquotes, must remove them */
4065 if (strchr(cname, '"')) {
4067 Newx(cname,clen+1,char);
4080 cmd = create_command_line(cname, clen, argv);
4082 env = PerlEnv_get_childenv();
4083 dir = PerlEnv_get_childdir();
4086 case P_NOWAIT: /* asynch + remember result */
4087 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4092 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4095 create |= CREATE_NEW_PROCESS_GROUP;
4098 case P_WAIT: /* synchronous execution */
4100 default: /* invalid mode */
4105 memset(&StartupInfo,0,sizeof(StartupInfo));
4106 StartupInfo.cb = sizeof(StartupInfo);
4107 memset(&tbl,0,sizeof(tbl));
4108 PerlEnv_get_child_IO(&tbl);
4109 StartupInfo.dwFlags = tbl.dwFlags;
4110 StartupInfo.dwX = tbl.dwX;
4111 StartupInfo.dwY = tbl.dwY;
4112 StartupInfo.dwXSize = tbl.dwXSize;
4113 StartupInfo.dwYSize = tbl.dwYSize;
4114 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4115 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4116 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4117 StartupInfo.wShowWindow = tbl.wShowWindow;
4118 StartupInfo.hStdInput = tbl.childStdIn;
4119 StartupInfo.hStdOutput = tbl.childStdOut;
4120 StartupInfo.hStdError = tbl.childStdErr;
4121 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4122 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4123 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4125 create |= CREATE_NEW_CONSOLE;
4128 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4130 if (w32_use_showwindow) {
4131 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4132 StartupInfo.wShowWindow = w32_showwindow;
4135 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4138 if (!CreateProcess(cname, /* search PATH to find executable */
4139 cmd, /* executable, and its arguments */
4140 NULL, /* process attributes */
4141 NULL, /* thread attributes */
4142 TRUE, /* inherit handles */
4143 create, /* creation flags */
4144 (LPVOID)env, /* inherit environment */
4145 dir, /* inherit cwd */
4147 &ProcessInformation))
4149 /* initial NULL argument to CreateProcess() does a PATH
4150 * search, but it always first looks in the directory
4151 * where the current process was started, which behavior
4152 * is undesirable for backward compatibility. So we
4153 * jump through our own hoops by picking out the path
4154 * we really want it to use. */
4156 fullcmd = qualified_path(cname);
4158 if (cname != cmdname)
4161 DEBUG_p(PerlIO_printf(Perl_debug_log,
4162 "Retrying [%s] with same args\n",
4172 if (mode == P_NOWAIT) {
4173 /* asynchronous spawn -- store handle, return PID */
4174 ret = (int)ProcessInformation.dwProcessId;
4175 if (IsWin95() && ret < 0)
4178 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4179 w32_child_pids[w32_num_children] = (DWORD)ret;
4184 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4185 /* FIXME: if msgwait returned due to message perhaps forward the
4186 "signal" to the process
4188 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4190 CloseHandle(ProcessInformation.hProcess);
4193 CloseHandle(ProcessInformation.hThread);
4196 PerlEnv_free_childenv(env);
4197 PerlEnv_free_childdir(dir);
4199 if (cname != cmdname)
4206 win32_execv(const char *cmdname, const char *const *argv)
4210 /* if this is a pseudo-forked child, we just want to spawn
4211 * the new program, and return */
4213 # ifdef __BORLANDC__
4214 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4216 return spawnv(P_WAIT, cmdname, argv);
4220 return execv(cmdname, (char *const *)argv);
4222 return execv(cmdname, argv);
4227 win32_execvp(const char *cmdname, const char *const *argv)
4231 /* if this is a pseudo-forked child, we just want to spawn
4232 * the new program, and return */
4233 if (w32_pseudo_id) {
4234 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4244 return execvp(cmdname, (char *const *)argv);
4246 return execvp(cmdname, argv);
4251 win32_perror(const char *str)
4257 win32_setbuf(FILE *pf, char *buf)
4263 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4265 return setvbuf(pf, buf, type, size);
4269 win32_flushall(void)
4275 win32_fcloseall(void)
4281 win32_fgets(char *s, int n, FILE *pf)
4283 return fgets(s, n, pf);
4293 win32_fgetc(FILE *pf)
4299 win32_putc(int c, FILE *pf)
4305 win32_puts(const char *s)
4317 win32_putchar(int c)
4324 #ifndef USE_PERL_SBRK
4326 static char *committed = NULL; /* XXX threadead */
4327 static char *base = NULL; /* XXX threadead */
4328 static char *reserved = NULL; /* XXX threadead */
4329 static char *brk = NULL; /* XXX threadead */
4330 static DWORD pagesize = 0; /* XXX threadead */
4333 sbrk(ptrdiff_t need)
4338 GetSystemInfo(&info);
4339 /* Pretend page size is larger so we don't perpetually
4340 * call the OS to commit just one page ...
4342 pagesize = info.dwPageSize << 3;
4344 if (brk+need >= reserved)
4346 DWORD size = brk+need-reserved;
4348 char *prev_committed = NULL;
4349 if (committed && reserved && committed < reserved)
4351 /* Commit last of previous chunk cannot span allocations */
4352 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4355 /* Remember where we committed from in case we want to decommit later */
4356 prev_committed = committed;
4357 committed = reserved;
4360 /* Reserve some (more) space
4361 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4362 * this is only address space not memory...
4363 * Note this is a little sneaky, 1st call passes NULL as reserved
4364 * so lets system choose where we start, subsequent calls pass
4365 * the old end address so ask for a contiguous block
4368 if (size < 64*1024*1024)
4369 size = 64*1024*1024;
4370 size = ((size + pagesize - 1) / pagesize) * pagesize;
4371 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4374 reserved = addr+size;
4384 /* The existing block could not be extended far enough, so decommit
4385 * anything that was just committed above and start anew */
4388 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4391 reserved = base = committed = brk = NULL;
4402 if (brk > committed)
4404 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4406 if (committed+size > reserved)
4407 size = reserved-committed;
4408 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4421 win32_malloc(size_t size)
4423 return malloc(size);
4427 win32_calloc(size_t numitems, size_t size)
4429 return calloc(numitems,size);
4433 win32_realloc(void *block, size_t size)
4435 return realloc(block,size);
4439 win32_free(void *block)
4446 win32_open_osfhandle(intptr_t handle, int flags)
4448 #ifdef USE_FIXED_OSFHANDLE
4450 return my_open_osfhandle(handle, flags);
4452 return _open_osfhandle(handle, flags);
4456 win32_get_osfhandle(int fd)
4458 return (intptr_t)_get_osfhandle(fd);
4462 win32_fdupopen(FILE *pf)
4467 int fileno = win32_dup(win32_fileno(pf));
4469 /* open the file in the same mode */
4471 if((pf)->flags & _F_READ) {
4475 else if((pf)->flags & _F_WRIT) {
4479 else if((pf)->flags & _F_RDWR) {
4485 if((pf)->_flag & _IOREAD) {
4489 else if((pf)->_flag & _IOWRT) {
4493 else if((pf)->_flag & _IORW) {
4500 /* it appears that the binmode is attached to the
4501 * file descriptor so binmode files will be handled
4504 pfdup = win32_fdopen(fileno, mode);
4506 /* move the file pointer to the same position */
4507 if (!fgetpos(pf, &pos)) {
4508 fsetpos(pfdup, &pos);
4514 win32_dynaload(const char* filename)
4517 char buf[MAX_PATH+1];
4520 /* LoadLibrary() doesn't recognize forward slashes correctly,
4521 * so turn 'em back. */
4522 first = strchr(filename, '/');
4524 STRLEN len = strlen(filename);
4525 if (len <= MAX_PATH) {
4526 strcpy(buf, filename);
4527 filename = &buf[first - filename];
4529 if (*filename == '/')
4530 *(char*)filename = '\\';
4536 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4539 XS(w32_SetChildShowWindow)
4542 BOOL use_showwindow = w32_use_showwindow;
4543 /* use "unsigned short" because Perl has redefined "WORD" */
4544 unsigned short showwindow = w32_showwindow;
4547 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4549 if (items == 0 || !SvOK(ST(0)))
4550 w32_use_showwindow = FALSE;
4552 w32_use_showwindow = TRUE;
4553 w32_showwindow = (unsigned short)SvIV(ST(0));
4558 ST(0) = sv_2mortal(newSViv(showwindow));
4560 ST(0) = &PL_sv_undef;
4565 forward(pTHX_ const char *function)
4568 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
4571 call_pv(function, GIMME_V);
4574 #define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
4577 FORWARD(GetNextAvailDrive)
4578 FORWARD(GetLastError)
4579 FORWARD(SetLastError)
4584 FORWARD(GetOSVersion)
4587 FORWARD(FormatMessage)
4589 FORWARD(GetTickCount)
4590 FORWARD(GetShortPathName)
4591 FORWARD(GetFullPathName)
4592 FORWARD(GetLongPathName)
4596 /* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
4597 * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
4599 /* FORWARD(SetChildShowWindow) */
4604 Perl_init_os_extras(void)
4607 char *file = __FILE__;
4610 /* these names are Activeware compatible */
4611 newXS("Win32::GetCwd", w32_GetCwd, file);
4612 newXS("Win32::SetCwd", w32_SetCwd, file);
4613 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4614 newXS("Win32::GetLastError", w32_GetLastError, file);
4615 newXS("Win32::SetLastError", w32_SetLastError, file);
4616 newXS("Win32::LoginName", w32_LoginName, file);
4617 newXS("Win32::NodeName", w32_NodeName, file);
4618 newXS("Win32::DomainName", w32_DomainName, file);
4619 newXS("Win32::FsType", w32_FsType, file);
4620 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4621 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4622 newXS("Win32::IsWin95", w32_IsWin95, file);
4623 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4624 newXS("Win32::Spawn", w32_Spawn, file);
4625 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4626 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4627 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4628 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4629 newXS("Win32::CopyFile", w32_CopyFile, file);
4630 newXS("Win32::Sleep", w32_Sleep, file);
4631 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4635 win32_signal_context(void)
4640 my_perl = PL_curinterp;
4641 PERL_SET_THX(my_perl);
4645 return PL_curinterp;
4651 win32_ctrlhandler(DWORD dwCtrlType)
4654 dTHXa(PERL_GET_SIG_CONTEXT);
4660 switch(dwCtrlType) {
4661 case CTRL_CLOSE_EVENT:
4662 /* A signal that the system sends to all processes attached to a console when
4663 the user closes the console (either by choosing the Close command from the
4664 console window's System menu, or by choosing the End Task command from the
4667 if (do_raise(aTHX_ 1)) /* SIGHUP */
4668 sig_terminate(aTHX_ 1);
4672 /* A CTRL+c signal was received */
4673 if (do_raise(aTHX_ SIGINT))
4674 sig_terminate(aTHX_ SIGINT);
4677 case CTRL_BREAK_EVENT:
4678 /* A CTRL+BREAK signal was received */
4679 if (do_raise(aTHX_ SIGBREAK))
4680 sig_terminate(aTHX_ SIGBREAK);
4683 case CTRL_LOGOFF_EVENT:
4684 /* A signal that the system sends to all console processes when a user is logging
4685 off. This signal does not indicate which user is logging off, so no
4686 assumptions can be made.
4689 case CTRL_SHUTDOWN_EVENT:
4690 /* A signal that the system sends to all console processes when the system is
4693 if (do_raise(aTHX_ SIGTERM))
4694 sig_terminate(aTHX_ SIGTERM);
4703 #if _MSC_VER >= 1400
4704 # include <crtdbg.h>
4715 /* there is no Unicode environment on Windows 9X */
4719 /* fetch Unicode version of PATH */
4721 wide_path = win32_malloc(len*sizeof(WCHAR));
4723 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4727 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4732 /* convert to ANSI pathnames */
4733 wide_dir = wide_path;
4736 WCHAR *sep = wcschr(wide_dir, ';');
4744 /* remove quotes around pathname */
4745 if (*wide_dir == '"')
4747 wide_len = wcslen(wide_dir);
4748 if (wide_len && wide_dir[wide_len-1] == '"')
4749 wide_dir[wide_len-1] = '\0';
4751 /* append ansi_dir to ansi_path */
4752 ansi_dir = win32_ansipath(wide_dir);
4753 ansi_len = strlen(ansi_dir);
4755 size_t newlen = len + 1 + ansi_len;
4756 ansi_path = win32_realloc(ansi_path, newlen+1);
4759 ansi_path[len] = ';';
4760 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4765 ansi_path = win32_malloc(5+len+1);
4768 memcpy(ansi_path, "PATH=", 5);
4769 memcpy(ansi_path+5, ansi_dir, len+1);
4772 win32_free(ansi_dir);
4777 /* Update C RTL environ array. This will only have full effect if
4778 * perl_parse() is later called with `environ` as the `env` argument.
4779 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4781 * We do have to ansify() the PATH before Perl has been fully
4782 * initialized because S_find_script() uses the PATH when perl
4783 * is being invoked with the -S option. This happens before %ENV
4784 * is initialized in S_init_postdump_symbols().
4786 * XXX Is this a bug? Should S_find_script() use the environment
4787 * XXX passed in the `env` arg to parse_perl()?
4790 /* Keep system environment in sync because S_init_postdump_symbols()
4791 * will not call mg_set() if it initializes %ENV from `environ`.
4793 SetEnvironmentVariableA("PATH", ansi_path+5);
4794 /* We are intentionally leaking the ansi_path string here because
4795 * the Borland runtime library puts it directly into the environ
4796 * array. The Microsoft runtime library seems to make a copy,
4797 * but will leak the copy should it be replaced again later.
4798 * Since this code is only called once during PERL_SYS_INIT this
4799 * shouldn't really matter.
4802 win32_free(wide_path);
4806 Perl_win32_init(int *argcp, char ***argvp)
4810 #if _MSC_VER >= 1400
4811 _invalid_parameter_handler oldHandler, newHandler;
4812 newHandler = my_invalid_parameter_handler;
4813 oldHandler = _set_invalid_parameter_handler(newHandler);
4814 _CrtSetReportMode(_CRT_ASSERT, 0);
4816 /* Disable floating point errors, Perl will trap the ones we
4817 * care about. VC++ RTL defaults to switching these off
4818 * already, but the Borland RTL doesn't. Since we don't
4819 * want to be at the vendor's whim on the default, we set
4820 * it explicitly here.
4822 #if !defined(_ALPHA_) && !defined(__GNUC__)
4823 _control87(MCW_EM, MCW_EM);
4827 module = GetModuleHandle("ntdll.dll");
4829 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4832 module = GetModuleHandle("kernel32.dll");
4834 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4835 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4836 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4839 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4840 GetVersionEx(&g_osver);
4846 Perl_win32_term(void)
4856 win32_get_child_IO(child_IO_table* ptbl)
4858 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4859 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4860 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4864 win32_signal(int sig, Sighandler_t subcode)
4867 if (sig < SIG_SIZE) {
4868 int save_errno = errno;
4869 Sighandler_t result = signal(sig, subcode);
4870 if (result == SIG_ERR) {
4871 result = w32_sighandler[sig];
4874 w32_sighandler[sig] = subcode;
4884 #ifdef HAVE_INTERP_INTERN
4887 win32_csighandler(int sig)
4890 dTHXa(PERL_GET_SIG_CONTEXT);
4891 Perl_warn(aTHX_ "Got signal %d",sig);
4897 win32_create_message_window()
4899 /* "message-only" windows have been implemented in Windows 2000 and later.
4900 * On earlier versions we'll continue to post messages to a specific
4901 * thread and use hwnd==NULL. This is brittle when either an embedding
4902 * application or an XS module is also posting messages to hwnd=NULL
4903 * because once removed from the queue they cannot be delivered to the
4904 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4905 * if there is no window handle.
4907 if (g_osver.dwMajorVersion < 5)
4910 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4913 #if defined(__MINGW32__) && defined(__cplusplus)
4914 #define CAST_HWND__(x) (HWND__*)(x)
4916 #define CAST_HWND__(x) x
4920 Perl_sys_intern_init(pTHX)
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;
4941 # ifdef MULTIPLICITY
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);
4955 Perl_sys_intern_clear(pTHX)
4957 Safefree(w32_perlshell_tokens);
4958 Safefree(w32_perlshell_vec);
4959 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4960 Safefree(w32_children);
4962 KillTimer(w32_message_hwnd, w32_timerid);
4965 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4966 DestroyWindow(w32_message_hwnd);
4967 # ifdef MULTIPLICITY
4968 if (my_perl == PL_curinterp) {
4972 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4974 # ifdef USE_ITHREADS
4975 Safefree(w32_pseudo_children);
4979 # ifdef USE_ITHREADS
4982 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4984 dst->perlshell_tokens = Nullch;
4985 dst->perlshell_vec = (char**)NULL;
4986 dst->perlshell_items = 0;
4987 dst->fdpid = newAV();
4988 Newxz(dst->children, 1, child_tab);
4990 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4992 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4993 dst->poll_count = 0;
4994 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4996 # endif /* USE_ITHREADS */
4997 #endif /* HAVE_INTERP_INTERN */
5000 win32_free_argvw(pTHX_ void *ptr)
5002 char** argv = (char**)ptr;
5010 win32_argv2utf8(int argc, char** argv)
5015 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5016 if (lpwStr && argc) {
5018 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5019 Newxz(psz, length, char);
5020 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5023 call_atexit(win32_free_argvw, argv);
5025 GlobalFree((HGLOBAL)lpwStr);