3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc.
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
16 # define Win32_Winsock
20 # define _WIN32_WINNT 0x0500 /* needed for CreateHardlink() etc. */
31 /* #include "config.h" */
33 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
42 #define PERL_NO_GET_CONTEXT
47 /* assert.h conflicts with #define of assert in perl.h */
56 #if defined(_MSC_VER) || defined(__MINGW32__)
57 # include <sys/utime.h>
63 /* Mingw32 defaults to globing command line
64 * So we turn it off like this:
69 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
70 /* Mingw32-1.1 is missing some prototypes */
72 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
73 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
74 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
80 #if defined(__BORLANDC__)
82 # define _utimbuf utimbuf
87 #define EXECF_SPAWN_NOWAIT 3
89 #if defined(PERL_IMPLICIT_SYS)
90 # undef win32_get_privlib
91 # define win32_get_privlib g_win32_get_privlib
92 # undef win32_get_sitelib
93 # define win32_get_sitelib g_win32_get_sitelib
94 # undef win32_get_vendorlib
95 # define win32_get_vendorlib g_win32_get_vendorlib
97 # define getlogin g_getlogin
100 static void get_shell(void);
101 static long tokenize(const char *str, char **dest, char ***destv);
102 static int do_spawn2(pTHX_ const char *cmd, int exectype);
103 static BOOL has_shell_metachars(const char *ptr);
104 static long filetime_to_clock(PFILETIME ft);
105 static BOOL filetime_from_time(PFILETIME ft, time_t t);
106 static char * get_emd_part(SV **leading, STRLEN *const len,
107 char *trailing, ...);
108 static void remove_dead_process(long deceased);
109 static long find_pid(int pid);
110 static char * qualified_path(const char *cmd);
111 static char * win32_get_xlib(const char *pl, const char *xlib,
112 const char *libname, STRLEN *const len);
113 static LRESULT win32_process_message(HWND hwnd, UINT msg,
114 WPARAM wParam, LPARAM lParam);
117 static void remove_dead_pseudo_process(long child);
118 static long find_pseudo_pid(int pid);
122 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
123 char w32_module_name[MAX_PATH+1];
126 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
129 /* Silence STDERR grumblings from Borland's math library. */
131 _matherr(struct _exception *a)
138 /* VS2005 (MSC version 14) provides a mechanism to set an invalid
139 * parameter handler. This functionality is not available in the
140 * 64-bit compiler from the Platform SDK, which unfortunately also
141 * believes itself to be MSC version 14.
143 * There is no #define related to _set_invalid_parameter_handler(),
144 * but we can check for one of the constants defined for
145 * _set_abort_behavior(), which was introduced into stdlib.h at
149 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
150 # define SET_INVALID_PARAMETER_HANDLER
153 #ifdef SET_INVALID_PARAMETER_HANDLER
154 void my_invalid_parameter_handler(const wchar_t* expression,
155 const wchar_t* function,
161 wprintf(L"Invalid parameter detected in function %s."
162 L" File: %s Line: %d\n", function, file, line);
163 wprintf(L"Expression: %s\n", expression);
169 set_w32_module_name(void)
171 /* this function may be called at DLL_PROCESS_ATTACH time */
173 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
174 ? GetModuleHandle(NULL)
175 : w32_perldll_handle);
177 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
178 osver.dwOSVersionInfoSize = sizeof(osver);
179 GetVersionEx(&osver);
181 if (osver.dwMajorVersion > 4) {
182 WCHAR modulename[MAX_PATH];
183 WCHAR fullname[MAX_PATH];
186 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
187 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
188 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
190 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
192 /* Make sure we get an absolute pathname in case the module was loaded
193 * explicitly by LoadLibrary() with a relative path. */
194 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
196 /* Make sure we start with the long path name of the module because we
197 * later scan for pathname components to match "5.xx" to locate
198 * compatible sitelib directories, and the short pathname might mangle
199 * this path segment (e.g. by removing the dot on NTFS to something
200 * like "5xx~1.yy") */
201 if (pfnGetLongPathNameW)
202 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
204 /* remove \\?\ prefix */
205 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
206 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
208 ansi = win32_ansipath(fullname);
209 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
213 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
215 /* remove \\?\ prefix */
216 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
217 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
219 /* try to get full path to binary (which may be mangled when perl is
220 * run from a 16-bit app) */
221 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
222 win32_longpath(w32_module_name);
223 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
226 /* normalize to forward slashes */
227 ptr = w32_module_name;
235 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
237 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
239 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
242 const char *subkey = "Software\\Perl";
246 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
247 if (retval == ERROR_SUCCESS) {
249 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
250 if (retval == ERROR_SUCCESS
251 && (type == REG_SZ || type == REG_EXPAND_SZ))
255 *svp = sv_2mortal(newSVpvn("",0));
256 SvGROW(*svp, datalen);
257 retval = RegQueryValueEx(handle, valuename, 0, NULL,
258 (PBYTE)SvPVX(*svp), &datalen);
259 if (retval == ERROR_SUCCESS) {
261 SvCUR_set(*svp,datalen-1);
269 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
271 get_regstr(const char *valuename, SV **svp)
273 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
275 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
279 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
281 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
285 char mod_name[MAX_PATH+1];
291 va_start(ap, trailing_path);
292 strip = va_arg(ap, char *);
294 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
295 baselen = strlen(base);
297 if (!*w32_module_name) {
298 set_w32_module_name();
300 strcpy(mod_name, w32_module_name);
301 ptr = strrchr(mod_name, '/');
302 while (ptr && strip) {
303 /* look for directories to skip back */
306 ptr = strrchr(mod_name, '/');
307 /* avoid stripping component if there is no slash,
308 * or it doesn't match ... */
309 if (!ptr || stricmp(ptr+1, strip) != 0) {
310 /* ... but not if component matches m|5\.$patchlevel.*| */
311 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
312 && strncmp(strip, base, baselen) == 0
313 && strncmp(ptr+1, base, baselen) == 0))
319 strip = va_arg(ap, char *);
327 strcpy(++ptr, trailing_path);
329 /* only add directory if it exists */
330 if (GetFileAttributes(mod_name) != (DWORD) -1) {
331 /* directory exists */
334 *prev_pathp = sv_2mortal(newSVpvn("",0));
335 else if (SvPVX(*prev_pathp))
336 sv_catpvn(*prev_pathp, ";", 1);
337 sv_catpv(*prev_pathp, mod_name);
339 *len = SvCUR(*prev_pathp);
340 return SvPVX(*prev_pathp);
347 win32_get_privlib(const char *pl, STRLEN *const len)
350 char *stdlib = "lib";
351 char buffer[MAX_PATH+1];
354 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
355 sprintf(buffer, "%s-%s", stdlib, pl);
356 if (!get_regstr(buffer, &sv))
357 (void)get_regstr(stdlib, &sv);
359 /* $stdlib .= ";$EMD/../../lib" */
360 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
364 win32_get_xlib(const char *pl, const char *xlib, const char *libname,
369 char pathstr[MAX_PATH+1];
373 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
374 sprintf(regstr, "%s-%s", xlib, pl);
375 (void)get_regstr(regstr, &sv1);
378 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
379 sprintf(pathstr, "%s/%s/lib", libname, pl);
380 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
382 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
383 (void)get_regstr(xlib, &sv2);
386 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
387 sprintf(pathstr, "%s/lib", libname);
388 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
395 sv_catpvn(sv1, ";", 1);
405 win32_get_sitelib(const char *pl, STRLEN *const len)
407 return win32_get_xlib(pl, "sitelib", "site", len);
410 #ifndef PERL_VENDORLIB_NAME
411 # define PERL_VENDORLIB_NAME "vendor"
415 win32_get_vendorlib(const char *pl, STRLEN *const len)
417 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
421 has_shell_metachars(const char *ptr)
427 * Scan string looking for redirection (< or >) or pipe
428 * characters (|) that are not in a quoted string.
429 * Shell variable interpolation (%VAR%) can also happen inside strings.
461 #if !defined(PERL_IMPLICIT_SYS)
462 /* since the current process environment is being updated in util.c
463 * the library functions will get the correct environment
466 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
468 PERL_FLUSHALL_FOR_CHILD;
469 return win32_popen(cmd, mode);
473 Perl_my_pclose(pTHX_ PerlIO *fp)
475 return win32_pclose(fp);
479 DllExport unsigned long
482 return (unsigned long)g_osver.dwPlatformId;
491 return -((int)w32_pseudo_id);
496 /* Tokenize a string. Words are null-separated, and the list
497 * ends with a doubled null. Any character (except null and
498 * including backslash) may be escaped by preceding it with a
499 * backslash (the backslash will be stripped).
500 * Returns number of words in result buffer.
503 tokenize(const char *str, char **dest, char ***destv)
505 char *retstart = NULL;
506 char **retvstart = 0;
510 int slen = strlen(str);
512 register char **retv;
513 Newx(ret, slen+2, char);
514 Newx(retv, (slen+3)/2, char*);
522 if (*ret == '\\' && *str)
524 else if (*ret == ' ') {
540 retvstart[items] = NULL;
553 if (!w32_perlshell_tokens) {
554 /* we don't use COMSPEC here for two reasons:
555 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
556 * uncontrolled unportability of the ensuing scripts.
557 * 2. PERL5SHELL could be set to a shell that may not be fit for
558 * interactive use (which is what most programs look in COMSPEC
561 const char* defaultshell = "cmd.exe /x/d/c";
562 const char *usershell = PerlEnv_getenv("PERL5SHELL");
563 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
564 &w32_perlshell_tokens,
570 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
578 PERL_ARGS_ASSERT_DO_ASPAWN;
584 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
586 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
591 while (++mark <= sp) {
592 if (*mark && (str = SvPV_nolen(*mark)))
599 status = win32_spawnvp(flag,
600 (const char*)(really ? SvPV_nolen(really) : argv[0]),
601 (const char* const*)argv);
603 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
604 /* possible shell-builtin, invoke with shell */
606 sh_items = w32_perlshell_items;
608 argv[index+sh_items] = argv[index];
609 while (--sh_items >= 0)
610 argv[sh_items] = w32_perlshell_vec[sh_items];
612 status = win32_spawnvp(flag,
613 (const char*)(really ? SvPV_nolen(really) : argv[0]),
614 (const char* const*)argv);
617 if (flag == P_NOWAIT) {
618 PL_statusvalue = -1; /* >16bits hint for pp_system() */
622 if (ckWARN(WARN_EXEC))
623 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
628 PL_statusvalue = status;
634 /* returns pointer to the next unquoted space or the end of the string */
636 find_next_space(const char *s)
638 bool in_quotes = FALSE;
640 /* ignore doubled backslashes, or backslash+quote */
641 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
644 /* keep track of when we're within quotes */
645 else if (*s == '"') {
647 in_quotes = !in_quotes;
649 /* break it up only at spaces that aren't in quotes */
650 else if (!in_quotes && isSPACE(*s))
659 do_spawn2(pTHX_ const char *cmd, int exectype)
665 BOOL needToTry = TRUE;
668 /* Save an extra exec if possible. See if there are shell
669 * metacharacters in it */
670 if (!has_shell_metachars(cmd)) {
671 Newx(argv, strlen(cmd) / 2 + 2, char*);
672 Newx(cmd2, strlen(cmd) + 1, char);
675 for (s = cmd2; *s;) {
676 while (*s && isSPACE(*s))
680 s = find_next_space(s);
688 status = win32_spawnvp(P_WAIT, argv[0],
689 (const char* const*)argv);
691 case EXECF_SPAWN_NOWAIT:
692 status = win32_spawnvp(P_NOWAIT, argv[0],
693 (const char* const*)argv);
696 status = win32_execvp(argv[0], (const char* const*)argv);
699 if (status != -1 || errno == 0)
709 Newx(argv, w32_perlshell_items + 2, char*);
710 while (++i < w32_perlshell_items)
711 argv[i] = w32_perlshell_vec[i];
712 argv[i++] = (char *)cmd;
716 status = win32_spawnvp(P_WAIT, argv[0],
717 (const char* const*)argv);
719 case EXECF_SPAWN_NOWAIT:
720 status = win32_spawnvp(P_NOWAIT, argv[0],
721 (const char* const*)argv);
724 status = win32_execvp(argv[0], (const char* const*)argv);
730 if (exectype == EXECF_SPAWN_NOWAIT) {
731 PL_statusvalue = -1; /* >16bits hint for pp_system() */
735 if (ckWARN(WARN_EXEC))
736 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
737 (exectype == EXECF_EXEC ? "exec" : "spawn"),
738 cmd, strerror(errno));
743 PL_statusvalue = status;
749 Perl_do_spawn(pTHX_ char *cmd)
751 PERL_ARGS_ASSERT_DO_SPAWN;
753 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
757 Perl_do_spawn_nowait(pTHX_ char *cmd)
759 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
761 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
765 Perl_do_exec(pTHX_ const char *cmd)
767 PERL_ARGS_ASSERT_DO_EXEC;
769 do_spawn2(aTHX_ cmd, EXECF_EXEC);
773 /* The idea here is to read all the directory names into a string table
774 * (separated by nulls) and when one of the other dir functions is called
775 * return the pointer to the current file name.
778 win32_opendir(const char *filename)
784 char scanname[MAX_PATH+3];
785 WCHAR wscanname[sizeof(scanname)];
786 WIN32_FIND_DATAW wFindData;
787 char buffer[MAX_PATH*2];
790 len = strlen(filename);
795 if (len > MAX_PATH) {
796 errno = ENAMETOOLONG;
800 /* Get us a DIR structure */
803 /* Create the search pattern */
804 strcpy(scanname, filename);
806 /* bare drive name means look in cwd for drive */
807 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
808 scanname[len++] = '.';
809 scanname[len++] = '/';
811 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
812 scanname[len++] = '/';
814 scanname[len++] = '*';
815 scanname[len] = '\0';
817 /* do the FindFirstFile call */
818 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
819 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
821 if (dirp->handle == INVALID_HANDLE_VALUE) {
822 DWORD err = GetLastError();
823 /* FindFirstFile() fails on empty drives! */
825 case ERROR_FILE_NOT_FOUND:
827 case ERROR_NO_MORE_FILES:
828 case ERROR_PATH_NOT_FOUND:
831 case ERROR_NOT_ENOUGH_MEMORY:
843 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
844 wFindData.cFileName, -1,
845 buffer, sizeof(buffer), NULL, &use_default);
846 if (use_default && *wFindData.cAlternateFileName) {
847 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
848 wFindData.cAlternateFileName, -1,
849 buffer, sizeof(buffer), NULL, NULL);
852 /* now allocate the first part of the string table for
853 * the filenames that we find.
855 idx = strlen(buffer)+1;
860 Newx(dirp->start, dirp->size, char);
861 strcpy(dirp->start, buffer);
863 dirp->end = dirp->curr = dirp->start;
869 /* Readdir just returns the current string pointer and bumps the
870 * string pointer to the nDllExport entry.
872 DllExport struct direct *
873 win32_readdir(DIR *dirp)
878 /* first set up the structure to return */
879 len = strlen(dirp->curr);
880 strcpy(dirp->dirstr.d_name, dirp->curr);
881 dirp->dirstr.d_namlen = len;
884 dirp->dirstr.d_ino = dirp->curr - dirp->start;
886 /* Now set up for the next call to readdir */
887 dirp->curr += len + 1;
888 if (dirp->curr >= dirp->end) {
891 char buffer[MAX_PATH*2];
893 if (dirp->handle == INVALID_HANDLE_VALUE) {
896 /* finding the next file that matches the wildcard
897 * (which should be all of them in this directory!).
900 WIN32_FIND_DATAW wFindData;
901 res = FindNextFileW(dirp->handle, &wFindData);
903 BOOL use_default = FALSE;
904 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
905 wFindData.cFileName, -1,
906 buffer, sizeof(buffer), NULL, &use_default);
907 if (use_default && *wFindData.cAlternateFileName) {
908 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
909 wFindData.cAlternateFileName, -1,
910 buffer, sizeof(buffer), NULL, NULL);
915 long endpos = dirp->end - dirp->start;
916 long newsize = endpos + strlen(buffer) + 1;
917 /* bump the string table size by enough for the
918 * new name and its null terminator */
919 while (newsize > dirp->size) {
920 long curpos = dirp->curr - dirp->start;
922 Renew(dirp->start, dirp->size, char);
923 dirp->curr = dirp->start + curpos;
925 strcpy(dirp->start + endpos, buffer);
926 dirp->end = dirp->start + newsize;
931 if (dirp->handle != INVALID_HANDLE_VALUE) {
932 FindClose(dirp->handle);
933 dirp->handle = INVALID_HANDLE_VALUE;
937 return &(dirp->dirstr);
943 /* Telldir returns the current string pointer position */
945 win32_telldir(DIR *dirp)
947 return dirp->curr ? (dirp->curr - dirp->start) : -1;
951 /* Seekdir moves the string pointer to a previously saved position
952 * (returned by telldir).
955 win32_seekdir(DIR *dirp, long loc)
957 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
960 /* Rewinddir resets the string pointer to the start */
962 win32_rewinddir(DIR *dirp)
964 dirp->curr = dirp->start;
967 /* free the memory allocated by opendir */
969 win32_closedir(DIR *dirp)
972 if (dirp->handle != INVALID_HANDLE_VALUE)
973 FindClose(dirp->handle);
974 Safefree(dirp->start);
979 /* duplicate a open DIR* for interpreter cloning */
981 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
984 PerlInterpreter *const from = param->proto_perl;
985 PerlInterpreter *const to = PERL_GET_THX;
990 /* switch back to original interpreter because win32_readdir()
991 * might Renew(dirp->start).
997 /* mark current position; read all remaining entries into the
998 * cache, and then restore to current position.
1000 pos = win32_telldir(dirp);
1001 while (win32_readdir(dirp)) {
1002 /* read all entries into cache */
1004 win32_seekdir(dirp, pos);
1006 /* switch back to new interpreter to allocate new DIR structure */
1012 memcpy(dup, dirp, sizeof(DIR));
1014 Newx(dup->start, dirp->size, char);
1015 memcpy(dup->start, dirp->start, dirp->size);
1017 dup->end = dup->start + (dirp->end - dirp->start);
1019 dup->curr = dup->start + (dirp->curr - dirp->start);
1031 * Just pretend that everyone is a superuser. NT will let us know if
1032 * we don\'t really have permission to do something.
1035 #define ROOT_UID ((uid_t)0)
1036 #define ROOT_GID ((gid_t)0)
1065 return (auid == ROOT_UID ? 0 : -1);
1071 return (agid == ROOT_GID ? 0 : -1);
1078 char *buf = w32_getlogin_buffer;
1079 DWORD size = sizeof(w32_getlogin_buffer);
1080 if (GetUserName(buf,&size))
1086 chown(const char *path, uid_t owner, gid_t group)
1093 * XXX this needs strengthening (for PerlIO)
1096 int mkstemp(const char *path)
1099 char buf[MAX_PATH+1];
1103 if (i++ > 10) { /* give up */
1107 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1111 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1121 long child = w32_num_children;
1122 while (--child >= 0) {
1123 if ((int)w32_child_pids[child] == pid)
1130 remove_dead_process(long child)
1134 CloseHandle(w32_child_handles[child]);
1135 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1136 (w32_num_children-child-1), HANDLE);
1137 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1138 (w32_num_children-child-1), DWORD);
1145 find_pseudo_pid(int pid)
1148 long child = w32_num_pseudo_children;
1149 while (--child >= 0) {
1150 if ((int)w32_pseudo_child_pids[child] == pid)
1157 remove_dead_pseudo_process(long child)
1161 CloseHandle(w32_pseudo_child_handles[child]);
1162 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1163 (w32_num_pseudo_children-child-1), HANDLE);
1164 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1165 (w32_num_pseudo_children-child-1), DWORD);
1166 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1167 (w32_num_pseudo_children-child-1), HWND);
1168 w32_num_pseudo_children--;
1174 terminate_process(DWORD pid, HANDLE process_handle, int sig)
1178 /* "Does process exist?" use of kill */
1181 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1186 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1189 default: /* For now be backwards compatible with perl 5.6 */
1191 /* Note that we will only be able to kill processes owned by the
1192 * current process owner, even when we are running as an administrator.
1193 * To kill processes of other owners we would need to set the
1194 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1196 if (TerminateProcess(process_handle, sig))
1204 killpg(int pid, int sig)
1206 HANDLE process_handle;
1207 HANDLE snapshot_handle;
1210 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1211 if (process_handle == NULL)
1214 killed += terminate_process(pid, process_handle, sig);
1216 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1217 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1218 PROCESSENTRY32 entry;
1220 entry.dwSize = sizeof(entry);
1221 if (Process32First(snapshot_handle, &entry)) {
1223 if (entry.th32ParentProcessID == (DWORD)pid)
1224 killed += killpg(entry.th32ProcessID, sig);
1225 entry.dwSize = sizeof(entry);
1227 while (Process32Next(snapshot_handle, &entry));
1229 CloseHandle(snapshot_handle);
1231 CloseHandle(process_handle);
1236 my_kill(int pid, int sig)
1239 HANDLE process_handle;
1242 return killpg(pid, -sig);
1244 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1245 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1246 if (process_handle != NULL) {
1247 retval = terminate_process(pid, process_handle, sig);
1248 CloseHandle(process_handle);
1254 win32_kill(int pid, int sig)
1260 /* it is a pseudo-forked child */
1261 child = find_pseudo_pid(-pid);
1263 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1264 HANDLE hProcess = w32_pseudo_child_handles[child];
1267 /* "Does process exist?" use of kill */
1271 /* kill -9 style un-graceful exit */
1272 if (TerminateThread(hProcess, sig)) {
1273 remove_dead_pseudo_process(child);
1280 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1281 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1282 /* Yield and wait for the other thread to send us its message_hwnd */
1284 win32_async_check(aTHX);
1285 hwnd = w32_pseudo_child_message_hwnds[child];
1288 if (hwnd != INVALID_HANDLE_VALUE) {
1289 /* We fake signals to pseudo-processes using Win32
1290 * message queue. In Win9X the pids are negative already. */
1291 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1292 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1294 /* It might be us ... */
1307 child = find_pid(pid);
1309 if (my_kill(pid, sig)) {
1311 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1312 exitcode != STILL_ACTIVE)
1314 remove_dead_process(child);
1320 if (my_kill(pid, sig))
1329 win32_stat(const char *path, Stat_t *sbuf)
1332 char buffer[MAX_PATH+1];
1333 int l = strlen(path);
1336 BOOL expect_dir = FALSE;
1338 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1339 GV_NOTQUAL, SVt_PV);
1340 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1343 switch(path[l - 1]) {
1344 /* FindFirstFile() and stat() are buggy with a trailing
1345 * slashes, except for the root directory of a drive */
1348 if (l > sizeof(buffer)) {
1349 errno = ENAMETOOLONG;
1353 strncpy(buffer, path, l);
1354 /* remove additional trailing slashes */
1355 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1357 /* add back slash if we otherwise end up with just a drive letter */
1358 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1365 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1367 if (l == 2 && isALPHA(path[0])) {
1368 buffer[0] = path[0];
1379 path = PerlDir_mapA(path);
1383 /* We must open & close the file once; otherwise file attribute changes */
1384 /* might not yet have propagated to "other" hard links of the same file. */
1385 /* This also gives us an opportunity to determine the number of links. */
1386 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1387 if (handle != INVALID_HANDLE_VALUE) {
1388 BY_HANDLE_FILE_INFORMATION bhi;
1389 if (GetFileInformationByHandle(handle, &bhi))
1390 nlink = bhi.nNumberOfLinks;
1391 CloseHandle(handle);
1395 /* path will be mapped correctly above */
1396 #if defined(WIN64) || defined(USE_LARGE_FILES)
1397 res = _stati64(path, sbuf);
1399 res = stat(path, sbuf);
1401 sbuf->st_nlink = nlink;
1404 /* CRT is buggy on sharenames, so make sure it really isn't.
1405 * XXX using GetFileAttributesEx() will enable us to set
1406 * sbuf->st_*time (but note that's not available on the
1407 * Windows of 1995) */
1408 DWORD r = GetFileAttributesA(path);
1409 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1410 /* sbuf may still contain old garbage since stat() failed */
1411 Zero(sbuf, 1, Stat_t);
1412 sbuf->st_mode = S_IFDIR | S_IREAD;
1414 if (!(r & FILE_ATTRIBUTE_READONLY))
1415 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1420 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1421 && (path[2] == '\\' || path[2] == '/'))
1423 /* The drive can be inaccessible, some _stat()s are buggy */
1424 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1429 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1433 if (S_ISDIR(sbuf->st_mode)) {
1434 /* Ensure the "write" bit is switched off in the mode for
1435 * directories with the read-only attribute set. Borland (at least)
1436 * switches it on for directories, which is technically correct
1437 * (directories are indeed always writable unless denied by DACLs),
1438 * but we want stat() and -w to reflect the state of the read-only
1439 * attribute for symmetry with chmod(). */
1440 DWORD r = GetFileAttributesA(path);
1441 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1442 sbuf->st_mode &= ~S_IWRITE;
1446 if (S_ISDIR(sbuf->st_mode)) {
1447 sbuf->st_mode |= S_IEXEC;
1449 else if (S_ISREG(sbuf->st_mode)) {
1451 if (l >= 4 && path[l-4] == '.') {
1452 const char *e = path + l - 3;
1453 if (strnicmp(e,"exe",3)
1454 && strnicmp(e,"bat",3)
1455 && strnicmp(e,"com",3)
1456 && strnicmp(e,"cmd",3))
1457 sbuf->st_mode &= ~S_IEXEC;
1459 sbuf->st_mode |= S_IEXEC;
1462 sbuf->st_mode &= ~S_IEXEC;
1463 /* Propagate permissions to _group_ and _others_ */
1464 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1465 sbuf->st_mode |= (perms>>3) | (perms>>6);
1472 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1473 #define SKIP_SLASHES(s) \
1475 while (*(s) && isSLASH(*(s))) \
1478 #define COPY_NONSLASHES(d,s) \
1480 while (*(s) && !isSLASH(*(s))) \
1484 /* Find the longname of a given path. path is destructively modified.
1485 * It should have space for at least MAX_PATH characters. */
1487 win32_longpath(char *path)
1489 WIN32_FIND_DATA fdata;
1491 char tmpbuf[MAX_PATH+1];
1492 char *tmpstart = tmpbuf;
1499 if (isALPHA(path[0]) && path[1] == ':') {
1501 *tmpstart++ = path[0];
1505 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1507 *tmpstart++ = path[0];
1508 *tmpstart++ = path[1];
1509 SKIP_SLASHES(start);
1510 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1512 *tmpstart++ = *start++;
1513 SKIP_SLASHES(start);
1514 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1519 /* copy initial slash, if any */
1520 if (isSLASH(*start)) {
1521 *tmpstart++ = *start++;
1523 SKIP_SLASHES(start);
1526 /* FindFirstFile() expands "." and "..", so we need to pass
1527 * those through unmolested */
1529 && (!start[1] || isSLASH(start[1])
1530 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1532 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1537 /* if this is the end, bust outta here */
1541 /* now we're at a non-slash; walk up to next slash */
1542 while (*start && !isSLASH(*start))
1545 /* stop and find full name of component */
1548 fhand = FindFirstFile(path,&fdata);
1550 if (fhand != INVALID_HANDLE_VALUE) {
1551 STRLEN len = strlen(fdata.cFileName);
1552 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1553 strcpy(tmpstart, fdata.cFileName);
1564 /* failed a step, just return without side effects */
1565 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1570 strcpy(path,tmpbuf);
1579 /* Can't use PerlIO to write as it allocates memory */
1580 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1581 PL_no_mem, strlen(PL_no_mem));
1587 /* The win32_ansipath() function takes a Unicode filename and converts it
1588 * into the current Windows codepage. If some characters cannot be mapped,
1589 * then it will convert the short name instead.
1591 * The buffer to the ansi pathname must be freed with win32_free() when it
1592 * it no longer needed.
1594 * The argument to win32_ansipath() must exist before this function is
1595 * called; otherwise there is no way to determine the short path name.
1597 * Ideas for future refinement:
1598 * - Only convert those segments of the path that are not in the current
1599 * codepage, but leave the other segments in their long form.
1600 * - If the resulting name is longer than MAX_PATH, start converting
1601 * additional path segments into short names until the full name
1602 * is shorter than MAX_PATH. Shorten the filename part last!
1605 win32_ansipath(const WCHAR *widename)
1608 BOOL use_default = FALSE;
1609 size_t widelen = wcslen(widename)+1;
1610 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1611 NULL, 0, NULL, NULL);
1612 name = win32_malloc(len);
1616 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1617 name, len, NULL, &use_default);
1619 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1621 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1624 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1626 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1627 NULL, 0, NULL, NULL);
1628 name = win32_realloc(name, len);
1631 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1632 name, len, NULL, NULL);
1633 win32_free(shortname);
1640 win32_getenv(const char *name)
1646 needlen = GetEnvironmentVariableA(name,NULL,0);
1648 curitem = sv_2mortal(newSVpvn("", 0));
1650 SvGROW(curitem, needlen+1);
1651 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1653 } while (needlen >= SvLEN(curitem));
1654 SvCUR_set(curitem, needlen);
1657 /* allow any environment variables that begin with 'PERL'
1658 to be stored in the registry */
1659 if (strncmp(name, "PERL", 4) == 0)
1660 (void)get_regstr(name, &curitem);
1662 if (curitem && SvCUR(curitem))
1663 return SvPVX(curitem);
1669 win32_putenv(const char *name)
1677 Newx(curitem,strlen(name)+1,char);
1678 strcpy(curitem, name);
1679 val = strchr(curitem, '=');
1681 /* The sane way to deal with the environment.
1682 * Has these advantages over putenv() & co.:
1683 * * enables us to store a truly empty value in the
1684 * environment (like in UNIX).
1685 * * we don't have to deal with RTL globals, bugs and leaks
1686 * (specifically, see http://support.microsoft.com/kb/235601).
1688 * Why you may want to use the RTL environment handling
1689 * (previously enabled by USE_WIN32_RTL_ENV):
1690 * * environ[] and RTL functions will not reflect changes,
1691 * which might be an issue if extensions want to access
1692 * the env. via RTL. This cuts both ways, since RTL will
1693 * not see changes made by extensions that call the Win32
1694 * functions directly, either.
1698 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1707 filetime_to_clock(PFILETIME ft)
1709 __int64 qw = ft->dwHighDateTime;
1711 qw |= ft->dwLowDateTime;
1712 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1717 win32_times(struct tms *timebuf)
1722 clock_t process_time_so_far = clock();
1723 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1725 timebuf->tms_utime = filetime_to_clock(&user);
1726 timebuf->tms_stime = filetime_to_clock(&kernel);
1727 timebuf->tms_cutime = 0;
1728 timebuf->tms_cstime = 0;
1730 /* That failed - e.g. Win95 fallback to clock() */
1731 timebuf->tms_utime = process_time_so_far;
1732 timebuf->tms_stime = 0;
1733 timebuf->tms_cutime = 0;
1734 timebuf->tms_cstime = 0;
1736 return process_time_so_far;
1739 /* fix utime() so it works on directories in NT */
1741 filetime_from_time(PFILETIME pFileTime, time_t Time)
1743 struct tm *pTM = localtime(&Time);
1744 SYSTEMTIME SystemTime;
1750 SystemTime.wYear = pTM->tm_year + 1900;
1751 SystemTime.wMonth = pTM->tm_mon + 1;
1752 SystemTime.wDay = pTM->tm_mday;
1753 SystemTime.wHour = pTM->tm_hour;
1754 SystemTime.wMinute = pTM->tm_min;
1755 SystemTime.wSecond = pTM->tm_sec;
1756 SystemTime.wMilliseconds = 0;
1758 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1759 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1763 win32_unlink(const char *filename)
1769 filename = PerlDir_mapA(filename);
1770 attrs = GetFileAttributesA(filename);
1771 if (attrs == 0xFFFFFFFF) {
1775 if (attrs & FILE_ATTRIBUTE_READONLY) {
1776 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1777 ret = unlink(filename);
1779 (void)SetFileAttributesA(filename, attrs);
1782 ret = unlink(filename);
1787 win32_utime(const char *filename, struct utimbuf *times)
1794 struct utimbuf TimeBuffer;
1797 filename = PerlDir_mapA(filename);
1798 rc = utime(filename, times);
1800 /* EACCES: path specifies directory or readonly file */
1801 if (rc == 0 || errno != EACCES)
1804 if (times == NULL) {
1805 times = &TimeBuffer;
1806 time(×->actime);
1807 times->modtime = times->actime;
1810 /* This will (and should) still fail on readonly files */
1811 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1812 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1813 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1814 if (handle == INVALID_HANDLE_VALUE)
1817 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1818 filetime_from_time(&ftAccess, times->actime) &&
1819 filetime_from_time(&ftWrite, times->modtime) &&
1820 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1825 CloseHandle(handle);
1830 unsigned __int64 ft_i64;
1835 #define Const64(x) x##LL
1837 #define Const64(x) x##i64
1839 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1840 #define EPOCH_BIAS Const64(116444736000000000)
1842 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1843 * and appears to be unsupported even by glibc) */
1845 win32_gettimeofday(struct timeval *tp, void *not_used)
1849 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1850 GetSystemTimeAsFileTime(&ft.ft_val);
1852 /* seconds since epoch */
1853 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1855 /* microseconds remaining */
1856 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1862 win32_uname(struct utsname *name)
1864 struct hostent *hep;
1865 STRLEN nodemax = sizeof(name->nodename)-1;
1868 switch (g_osver.dwPlatformId) {
1869 case VER_PLATFORM_WIN32_WINDOWS:
1870 strcpy(name->sysname, "Windows");
1872 case VER_PLATFORM_WIN32_NT:
1873 strcpy(name->sysname, "Windows NT");
1875 case VER_PLATFORM_WIN32s:
1876 strcpy(name->sysname, "Win32s");
1879 strcpy(name->sysname, "Win32 Unknown");
1884 sprintf(name->release, "%d.%d",
1885 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1888 sprintf(name->version, "Build %d",
1889 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1890 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1891 if (g_osver.szCSDVersion[0]) {
1892 char *buf = name->version + strlen(name->version);
1893 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1897 hep = win32_gethostbyname("localhost");
1899 STRLEN len = strlen(hep->h_name);
1900 if (len <= nodemax) {
1901 strcpy(name->nodename, hep->h_name);
1904 strncpy(name->nodename, hep->h_name, nodemax);
1905 name->nodename[nodemax] = '\0';
1910 if (!GetComputerName(name->nodename, &sz))
1911 *name->nodename = '\0';
1914 /* machine (architecture) */
1919 GetSystemInfo(&info);
1921 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1922 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
1923 procarch = info.u.s.wProcessorArchitecture;
1925 procarch = info.wProcessorArchitecture;
1928 case PROCESSOR_ARCHITECTURE_INTEL:
1929 arch = "x86"; break;
1930 case PROCESSOR_ARCHITECTURE_IA64:
1931 arch = "ia64"; break;
1932 case PROCESSOR_ARCHITECTURE_AMD64:
1933 arch = "amd64"; break;
1934 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1935 arch = "unknown"; break;
1937 sprintf(name->machine, "unknown(0x%x)", procarch);
1938 arch = name->machine;
1941 if (name->machine != arch)
1942 strcpy(name->machine, arch);
1947 /* Timing related stuff */
1950 do_raise(pTHX_ int sig)
1952 if (sig < SIG_SIZE) {
1953 Sighandler_t handler = w32_sighandler[sig];
1954 if (handler == SIG_IGN) {
1957 else if (handler != SIG_DFL) {
1962 /* Choose correct default behaviour */
1978 /* Tell caller to exit thread/process as approriate */
1983 sig_terminate(pTHX_ int sig)
1985 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1986 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1993 win32_async_check(pTHX)
1996 HWND hwnd = w32_message_hwnd;
1998 /* Reset w32_poll_count before doing anything else, incase we dispatch
1999 * messages that end up calling back into perl */
2002 if (hwnd != INVALID_HANDLE_VALUE) {
2003 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2004 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2009 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2010 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2012 /* re-post a WM_QUIT message (we'll mark it as read later) */
2013 if(msg.message == WM_QUIT) {
2014 PostQuitMessage((int)msg.wParam);
2018 if(!CallMsgFilter(&msg, MSGF_USER))
2020 TranslateMessage(&msg);
2021 DispatchMessage(&msg);
2026 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2027 * This is necessary when we are being called by win32_msgwait() to
2028 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2029 * message over and over. An example how this can happen is when
2030 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2031 * is generating messages before the process terminated.
2033 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2035 /* Above or other stuff may have set a signal flag */
2042 /* This function will not return until the timeout has elapsed, or until
2043 * one of the handles is ready. */
2045 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2047 /* We may need several goes at this - so compute when we stop */
2049 if (timeout != INFINITE) {
2050 ticks = GetTickCount();
2054 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2057 if (result == WAIT_TIMEOUT) {
2058 /* Ran out of time - explicit return of zero to avoid -ve if we
2059 have scheduling issues
2063 if (timeout != INFINITE) {
2064 ticks = GetTickCount();
2066 if (result == WAIT_OBJECT_0 + count) {
2067 /* Message has arrived - check it */
2068 (void)win32_async_check(aTHX);
2071 /* Not timeout or message - one of handles is ready */
2075 /* compute time left to wait */
2076 ticks = timeout - ticks;
2077 /* If we are past the end say zero */
2078 return (ticks > 0) ? ticks : 0;
2082 win32_internal_wait(int *status, DWORD timeout)
2084 /* XXX this wait emulation only knows about processes
2085 * spawned via win32_spawnvp(P_NOWAIT, ...).
2089 DWORD exitcode, waitcode;
2092 if (w32_num_pseudo_children) {
2093 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2094 timeout, &waitcode);
2095 /* Time out here if there are no other children to wait for. */
2096 if (waitcode == WAIT_TIMEOUT) {
2097 if (!w32_num_children) {
2101 else if (waitcode != WAIT_FAILED) {
2102 if (waitcode >= WAIT_ABANDONED_0
2103 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2104 i = waitcode - WAIT_ABANDONED_0;
2106 i = waitcode - WAIT_OBJECT_0;
2107 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2108 *status = (int)((exitcode & 0xff) << 8);
2109 retval = (int)w32_pseudo_child_pids[i];
2110 remove_dead_pseudo_process(i);
2117 if (!w32_num_children) {
2122 /* if a child exists, wait for it to die */
2123 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2124 if (waitcode == WAIT_TIMEOUT) {
2127 if (waitcode != WAIT_FAILED) {
2128 if (waitcode >= WAIT_ABANDONED_0
2129 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2130 i = waitcode - WAIT_ABANDONED_0;
2132 i = waitcode - WAIT_OBJECT_0;
2133 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2134 *status = (int)((exitcode & 0xff) << 8);
2135 retval = (int)w32_child_pids[i];
2136 remove_dead_process(i);
2141 errno = GetLastError();
2146 win32_waitpid(int pid, int *status, int flags)
2149 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2152 if (pid == -1) /* XXX threadid == 1 ? */
2153 return win32_internal_wait(status, timeout);
2156 child = find_pseudo_pid(-pid);
2158 HANDLE hThread = w32_pseudo_child_handles[child];
2160 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2161 if (waitcode == WAIT_TIMEOUT) {
2164 else if (waitcode == WAIT_OBJECT_0) {
2165 if (GetExitCodeThread(hThread, &waitcode)) {
2166 *status = (int)((waitcode & 0xff) << 8);
2167 retval = (int)w32_pseudo_child_pids[child];
2168 remove_dead_pseudo_process(child);
2180 child = find_pid(pid);
2182 hProcess = w32_child_handles[child];
2183 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2184 if (waitcode == WAIT_TIMEOUT) {
2187 else if (waitcode == WAIT_OBJECT_0) {
2188 if (GetExitCodeProcess(hProcess, &waitcode)) {
2189 *status = (int)((waitcode & 0xff) << 8);
2190 retval = (int)w32_child_pids[child];
2191 remove_dead_process(child);
2199 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2201 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2202 if (waitcode == WAIT_TIMEOUT) {
2203 CloseHandle(hProcess);
2206 else if (waitcode == WAIT_OBJECT_0) {
2207 if (GetExitCodeProcess(hProcess, &waitcode)) {
2208 *status = (int)((waitcode & 0xff) << 8);
2209 CloseHandle(hProcess);
2213 CloseHandle(hProcess);
2219 return retval >= 0 ? pid : retval;
2223 win32_wait(int *status)
2225 return win32_internal_wait(status, INFINITE);
2228 DllExport unsigned int
2229 win32_sleep(unsigned int t)
2232 /* Win32 times are in ms so *1000 in and /1000 out */
2233 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2236 DllExport unsigned int
2237 win32_alarm(unsigned int sec)
2240 * the 'obvious' implentation is SetTimer() with a callback
2241 * which does whatever receiving SIGALRM would do
2242 * we cannot use SIGALRM even via raise() as it is not
2243 * one of the supported codes in <signal.h>
2247 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2248 w32_message_hwnd = win32_create_message_window();
2251 if (w32_message_hwnd == NULL)
2252 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2255 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2260 KillTimer(w32_message_hwnd, w32_timerid);
2267 #ifdef HAVE_DES_FCRYPT
2268 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2272 win32_crypt(const char *txt, const char *salt)
2275 #ifdef HAVE_DES_FCRYPT
2276 return des_fcrypt(txt, salt, w32_crypt_buffer);
2278 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2283 /* simulate flock by locking a range on the file */
2285 #define LK_LEN 0xffff0000
2288 win32_flock(int fd, int oper)
2294 fh = (HANDLE)_get_osfhandle(fd);
2295 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2298 memset(&o, 0, sizeof(o));
2301 case LOCK_SH: /* shared lock */
2302 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2305 case LOCK_EX: /* exclusive lock */
2306 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2309 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2310 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2313 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2314 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2318 case LOCK_UN: /* unlock lock */
2319 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2322 default: /* unknown */
2327 if (GetLastError() == ERROR_LOCK_VIOLATION)
2328 errno = WSAEWOULDBLOCK;
2338 * redirected io subsystem for all XS modules
2351 return (&(_environ));
2354 /* the rest are the remapped stdio routines */
2374 win32_ferror(FILE *fp)
2376 return (ferror(fp));
2381 win32_feof(FILE *fp)
2387 * Since the errors returned by the socket error function
2388 * WSAGetLastError() are not known by the library routine strerror
2389 * we have to roll our own.
2393 win32_strerror(int e)
2395 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2396 extern int sys_nerr;
2399 if (e < 0 || e > sys_nerr) {
2404 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2405 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2406 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2409 strcpy(w32_strerror_buffer, "Unknown Error");
2411 return w32_strerror_buffer;
2415 #define strerror win32_strerror
2419 win32_str_os_error(void *sv, DWORD dwErr)
2423 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2424 |FORMAT_MESSAGE_IGNORE_INSERTS
2425 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2426 dwErr, 0, (char *)&sMsg, 1, NULL);
2427 /* strip trailing whitespace and period */
2430 --dwLen; /* dwLen doesn't include trailing null */
2431 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2432 if ('.' != sMsg[dwLen])
2437 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2439 dwLen = sprintf(sMsg,
2440 "Unknown error #0x%lX (lookup 0x%lX)",
2441 dwErr, GetLastError());
2445 sv_setpvn((SV*)sv, sMsg, dwLen);
2451 win32_fprintf(FILE *fp, const char *format, ...)
2454 va_start(marker, format); /* Initialize variable arguments. */
2456 return (vfprintf(fp, format, marker));
2460 win32_printf(const char *format, ...)
2463 va_start(marker, format); /* Initialize variable arguments. */
2465 return (vprintf(format, marker));
2469 win32_vfprintf(FILE *fp, const char *format, va_list args)
2471 return (vfprintf(fp, format, args));
2475 win32_vprintf(const char *format, va_list args)
2477 return (vprintf(format, args));
2481 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2483 return fread(buf, size, count, fp);
2487 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2489 return fwrite(buf, size, count, fp);
2492 #define MODE_SIZE 10
2495 win32_fopen(const char *filename, const char *mode)
2503 if (stricmp(filename, "/dev/null")==0)
2506 f = fopen(PerlDir_mapA(filename), mode);
2507 /* avoid buffering headaches for child processes */
2508 if (f && *mode == 'a')
2509 win32_fseek(f, 0, SEEK_END);
2513 #ifndef USE_SOCKETS_AS_HANDLES
2515 #define fdopen my_fdopen
2519 win32_fdopen(int handle, const char *mode)
2523 f = fdopen(handle, (char *) mode);
2524 /* avoid buffering headaches for child processes */
2525 if (f && *mode == 'a')
2526 win32_fseek(f, 0, SEEK_END);
2531 win32_freopen(const char *path, const char *mode, FILE *stream)
2534 if (stricmp(path, "/dev/null")==0)
2537 return freopen(PerlDir_mapA(path), mode, stream);
2541 win32_fclose(FILE *pf)
2543 return my_fclose(pf); /* defined in win32sck.c */
2547 win32_fputs(const char *s,FILE *pf)
2549 return fputs(s, pf);
2553 win32_fputc(int c,FILE *pf)
2559 win32_ungetc(int c,FILE *pf)
2561 return ungetc(c,pf);
2565 win32_getc(FILE *pf)
2571 win32_fileno(FILE *pf)
2577 win32_clearerr(FILE *pf)
2584 win32_fflush(FILE *pf)
2590 win32_ftell(FILE *pf)
2592 #if defined(WIN64) || defined(USE_LARGE_FILES)
2593 #if defined(__BORLANDC__) /* buk */
2594 return win32_tell( fileno( pf ) );
2597 if (fgetpos(pf, &pos))
2607 win32_fseek(FILE *pf, Off_t offset,int origin)
2609 #if defined(WIN64) || defined(USE_LARGE_FILES)
2610 #if defined(__BORLANDC__) /* buk */
2620 if (fgetpos(pf, &pos))
2625 fseek(pf, 0, SEEK_END);
2626 pos = _telli64(fileno(pf));
2635 return fsetpos(pf, &offset);
2638 return fseek(pf, (long)offset, origin);
2643 win32_fgetpos(FILE *pf,fpos_t *p)
2645 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2646 if( win32_tell(fileno(pf)) == -1L ) {
2652 return fgetpos(pf, p);
2657 win32_fsetpos(FILE *pf,const fpos_t *p)
2659 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2660 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2662 return fsetpos(pf, p);
2667 win32_rewind(FILE *pf)
2677 char prefix[MAX_PATH+1];
2678 char filename[MAX_PATH+1];
2679 DWORD len = GetTempPath(MAX_PATH, prefix);
2680 if (len && len < MAX_PATH) {
2681 if (GetTempFileName(prefix, "plx", 0, filename)) {
2682 HANDLE fh = CreateFile(filename,
2683 DELETE | GENERIC_READ | GENERIC_WRITE,
2687 FILE_ATTRIBUTE_NORMAL
2688 | FILE_FLAG_DELETE_ON_CLOSE,
2690 if (fh != INVALID_HANDLE_VALUE) {
2691 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2693 #if defined(__BORLANDC__)
2694 setmode(fd,O_BINARY);
2696 DEBUG_p(PerlIO_printf(Perl_debug_log,
2697 "Created tmpfile=%s\n",filename));
2709 int fd = win32_tmpfd();
2711 return win32_fdopen(fd, "w+b");
2723 win32_fstat(int fd, Stat_t *sbufptr)
2726 /* A file designated by filehandle is not shown as accessible
2727 * for write operations, probably because it is opened for reading.
2730 BY_HANDLE_FILE_INFORMATION bhfi;
2731 # if defined(WIN64) || defined(USE_LARGE_FILES)
2732 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2734 int rc = fstat(fd,&tmp);
2736 sbufptr->st_dev = tmp.st_dev;
2737 sbufptr->st_ino = tmp.st_ino;
2738 sbufptr->st_mode = tmp.st_mode;
2739 sbufptr->st_nlink = tmp.st_nlink;
2740 sbufptr->st_uid = tmp.st_uid;
2741 sbufptr->st_gid = tmp.st_gid;
2742 sbufptr->st_rdev = tmp.st_rdev;
2743 sbufptr->st_size = tmp.st_size;
2744 sbufptr->st_atime = tmp.st_atime;
2745 sbufptr->st_mtime = tmp.st_mtime;
2746 sbufptr->st_ctime = tmp.st_ctime;
2748 int rc = fstat(fd,sbufptr);
2751 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2752 # if defined(WIN64) || defined(USE_LARGE_FILES)
2753 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2755 sbufptr->st_mode &= 0xFE00;
2756 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2757 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2759 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2760 + ((S_IREAD|S_IWRITE) >> 6));
2764 # if defined(WIN64) || defined(USE_LARGE_FILES)
2765 return _fstati64(fd, sbufptr);
2767 return fstat(fd, sbufptr);
2773 win32_pipe(int *pfd, unsigned int size, int mode)
2775 return _pipe(pfd, size, mode);
2779 win32_popenlist(const char *mode, IV narg, SV **args)
2782 Perl_croak(aTHX_ "List form of pipe open not implemented");
2787 * a popen() clone that respects PERL5SHELL
2789 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2793 win32_popen(const char *command, const char *mode)
2795 #ifdef USE_RTL_POPEN
2796 return _popen(command, mode);
2808 /* establish which ends read and write */
2809 if (strchr(mode,'w')) {
2810 stdfd = 0; /* stdin */
2813 nhandle = STD_INPUT_HANDLE;
2815 else if (strchr(mode,'r')) {
2816 stdfd = 1; /* stdout */
2819 nhandle = STD_OUTPUT_HANDLE;
2824 /* set the correct mode */
2825 if (strchr(mode,'b'))
2827 else if (strchr(mode,'t'))
2830 ourmode = _fmode & (O_TEXT | O_BINARY);
2832 /* the child doesn't inherit handles */
2833 ourmode |= O_NOINHERIT;
2835 if (win32_pipe(p, 512, ourmode) == -1)
2838 /* save the old std handle (this needs to happen before the
2839 * dup2(), since that might call SetStdHandle() too) */
2842 old_h = GetStdHandle(nhandle);
2844 /* save current stdfd */
2845 if ((oldfd = win32_dup(stdfd)) == -1)
2848 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2849 /* stdfd will be inherited by the child */
2850 if (win32_dup2(p[child], stdfd) == -1)
2853 /* close the child end in parent */
2854 win32_close(p[child]);
2856 /* set the new std handle (in case dup2() above didn't) */
2857 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2859 /* start the child */
2862 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2865 /* revert stdfd to whatever it was before */
2866 if (win32_dup2(oldfd, stdfd) == -1)
2869 /* close saved handle */
2872 /* restore the old std handle (this needs to happen after the
2873 * dup2(), since that might call SetStdHandle() too */
2875 SetStdHandle(nhandle, old_h);
2880 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2882 /* set process id so that it can be returned by perl's open() */
2883 PL_forkprocess = childpid;
2886 /* we have an fd, return a file stream */
2887 return (PerlIO_fdopen(p[parent], (char *)mode));
2890 /* we don't need to check for errors here */
2894 win32_dup2(oldfd, stdfd);
2898 SetStdHandle(nhandle, old_h);
2904 #endif /* USE_RTL_POPEN */
2912 win32_pclose(PerlIO *pf)
2914 #ifdef USE_RTL_POPEN
2918 int childpid, status;
2921 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2924 childpid = SvIVX(sv);
2940 if (win32_waitpid(childpid, &status, 0) == -1)
2945 #endif /* USE_RTL_POPEN */
2949 win32_link(const char *oldname, const char *newname)
2952 WCHAR wOldName[MAX_PATH+1];
2953 WCHAR wNewName[MAX_PATH+1];
2955 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2956 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2957 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2958 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2962 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2967 win32_rename(const char *oname, const char *newname)
2969 char szOldName[MAX_PATH+1];
2971 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2974 if (stricmp(newname, oname))
2975 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2976 strcpy(szOldName, PerlDir_mapA(oname));
2978 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2980 DWORD err = GetLastError();
2982 case ERROR_BAD_NET_NAME:
2983 case ERROR_BAD_NETPATH:
2984 case ERROR_BAD_PATHNAME:
2985 case ERROR_FILE_NOT_FOUND:
2986 case ERROR_FILENAME_EXCED_RANGE:
2987 case ERROR_INVALID_DRIVE:
2988 case ERROR_NO_MORE_FILES:
2989 case ERROR_PATH_NOT_FOUND:
3002 win32_setmode(int fd, int mode)
3004 return setmode(fd, mode);
3008 win32_chsize(int fd, Off_t size)
3010 #if defined(WIN64) || defined(USE_LARGE_FILES)
3012 Off_t cur, end, extend;
3014 cur = win32_tell(fd);
3017 end = win32_lseek(fd, 0, SEEK_END);
3020 extend = size - end;
3024 else if (extend > 0) {
3025 /* must grow the file, padding with nulls */
3027 int oldmode = win32_setmode(fd, O_BINARY);
3029 memset(b, '\0', sizeof(b));
3031 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3032 count = win32_write(fd, b, count);
3033 if ((int)count < 0) {
3037 } while ((extend -= count) > 0);
3038 win32_setmode(fd, oldmode);
3041 /* shrink the file */
3042 win32_lseek(fd, size, SEEK_SET);
3043 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3049 win32_lseek(fd, cur, SEEK_SET);
3052 return chsize(fd, (long)size);
3057 win32_lseek(int fd, Off_t offset, int origin)
3059 #if defined(WIN64) || defined(USE_LARGE_FILES)
3060 #if defined(__BORLANDC__) /* buk */
3062 pos.QuadPart = offset;
3063 pos.LowPart = SetFilePointer(
3064 (HANDLE)_get_osfhandle(fd),
3069 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3073 return pos.QuadPart;
3075 return _lseeki64(fd, offset, origin);
3078 return lseek(fd, (long)offset, origin);
3085 #if defined(WIN64) || defined(USE_LARGE_FILES)
3086 #if defined(__BORLANDC__) /* buk */
3089 pos.LowPart = SetFilePointer(
3090 (HANDLE)_get_osfhandle(fd),
3095 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3099 return pos.QuadPart;
3100 /* return tell(fd); */
3102 return _telli64(fd);
3110 win32_open(const char *path, int flag, ...)
3117 pmode = va_arg(ap, int);
3120 if (stricmp(path, "/dev/null")==0)
3123 return open(PerlDir_mapA(path), flag, pmode);
3126 /* close() that understands socket */
3127 extern int my_close(int); /* in win32sck.c */
3132 return my_close(fd);
3142 win32_isatty(int fd)
3144 /* The Microsoft isatty() function returns true for *all*
3145 * character mode devices, including "nul". Our implementation
3146 * should only return true if the handle has a console buffer.
3149 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3150 if (fh == (HANDLE)-1) {
3151 /* errno is already set to EBADF */
3155 if (GetConsoleMode(fh, &mode))
3169 win32_dup2(int fd1,int fd2)
3171 return dup2(fd1,fd2);
3174 #ifdef PERL_MSVCRT_READFIX
3176 #define LF 10 /* line feed */
3177 #define CR 13 /* carriage return */
3178 #define CTRLZ 26 /* ctrl-z means eof for text */
3179 #define FOPEN 0x01 /* file handle open */
3180 #define FEOFLAG 0x02 /* end of file has been encountered */
3181 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3182 #define FPIPE 0x08 /* file handle refers to a pipe */
3183 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3184 #define FDEV 0x40 /* file handle refers to device */
3185 #define FTEXT 0x80 /* file handle is in text mode */
3186 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3189 _fixed_read(int fh, void *buf, unsigned cnt)
3191 int bytes_read; /* number of bytes read */
3192 char *buffer; /* buffer to read to */
3193 int os_read; /* bytes read on OS call */
3194 char *p, *q; /* pointers into buffer */
3195 char peekchr; /* peek-ahead character */
3196 ULONG filepos; /* file position after seek */
3197 ULONG dosretval; /* o.s. return value */
3199 /* validate handle */
3200 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3201 !(_osfile(fh) & FOPEN))
3203 /* out of range -- return error */
3205 _doserrno = 0; /* not o.s. error */
3210 * If lockinitflag is FALSE, assume fd is device
3211 * lockinitflag is set to TRUE by open.
3213 if (_pioinfo(fh)->lockinitflag)
3214 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3216 bytes_read = 0; /* nothing read yet */
3217 buffer = (char*)buf;
3219 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3220 /* nothing to read or at EOF, so return 0 read */
3224 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3225 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3227 *buffer++ = _pipech(fh);
3230 _pipech(fh) = LF; /* mark as empty */
3235 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3237 /* ReadFile has reported an error. recognize two special cases.
3239 * 1. map ERROR_ACCESS_DENIED to EBADF
3241 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3242 * means the handle is a read-handle on a pipe for which
3243 * all write-handles have been closed and all data has been
3246 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3247 /* wrong read/write mode should return EBADF, not EACCES */
3249 _doserrno = dosretval;
3253 else if (dosretval == ERROR_BROKEN_PIPE) {
3263 bytes_read += os_read; /* update bytes read */
3265 if (_osfile(fh) & FTEXT) {
3266 /* now must translate CR-LFs to LFs in the buffer */
3268 /* set CRLF flag to indicate LF at beginning of buffer */
3269 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3270 /* _osfile(fh) |= FCRLF; */
3272 /* _osfile(fh) &= ~FCRLF; */
3274 _osfile(fh) &= ~FCRLF;
3276 /* convert chars in the buffer: p is src, q is dest */
3278 while (p < (char *)buf + bytes_read) {
3280 /* if fh is not a device, set ctrl-z flag */
3281 if (!(_osfile(fh) & FDEV))
3282 _osfile(fh) |= FEOFLAG;
3283 break; /* stop translating */
3288 /* *p is CR, so must check next char for LF */
3289 if (p < (char *)buf + bytes_read - 1) {
3292 *q++ = LF; /* convert CR-LF to LF */
3295 *q++ = *p++; /* store char normally */
3298 /* This is the hard part. We found a CR at end of
3299 buffer. We must peek ahead to see if next char
3304 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3305 (LPDWORD)&os_read, NULL))
3306 dosretval = GetLastError();
3308 if (dosretval != 0 || os_read == 0) {
3309 /* couldn't read ahead, store CR */
3313 /* peekchr now has the extra character -- we now
3314 have several possibilities:
3315 1. disk file and char is not LF; just seek back
3317 2. disk file and char is LF; store LF, don't seek back
3318 3. pipe/device and char is LF; store LF.
3319 4. pipe/device and char isn't LF, store CR and
3320 put char in pipe lookahead buffer. */
3321 if (_osfile(fh) & (FDEV|FPIPE)) {
3322 /* non-seekable device */
3327 _pipech(fh) = peekchr;
3332 if (peekchr == LF) {
3333 /* nothing read yet; must make some
3336 /* turn on this flag for tell routine */
3337 _osfile(fh) |= FCRLF;
3340 HANDLE osHandle; /* o.s. handle value */
3342 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3344 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3345 dosretval = GetLastError();
3356 /* we now change bytes_read to reflect the true number of chars
3358 bytes_read = q - (char *)buf;
3362 if (_pioinfo(fh)->lockinitflag)
3363 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3368 #endif /* PERL_MSVCRT_READFIX */
3371 win32_read(int fd, void *buf, unsigned int cnt)
3373 #ifdef PERL_MSVCRT_READFIX
3374 return _fixed_read(fd, buf, cnt);
3376 return read(fd, buf, cnt);
3381 win32_write(int fd, const void *buf, unsigned int cnt)
3383 return write(fd, buf, cnt);
3387 win32_mkdir(const char *dir, int mode)
3390 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3394 win32_rmdir(const char *dir)
3397 return rmdir(PerlDir_mapA(dir));
3401 win32_chdir(const char *dir)
3412 win32_access(const char *path, int mode)
3415 return access(PerlDir_mapA(path), mode);
3419 win32_chmod(const char *path, int mode)
3422 return chmod(PerlDir_mapA(path), mode);
3427 create_command_line(char *cname, STRLEN clen, const char * const *args)
3434 bool bat_file = FALSE;
3435 bool cmd_shell = FALSE;
3436 bool dumb_shell = FALSE;
3437 bool extra_quotes = FALSE;
3438 bool quote_next = FALSE;
3441 cname = (char*)args[0];
3443 /* The NT cmd.exe shell has the following peculiarity that needs to be
3444 * worked around. It strips a leading and trailing dquote when any
3445 * of the following is true:
3446 * 1. the /S switch was used
3447 * 2. there are more than two dquotes
3448 * 3. there is a special character from this set: &<>()@^|
3449 * 4. no whitespace characters within the two dquotes
3450 * 5. string between two dquotes isn't an executable file
3451 * To work around this, we always add a leading and trailing dquote
3452 * to the string, if the first argument is either "cmd.exe" or "cmd",
3453 * and there were at least two or more arguments passed to cmd.exe
3454 * (not including switches).
3455 * XXX the above rules (from "cmd /?") don't seem to be applied
3456 * always, making for the convolutions below :-(
3460 clen = strlen(cname);
3463 && (stricmp(&cname[clen-4], ".bat") == 0
3464 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3470 char *exe = strrchr(cname, '/');
3471 char *exe2 = strrchr(cname, '\\');
3478 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3482 else if (stricmp(exe, "command.com") == 0
3483 || stricmp(exe, "command") == 0)
3490 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3491 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3492 STRLEN curlen = strlen(arg);
3493 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3494 len += 2; /* assume quoting needed (worst case) */
3496 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3498 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3501 Newx(cmd, len, char);
3506 extra_quotes = TRUE;
3509 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3511 STRLEN curlen = strlen(arg);
3513 /* we want to protect empty arguments and ones with spaces with
3514 * dquotes, but only if they aren't already there */
3519 else if (quote_next) {
3520 /* see if it really is multiple arguments pretending to
3521 * be one and force a set of quotes around it */
3522 if (*find_next_space(arg))
3525 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3527 while (i < curlen) {
3528 if (isSPACE(arg[i])) {
3531 else if (arg[i] == '"') {
3555 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3556 && stricmp(arg+curlen-2, "/c") == 0)
3558 /* is there a next argument? */
3559 if (args[index+1]) {
3560 /* are there two or more next arguments? */
3561 if (args[index+2]) {
3563 extra_quotes = TRUE;
3566 /* single argument, force quoting if it has spaces */
3582 qualified_path(const char *cmd)
3586 char *fullcmd, *curfullcmd;
3592 fullcmd = (char*)cmd;
3594 if (*fullcmd == '/' || *fullcmd == '\\')
3601 pathstr = PerlEnv_getenv("PATH");
3603 /* worst case: PATH is a single directory; we need additional space
3604 * to append "/", ".exe" and trailing "\0" */
3605 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3606 curfullcmd = fullcmd;
3611 /* start by appending the name to the current prefix */
3612 strcpy(curfullcmd, cmd);
3613 curfullcmd += cmdlen;
3615 /* if it doesn't end with '.', or has no extension, try adding
3616 * a trailing .exe first */
3617 if (cmd[cmdlen-1] != '.'
3618 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3620 strcpy(curfullcmd, ".exe");
3621 res = GetFileAttributes(fullcmd);
3622 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3627 /* that failed, try the bare name */
3628 res = GetFileAttributes(fullcmd);
3629 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3632 /* quit if no other path exists, or if cmd already has path */
3633 if (!pathstr || !*pathstr || has_slash)
3636 /* skip leading semis */
3637 while (*pathstr == ';')
3640 /* build a new prefix from scratch */
3641 curfullcmd = fullcmd;
3642 while (*pathstr && *pathstr != ';') {
3643 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3644 pathstr++; /* skip initial '"' */
3645 while (*pathstr && *pathstr != '"') {
3646 *curfullcmd++ = *pathstr++;
3649 pathstr++; /* skip trailing '"' */
3652 *curfullcmd++ = *pathstr++;
3656 pathstr++; /* skip trailing semi */
3657 if (curfullcmd > fullcmd /* append a dir separator */
3658 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3660 *curfullcmd++ = '\\';
3668 /* The following are just place holders.
3669 * Some hosts may provide and environment that the OS is
3670 * not tracking, therefore, these host must provide that
3671 * environment and the current directory to CreateProcess
3675 win32_get_childenv(void)
3681 win32_free_childenv(void* d)
3686 win32_clearenv(void)
3688 char *envv = GetEnvironmentStrings();
3692 char *end = strchr(cur,'=');
3693 if (end && end != cur) {
3695 SetEnvironmentVariable(cur, NULL);
3697 cur = end + strlen(end+1)+2;
3699 else if ((len = strlen(cur)))
3702 FreeEnvironmentStrings(envv);
3706 win32_get_childdir(void)
3710 char szfilename[MAX_PATH+1];
3712 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3713 Newx(ptr, strlen(szfilename)+1, char);
3714 strcpy(ptr, szfilename);
3719 win32_free_childdir(char* d)
3726 /* XXX this needs to be made more compatible with the spawnvp()
3727 * provided by the various RTLs. In particular, searching for
3728 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3729 * This doesn't significantly affect perl itself, because we
3730 * always invoke things using PERL5SHELL if a direct attempt to
3731 * spawn the executable fails.
3733 * XXX splitting and rejoining the commandline between do_aspawn()
3734 * and win32_spawnvp() could also be avoided.
3738 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3740 #ifdef USE_RTL_SPAWNVP
3741 return spawnvp(mode, cmdname, (char * const *)argv);
3748 STARTUPINFO StartupInfo;
3749 PROCESS_INFORMATION ProcessInformation;
3752 char *fullcmd = NULL;
3753 char *cname = (char *)cmdname;
3757 clen = strlen(cname);
3758 /* if command name contains dquotes, must remove them */
3759 if (strchr(cname, '"')) {
3761 Newx(cname,clen+1,char);
3774 cmd = create_command_line(cname, clen, argv);
3776 env = PerlEnv_get_childenv();
3777 dir = PerlEnv_get_childdir();
3780 case P_NOWAIT: /* asynch + remember result */
3781 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3786 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3789 create |= CREATE_NEW_PROCESS_GROUP;
3792 case P_WAIT: /* synchronous execution */
3794 default: /* invalid mode */
3799 memset(&StartupInfo,0,sizeof(StartupInfo));
3800 StartupInfo.cb = sizeof(StartupInfo);
3801 memset(&tbl,0,sizeof(tbl));
3802 PerlEnv_get_child_IO(&tbl);
3803 StartupInfo.dwFlags = tbl.dwFlags;
3804 StartupInfo.dwX = tbl.dwX;
3805 StartupInfo.dwY = tbl.dwY;
3806 StartupInfo.dwXSize = tbl.dwXSize;
3807 StartupInfo.dwYSize = tbl.dwYSize;
3808 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3809 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3810 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3811 StartupInfo.wShowWindow = tbl.wShowWindow;
3812 StartupInfo.hStdInput = tbl.childStdIn;
3813 StartupInfo.hStdOutput = tbl.childStdOut;
3814 StartupInfo.hStdError = tbl.childStdErr;
3815 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3816 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3817 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3819 create |= CREATE_NEW_CONSOLE;
3822 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3824 if (w32_use_showwindow) {
3825 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3826 StartupInfo.wShowWindow = w32_showwindow;
3829 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3832 if (!CreateProcess(cname, /* search PATH to find executable */
3833 cmd, /* executable, and its arguments */
3834 NULL, /* process attributes */
3835 NULL, /* thread attributes */
3836 TRUE, /* inherit handles */
3837 create, /* creation flags */
3838 (LPVOID)env, /* inherit environment */
3839 dir, /* inherit cwd */
3841 &ProcessInformation))
3843 /* initial NULL argument to CreateProcess() does a PATH
3844 * search, but it always first looks in the directory
3845 * where the current process was started, which behavior
3846 * is undesirable for backward compatibility. So we
3847 * jump through our own hoops by picking out the path
3848 * we really want it to use. */
3850 fullcmd = qualified_path(cname);
3852 if (cname != cmdname)
3855 DEBUG_p(PerlIO_printf(Perl_debug_log,
3856 "Retrying [%s] with same args\n",
3866 if (mode == P_NOWAIT) {
3867 /* asynchronous spawn -- store handle, return PID */
3868 ret = (int)ProcessInformation.dwProcessId;
3870 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3871 w32_child_pids[w32_num_children] = (DWORD)ret;
3876 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3877 /* FIXME: if msgwait returned due to message perhaps forward the
3878 "signal" to the process
3880 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3882 CloseHandle(ProcessInformation.hProcess);
3885 CloseHandle(ProcessInformation.hThread);
3888 PerlEnv_free_childenv(env);
3889 PerlEnv_free_childdir(dir);
3891 if (cname != cmdname)
3898 win32_execv(const char *cmdname, const char *const *argv)
3902 /* if this is a pseudo-forked child, we just want to spawn
3903 * the new program, and return */
3905 # ifdef __BORLANDC__
3906 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3908 return spawnv(P_WAIT, cmdname, argv);
3912 return execv(cmdname, (char *const *)argv);
3914 return execv(cmdname, argv);
3919 win32_execvp(const char *cmdname, const char *const *argv)
3923 /* if this is a pseudo-forked child, we just want to spawn
3924 * the new program, and return */
3925 if (w32_pseudo_id) {
3926 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3936 return execvp(cmdname, (char *const *)argv);
3938 return execvp(cmdname, argv);
3943 win32_perror(const char *str)
3949 win32_setbuf(FILE *pf, char *buf)
3955 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3957 return setvbuf(pf, buf, type, size);
3961 win32_flushall(void)
3967 win32_fcloseall(void)
3973 win32_fgets(char *s, int n, FILE *pf)
3975 return fgets(s, n, pf);
3985 win32_fgetc(FILE *pf)
3991 win32_putc(int c, FILE *pf)
3997 win32_puts(const char *s)
4009 win32_putchar(int c)
4016 #ifndef USE_PERL_SBRK
4018 static char *committed = NULL; /* XXX threadead */
4019 static char *base = NULL; /* XXX threadead */
4020 static char *reserved = NULL; /* XXX threadead */
4021 static char *brk = NULL; /* XXX threadead */
4022 static DWORD pagesize = 0; /* XXX threadead */
4025 sbrk(ptrdiff_t need)
4030 GetSystemInfo(&info);
4031 /* Pretend page size is larger so we don't perpetually
4032 * call the OS to commit just one page ...
4034 pagesize = info.dwPageSize << 3;
4036 if (brk+need >= reserved)
4038 DWORD size = brk+need-reserved;
4040 char *prev_committed = NULL;
4041 if (committed && reserved && committed < reserved)
4043 /* Commit last of previous chunk cannot span allocations */
4044 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4047 /* Remember where we committed from in case we want to decommit later */
4048 prev_committed = committed;
4049 committed = reserved;
4052 /* Reserve some (more) space
4053 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4054 * this is only address space not memory...
4055 * Note this is a little sneaky, 1st call passes NULL as reserved
4056 * so lets system choose where we start, subsequent calls pass
4057 * the old end address so ask for a contiguous block
4060 if (size < 64*1024*1024)
4061 size = 64*1024*1024;
4062 size = ((size + pagesize - 1) / pagesize) * pagesize;
4063 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4066 reserved = addr+size;
4076 /* The existing block could not be extended far enough, so decommit
4077 * anything that was just committed above and start anew */
4080 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4083 reserved = base = committed = brk = NULL;
4094 if (brk > committed)
4096 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4098 if (committed+size > reserved)
4099 size = reserved-committed;
4100 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4113 win32_malloc(size_t size)
4115 return malloc(size);
4119 win32_calloc(size_t numitems, size_t size)
4121 return calloc(numitems,size);
4125 win32_realloc(void *block, size_t size)
4127 return realloc(block,size);
4131 win32_free(void *block)
4138 win32_open_osfhandle(intptr_t handle, int flags)
4140 return _open_osfhandle(handle, flags);
4144 win32_get_osfhandle(int fd)
4146 return (intptr_t)_get_osfhandle(fd);
4150 win32_fdupopen(FILE *pf)
4155 int fileno = win32_dup(win32_fileno(pf));
4157 /* open the file in the same mode */
4159 if((pf)->flags & _F_READ) {
4163 else if((pf)->flags & _F_WRIT) {
4167 else if((pf)->flags & _F_RDWR) {
4173 if((pf)->_flag & _IOREAD) {
4177 else if((pf)->_flag & _IOWRT) {
4181 else if((pf)->_flag & _IORW) {
4188 /* it appears that the binmode is attached to the
4189 * file descriptor so binmode files will be handled
4192 pfdup = win32_fdopen(fileno, mode);
4194 /* move the file pointer to the same position */
4195 if (!fgetpos(pf, &pos)) {
4196 fsetpos(pfdup, &pos);
4202 win32_dynaload(const char* filename)
4205 char buf[MAX_PATH+1];
4208 /* LoadLibrary() doesn't recognize forward slashes correctly,
4209 * so turn 'em back. */
4210 first = strchr(filename, '/');
4212 STRLEN len = strlen(filename);
4213 if (len <= MAX_PATH) {
4214 strcpy(buf, filename);
4215 filename = &buf[first - filename];
4217 if (*filename == '/')
4218 *(char*)filename = '\\';
4224 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4227 XS(w32_SetChildShowWindow)
4230 BOOL use_showwindow = w32_use_showwindow;
4231 /* use "unsigned short" because Perl has redefined "WORD" */
4232 unsigned short showwindow = w32_showwindow;
4235 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4237 if (items == 0 || !SvOK(ST(0)))
4238 w32_use_showwindow = FALSE;
4240 w32_use_showwindow = TRUE;
4241 w32_showwindow = (unsigned short)SvIV(ST(0));
4246 ST(0) = sv_2mortal(newSViv(showwindow));
4248 ST(0) = &PL_sv_undef;
4253 Perl_init_os_extras(void)
4256 char *file = __FILE__;
4258 /* Initialize Win32CORE if it has been statically linked. */
4259 void (*pfn_init)(pTHX);
4260 #if defined(__BORLANDC__)
4261 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4262 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4264 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4269 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4273 win32_signal_context(void)
4278 my_perl = PL_curinterp;
4279 PERL_SET_THX(my_perl);
4283 return PL_curinterp;
4289 win32_ctrlhandler(DWORD dwCtrlType)
4292 dTHXa(PERL_GET_SIG_CONTEXT);
4298 switch(dwCtrlType) {
4299 case CTRL_CLOSE_EVENT:
4300 /* A signal that the system sends to all processes attached to a console when
4301 the user closes the console (either by choosing the Close command from the
4302 console window's System menu, or by choosing the End Task command from the
4305 if (do_raise(aTHX_ 1)) /* SIGHUP */
4306 sig_terminate(aTHX_ 1);
4310 /* A CTRL+c signal was received */
4311 if (do_raise(aTHX_ SIGINT))
4312 sig_terminate(aTHX_ SIGINT);
4315 case CTRL_BREAK_EVENT:
4316 /* A CTRL+BREAK signal was received */
4317 if (do_raise(aTHX_ SIGBREAK))
4318 sig_terminate(aTHX_ SIGBREAK);
4321 case CTRL_LOGOFF_EVENT:
4322 /* A signal that the system sends to all console processes when a user is logging
4323 off. This signal does not indicate which user is logging off, so no
4324 assumptions can be made.
4327 case CTRL_SHUTDOWN_EVENT:
4328 /* A signal that the system sends to all console processes when the system is
4331 if (do_raise(aTHX_ SIGTERM))
4332 sig_terminate(aTHX_ SIGTERM);
4341 #ifdef SET_INVALID_PARAMETER_HANDLER
4342 # include <crtdbg.h>
4353 /* fetch Unicode version of PATH */
4355 wide_path = win32_malloc(len*sizeof(WCHAR));
4357 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4361 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4366 /* convert to ANSI pathnames */
4367 wide_dir = wide_path;
4370 WCHAR *sep = wcschr(wide_dir, ';');
4378 /* remove quotes around pathname */
4379 if (*wide_dir == '"')
4381 wide_len = wcslen(wide_dir);
4382 if (wide_len && wide_dir[wide_len-1] == '"')
4383 wide_dir[wide_len-1] = '\0';
4385 /* append ansi_dir to ansi_path */
4386 ansi_dir = win32_ansipath(wide_dir);
4387 ansi_len = strlen(ansi_dir);
4389 size_t newlen = len + 1 + ansi_len;
4390 ansi_path = win32_realloc(ansi_path, newlen+1);
4393 ansi_path[len] = ';';
4394 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4399 ansi_path = win32_malloc(5+len+1);
4402 memcpy(ansi_path, "PATH=", 5);
4403 memcpy(ansi_path+5, ansi_dir, len+1);
4406 win32_free(ansi_dir);
4411 /* Update C RTL environ array. This will only have full effect if
4412 * perl_parse() is later called with `environ` as the `env` argument.
4413 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4415 * We do have to ansify() the PATH before Perl has been fully
4416 * initialized because S_find_script() uses the PATH when perl
4417 * is being invoked with the -S option. This happens before %ENV
4418 * is initialized in S_init_postdump_symbols().
4420 * XXX Is this a bug? Should S_find_script() use the environment
4421 * XXX passed in the `env` arg to parse_perl()?
4424 /* Keep system environment in sync because S_init_postdump_symbols()
4425 * will not call mg_set() if it initializes %ENV from `environ`.
4427 SetEnvironmentVariableA("PATH", ansi_path+5);
4428 /* We are intentionally leaking the ansi_path string here because
4429 * the Borland runtime library puts it directly into the environ
4430 * array. The Microsoft runtime library seems to make a copy,
4431 * but will leak the copy should it be replaced again later.
4432 * Since this code is only called once during PERL_SYS_INIT this
4433 * shouldn't really matter.
4436 win32_free(wide_path);
4440 Perl_win32_init(int *argcp, char ***argvp)
4442 #ifdef SET_INVALID_PARAMETER_HANDLER
4443 _invalid_parameter_handler oldHandler, newHandler;
4444 newHandler = my_invalid_parameter_handler;
4445 oldHandler = _set_invalid_parameter_handler(newHandler);
4446 _CrtSetReportMode(_CRT_ASSERT, 0);
4448 /* Disable floating point errors, Perl will trap the ones we
4449 * care about. VC++ RTL defaults to switching these off
4450 * already, but the Borland RTL doesn't. Since we don't
4451 * want to be at the vendor's whim on the default, we set
4452 * it explicitly here.
4454 #if !defined(__GNUC__)
4455 _control87(MCW_EM, MCW_EM);
4459 /* When the manifest resource requests Common-Controls v6 then
4460 * user32.dll no longer registers all the Windows classes used for
4461 * standard controls but leaves some of them to be registered by
4462 * comctl32.dll. InitCommonControls() doesn't do anything but calling
4463 * it makes sure comctl32.dll gets loaded into the process and registers
4464 * the standard control classes. Without this even normal Windows APIs
4465 * like MessageBox() can fail under some versions of Windows XP.
4467 InitCommonControls();
4469 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4470 GetVersionEx(&g_osver);
4476 Perl_win32_term(void)
4486 win32_get_child_IO(child_IO_table* ptbl)
4488 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4489 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4490 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4494 win32_signal(int sig, Sighandler_t subcode)
4497 if (sig < SIG_SIZE) {
4498 int save_errno = errno;
4499 Sighandler_t result = signal(sig, subcode);
4500 if (result == SIG_ERR) {
4501 result = w32_sighandler[sig];
4504 w32_sighandler[sig] = subcode;
4513 /* The PerlMessageWindowClass's WindowProc */
4515 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4517 return win32_process_message(hwnd, msg, wParam, lParam) ?
4518 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4521 /* The real message handler. Can be called with
4522 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4523 * that it processes */
4525 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4527 /* BEWARE. The context retrieved using dTHX; is the context of the
4528 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4529 * up to and including WM_CREATE. If it ever happens that you need the
4530 * 'child' context before this, then it needs to be passed into
4531 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4532 * from the lparam of CreateWindow(). It could then be stored/retrieved
4533 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4534 * the dTHX calls here. */
4535 /* XXX For now it is assumed that the overhead of the dTHX; for what
4536 * are relativley infrequent code-paths, is better than the added
4537 * complexity of getting the correct context passed into
4538 * win32_create_message_window() */
4543 case WM_USER_MESSAGE: {
4544 long child = find_pseudo_pid((int)wParam);
4547 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4554 case WM_USER_KILL: {
4556 /* We use WM_USER_KILL to fake kill() with other signals */
4557 int sig = (int)wParam;
4558 if (do_raise(aTHX_ sig))
4559 sig_terminate(aTHX_ sig);
4566 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4567 if (w32_timerid && w32_timerid==(UINT)wParam) {
4568 KillTimer(w32_message_hwnd, w32_timerid);
4571 /* Now fake a call to signal handler */
4572 if (do_raise(aTHX_ 14))
4573 sig_terminate(aTHX_ 14);
4585 /* Above or other stuff may have set a signal flag, and we may not have
4586 * been called from win32_async_check() (e.g. some other GUI's message
4587 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4588 * handler that die's, and the message loop that calls here is wrapped
4589 * in an eval, then you may well end up with orphaned windows - signals
4590 * are dispatched by win32_async_check() */
4596 win32_create_message_window_class(void)
4598 /* create the window class for "message only" windows */
4602 wc.lpfnWndProc = win32_message_window_proc;
4603 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4604 wc.lpszClassName = "PerlMessageWindowClass";
4606 /* second and subsequent calls will fail, but class
4607 * will already be registered */
4612 win32_create_message_window(void)
4614 win32_create_message_window_class();
4615 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4616 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4619 #ifdef HAVE_INTERP_INTERN
4622 win32_csighandler(int sig)
4625 dTHXa(PERL_GET_SIG_CONTEXT);
4626 Perl_warn(aTHX_ "Got signal %d",sig);
4631 #if defined(__MINGW32__) && defined(__cplusplus)
4632 #define CAST_HWND__(x) (HWND__*)(x)
4634 #define CAST_HWND__(x) x
4638 Perl_sys_intern_init(pTHX)
4642 w32_perlshell_tokens = NULL;
4643 w32_perlshell_vec = (char**)NULL;
4644 w32_perlshell_items = 0;
4645 w32_fdpid = newAV();
4646 Newx(w32_children, 1, child_tab);
4647 w32_num_children = 0;
4648 # ifdef USE_ITHREADS
4650 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4651 w32_num_pseudo_children = 0;
4654 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4656 for (i=0; i < SIG_SIZE; i++) {
4657 w32_sighandler[i] = SIG_DFL;
4659 # ifdef MULTIPLICITY
4660 if (my_perl == PL_curinterp) {
4664 /* Force C runtime signal stuff to set its console handler */
4665 signal(SIGINT,win32_csighandler);
4666 signal(SIGBREAK,win32_csighandler);
4668 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4669 * flag. This has the side-effect of disabling Ctrl-C events in all
4670 * processes in this group.
4671 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4672 * with a NULL handler.
4674 SetConsoleCtrlHandler(NULL,FALSE);
4676 /* Push our handler on top */
4677 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4682 Perl_sys_intern_clear(pTHX)
4684 Safefree(w32_perlshell_tokens);
4685 Safefree(w32_perlshell_vec);
4686 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4687 Safefree(w32_children);
4689 KillTimer(w32_message_hwnd, w32_timerid);
4692 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4693 DestroyWindow(w32_message_hwnd);
4694 # ifdef MULTIPLICITY
4695 if (my_perl == PL_curinterp) {
4699 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4701 # ifdef USE_ITHREADS
4702 Safefree(w32_pseudo_children);
4706 # ifdef USE_ITHREADS
4709 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4711 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4713 dst->perlshell_tokens = NULL;
4714 dst->perlshell_vec = (char**)NULL;
4715 dst->perlshell_items = 0;
4716 dst->fdpid = newAV();
4717 Newxz(dst->children, 1, child_tab);
4719 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4721 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
4722 dst->poll_count = 0;
4723 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4725 # endif /* USE_ITHREADS */
4726 #endif /* HAVE_INTERP_INTERN */