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)
198 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
199 ? GetModuleHandle(NULL)
200 : w32_perldll_handle),
201 w32_module_name, sizeof(w32_module_name));
203 /* remove \\?\ prefix */
204 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
205 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
207 /* try to get full path to binary (which may be mangled when perl is
208 * run from a 16-bit app) */
209 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
210 (void)win32_longpath(w32_module_name);
211 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
213 /* normalize to forward slashes */
214 ptr = w32_module_name;
222 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
224 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
226 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
229 const char *subkey = "Software\\Perl";
233 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
234 if (retval == ERROR_SUCCESS) {
236 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
237 if (retval == ERROR_SUCCESS
238 && (type == REG_SZ || type == REG_EXPAND_SZ))
242 *svp = sv_2mortal(newSVpvn("",0));
243 SvGROW(*svp, datalen);
244 retval = RegQueryValueEx(handle, valuename, 0, NULL,
245 (PBYTE)SvPVX(*svp), &datalen);
246 if (retval == ERROR_SUCCESS) {
248 SvCUR_set(*svp,datalen-1);
256 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
258 get_regstr(const char *valuename, SV **svp)
260 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
262 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
266 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
268 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
272 char mod_name[MAX_PATH+1];
278 va_start(ap, trailing_path);
279 strip = va_arg(ap, char *);
281 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
282 baselen = strlen(base);
284 if (!*w32_module_name) {
285 set_w32_module_name();
287 strcpy(mod_name, w32_module_name);
288 ptr = strrchr(mod_name, '/');
289 while (ptr && strip) {
290 /* look for directories to skip back */
293 ptr = strrchr(mod_name, '/');
294 /* avoid stripping component if there is no slash,
295 * or it doesn't match ... */
296 if (!ptr || stricmp(ptr+1, strip) != 0) {
297 /* ... but not if component matches m|5\.$patchlevel.*| */
298 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
299 && strncmp(strip, base, baselen) == 0
300 && strncmp(ptr+1, base, baselen) == 0))
306 strip = va_arg(ap, char *);
314 strcpy(++ptr, trailing_path);
316 /* only add directory if it exists */
317 if (GetFileAttributes(mod_name) != (DWORD) -1) {
318 /* directory exists */
321 *prev_pathp = sv_2mortal(newSVpvn("",0));
322 else if (SvPVX(*prev_pathp))
323 sv_catpvn(*prev_pathp, ";", 1);
324 sv_catpv(*prev_pathp, mod_name);
325 return SvPVX(*prev_pathp);
332 win32_get_privlib(const char *pl)
335 char *stdlib = "lib";
336 char buffer[MAX_PATH+1];
339 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
340 sprintf(buffer, "%s-%s", stdlib, pl);
341 if (!get_regstr(buffer, &sv))
342 (void)get_regstr(stdlib, &sv);
344 /* $stdlib .= ";$EMD/../../lib" */
345 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
349 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
353 char pathstr[MAX_PATH+1];
357 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
358 sprintf(regstr, "%s-%s", xlib, pl);
359 (void)get_regstr(regstr, &sv1);
362 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
363 sprintf(pathstr, "%s/%s/lib", libname, pl);
364 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
366 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
367 (void)get_regstr(xlib, &sv2);
370 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
371 sprintf(pathstr, "%s/lib", libname);
372 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
381 sv_catpvn(sv1, ";", 1);
388 win32_get_sitelib(const char *pl)
390 return win32_get_xlib(pl, "sitelib", "site");
393 #ifndef PERL_VENDORLIB_NAME
394 # define PERL_VENDORLIB_NAME "vendor"
398 win32_get_vendorlib(const char *pl)
400 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
404 has_shell_metachars(const char *ptr)
410 * Scan string looking for redirection (< or >) or pipe
411 * characters (|) that are not in a quoted string.
412 * Shell variable interpolation (%VAR%) can also happen inside strings.
444 #if !defined(PERL_IMPLICIT_SYS)
445 /* since the current process environment is being updated in util.c
446 * the library functions will get the correct environment
449 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
452 #define fixcmd(x) { \
453 char *pspace = strchr((x),' '); \
456 while (p < pspace) { \
467 PERL_FLUSHALL_FOR_CHILD;
468 return win32_popen(cmd, mode);
472 Perl_my_pclose(pTHX_ PerlIO *fp)
474 return win32_pclose(fp);
478 DllExport unsigned long
481 return (unsigned long)g_osver.dwPlatformId;
491 return -((int)w32_pseudo_id);
494 /* Windows 9x appears to always reports a pid for threads and processes
495 * that has the high bit set. So we treat the lower 31 bits as the
496 * "real" PID for Perl's purposes. */
497 if (IsWin95() && pid < 0)
502 /* Tokenize a string. Words are null-separated, and the list
503 * ends with a doubled null. Any character (except null and
504 * including backslash) may be escaped by preceding it with a
505 * backslash (the backslash will be stripped).
506 * Returns number of words in result buffer.
509 tokenize(const char *str, char **dest, char ***destv)
511 char *retstart = Nullch;
512 char **retvstart = 0;
516 int slen = strlen(str);
518 register char **retv;
519 Newx(ret, slen+2, char);
520 Newx(retv, (slen+3)/2, char*);
528 if (*ret == '\\' && *str)
530 else if (*ret == ' ') {
546 retvstart[items] = Nullch;
559 if (!w32_perlshell_tokens) {
560 /* we don't use COMSPEC here for two reasons:
561 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
562 * uncontrolled unportability of the ensuing scripts.
563 * 2. PERL5SHELL could be set to a shell that may not be fit for
564 * interactive use (which is what most programs look in COMSPEC
567 const char* defaultshell = (IsWinNT()
568 ? "cmd.exe /x/d/c" : "command.com /c");
569 const char *usershell = PerlEnv_getenv("PERL5SHELL");
570 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
571 &w32_perlshell_tokens,
577 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
589 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
591 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
596 while (++mark <= sp) {
597 if (*mark && (str = SvPV_nolen(*mark)))
604 status = win32_spawnvp(flag,
605 (const char*)(really ? SvPV_nolen(really) : argv[0]),
606 (const char* const*)argv);
608 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
609 /* possible shell-builtin, invoke with shell */
611 sh_items = w32_perlshell_items;
613 argv[index+sh_items] = argv[index];
614 while (--sh_items >= 0)
615 argv[sh_items] = w32_perlshell_vec[sh_items];
617 status = win32_spawnvp(flag,
618 (const char*)(really ? SvPV_nolen(really) : argv[0]),
619 (const char* const*)argv);
622 if (flag == P_NOWAIT) {
624 PL_statusvalue = -1; /* >16bits hint for pp_system() */
628 if (ckWARN(WARN_EXEC))
629 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
634 PL_statusvalue = status;
640 /* returns pointer to the next unquoted space or the end of the string */
642 find_next_space(const char *s)
644 bool in_quotes = FALSE;
646 /* ignore doubled backslashes, or backslash+quote */
647 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
650 /* keep track of when we're within quotes */
651 else if (*s == '"') {
653 in_quotes = !in_quotes;
655 /* break it up only at spaces that aren't in quotes */
656 else if (!in_quotes && isSPACE(*s))
665 do_spawn2(pTHX_ const char *cmd, int exectype)
671 BOOL needToTry = TRUE;
674 /* Save an extra exec if possible. See if there are shell
675 * metacharacters in it */
676 if (!has_shell_metachars(cmd)) {
677 Newx(argv, strlen(cmd) / 2 + 2, char*);
678 Newx(cmd2, strlen(cmd) + 1, char);
681 for (s = cmd2; *s;) {
682 while (*s && isSPACE(*s))
686 s = find_next_space(s);
694 status = win32_spawnvp(P_WAIT, argv[0],
695 (const char* const*)argv);
697 case EXECF_SPAWN_NOWAIT:
698 status = win32_spawnvp(P_NOWAIT, argv[0],
699 (const char* const*)argv);
702 status = win32_execvp(argv[0], (const char* const*)argv);
705 if (status != -1 || errno == 0)
715 Newx(argv, w32_perlshell_items + 2, char*);
716 while (++i < w32_perlshell_items)
717 argv[i] = w32_perlshell_vec[i];
718 argv[i++] = (char *)cmd;
722 status = win32_spawnvp(P_WAIT, argv[0],
723 (const char* const*)argv);
725 case EXECF_SPAWN_NOWAIT:
726 status = win32_spawnvp(P_NOWAIT, argv[0],
727 (const char* const*)argv);
730 status = win32_execvp(argv[0], (const char* const*)argv);
736 if (exectype == EXECF_SPAWN_NOWAIT) {
738 PL_statusvalue = -1; /* >16bits hint for pp_system() */
742 if (ckWARN(WARN_EXEC))
743 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
744 (exectype == EXECF_EXEC ? "exec" : "spawn"),
745 cmd, strerror(errno));
750 PL_statusvalue = status;
756 Perl_do_spawn(pTHX_ char *cmd)
758 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
762 Perl_do_spawn_nowait(pTHX_ char *cmd)
764 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
768 Perl_do_exec(pTHX_ const char *cmd)
770 do_spawn2(aTHX_ cmd, EXECF_EXEC);
774 /* The idea here is to read all the directory names into a string table
775 * (separated by nulls) and when one of the other dir functions is called
776 * return the pointer to the current file name.
779 win32_opendir(const char *filename)
785 char scanname[MAX_PATH+3];
787 WIN32_FIND_DATAA aFindData;
788 WIN32_FIND_DATAW wFindData;
790 char buffer[MAX_PATH*2];
793 len = strlen(filename);
797 /* check to see if filename is a directory */
798 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
801 /* Get us a DIR structure */
804 /* Create the search pattern */
805 strcpy(scanname, filename);
807 /* bare drive name means look in cwd for drive */
808 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
809 scanname[len++] = '.';
810 scanname[len++] = '/';
812 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
813 scanname[len++] = '/';
815 scanname[len++] = '*';
816 scanname[len] = '\0';
818 /* do the FindFirstFile call */
820 WCHAR wscanname[sizeof(scanname)];
821 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
822 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
826 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
828 if (dirp->handle == INVALID_HANDLE_VALUE) {
829 DWORD err = GetLastError();
830 /* FindFirstFile() fails on empty drives! */
832 case ERROR_FILE_NOT_FOUND:
834 case ERROR_NO_MORE_FILES:
835 case ERROR_PATH_NOT_FOUND:
838 case ERROR_NOT_ENOUGH_MEMORY:
850 BOOL use_default = FALSE;
851 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
852 wFindData.cFileName, -1,
853 buffer, sizeof(buffer), NULL, &use_default);
854 if (use_default && *wFindData.cAlternateFileName) {
855 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
856 wFindData.cAlternateFileName, -1,
857 buffer, sizeof(buffer), NULL, NULL);
862 ptr = aFindData.cFileName;
864 /* now allocate the first part of the string table for
865 * the filenames that we find.
872 Newx(dirp->start, dirp->size, char);
873 strcpy(dirp->start, ptr);
875 dirp->end = dirp->curr = dirp->start;
881 /* Readdir just returns the current string pointer and bumps the
882 * string pointer to the nDllExport entry.
884 DllExport struct direct *
885 win32_readdir(DIR *dirp)
890 /* first set up the structure to return */
891 len = strlen(dirp->curr);
892 strcpy(dirp->dirstr.d_name, dirp->curr);
893 dirp->dirstr.d_namlen = len;
896 dirp->dirstr.d_ino = dirp->curr - dirp->start;
898 /* Now set up for the next call to readdir */
899 dirp->curr += len + 1;
900 if (dirp->curr >= dirp->end) {
903 WIN32_FIND_DATAA aFindData;
904 char buffer[MAX_PATH*2];
907 /* finding the next file that matches the wildcard
908 * (which should be all of them in this directory!).
911 WIN32_FIND_DATAW wFindData;
912 res = FindNextFileW(dirp->handle, &wFindData);
914 BOOL use_default = FALSE;
915 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
916 wFindData.cFileName, -1,
917 buffer, sizeof(buffer), NULL, &use_default);
918 if (use_default && *wFindData.cAlternateFileName) {
919 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
920 wFindData.cAlternateFileName, -1,
921 buffer, sizeof(buffer), NULL, NULL);
927 res = FindNextFileA(dirp->handle, &aFindData);
928 ptr = aFindData.cFileName;
931 long endpos = dirp->end - dirp->start;
932 long newsize = endpos + strlen(ptr) + 1;
933 /* bump the string table size by enough for the
934 * new name and its null terminator */
935 while (newsize > dirp->size) {
936 long curpos = dirp->curr - dirp->start;
938 Renew(dirp->start, dirp->size, char);
939 dirp->curr = dirp->start + curpos;
941 strcpy(dirp->start + endpos, ptr);
942 dirp->end = dirp->start + newsize;
948 return &(dirp->dirstr);
954 /* Telldir returns the current string pointer position */
956 win32_telldir(DIR *dirp)
958 return (dirp->curr - dirp->start);
962 /* Seekdir moves the string pointer to a previously saved position
963 * (returned by telldir).
966 win32_seekdir(DIR *dirp, long loc)
968 dirp->curr = dirp->start + loc;
971 /* Rewinddir resets the string pointer to the start */
973 win32_rewinddir(DIR *dirp)
975 dirp->curr = dirp->start;
978 /* free the memory allocated by opendir */
980 win32_closedir(DIR *dirp)
983 if (dirp->handle != INVALID_HANDLE_VALUE)
984 FindClose(dirp->handle);
985 Safefree(dirp->start);
998 * Just pretend that everyone is a superuser. NT will let us know if
999 * we don\'t really have permission to do something.
1002 #define ROOT_UID ((uid_t)0)
1003 #define ROOT_GID ((gid_t)0)
1032 return (auid == ROOT_UID ? 0 : -1);
1038 return (agid == ROOT_GID ? 0 : -1);
1045 char *buf = w32_getlogin_buffer;
1046 DWORD size = sizeof(w32_getlogin_buffer);
1047 if (GetUserName(buf,&size))
1053 chown(const char *path, uid_t owner, gid_t group)
1060 * XXX this needs strengthening (for PerlIO)
1063 int mkstemp(const char *path)
1066 char buf[MAX_PATH+1];
1070 if (i++ > 10) { /* give up */
1074 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1078 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1088 long child = w32_num_children;
1089 while (--child >= 0) {
1090 if ((int)w32_child_pids[child] == pid)
1097 remove_dead_process(long child)
1101 CloseHandle(w32_child_handles[child]);
1102 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1103 (w32_num_children-child-1), HANDLE);
1104 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1105 (w32_num_children-child-1), DWORD);
1112 find_pseudo_pid(int pid)
1115 long child = w32_num_pseudo_children;
1116 while (--child >= 0) {
1117 if ((int)w32_pseudo_child_pids[child] == pid)
1124 remove_dead_pseudo_process(long child)
1128 CloseHandle(w32_pseudo_child_handles[child]);
1129 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1130 (w32_num_pseudo_children-child-1), HANDLE);
1131 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1132 (w32_num_pseudo_children-child-1), DWORD);
1133 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1134 (w32_num_pseudo_children-child-1), HWND);
1135 w32_num_pseudo_children--;
1141 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1145 /* "Does process exist?" use of kill */
1148 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1153 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1156 default: /* For now be backwards compatible with perl 5.6 */
1158 /* Note that we will only be able to kill processes owned by the
1159 * current process owner, even when we are running as an administrator.
1160 * To kill processes of other owners we would need to set the
1161 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1163 if (TerminateProcess(process_handle, sig))
1170 /* Traverse process tree using ToolHelp functions */
1172 kill_process_tree_toolhelp(DWORD pid, int sig)
1174 HANDLE process_handle;
1175 HANDLE snapshot_handle;
1178 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1179 if (process_handle == INVALID_HANDLE_VALUE)
1182 killed += terminate_process(pid, process_handle, sig);
1184 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1185 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1186 PROCESSENTRY32 entry;
1188 entry.dwSize = sizeof(entry);
1189 if (pfnProcess32First(snapshot_handle, &entry)) {
1191 if (entry.th32ParentProcessID == pid)
1192 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1193 entry.dwSize = sizeof(entry);
1195 while (pfnProcess32Next(snapshot_handle, &entry));
1197 CloseHandle(snapshot_handle);
1199 CloseHandle(process_handle);
1203 /* Traverse process tree using undocumented system information structures.
1204 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1207 kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1209 HANDLE process_handle;
1210 SYSTEM_PROCESSES *p = process_info;
1213 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1214 if (process_handle == INVALID_HANDLE_VALUE)
1217 killed += terminate_process(pid, process_handle, sig);
1220 if (p->InheritedFromProcessId == (DWORD)pid)
1221 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1223 if (p->NextEntryDelta == 0)
1226 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1229 CloseHandle(process_handle);
1234 killpg(int pid, int sig)
1236 /* Use "documented" method whenever available */
1237 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1238 return kill_process_tree_toolhelp((DWORD)pid, sig);
1241 /* Fall back to undocumented Windows internals on Windows NT */
1242 if (pfnZwQuerySystemInformation) {
1247 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1248 Newx(buffer, size, char);
1250 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1251 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1260 my_kill(int pid, int sig)
1263 HANDLE process_handle;
1266 return killpg(pid, -sig);
1268 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1269 if (process_handle != INVALID_HANDLE_VALUE) {
1270 retval = terminate_process(pid, process_handle, sig);
1271 CloseHandle(process_handle);
1277 win32_kill(int pid, int sig)
1284 /* it is a pseudo-forked child */
1285 child = find_pseudo_pid(-pid);
1287 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1288 hProcess = w32_pseudo_child_handles[child];
1291 /* "Does process exist?" use of kill */
1295 /* kill -9 style un-graceful exit */
1296 if (TerminateThread(hProcess, sig)) {
1297 remove_dead_pseudo_process(child);
1304 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1305 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1306 /* Yield and wait for the other thread to send us its message_hwnd */
1308 win32_async_check(aTHX);
1311 if (hwnd != INVALID_HANDLE_VALUE) {
1312 /* We fake signals to pseudo-processes using Win32
1313 * message queue. In Win9X the pids are negative already. */
1314 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1315 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1317 /* It might be us ... */
1326 else if (IsWin95()) {
1334 child = find_pid(pid);
1336 if (my_kill(pid, sig)) {
1338 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1339 exitcode != STILL_ACTIVE)
1341 remove_dead_process(child);
1348 if (my_kill((IsWin95() ? -pid : pid), sig))
1357 win32_stat(const char *path, Stat_t *sbuf)
1360 char buffer[MAX_PATH+1];
1361 int l = strlen(path);
1364 BOOL expect_dir = FALSE;
1366 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1367 GV_NOTQUAL, SVt_PV);
1368 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1371 switch(path[l - 1]) {
1372 /* FindFirstFile() and stat() are buggy with a trailing
1373 * slashes, except for the root directory of a drive */
1376 if (l > sizeof(buffer)) {
1377 errno = ENAMETOOLONG;
1381 strncpy(buffer, path, l);
1382 /* remove additional trailing slashes */
1383 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1385 /* add back slash if we otherwise end up with just a drive letter */
1386 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1393 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1395 if (l == 2 && isALPHA(path[0])) {
1396 buffer[0] = path[0];
1407 path = PerlDir_mapA(path);
1411 /* We must open & close the file once; otherwise file attribute changes */
1412 /* might not yet have propagated to "other" hard links of the same file. */
1413 /* This also gives us an opportunity to determine the number of links. */
1414 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1415 if (handle != INVALID_HANDLE_VALUE) {
1416 BY_HANDLE_FILE_INFORMATION bhi;
1417 if (GetFileInformationByHandle(handle, &bhi))
1418 nlink = bhi.nNumberOfLinks;
1419 CloseHandle(handle);
1423 /* path will be mapped correctly above */
1424 #if defined(WIN64) || defined(USE_LARGE_FILES)
1425 res = _stati64(path, sbuf);
1427 res = stat(path, sbuf);
1429 sbuf->st_nlink = nlink;
1432 /* CRT is buggy on sharenames, so make sure it really isn't.
1433 * XXX using GetFileAttributesEx() will enable us to set
1434 * sbuf->st_*time (but note that's not available on the
1435 * Windows of 1995) */
1436 DWORD r = GetFileAttributesA(path);
1437 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1438 /* sbuf may still contain old garbage since stat() failed */
1439 Zero(sbuf, 1, Stat_t);
1440 sbuf->st_mode = S_IFDIR | S_IREAD;
1442 if (!(r & FILE_ATTRIBUTE_READONLY))
1443 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1448 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1449 && (path[2] == '\\' || path[2] == '/'))
1451 /* The drive can be inaccessible, some _stat()s are buggy */
1452 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1457 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1462 if (S_ISDIR(sbuf->st_mode))
1463 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1464 else if (S_ISREG(sbuf->st_mode)) {
1466 if (l >= 4 && path[l-4] == '.') {
1467 const char *e = path + l - 3;
1468 if (strnicmp(e,"exe",3)
1469 && strnicmp(e,"bat",3)
1470 && strnicmp(e,"com",3)
1471 && (IsWin95() || strnicmp(e,"cmd",3)))
1472 sbuf->st_mode &= ~S_IEXEC;
1474 sbuf->st_mode |= S_IEXEC;
1477 sbuf->st_mode &= ~S_IEXEC;
1478 /* Propagate permissions to _group_ and _others_ */
1479 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1480 sbuf->st_mode |= (perms>>3) | (perms>>6);
1487 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1488 #define SKIP_SLASHES(s) \
1490 while (*(s) && isSLASH(*(s))) \
1493 #define COPY_NONSLASHES(d,s) \
1495 while (*(s) && !isSLASH(*(s))) \
1499 /* Find the longname of a given path. path is destructively modified.
1500 * It should have space for at least MAX_PATH characters. */
1502 win32_longpath(char *path)
1504 WIN32_FIND_DATA fdata;
1506 char tmpbuf[MAX_PATH+1];
1507 char *tmpstart = tmpbuf;
1514 if (isALPHA(path[0]) && path[1] == ':') {
1516 *tmpstart++ = path[0];
1520 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1522 *tmpstart++ = path[0];
1523 *tmpstart++ = path[1];
1524 SKIP_SLASHES(start);
1525 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1527 *tmpstart++ = *start++;
1528 SKIP_SLASHES(start);
1529 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1534 /* copy initial slash, if any */
1535 if (isSLASH(*start)) {
1536 *tmpstart++ = *start++;
1538 SKIP_SLASHES(start);
1541 /* FindFirstFile() expands "." and "..", so we need to pass
1542 * those through unmolested */
1544 && (!start[1] || isSLASH(start[1])
1545 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1547 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1552 /* if this is the end, bust outta here */
1556 /* now we're at a non-slash; walk up to next slash */
1557 while (*start && !isSLASH(*start))
1560 /* stop and find full name of component */
1563 fhand = FindFirstFile(path,&fdata);
1565 if (fhand != INVALID_HANDLE_VALUE) {
1566 STRLEN len = strlen(fdata.cFileName);
1567 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1568 strcpy(tmpstart, fdata.cFileName);
1579 /* failed a step, just return without side effects */
1580 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1585 strcpy(path,tmpbuf);
1590 win32_getenv(const char *name)
1594 SV *curitem = Nullsv;
1596 needlen = GetEnvironmentVariableA(name,NULL,0);
1598 curitem = sv_2mortal(newSVpvn("", 0));
1600 SvGROW(curitem, needlen+1);
1601 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1603 } while (needlen >= SvLEN(curitem));
1604 SvCUR_set(curitem, needlen);
1607 /* allow any environment variables that begin with 'PERL'
1608 to be stored in the registry */
1609 if (strncmp(name, "PERL", 4) == 0)
1610 (void)get_regstr(name, &curitem);
1612 if (curitem && SvCUR(curitem))
1613 return SvPVX(curitem);
1619 win32_putenv(const char *name)
1627 Newx(curitem,strlen(name)+1,char);
1628 strcpy(curitem, name);
1629 val = strchr(curitem, '=');
1631 /* The sane way to deal with the environment.
1632 * Has these advantages over putenv() & co.:
1633 * * enables us to store a truly empty value in the
1634 * environment (like in UNIX).
1635 * * we don't have to deal with RTL globals, bugs and leaks.
1637 * Why you may want to enable USE_WIN32_RTL_ENV:
1638 * * environ[] and RTL functions will not reflect changes,
1639 * which might be an issue if extensions want to access
1640 * the env. via RTL. This cuts both ways, since RTL will
1641 * not see changes made by extensions that call the Win32
1642 * functions directly, either.
1646 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1655 filetime_to_clock(PFILETIME ft)
1657 __int64 qw = ft->dwHighDateTime;
1659 qw |= ft->dwLowDateTime;
1660 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1665 win32_times(struct tms *timebuf)
1670 clock_t process_time_so_far = clock();
1671 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1673 timebuf->tms_utime = filetime_to_clock(&user);
1674 timebuf->tms_stime = filetime_to_clock(&kernel);
1675 timebuf->tms_cutime = 0;
1676 timebuf->tms_cstime = 0;
1678 /* That failed - e.g. Win95 fallback to clock() */
1679 timebuf->tms_utime = process_time_so_far;
1680 timebuf->tms_stime = 0;
1681 timebuf->tms_cutime = 0;
1682 timebuf->tms_cstime = 0;
1684 return process_time_so_far;
1687 /* fix utime() so it works on directories in NT */
1689 filetime_from_time(PFILETIME pFileTime, time_t Time)
1691 struct tm *pTM = localtime(&Time);
1692 SYSTEMTIME SystemTime;
1698 SystemTime.wYear = pTM->tm_year + 1900;
1699 SystemTime.wMonth = pTM->tm_mon + 1;
1700 SystemTime.wDay = pTM->tm_mday;
1701 SystemTime.wHour = pTM->tm_hour;
1702 SystemTime.wMinute = pTM->tm_min;
1703 SystemTime.wSecond = pTM->tm_sec;
1704 SystemTime.wMilliseconds = 0;
1706 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1707 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1711 win32_unlink(const char *filename)
1717 filename = PerlDir_mapA(filename);
1718 attrs = GetFileAttributesA(filename);
1719 if (attrs == 0xFFFFFFFF) {
1723 if (attrs & FILE_ATTRIBUTE_READONLY) {
1724 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1725 ret = unlink(filename);
1727 (void)SetFileAttributesA(filename, attrs);
1730 ret = unlink(filename);
1735 win32_utime(const char *filename, struct utimbuf *times)
1742 struct utimbuf TimeBuffer;
1745 filename = PerlDir_mapA(filename);
1746 rc = utime(filename, times);
1748 /* EACCES: path specifies directory or readonly file */
1749 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1752 if (times == NULL) {
1753 times = &TimeBuffer;
1754 time(×->actime);
1755 times->modtime = times->actime;
1758 /* This will (and should) still fail on readonly files */
1759 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1760 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1761 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1762 if (handle == INVALID_HANDLE_VALUE)
1765 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1766 filetime_from_time(&ftAccess, times->actime) &&
1767 filetime_from_time(&ftWrite, times->modtime) &&
1768 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1773 CloseHandle(handle);
1778 unsigned __int64 ft_i64;
1783 #define Const64(x) x##LL
1785 #define Const64(x) x##i64
1787 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1788 #define EPOCH_BIAS Const64(116444736000000000)
1790 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1791 * and appears to be unsupported even by glibc) */
1793 win32_gettimeofday(struct timeval *tp, void *not_used)
1797 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1798 GetSystemTimeAsFileTime(&ft.ft_val);
1800 /* seconds since epoch */
1801 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1803 /* microseconds remaining */
1804 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1810 win32_uname(struct utsname *name)
1812 struct hostent *hep;
1813 STRLEN nodemax = sizeof(name->nodename)-1;
1816 switch (g_osver.dwPlatformId) {
1817 case VER_PLATFORM_WIN32_WINDOWS:
1818 strcpy(name->sysname, "Windows");
1820 case VER_PLATFORM_WIN32_NT:
1821 strcpy(name->sysname, "Windows NT");
1823 case VER_PLATFORM_WIN32s:
1824 strcpy(name->sysname, "Win32s");
1827 strcpy(name->sysname, "Win32 Unknown");
1832 sprintf(name->release, "%d.%d",
1833 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1836 sprintf(name->version, "Build %d",
1837 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1838 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1839 if (g_osver.szCSDVersion[0]) {
1840 char *buf = name->version + strlen(name->version);
1841 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1845 hep = win32_gethostbyname("localhost");
1847 STRLEN len = strlen(hep->h_name);
1848 if (len <= nodemax) {
1849 strcpy(name->nodename, hep->h_name);
1852 strncpy(name->nodename, hep->h_name, nodemax);
1853 name->nodename[nodemax] = '\0';
1858 if (!GetComputerName(name->nodename, &sz))
1859 *name->nodename = '\0';
1862 /* machine (architecture) */
1867 GetSystemInfo(&info);
1869 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1870 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1871 procarch = info.u.s.wProcessorArchitecture;
1873 procarch = info.wProcessorArchitecture;
1876 case PROCESSOR_ARCHITECTURE_INTEL:
1877 arch = "x86"; break;
1878 case PROCESSOR_ARCHITECTURE_MIPS:
1879 arch = "mips"; break;
1880 case PROCESSOR_ARCHITECTURE_ALPHA:
1881 arch = "alpha"; break;
1882 case PROCESSOR_ARCHITECTURE_PPC:
1883 arch = "ppc"; break;
1884 #ifdef PROCESSOR_ARCHITECTURE_SHX
1885 case PROCESSOR_ARCHITECTURE_SHX:
1886 arch = "shx"; break;
1888 #ifdef PROCESSOR_ARCHITECTURE_ARM
1889 case PROCESSOR_ARCHITECTURE_ARM:
1890 arch = "arm"; break;
1892 #ifdef PROCESSOR_ARCHITECTURE_IA64
1893 case PROCESSOR_ARCHITECTURE_IA64:
1894 arch = "ia64"; break;
1896 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1897 case PROCESSOR_ARCHITECTURE_ALPHA64:
1898 arch = "alpha64"; break;
1900 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1901 case PROCESSOR_ARCHITECTURE_MSIL:
1902 arch = "msil"; break;
1904 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1905 case PROCESSOR_ARCHITECTURE_AMD64:
1906 arch = "amd64"; break;
1908 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1909 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1910 arch = "ia32-64"; break;
1912 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1913 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1914 arch = "unknown"; break;
1917 sprintf(name->machine, "unknown(0x%x)", procarch);
1918 arch = name->machine;
1921 if (name->machine != arch)
1922 strcpy(name->machine, arch);
1927 /* Timing related stuff */
1930 do_raise(pTHX_ int sig)
1932 if (sig < SIG_SIZE) {
1933 Sighandler_t handler = w32_sighandler[sig];
1934 if (handler == SIG_IGN) {
1937 else if (handler != SIG_DFL) {
1942 /* Choose correct default behaviour */
1958 /* Tell caller to exit thread/process as approriate */
1963 sig_terminate(pTHX_ int sig)
1965 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1966 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1973 win32_async_check(pTHX)
1976 HWND hwnd = w32_message_hwnd;
1980 if (hwnd == INVALID_HANDLE_VALUE) {
1981 /* Call PeekMessage() to mark all pending messages in the queue as "old".
1982 * This is necessary when we are being called by win32_msgwait() to
1983 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
1984 * message over and over. An example how this can happen is when
1985 * Perl is calling win32_waitpid() inside a GUI application and the GUI
1986 * is generating messages before the process terminated.
1988 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
1994 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1995 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2000 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2001 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2003 switch (msg.message) {
2005 case WM_USER_MESSAGE: {
2006 int child = find_pseudo_pid(msg.wParam);
2008 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
2013 case WM_USER_KILL: {
2014 /* We use WM_USER to fake kill() with other signals */
2015 int sig = msg.wParam;
2016 if (do_raise(aTHX_ sig))
2017 sig_terminate(aTHX_ sig);
2022 /* alarm() is a one-shot but SetTimer() repeats so kill it */
2023 if (w32_timerid && w32_timerid==msg.wParam) {
2024 KillTimer(w32_message_hwnd, w32_timerid);
2027 /* Now fake a call to signal handler */
2028 if (do_raise(aTHX_ 14))
2029 sig_terminate(aTHX_ 14);
2036 /* Above or other stuff may have set a signal flag */
2037 if (PL_sig_pending) {
2043 /* This function will not return until the timeout has elapsed, or until
2044 * one of the handles is ready. */
2046 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2048 /* We may need several goes at this - so compute when we stop */
2050 if (timeout != INFINITE) {
2051 ticks = GetTickCount();
2055 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
2058 if (result == WAIT_TIMEOUT) {
2059 /* Ran out of time - explicit return of zero to avoid -ve if we
2060 have scheduling issues
2064 if (timeout != INFINITE) {
2065 ticks = GetTickCount();
2067 if (result == WAIT_OBJECT_0 + count) {
2068 /* Message has arrived - check it */
2069 (void)win32_async_check(aTHX);
2072 /* Not timeout or message - one of handles is ready */
2076 /* compute time left to wait */
2077 ticks = timeout - ticks;
2078 /* If we are past the end say zero */
2079 return (ticks > 0) ? ticks : 0;
2083 win32_internal_wait(int *status, DWORD timeout)
2085 /* XXX this wait emulation only knows about processes
2086 * spawned via win32_spawnvp(P_NOWAIT, ...).
2090 DWORD exitcode, waitcode;
2093 if (w32_num_pseudo_children) {
2094 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2095 timeout, &waitcode);
2096 /* Time out here if there are no other children to wait for. */
2097 if (waitcode == WAIT_TIMEOUT) {
2098 if (!w32_num_children) {
2102 else if (waitcode != WAIT_FAILED) {
2103 if (waitcode >= WAIT_ABANDONED_0
2104 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2105 i = waitcode - WAIT_ABANDONED_0;
2107 i = waitcode - WAIT_OBJECT_0;
2108 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2109 *status = (int)((exitcode & 0xff) << 8);
2110 retval = (int)w32_pseudo_child_pids[i];
2111 remove_dead_pseudo_process(i);
2118 if (!w32_num_children) {
2123 /* if a child exists, wait for it to die */
2124 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2125 if (waitcode == WAIT_TIMEOUT) {
2128 if (waitcode != WAIT_FAILED) {
2129 if (waitcode >= WAIT_ABANDONED_0
2130 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2131 i = waitcode - WAIT_ABANDONED_0;
2133 i = waitcode - WAIT_OBJECT_0;
2134 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2135 *status = (int)((exitcode & 0xff) << 8);
2136 retval = (int)w32_child_pids[i];
2137 remove_dead_process(i);
2142 errno = GetLastError();
2147 win32_waitpid(int pid, int *status, int flags)
2150 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2153 if (pid == -1) /* XXX threadid == 1 ? */
2154 return win32_internal_wait(status, timeout);
2157 child = find_pseudo_pid(-pid);
2159 HANDLE hThread = w32_pseudo_child_handles[child];
2161 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2162 if (waitcode == WAIT_TIMEOUT) {
2165 else if (waitcode == WAIT_OBJECT_0) {
2166 if (GetExitCodeThread(hThread, &waitcode)) {
2167 *status = (int)((waitcode & 0xff) << 8);
2168 retval = (int)w32_pseudo_child_pids[child];
2169 remove_dead_pseudo_process(child);
2176 else if (IsWin95()) {
2185 child = find_pid(pid);
2187 hProcess = w32_child_handles[child];
2188 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2189 if (waitcode == WAIT_TIMEOUT) {
2192 else if (waitcode == WAIT_OBJECT_0) {
2193 if (GetExitCodeProcess(hProcess, &waitcode)) {
2194 *status = (int)((waitcode & 0xff) << 8);
2195 retval = (int)w32_child_pids[child];
2196 remove_dead_process(child);
2205 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2206 (IsWin95() ? -pid : pid));
2208 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2209 if (waitcode == WAIT_TIMEOUT) {
2210 CloseHandle(hProcess);
2213 else if (waitcode == WAIT_OBJECT_0) {
2214 if (GetExitCodeProcess(hProcess, &waitcode)) {
2215 *status = (int)((waitcode & 0xff) << 8);
2216 CloseHandle(hProcess);
2220 CloseHandle(hProcess);
2226 return retval >= 0 ? pid : retval;
2230 win32_wait(int *status)
2232 return win32_internal_wait(status, INFINITE);
2235 DllExport unsigned int
2236 win32_sleep(unsigned int t)
2239 /* Win32 times are in ms so *1000 in and /1000 out */
2240 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2243 DllExport unsigned int
2244 win32_alarm(unsigned int sec)
2247 * the 'obvious' implentation is SetTimer() with a callback
2248 * which does whatever receiving SIGALRM would do
2249 * we cannot use SIGALRM even via raise() as it is not
2250 * one of the supported codes in <signal.h>
2254 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2255 w32_message_hwnd = win32_create_message_window();
2258 if (w32_message_hwnd == NULL)
2259 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2262 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2267 KillTimer(w32_message_hwnd, w32_timerid);
2274 #ifdef HAVE_DES_FCRYPT
2275 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2279 win32_crypt(const char *txt, const char *salt)
2282 #ifdef HAVE_DES_FCRYPT
2283 return des_fcrypt(txt, salt, w32_crypt_buffer);
2285 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2290 #ifdef USE_FIXED_OSFHANDLE
2292 #define FOPEN 0x01 /* file handle open */
2293 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2294 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2295 #define FDEV 0x40 /* file handle refers to device */
2296 #define FTEXT 0x80 /* file handle is in text mode */
2299 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2302 * This function allocates a free C Runtime file handle and associates
2303 * it with the Win32 HANDLE specified by the first parameter. This is a
2304 * temperary fix for WIN95's brain damage GetFileType() error on socket
2305 * we just bypass that call for socket
2307 * This works with MSVC++ 4.0+ or GCC/Mingw32
2310 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2311 * int flags - flags to associate with C Runtime file handle.
2314 * returns index of entry in fh, if successful
2315 * return -1, if no free entry is found
2319 *******************************************************************************/
2322 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2323 * this lets sockets work on Win9X with GCC and should fix the problems
2328 /* create an ioinfo entry, kill its handle, and steal the entry */
2333 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2334 int fh = _open_osfhandle((intptr_t)hF, 0);
2338 EnterCriticalSection(&(_pioinfo(fh)->lock));
2343 my_open_osfhandle(intptr_t osfhandle, int flags)
2346 char fileflags; /* _osfile flags */
2348 /* copy relevant flags from second parameter */
2351 if (flags & O_APPEND)
2352 fileflags |= FAPPEND;
2357 if (flags & O_NOINHERIT)
2358 fileflags |= FNOINHERIT;
2360 /* attempt to allocate a C Runtime file handle */
2361 if ((fh = _alloc_osfhnd()) == -1) {
2362 errno = EMFILE; /* too many open files */
2363 _doserrno = 0L; /* not an OS error */
2364 return -1; /* return error to caller */
2367 /* the file is open. now, set the info in _osfhnd array */
2368 _set_osfhnd(fh, osfhandle);
2370 fileflags |= FOPEN; /* mark as open */
2372 _osfile(fh) = fileflags; /* set osfile entry */
2373 LeaveCriticalSection(&_pioinfo(fh)->lock);
2375 return fh; /* return handle */
2378 #endif /* USE_FIXED_OSFHANDLE */
2380 /* simulate flock by locking a range on the file */
2382 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2383 #define LK_LEN 0xffff0000
2386 win32_flock(int fd, int oper)
2394 Perl_croak_nocontext("flock() unimplemented on this platform");
2397 fh = (HANDLE)_get_osfhandle(fd);
2398 memset(&o, 0, sizeof(o));
2401 case LOCK_SH: /* shared lock */
2402 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2404 case LOCK_EX: /* exclusive lock */
2405 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2407 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2408 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2410 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2411 LK_ERR(LockFileEx(fh,
2412 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2413 0, LK_LEN, 0, &o),i);
2415 case LOCK_UN: /* unlock lock */
2416 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2418 default: /* unknown */
2429 * redirected io subsystem for all XS modules
2442 return (&(_environ));
2445 /* the rest are the remapped stdio routines */
2465 win32_ferror(FILE *fp)
2467 return (ferror(fp));
2472 win32_feof(FILE *fp)
2478 * Since the errors returned by the socket error function
2479 * WSAGetLastError() are not known by the library routine strerror
2480 * we have to roll our own.
2484 win32_strerror(int e)
2486 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2487 extern int sys_nerr;
2491 if (e < 0 || e > sys_nerr) {
2496 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2497 w32_strerror_buffer,
2498 sizeof(w32_strerror_buffer), NULL) == 0)
2499 strcpy(w32_strerror_buffer, "Unknown Error");
2501 return w32_strerror_buffer;
2507 win32_str_os_error(void *sv, DWORD dwErr)
2511 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2512 |FORMAT_MESSAGE_IGNORE_INSERTS
2513 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2514 dwErr, 0, (char *)&sMsg, 1, NULL);
2515 /* strip trailing whitespace and period */
2518 --dwLen; /* dwLen doesn't include trailing null */
2519 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2520 if ('.' != sMsg[dwLen])
2525 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2527 dwLen = sprintf(sMsg,
2528 "Unknown error #0x%lX (lookup 0x%lX)",
2529 dwErr, GetLastError());
2533 sv_setpvn((SV*)sv, sMsg, dwLen);
2539 win32_fprintf(FILE *fp, const char *format, ...)
2542 va_start(marker, format); /* Initialize variable arguments. */
2544 return (vfprintf(fp, format, marker));
2548 win32_printf(const char *format, ...)
2551 va_start(marker, format); /* Initialize variable arguments. */
2553 return (vprintf(format, marker));
2557 win32_vfprintf(FILE *fp, const char *format, va_list args)
2559 return (vfprintf(fp, format, args));
2563 win32_vprintf(const char *format, va_list args)
2565 return (vprintf(format, args));
2569 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2571 return fread(buf, size, count, fp);
2575 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2577 return fwrite(buf, size, count, fp);
2580 #define MODE_SIZE 10
2583 win32_fopen(const char *filename, const char *mode)
2591 if (stricmp(filename, "/dev/null")==0)
2594 f = fopen(PerlDir_mapA(filename), mode);
2595 /* avoid buffering headaches for child processes */
2596 if (f && *mode == 'a')
2597 win32_fseek(f, 0, SEEK_END);
2601 #ifndef USE_SOCKETS_AS_HANDLES
2603 #define fdopen my_fdopen
2607 win32_fdopen(int handle, const char *mode)
2611 f = fdopen(handle, (char *) mode);
2612 /* avoid buffering headaches for child processes */
2613 if (f && *mode == 'a')
2614 win32_fseek(f, 0, SEEK_END);
2619 win32_freopen(const char *path, const char *mode, FILE *stream)
2622 if (stricmp(path, "/dev/null")==0)
2625 return freopen(PerlDir_mapA(path), mode, stream);
2629 win32_fclose(FILE *pf)
2631 return my_fclose(pf); /* defined in win32sck.c */
2635 win32_fputs(const char *s,FILE *pf)
2637 return fputs(s, pf);
2641 win32_fputc(int c,FILE *pf)
2647 win32_ungetc(int c,FILE *pf)
2649 return ungetc(c,pf);
2653 win32_getc(FILE *pf)
2659 win32_fileno(FILE *pf)
2665 win32_clearerr(FILE *pf)
2672 win32_fflush(FILE *pf)
2678 win32_ftell(FILE *pf)
2680 #if defined(WIN64) || defined(USE_LARGE_FILES)
2681 #if defined(__BORLANDC__) /* buk */
2682 return win32_tell( fileno( pf ) );
2685 if (fgetpos(pf, &pos))
2695 win32_fseek(FILE *pf, Off_t offset,int origin)
2697 #if defined(WIN64) || defined(USE_LARGE_FILES)
2698 #if defined(__BORLANDC__) /* buk */
2708 if (fgetpos(pf, &pos))
2713 fseek(pf, 0, SEEK_END);
2714 pos = _telli64(fileno(pf));
2723 return fsetpos(pf, &offset);
2726 return fseek(pf, (long)offset, origin);
2731 win32_fgetpos(FILE *pf,fpos_t *p)
2733 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2734 if( win32_tell(fileno(pf)) == -1L ) {
2740 return fgetpos(pf, p);
2745 win32_fsetpos(FILE *pf,const fpos_t *p)
2747 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2748 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2750 return fsetpos(pf, p);
2755 win32_rewind(FILE *pf)
2765 char prefix[MAX_PATH+1];
2766 char filename[MAX_PATH+1];
2767 DWORD len = GetTempPath(MAX_PATH, prefix);
2768 if (len && len < MAX_PATH) {
2769 if (GetTempFileName(prefix, "plx", 0, filename)) {
2770 HANDLE fh = CreateFile(filename,
2771 DELETE | GENERIC_READ | GENERIC_WRITE,
2775 FILE_ATTRIBUTE_NORMAL
2776 | FILE_FLAG_DELETE_ON_CLOSE,
2778 if (fh != INVALID_HANDLE_VALUE) {
2779 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2781 #if defined(__BORLANDC__)
2782 setmode(fd,O_BINARY);
2784 DEBUG_p(PerlIO_printf(Perl_debug_log,
2785 "Created tmpfile=%s\n",filename));
2797 int fd = win32_tmpfd();
2799 return win32_fdopen(fd, "w+b");
2811 win32_fstat(int fd, Stat_t *sbufptr)
2814 /* A file designated by filehandle is not shown as accessible
2815 * for write operations, probably because it is opened for reading.
2818 BY_HANDLE_FILE_INFORMATION bhfi;
2819 #if defined(WIN64) || defined(USE_LARGE_FILES)
2820 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2822 int rc = fstat(fd,&tmp);
2824 sbufptr->st_dev = tmp.st_dev;
2825 sbufptr->st_ino = tmp.st_ino;
2826 sbufptr->st_mode = tmp.st_mode;
2827 sbufptr->st_nlink = tmp.st_nlink;
2828 sbufptr->st_uid = tmp.st_uid;
2829 sbufptr->st_gid = tmp.st_gid;
2830 sbufptr->st_rdev = tmp.st_rdev;
2831 sbufptr->st_size = tmp.st_size;
2832 sbufptr->st_atime = tmp.st_atime;
2833 sbufptr->st_mtime = tmp.st_mtime;
2834 sbufptr->st_ctime = tmp.st_ctime;
2836 int rc = fstat(fd,sbufptr);
2839 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2840 #if defined(WIN64) || defined(USE_LARGE_FILES)
2841 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2843 sbufptr->st_mode &= 0xFE00;
2844 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2845 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2847 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2848 + ((S_IREAD|S_IWRITE) >> 6));
2852 return my_fstat(fd,sbufptr);
2857 win32_pipe(int *pfd, unsigned int size, int mode)
2859 return _pipe(pfd, size, mode);
2863 win32_popenlist(const char *mode, IV narg, SV **args)
2866 Perl_croak(aTHX_ "List form of pipe open not implemented");
2871 * a popen() clone that respects PERL5SHELL
2873 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2877 win32_popen(const char *command, const char *mode)
2879 #ifdef USE_RTL_POPEN
2880 return _popen(command, mode);
2892 /* establish which ends read and write */
2893 if (strchr(mode,'w')) {
2894 stdfd = 0; /* stdin */
2897 nhandle = STD_INPUT_HANDLE;
2899 else if (strchr(mode,'r')) {
2900 stdfd = 1; /* stdout */
2903 nhandle = STD_OUTPUT_HANDLE;
2908 /* set the correct mode */
2909 if (strchr(mode,'b'))
2911 else if (strchr(mode,'t'))
2914 ourmode = _fmode & (O_TEXT | O_BINARY);
2916 /* the child doesn't inherit handles */
2917 ourmode |= O_NOINHERIT;
2919 if (win32_pipe(p, 512, ourmode) == -1)
2922 /* save the old std handle (this needs to happen before the
2923 * dup2(), since that might call SetStdHandle() too) */
2926 old_h = GetStdHandle(nhandle);
2928 /* save current stdfd */
2929 if ((oldfd = win32_dup(stdfd)) == -1)
2932 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2933 /* stdfd will be inherited by the child */
2934 if (win32_dup2(p[child], stdfd) == -1)
2937 /* close the child end in parent */
2938 win32_close(p[child]);
2940 /* set the new std handle (in case dup2() above didn't) */
2941 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2943 /* start the child */
2946 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2949 /* revert stdfd to whatever it was before */
2950 if (win32_dup2(oldfd, stdfd) == -1)
2953 /* close saved handle */
2956 /* restore the old std handle (this needs to happen after the
2957 * dup2(), since that might call SetStdHandle() too */
2959 SetStdHandle(nhandle, old_h);
2965 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2968 /* set process id so that it can be returned by perl's open() */
2969 PL_forkprocess = childpid;
2972 /* we have an fd, return a file stream */
2973 return (PerlIO_fdopen(p[parent], (char *)mode));
2976 /* we don't need to check for errors here */
2980 win32_dup2(oldfd, stdfd);
2984 SetStdHandle(nhandle, old_h);
2990 #endif /* USE_RTL_POPEN */
2998 win32_pclose(PerlIO *pf)
3000 #ifdef USE_RTL_POPEN
3004 int childpid, status;
3008 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3011 childpid = SvIVX(sv);
3029 if (win32_waitpid(childpid, &status, 0) == -1)
3034 #endif /* USE_RTL_POPEN */
3040 LPCWSTR lpExistingFileName,
3041 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3044 WCHAR wFullName[MAX_PATH+1];
3045 LPVOID lpContext = NULL;
3046 WIN32_STREAM_ID StreamId;
3047 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3052 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3053 BOOL, BOOL, LPVOID*) =
3054 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3055 BOOL, BOOL, LPVOID*))
3056 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3057 if (pfnBackupWrite == NULL)
3060 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3063 dwLen = (dwLen+1)*sizeof(WCHAR);
3065 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3066 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3067 NULL, OPEN_EXISTING, 0, NULL);
3068 if (handle == INVALID_HANDLE_VALUE)
3071 StreamId.dwStreamId = BACKUP_LINK;
3072 StreamId.dwStreamAttributes = 0;
3073 StreamId.dwStreamNameSize = 0;
3074 #if defined(__BORLANDC__) \
3075 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3076 StreamId.Size.u.HighPart = 0;
3077 StreamId.Size.u.LowPart = dwLen;
3079 StreamId.Size.HighPart = 0;
3080 StreamId.Size.LowPart = dwLen;
3083 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3084 FALSE, FALSE, &lpContext);
3086 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3087 FALSE, FALSE, &lpContext);
3088 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3091 CloseHandle(handle);
3096 win32_link(const char *oldname, const char *newname)
3099 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3100 WCHAR wOldName[MAX_PATH+1];
3101 WCHAR wNewName[MAX_PATH+1];
3104 Perl_croak(aTHX_ PL_no_func, "link");
3106 pfnCreateHardLinkW =
3107 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3108 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3109 if (pfnCreateHardLinkW == NULL)
3110 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3112 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3113 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3114 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3115 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3119 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3124 win32_rename(const char *oname, const char *newname)
3126 char szOldName[MAX_PATH+1];
3127 char szNewName[MAX_PATH+1];
3131 /* XXX despite what the documentation says about MoveFileEx(),
3132 * it doesn't work under Windows95!
3135 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3136 if (stricmp(newname, oname))
3137 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3138 strcpy(szOldName, PerlDir_mapA(oname));
3139 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3141 DWORD err = GetLastError();
3143 case ERROR_BAD_NET_NAME:
3144 case ERROR_BAD_NETPATH:
3145 case ERROR_BAD_PATHNAME:
3146 case ERROR_FILE_NOT_FOUND:
3147 case ERROR_FILENAME_EXCED_RANGE:
3148 case ERROR_INVALID_DRIVE:
3149 case ERROR_NO_MORE_FILES:
3150 case ERROR_PATH_NOT_FOUND:
3163 char szTmpName[MAX_PATH+1];
3164 char dname[MAX_PATH+1];
3165 char *endname = Nullch;
3167 DWORD from_attr, to_attr;
3169 strcpy(szOldName, PerlDir_mapA(oname));
3170 strcpy(szNewName, PerlDir_mapA(newname));
3172 /* if oname doesn't exist, do nothing */
3173 from_attr = GetFileAttributes(szOldName);
3174 if (from_attr == 0xFFFFFFFF) {
3179 /* if newname exists, rename it to a temporary name so that we
3180 * don't delete it in case oname happens to be the same file
3181 * (but perhaps accessed via a different path)
3183 to_attr = GetFileAttributes(szNewName);
3184 if (to_attr != 0xFFFFFFFF) {
3185 /* if newname is a directory, we fail
3186 * XXX could overcome this with yet more convoluted logic */
3187 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3191 tmplen = strlen(szNewName);
3192 strcpy(szTmpName,szNewName);
3193 endname = szTmpName+tmplen;
3194 for (; endname > szTmpName ; --endname) {
3195 if (*endname == '/' || *endname == '\\') {
3200 if (endname > szTmpName)
3201 endname = strcpy(dname,szTmpName);
3205 /* get a temporary filename in same directory
3206 * XXX is this really the best we can do? */
3207 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3211 DeleteFile(szTmpName);
3213 retval = rename(szNewName, szTmpName);
3220 /* rename oname to newname */
3221 retval = rename(szOldName, szNewName);
3223 /* if we created a temporary file before ... */
3224 if (endname != Nullch) {
3225 /* ...and rename succeeded, delete temporary file/directory */
3227 DeleteFile(szTmpName);
3228 /* else restore it to what it was */
3230 (void)rename(szTmpName, szNewName);
3237 win32_setmode(int fd, int mode)
3239 return setmode(fd, mode);
3243 win32_chsize(int fd, Off_t size)
3245 #if defined(WIN64) || defined(USE_LARGE_FILES)
3247 Off_t cur, end, extend;
3249 cur = win32_tell(fd);
3252 end = win32_lseek(fd, 0, SEEK_END);
3255 extend = size - end;
3259 else if (extend > 0) {
3260 /* must grow the file, padding with nulls */
3262 int oldmode = win32_setmode(fd, O_BINARY);
3264 memset(b, '\0', sizeof(b));
3266 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3267 count = win32_write(fd, b, count);
3268 if ((int)count < 0) {
3272 } while ((extend -= count) > 0);
3273 win32_setmode(fd, oldmode);
3276 /* shrink the file */
3277 win32_lseek(fd, size, SEEK_SET);
3278 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3284 win32_lseek(fd, cur, SEEK_SET);
3287 return chsize(fd, (long)size);
3292 win32_lseek(int fd, Off_t offset, int origin)
3294 #if defined(WIN64) || defined(USE_LARGE_FILES)
3295 #if defined(__BORLANDC__) /* buk */
3297 pos.QuadPart = offset;
3298 pos.LowPart = SetFilePointer(
3299 (HANDLE)_get_osfhandle(fd),
3304 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3308 return pos.QuadPart;
3310 return _lseeki64(fd, offset, origin);
3313 return lseek(fd, (long)offset, origin);
3320 #if defined(WIN64) || defined(USE_LARGE_FILES)
3321 #if defined(__BORLANDC__) /* buk */
3324 pos.LowPart = SetFilePointer(
3325 (HANDLE)_get_osfhandle(fd),
3330 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3334 return pos.QuadPart;
3335 /* return tell(fd); */
3337 return _telli64(fd);
3345 win32_open(const char *path, int flag, ...)
3352 pmode = va_arg(ap, int);
3355 if (stricmp(path, "/dev/null")==0)
3358 return open(PerlDir_mapA(path), flag, pmode);
3361 /* close() that understands socket */
3362 extern int my_close(int); /* in win32sck.c */
3367 return my_close(fd);
3383 win32_dup2(int fd1,int fd2)
3385 return dup2(fd1,fd2);
3388 #ifdef PERL_MSVCRT_READFIX
3390 #define LF 10 /* line feed */
3391 #define CR 13 /* carriage return */
3392 #define CTRLZ 26 /* ctrl-z means eof for text */
3393 #define FOPEN 0x01 /* file handle open */
3394 #define FEOFLAG 0x02 /* end of file has been encountered */
3395 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3396 #define FPIPE 0x08 /* file handle refers to a pipe */
3397 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3398 #define FDEV 0x40 /* file handle refers to device */
3399 #define FTEXT 0x80 /* file handle is in text mode */
3400 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3403 _fixed_read(int fh, void *buf, unsigned cnt)
3405 int bytes_read; /* number of bytes read */
3406 char *buffer; /* buffer to read to */
3407 int os_read; /* bytes read on OS call */
3408 char *p, *q; /* pointers into buffer */
3409 char peekchr; /* peek-ahead character */
3410 ULONG filepos; /* file position after seek */
3411 ULONG dosretval; /* o.s. return value */
3413 /* validate handle */
3414 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3415 !(_osfile(fh) & FOPEN))
3417 /* out of range -- return error */
3419 _doserrno = 0; /* not o.s. error */
3424 * If lockinitflag is FALSE, assume fd is device
3425 * lockinitflag is set to TRUE by open.
3427 if (_pioinfo(fh)->lockinitflag)
3428 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3430 bytes_read = 0; /* nothing read yet */
3431 buffer = (char*)buf;
3433 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3434 /* nothing to read or at EOF, so return 0 read */
3438 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3439 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3441 *buffer++ = _pipech(fh);
3444 _pipech(fh) = LF; /* mark as empty */
3449 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3451 /* ReadFile has reported an error. recognize two special cases.
3453 * 1. map ERROR_ACCESS_DENIED to EBADF
3455 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3456 * means the handle is a read-handle on a pipe for which
3457 * all write-handles have been closed and all data has been
3460 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3461 /* wrong read/write mode should return EBADF, not EACCES */
3463 _doserrno = dosretval;
3467 else if (dosretval == ERROR_BROKEN_PIPE) {
3477 bytes_read += os_read; /* update bytes read */
3479 if (_osfile(fh) & FTEXT) {
3480 /* now must translate CR-LFs to LFs in the buffer */
3482 /* set CRLF flag to indicate LF at beginning of buffer */
3483 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3484 /* _osfile(fh) |= FCRLF; */
3486 /* _osfile(fh) &= ~FCRLF; */
3488 _osfile(fh) &= ~FCRLF;
3490 /* convert chars in the buffer: p is src, q is dest */
3492 while (p < (char *)buf + bytes_read) {
3494 /* if fh is not a device, set ctrl-z flag */
3495 if (!(_osfile(fh) & FDEV))
3496 _osfile(fh) |= FEOFLAG;
3497 break; /* stop translating */
3502 /* *p is CR, so must check next char for LF */
3503 if (p < (char *)buf + bytes_read - 1) {
3506 *q++ = LF; /* convert CR-LF to LF */
3509 *q++ = *p++; /* store char normally */
3512 /* This is the hard part. We found a CR at end of
3513 buffer. We must peek ahead to see if next char
3518 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3519 (LPDWORD)&os_read, NULL))
3520 dosretval = GetLastError();
3522 if (dosretval != 0 || os_read == 0) {
3523 /* couldn't read ahead, store CR */
3527 /* peekchr now has the extra character -- we now
3528 have several possibilities:
3529 1. disk file and char is not LF; just seek back
3531 2. disk file and char is LF; store LF, don't seek back
3532 3. pipe/device and char is LF; store LF.
3533 4. pipe/device and char isn't LF, store CR and
3534 put char in pipe lookahead buffer. */
3535 if (_osfile(fh) & (FDEV|FPIPE)) {
3536 /* non-seekable device */
3541 _pipech(fh) = peekchr;
3546 if (peekchr == LF) {
3547 /* nothing read yet; must make some
3550 /* turn on this flag for tell routine */
3551 _osfile(fh) |= FCRLF;
3554 HANDLE osHandle; /* o.s. handle value */
3556 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3558 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3559 dosretval = GetLastError();
3570 /* we now change bytes_read to reflect the true number of chars
3572 bytes_read = q - (char *)buf;
3576 if (_pioinfo(fh)->lockinitflag)
3577 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3582 #endif /* PERL_MSVCRT_READFIX */
3585 win32_read(int fd, void *buf, unsigned int cnt)
3587 #ifdef PERL_MSVCRT_READFIX
3588 return _fixed_read(fd, buf, cnt);
3590 return read(fd, buf, cnt);
3595 win32_write(int fd, const void *buf, unsigned int cnt)
3597 return write(fd, buf, cnt);
3601 win32_mkdir(const char *dir, int mode)
3604 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3608 win32_rmdir(const char *dir)
3611 return rmdir(PerlDir_mapA(dir));
3615 win32_chdir(const char *dir)
3626 win32_access(const char *path, int mode)
3629 return access(PerlDir_mapA(path), mode);
3633 win32_chmod(const char *path, int mode)
3636 return chmod(PerlDir_mapA(path), mode);
3641 create_command_line(char *cname, STRLEN clen, const char * const *args)
3648 bool bat_file = FALSE;
3649 bool cmd_shell = FALSE;
3650 bool dumb_shell = FALSE;
3651 bool extra_quotes = FALSE;
3652 bool quote_next = FALSE;
3655 cname = (char*)args[0];
3657 /* The NT cmd.exe shell has the following peculiarity that needs to be
3658 * worked around. It strips a leading and trailing dquote when any
3659 * of the following is true:
3660 * 1. the /S switch was used
3661 * 2. there are more than two dquotes
3662 * 3. there is a special character from this set: &<>()@^|
3663 * 4. no whitespace characters within the two dquotes
3664 * 5. string between two dquotes isn't an executable file
3665 * To work around this, we always add a leading and trailing dquote
3666 * to the string, if the first argument is either "cmd.exe" or "cmd",
3667 * and there were at least two or more arguments passed to cmd.exe
3668 * (not including switches).
3669 * XXX the above rules (from "cmd /?") don't seem to be applied
3670 * always, making for the convolutions below :-(
3674 clen = strlen(cname);
3677 && (stricmp(&cname[clen-4], ".bat") == 0
3678 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3685 char *exe = strrchr(cname, '/');
3686 char *exe2 = strrchr(cname, '\\');
3693 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3697 else if (stricmp(exe, "command.com") == 0
3698 || stricmp(exe, "command") == 0)
3705 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3706 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3707 STRLEN curlen = strlen(arg);
3708 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3709 len += 2; /* assume quoting needed (worst case) */
3711 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3713 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3716 Newx(cmd, len, char);
3719 if (bat_file && !IsWin95()) {
3721 extra_quotes = TRUE;
3724 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3726 STRLEN curlen = strlen(arg);
3728 /* we want to protect empty arguments and ones with spaces with
3729 * dquotes, but only if they aren't already there */
3734 else if (quote_next) {
3735 /* see if it really is multiple arguments pretending to
3736 * be one and force a set of quotes around it */
3737 if (*find_next_space(arg))
3740 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3742 while (i < curlen) {
3743 if (isSPACE(arg[i])) {
3746 else if (arg[i] == '"') {
3770 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3771 && stricmp(arg+curlen-2, "/c") == 0)
3773 /* is there a next argument? */
3774 if (args[index+1]) {
3775 /* are there two or more next arguments? */
3776 if (args[index+2]) {
3778 extra_quotes = TRUE;
3781 /* single argument, force quoting if it has spaces */
3797 qualified_path(const char *cmd)
3801 char *fullcmd, *curfullcmd;
3807 fullcmd = (char*)cmd;
3809 if (*fullcmd == '/' || *fullcmd == '\\')
3816 pathstr = PerlEnv_getenv("PATH");
3818 /* worst case: PATH is a single directory; we need additional space
3819 * to append "/", ".exe" and trailing "\0" */
3820 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3821 curfullcmd = fullcmd;
3826 /* start by appending the name to the current prefix */
3827 strcpy(curfullcmd, cmd);
3828 curfullcmd += cmdlen;
3830 /* if it doesn't end with '.', or has no extension, try adding
3831 * a trailing .exe first */
3832 if (cmd[cmdlen-1] != '.'
3833 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3835 strcpy(curfullcmd, ".exe");
3836 res = GetFileAttributes(fullcmd);
3837 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3842 /* that failed, try the bare name */
3843 res = GetFileAttributes(fullcmd);
3844 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3847 /* quit if no other path exists, or if cmd already has path */
3848 if (!pathstr || !*pathstr || has_slash)
3851 /* skip leading semis */
3852 while (*pathstr == ';')
3855 /* build a new prefix from scratch */
3856 curfullcmd = fullcmd;
3857 while (*pathstr && *pathstr != ';') {
3858 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3859 pathstr++; /* skip initial '"' */
3860 while (*pathstr && *pathstr != '"') {
3861 *curfullcmd++ = *pathstr++;
3864 pathstr++; /* skip trailing '"' */
3867 *curfullcmd++ = *pathstr++;
3871 pathstr++; /* skip trailing semi */
3872 if (curfullcmd > fullcmd /* append a dir separator */
3873 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3875 *curfullcmd++ = '\\';
3883 /* The following are just place holders.
3884 * Some hosts may provide and environment that the OS is
3885 * not tracking, therefore, these host must provide that
3886 * environment and the current directory to CreateProcess
3890 win32_get_childenv(void)
3896 win32_free_childenv(void* d)
3901 win32_clearenv(void)
3903 char *envv = GetEnvironmentStrings();
3907 char *end = strchr(cur,'=');
3908 if (end && end != cur) {
3910 SetEnvironmentVariable(cur, NULL);
3912 cur = end + strlen(end+1)+2;
3914 else if ((len = strlen(cur)))
3917 FreeEnvironmentStrings(envv);
3921 win32_get_childdir(void)
3925 char szfilename[MAX_PATH+1];
3927 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3928 Newx(ptr, strlen(szfilename)+1, char);
3929 strcpy(ptr, szfilename);
3934 win32_free_childdir(char* d)
3941 /* XXX this needs to be made more compatible with the spawnvp()
3942 * provided by the various RTLs. In particular, searching for
3943 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3944 * This doesn't significantly affect perl itself, because we
3945 * always invoke things using PERL5SHELL if a direct attempt to
3946 * spawn the executable fails.
3948 * XXX splitting and rejoining the commandline between do_aspawn()
3949 * and win32_spawnvp() could also be avoided.
3953 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3955 #ifdef USE_RTL_SPAWNVP
3956 return spawnvp(mode, cmdname, (char * const *)argv);
3963 STARTUPINFO StartupInfo;
3964 PROCESS_INFORMATION ProcessInformation;
3967 char *fullcmd = Nullch;
3968 char *cname = (char *)cmdname;
3972 clen = strlen(cname);
3973 /* if command name contains dquotes, must remove them */
3974 if (strchr(cname, '"')) {
3976 Newx(cname,clen+1,char);
3989 cmd = create_command_line(cname, clen, argv);
3991 env = PerlEnv_get_childenv();
3992 dir = PerlEnv_get_childdir();
3995 case P_NOWAIT: /* asynch + remember result */
3996 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4001 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4004 create |= CREATE_NEW_PROCESS_GROUP;
4007 case P_WAIT: /* synchronous execution */
4009 default: /* invalid mode */
4014 memset(&StartupInfo,0,sizeof(StartupInfo));
4015 StartupInfo.cb = sizeof(StartupInfo);
4016 memset(&tbl,0,sizeof(tbl));
4017 PerlEnv_get_child_IO(&tbl);
4018 StartupInfo.dwFlags = tbl.dwFlags;
4019 StartupInfo.dwX = tbl.dwX;
4020 StartupInfo.dwY = tbl.dwY;
4021 StartupInfo.dwXSize = tbl.dwXSize;
4022 StartupInfo.dwYSize = tbl.dwYSize;
4023 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4024 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4025 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4026 StartupInfo.wShowWindow = tbl.wShowWindow;
4027 StartupInfo.hStdInput = tbl.childStdIn;
4028 StartupInfo.hStdOutput = tbl.childStdOut;
4029 StartupInfo.hStdError = tbl.childStdErr;
4030 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4031 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4032 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4034 create |= CREATE_NEW_CONSOLE;
4037 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4039 if (w32_use_showwindow) {
4040 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4041 StartupInfo.wShowWindow = w32_showwindow;
4044 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4047 if (!CreateProcess(cname, /* search PATH to find executable */
4048 cmd, /* executable, and its arguments */
4049 NULL, /* process attributes */
4050 NULL, /* thread attributes */
4051 TRUE, /* inherit handles */
4052 create, /* creation flags */
4053 (LPVOID)env, /* inherit environment */
4054 dir, /* inherit cwd */
4056 &ProcessInformation))
4058 /* initial NULL argument to CreateProcess() does a PATH
4059 * search, but it always first looks in the directory
4060 * where the current process was started, which behavior
4061 * is undesirable for backward compatibility. So we
4062 * jump through our own hoops by picking out the path
4063 * we really want it to use. */
4065 fullcmd = qualified_path(cname);
4067 if (cname != cmdname)
4070 DEBUG_p(PerlIO_printf(Perl_debug_log,
4071 "Retrying [%s] with same args\n",
4081 if (mode == P_NOWAIT) {
4082 /* asynchronous spawn -- store handle, return PID */
4083 ret = (int)ProcessInformation.dwProcessId;
4084 if (IsWin95() && ret < 0)
4087 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4088 w32_child_pids[w32_num_children] = (DWORD)ret;
4093 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4094 /* FIXME: if msgwait returned due to message perhaps forward the
4095 "signal" to the process
4097 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4099 CloseHandle(ProcessInformation.hProcess);
4102 CloseHandle(ProcessInformation.hThread);
4105 PerlEnv_free_childenv(env);
4106 PerlEnv_free_childdir(dir);
4108 if (cname != cmdname)
4115 win32_execv(const char *cmdname, const char *const *argv)
4119 /* if this is a pseudo-forked child, we just want to spawn
4120 * the new program, and return */
4122 # ifdef __BORLANDC__
4123 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4125 return spawnv(P_WAIT, cmdname, argv);
4129 return execv(cmdname, (char *const *)argv);
4131 return execv(cmdname, argv);
4136 win32_execvp(const char *cmdname, const char *const *argv)
4140 /* if this is a pseudo-forked child, we just want to spawn
4141 * the new program, and return */
4142 if (w32_pseudo_id) {
4143 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4153 return execvp(cmdname, (char *const *)argv);
4155 return execvp(cmdname, argv);
4160 win32_perror(const char *str)
4166 win32_setbuf(FILE *pf, char *buf)
4172 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4174 return setvbuf(pf, buf, type, size);
4178 win32_flushall(void)
4184 win32_fcloseall(void)
4190 win32_fgets(char *s, int n, FILE *pf)
4192 return fgets(s, n, pf);
4202 win32_fgetc(FILE *pf)
4208 win32_putc(int c, FILE *pf)
4214 win32_puts(const char *s)
4226 win32_putchar(int c)
4233 #ifndef USE_PERL_SBRK
4235 static char *committed = NULL; /* XXX threadead */
4236 static char *base = NULL; /* XXX threadead */
4237 static char *reserved = NULL; /* XXX threadead */
4238 static char *brk = NULL; /* XXX threadead */
4239 static DWORD pagesize = 0; /* XXX threadead */
4242 sbrk(ptrdiff_t need)
4247 GetSystemInfo(&info);
4248 /* Pretend page size is larger so we don't perpetually
4249 * call the OS to commit just one page ...
4251 pagesize = info.dwPageSize << 3;
4253 if (brk+need >= reserved)
4255 DWORD size = brk+need-reserved;
4257 char *prev_committed = NULL;
4258 if (committed && reserved && committed < reserved)
4260 /* Commit last of previous chunk cannot span allocations */
4261 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4264 /* Remember where we committed from in case we want to decommit later */
4265 prev_committed = committed;
4266 committed = reserved;
4269 /* Reserve some (more) space
4270 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4271 * this is only address space not memory...
4272 * Note this is a little sneaky, 1st call passes NULL as reserved
4273 * so lets system choose where we start, subsequent calls pass
4274 * the old end address so ask for a contiguous block
4277 if (size < 64*1024*1024)
4278 size = 64*1024*1024;
4279 size = ((size + pagesize - 1) / pagesize) * pagesize;
4280 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4283 reserved = addr+size;
4293 /* The existing block could not be extended far enough, so decommit
4294 * anything that was just committed above and start anew */
4297 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4300 reserved = base = committed = brk = NULL;
4311 if (brk > committed)
4313 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4315 if (committed+size > reserved)
4316 size = reserved-committed;
4317 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4330 win32_malloc(size_t size)
4332 return malloc(size);
4336 win32_calloc(size_t numitems, size_t size)
4338 return calloc(numitems,size);
4342 win32_realloc(void *block, size_t size)
4344 return realloc(block,size);
4348 win32_free(void *block)
4355 win32_open_osfhandle(intptr_t handle, int flags)
4357 #ifdef USE_FIXED_OSFHANDLE
4359 return my_open_osfhandle(handle, flags);
4361 return _open_osfhandle(handle, flags);
4365 win32_get_osfhandle(int fd)
4367 return (intptr_t)_get_osfhandle(fd);
4371 win32_fdupopen(FILE *pf)
4376 int fileno = win32_dup(win32_fileno(pf));
4378 /* open the file in the same mode */
4380 if((pf)->flags & _F_READ) {
4384 else if((pf)->flags & _F_WRIT) {
4388 else if((pf)->flags & _F_RDWR) {
4394 if((pf)->_flag & _IOREAD) {
4398 else if((pf)->_flag & _IOWRT) {
4402 else if((pf)->_flag & _IORW) {
4409 /* it appears that the binmode is attached to the
4410 * file descriptor so binmode files will be handled
4413 pfdup = win32_fdopen(fileno, mode);
4415 /* move the file pointer to the same position */
4416 if (!fgetpos(pf, &pos)) {
4417 fsetpos(pfdup, &pos);
4423 win32_dynaload(const char* filename)
4426 char buf[MAX_PATH+1];
4429 /* LoadLibrary() doesn't recognize forward slashes correctly,
4430 * so turn 'em back. */
4431 first = strchr(filename, '/');
4433 STRLEN len = strlen(filename);
4434 if (len <= MAX_PATH) {
4435 strcpy(buf, filename);
4436 filename = &buf[first - filename];
4438 if (*filename == '/')
4439 *(char*)filename = '\\';
4445 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4448 XS(w32_SetChildShowWindow)
4451 BOOL use_showwindow = w32_use_showwindow;
4452 /* use "unsigned short" because Perl has redefined "WORD" */
4453 unsigned short showwindow = w32_showwindow;
4456 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4458 if (items == 0 || !SvOK(ST(0)))
4459 w32_use_showwindow = FALSE;
4461 w32_use_showwindow = TRUE;
4462 w32_showwindow = (unsigned short)SvIV(ST(0));
4467 ST(0) = sv_2mortal(newSViv(showwindow));
4469 ST(0) = &PL_sv_undef;
4474 forward(pTHX_ const char *function)
4477 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
4480 call_pv(function, GIMME_V);
4483 #define FORWARD(function) XS(w32_##function){ forward(aTHX_ "Win32::"#function); }
4486 FORWARD(GetNextAvailDrive)
4487 FORWARD(GetLastError)
4488 FORWARD(SetLastError)
4493 FORWARD(GetOSVersion)
4496 FORWARD(FormatMessage)
4498 FORWARD(GetTickCount)
4499 FORWARD(GetShortPathName)
4500 FORWARD(GetFullPathName)
4501 FORWARD(GetLongPathName)
4505 /* Don't forward Win32::SetChildShowWindow(). It accesses the internal variable
4506 * w32_showwindow in thread_intern and is therefore not implemented in Win32.xs.
4508 /* FORWARD(SetChildShowWindow) */
4513 Perl_init_os_extras(void)
4516 char *file = __FILE__;
4519 /* these names are Activeware compatible */
4520 newXS("Win32::GetCwd", w32_GetCwd, file);
4521 newXS("Win32::SetCwd", w32_SetCwd, file);
4522 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4523 newXS("Win32::GetLastError", w32_GetLastError, file);
4524 newXS("Win32::SetLastError", w32_SetLastError, file);
4525 newXS("Win32::LoginName", w32_LoginName, file);
4526 newXS("Win32::NodeName", w32_NodeName, file);
4527 newXS("Win32::DomainName", w32_DomainName, file);
4528 newXS("Win32::FsType", w32_FsType, file);
4529 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4530 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4531 newXS("Win32::IsWin95", w32_IsWin95, file);
4532 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4533 newXS("Win32::Spawn", w32_Spawn, file);
4534 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4535 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4536 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4537 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4538 newXS("Win32::CopyFile", w32_CopyFile, file);
4539 newXS("Win32::Sleep", w32_Sleep, file);
4540 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4544 win32_signal_context(void)
4549 my_perl = PL_curinterp;
4550 PERL_SET_THX(my_perl);
4554 return PL_curinterp;
4560 win32_ctrlhandler(DWORD dwCtrlType)
4563 dTHXa(PERL_GET_SIG_CONTEXT);
4569 switch(dwCtrlType) {
4570 case CTRL_CLOSE_EVENT:
4571 /* A signal that the system sends to all processes attached to a console when
4572 the user closes the console (either by choosing the Close command from the
4573 console window's System menu, or by choosing the End Task command from the
4576 if (do_raise(aTHX_ 1)) /* SIGHUP */
4577 sig_terminate(aTHX_ 1);
4581 /* A CTRL+c signal was received */
4582 if (do_raise(aTHX_ SIGINT))
4583 sig_terminate(aTHX_ SIGINT);
4586 case CTRL_BREAK_EVENT:
4587 /* A CTRL+BREAK signal was received */
4588 if (do_raise(aTHX_ SIGBREAK))
4589 sig_terminate(aTHX_ SIGBREAK);
4592 case CTRL_LOGOFF_EVENT:
4593 /* A signal that the system sends to all console processes when a user is logging
4594 off. This signal does not indicate which user is logging off, so no
4595 assumptions can be made.
4598 case CTRL_SHUTDOWN_EVENT:
4599 /* A signal that the system sends to all console processes when the system is
4602 if (do_raise(aTHX_ SIGTERM))
4603 sig_terminate(aTHX_ SIGTERM);
4612 #if _MSC_VER >= 1400
4613 # include <crtdbg.h>
4617 Perl_win32_init(int *argcp, char ***argvp)
4621 #if _MSC_VER >= 1400
4622 _invalid_parameter_handler oldHandler, newHandler;
4623 newHandler = my_invalid_parameter_handler;
4624 oldHandler = _set_invalid_parameter_handler(newHandler);
4625 _CrtSetReportMode(_CRT_ASSERT, 0);
4627 /* Disable floating point errors, Perl will trap the ones we
4628 * care about. VC++ RTL defaults to switching these off
4629 * already, but the Borland RTL doesn't. Since we don't
4630 * want to be at the vendor's whim on the default, we set
4631 * it explicitly here.
4633 #if !defined(_ALPHA_) && !defined(__GNUC__)
4634 _control87(MCW_EM, MCW_EM);
4638 module = GetModuleHandle("ntdll.dll");
4640 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4643 module = GetModuleHandle("kernel32.dll");
4645 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4646 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4647 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4652 Perl_win32_term(void)
4662 win32_get_child_IO(child_IO_table* ptbl)
4664 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4665 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4666 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4670 win32_signal(int sig, Sighandler_t subcode)
4673 if (sig < SIG_SIZE) {
4674 int save_errno = errno;
4675 Sighandler_t result = signal(sig, subcode);
4676 if (result == SIG_ERR) {
4677 result = w32_sighandler[sig];
4680 w32_sighandler[sig] = subcode;
4690 #ifdef HAVE_INTERP_INTERN
4694 win32_csighandler(int sig)
4697 dTHXa(PERL_GET_SIG_CONTEXT);
4698 Perl_warn(aTHX_ "Got signal %d",sig);
4704 win32_create_message_window()
4706 /* "message-only" windows have been implemented in Windows 2000 and later.
4707 * On earlier versions we'll continue to post messages to a specific
4708 * thread and use hwnd==NULL. This is brittle when either an embedding
4709 * application or an XS module is also posting messages to hwnd=NULL
4710 * because once removed from the queue they cannot be delivered to the
4711 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4712 * if there is no window handle.
4714 if (g_osver.dwMajorVersion < 5)
4717 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4720 #if defined(__MINGW32__) && defined(__cplusplus)
4721 #define CAST_HWND__(x) (HWND__*)(x)
4723 #define CAST_HWND__(x) x
4727 Perl_sys_intern_init(pTHX)
4731 if (g_osver.dwOSVersionInfoSize == 0) {
4732 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4733 GetVersionEx(&g_osver);
4736 w32_perlshell_tokens = Nullch;
4737 w32_perlshell_vec = (char**)NULL;
4738 w32_perlshell_items = 0;
4739 w32_fdpid = newAV();
4740 Newx(w32_children, 1, child_tab);
4741 w32_num_children = 0;
4742 # ifdef USE_ITHREADS
4744 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4745 w32_num_pseudo_children = 0;
4748 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4750 for (i=0; i < SIG_SIZE; i++) {
4751 w32_sighandler[i] = SIG_DFL;
4754 if (my_perl == PL_curinterp) {
4758 /* Force C runtime signal stuff to set its console handler */
4759 signal(SIGINT,win32_csighandler);
4760 signal(SIGBREAK,win32_csighandler);
4761 /* Push our handler on top */
4762 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4767 Perl_sys_intern_clear(pTHX)
4769 Safefree(w32_perlshell_tokens);
4770 Safefree(w32_perlshell_vec);
4771 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4772 Safefree(w32_children);
4774 KillTimer(w32_message_hwnd, w32_timerid);
4777 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4778 DestroyWindow(w32_message_hwnd);
4779 # ifdef MULTIPLICITY
4780 if (my_perl == PL_curinterp) {
4784 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4786 # ifdef USE_ITHREADS
4787 Safefree(w32_pseudo_children);
4791 # ifdef USE_ITHREADS
4794 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4796 dst->perlshell_tokens = Nullch;
4797 dst->perlshell_vec = (char**)NULL;
4798 dst->perlshell_items = 0;
4799 dst->fdpid = newAV();
4800 Newxz(dst->children, 1, child_tab);
4802 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4804 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4805 dst->poll_count = 0;
4806 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4808 # endif /* USE_ITHREADS */
4809 #endif /* HAVE_INTERP_INTERN */
4812 win32_free_argvw(pTHX_ void *ptr)
4814 char** argv = (char**)ptr;
4822 win32_argv2utf8(int argc, char** argv)
4827 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4828 if (lpwStr && argc) {
4830 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4831 Newxz(psz, length, char);
4832 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4835 call_atexit(win32_free_argvw, argv);
4837 GlobalFree((HGLOBAL)lpwStr);