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
18 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20 # include <shellapi.h>
22 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
28 /* #include "config.h" */
30 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
39 #define PERL_NO_GET_CONTEXT
45 /* assert.h conflicts with #define of assert in perl.h */
52 #if defined(_MSC_VER) || defined(__MINGW32__)
53 #include <sys/utime.h>
58 /* Mingw32 defaults to globing command line
59 * So we turn it off like this:
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 /* Mingw32-1.1 is missing some prototypes */
66 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
73 #if defined(__BORLANDC__)
75 # define _utimbuf utimbuf
80 #define EXECF_SPAWN_NOWAIT 3
82 #if defined(PERL_IMPLICIT_SYS)
83 # undef win32_get_privlib
84 # define win32_get_privlib g_win32_get_privlib
85 # undef win32_get_sitelib
86 # define win32_get_sitelib g_win32_get_sitelib
87 # undef win32_get_vendorlib
88 # define win32_get_vendorlib g_win32_get_vendorlib
90 # define getlogin g_getlogin
93 static void get_shell(void);
94 static long tokenize(const char *str, char **dest, char ***destv);
95 static int do_spawn2(pTHX_ char *cmd, int exectype);
96 static BOOL has_shell_metachars(char *ptr);
97 static long filetime_to_clock(PFILETIME ft);
98 static BOOL filetime_from_time(PFILETIME ft, time_t t);
99 static char * get_emd_part(SV **leading, char *trailing, ...);
100 static void remove_dead_process(long deceased);
101 static long find_pid(int pid);
102 static char * qualified_path(const char *cmd);
103 static char * win32_get_xlib(const char *pl, const char *xlib,
104 const char *libname);
107 static void remove_dead_pseudo_process(long child);
108 static long find_pseudo_pid(int pid);
112 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113 char w32_module_name[MAX_PATH+1];
116 static DWORD w32_platform = (DWORD)-1;
118 #define ONE_K_BUFSIZE 1024
123 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
129 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
133 set_w32_module_name(void)
136 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
137 ? GetModuleHandle(NULL)
138 : w32_perldll_handle),
139 w32_module_name, sizeof(w32_module_name));
141 /* try to get full path to binary (which may be mangled when perl is
142 * run from a 16-bit app) */
143 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
144 (void)win32_longpath(w32_module_name);
145 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
147 /* normalize to forward slashes */
148 ptr = w32_module_name;
156 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
158 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
160 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
163 const char *subkey = "Software\\Perl";
167 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
168 if (retval == ERROR_SUCCESS) {
170 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
171 if (retval == ERROR_SUCCESS
172 && (type == REG_SZ || type == REG_EXPAND_SZ))
176 *svp = sv_2mortal(newSVpvn("",0));
177 SvGROW(*svp, datalen);
178 retval = RegQueryValueEx(handle, valuename, 0, NULL,
179 (PBYTE)SvPVX(*svp), &datalen);
180 if (retval == ERROR_SUCCESS) {
182 SvCUR_set(*svp,datalen-1);
190 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
192 get_regstr(const char *valuename, SV **svp)
194 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
196 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
200 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
202 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
206 char mod_name[MAX_PATH+1];
212 va_start(ap, trailing_path);
213 strip = va_arg(ap, char *);
215 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
216 baselen = strlen(base);
218 if (!*w32_module_name) {
219 set_w32_module_name();
221 strcpy(mod_name, w32_module_name);
222 ptr = strrchr(mod_name, '/');
223 while (ptr && strip) {
224 /* look for directories to skip back */
227 ptr = strrchr(mod_name, '/');
228 /* avoid stripping component if there is no slash,
229 * or it doesn't match ... */
230 if (!ptr || stricmp(ptr+1, strip) != 0) {
231 /* ... but not if component matches m|5\.$patchlevel.*| */
232 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
233 && strncmp(strip, base, baselen) == 0
234 && strncmp(ptr+1, base, baselen) == 0))
240 strip = va_arg(ap, char *);
248 strcpy(++ptr, trailing_path);
250 /* only add directory if it exists */
251 if (GetFileAttributes(mod_name) != (DWORD) -1) {
252 /* directory exists */
255 *prev_pathp = sv_2mortal(newSVpvn("",0));
256 sv_catpvn(*prev_pathp, ";", 1);
257 sv_catpv(*prev_pathp, mod_name);
258 return SvPVX(*prev_pathp);
265 win32_get_privlib(const char *pl)
268 char *stdlib = "lib";
269 char buffer[MAX_PATH+1];
272 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
273 sprintf(buffer, "%s-%s", stdlib, pl);
274 if (!get_regstr(buffer, &sv))
275 (void)get_regstr(stdlib, &sv);
277 /* $stdlib .= ";$EMD/../../lib" */
278 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
282 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
286 char pathstr[MAX_PATH+1];
290 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
291 sprintf(regstr, "%s-%s", xlib, pl);
292 (void)get_regstr(regstr, &sv1);
295 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
296 sprintf(pathstr, "%s/%s/lib", libname, pl);
297 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
299 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
300 (void)get_regstr(xlib, &sv2);
303 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
304 sprintf(pathstr, "%s/lib", libname);
305 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
314 sv_catpvn(sv1, ";", 1);
321 win32_get_sitelib(const char *pl)
323 return win32_get_xlib(pl, "sitelib", "site");
326 #ifndef PERL_VENDORLIB_NAME
327 # define PERL_VENDORLIB_NAME "vendor"
331 win32_get_vendorlib(const char *pl)
333 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
337 has_shell_metachars(char *ptr)
343 * Scan string looking for redirection (< or >) or pipe
344 * characters (|) that are not in a quoted string.
345 * Shell variable interpolation (%VAR%) can also happen inside strings.
377 #if !defined(PERL_IMPLICIT_SYS)
378 /* since the current process environment is being updated in util.c
379 * the library functions will get the correct environment
382 Perl_my_popen(pTHX_ char *cmd, char *mode)
385 #define fixcmd(x) { \
386 char *pspace = strchr((x),' '); \
389 while (p < pspace) { \
400 PERL_FLUSHALL_FOR_CHILD;
401 return win32_popen(cmd, mode);
405 Perl_my_pclose(pTHX_ PerlIO *fp)
407 return win32_pclose(fp);
411 DllExport unsigned long
414 static OSVERSIONINFO osver;
416 if (osver.dwPlatformId != w32_platform) {
417 memset(&osver, 0, sizeof(OSVERSIONINFO));
418 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
419 GetVersionEx(&osver);
420 w32_platform = osver.dwPlatformId;
422 return (unsigned long)w32_platform;
432 return -((int)w32_pseudo_id);
435 /* Windows 9x appears to always reports a pid for threads and processes
436 * that has the high bit set. So we treat the lower 31 bits as the
437 * "real" PID for Perl's purposes. */
438 if (IsWin95() && pid < 0)
443 /* Tokenize a string. Words are null-separated, and the list
444 * ends with a doubled null. Any character (except null and
445 * including backslash) may be escaped by preceding it with a
446 * backslash (the backslash will be stripped).
447 * Returns number of words in result buffer.
450 tokenize(const char *str, char **dest, char ***destv)
452 char *retstart = Nullch;
453 char **retvstart = 0;
457 int slen = strlen(str);
459 register char **retv;
460 New(1307, ret, slen+2, char);
461 New(1308, retv, (slen+3)/2, char*);
469 if (*ret == '\\' && *str)
471 else if (*ret == ' ') {
487 retvstart[items] = Nullch;
500 if (!w32_perlshell_tokens) {
501 /* we don't use COMSPEC here for two reasons:
502 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
503 * uncontrolled unportability of the ensuing scripts.
504 * 2. PERL5SHELL could be set to a shell that may not be fit for
505 * interactive use (which is what most programs look in COMSPEC
508 const char* defaultshell = (IsWinNT()
509 ? "cmd.exe /x/d/c" : "command.com /c");
510 const char *usershell = PerlEnv_getenv("PERL5SHELL");
511 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
512 &w32_perlshell_tokens,
518 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
530 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
532 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
537 while (++mark <= sp) {
538 if (*mark && (str = SvPV_nolen(*mark)))
545 status = win32_spawnvp(flag,
546 (const char*)(really ? SvPV_nolen(really) : argv[0]),
547 (const char* const*)argv);
549 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
550 /* possible shell-builtin, invoke with shell */
552 sh_items = w32_perlshell_items;
554 argv[index+sh_items] = argv[index];
555 while (--sh_items >= 0)
556 argv[sh_items] = w32_perlshell_vec[sh_items];
558 status = win32_spawnvp(flag,
559 (const char*)(really ? SvPV_nolen(really) : argv[0]),
560 (const char* const*)argv);
563 if (flag == P_NOWAIT) {
565 PL_statusvalue = -1; /* >16bits hint for pp_system() */
569 if (ckWARN(WARN_EXEC))
570 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
575 PL_statusvalue = status;
581 /* returns pointer to the next unquoted space or the end of the string */
583 find_next_space(const char *s)
585 bool in_quotes = FALSE;
587 /* ignore doubled backslashes, or backslash+quote */
588 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
591 /* keep track of when we're within quotes */
592 else if (*s == '"') {
594 in_quotes = !in_quotes;
596 /* break it up only at spaces that aren't in quotes */
597 else if (!in_quotes && isSPACE(*s))
606 do_spawn2(pTHX_ char *cmd, int exectype)
612 BOOL needToTry = TRUE;
615 /* Save an extra exec if possible. See if there are shell
616 * metacharacters in it */
617 if (!has_shell_metachars(cmd)) {
618 New(1301,argv, strlen(cmd) / 2 + 2, char*);
619 New(1302,cmd2, strlen(cmd) + 1, char);
622 for (s = cmd2; *s;) {
623 while (*s && isSPACE(*s))
627 s = find_next_space(s);
635 status = win32_spawnvp(P_WAIT, argv[0],
636 (const char* const*)argv);
638 case EXECF_SPAWN_NOWAIT:
639 status = win32_spawnvp(P_NOWAIT, argv[0],
640 (const char* const*)argv);
643 status = win32_execvp(argv[0], (const char* const*)argv);
646 if (status != -1 || errno == 0)
656 New(1306, argv, w32_perlshell_items + 2, char*);
657 while (++i < w32_perlshell_items)
658 argv[i] = w32_perlshell_vec[i];
663 status = win32_spawnvp(P_WAIT, argv[0],
664 (const char* const*)argv);
666 case EXECF_SPAWN_NOWAIT:
667 status = win32_spawnvp(P_NOWAIT, argv[0],
668 (const char* const*)argv);
671 status = win32_execvp(argv[0], (const char* const*)argv);
677 if (exectype == EXECF_SPAWN_NOWAIT) {
679 PL_statusvalue = -1; /* >16bits hint for pp_system() */
683 if (ckWARN(WARN_EXEC))
684 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
685 (exectype == EXECF_EXEC ? "exec" : "spawn"),
686 cmd, strerror(errno));
691 PL_statusvalue = status;
697 Perl_do_spawn(pTHX_ char *cmd)
699 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
703 Perl_do_spawn_nowait(pTHX_ char *cmd)
705 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
709 Perl_do_exec(pTHX_ char *cmd)
711 do_spawn2(aTHX_ cmd, EXECF_EXEC);
715 /* The idea here is to read all the directory names into a string table
716 * (separated by nulls) and when one of the other dir functions is called
717 * return the pointer to the current file name.
720 win32_opendir(char *filename)
726 char scanname[MAX_PATH+3];
728 WIN32_FIND_DATAA aFindData;
729 WIN32_FIND_DATAW wFindData;
731 char buffer[MAX_PATH*2];
732 WCHAR wbuffer[MAX_PATH+1];
735 len = strlen(filename);
739 /* check to see if filename is a directory */
740 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
743 /* Get us a DIR structure */
744 Newz(1303, dirp, 1, DIR);
746 /* Create the search pattern */
747 strcpy(scanname, filename);
749 /* bare drive name means look in cwd for drive */
750 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
751 scanname[len++] = '.';
752 scanname[len++] = '/';
754 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
755 scanname[len++] = '/';
757 scanname[len++] = '*';
758 scanname[len] = '\0';
760 /* do the FindFirstFile call */
762 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
763 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
766 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
769 if (fh == INVALID_HANDLE_VALUE) {
770 DWORD err = GetLastError();
771 /* FindFirstFile() fails on empty drives! */
773 case ERROR_FILE_NOT_FOUND:
775 case ERROR_NO_MORE_FILES:
776 case ERROR_PATH_NOT_FOUND:
779 case ERROR_NOT_ENOUGH_MEMORY:
790 /* now allocate the first part of the string table for
791 * the filenames that we find.
794 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
798 ptr = aFindData.cFileName;
805 New(1304, dirp->start, dirp->size, char);
806 strcpy(dirp->start, ptr);
808 dirp->end = dirp->curr = dirp->start;
814 /* Readdir just returns the current string pointer and bumps the
815 * string pointer to the nDllExport entry.
817 DllExport struct direct *
818 win32_readdir(DIR *dirp)
823 /* first set up the structure to return */
824 len = strlen(dirp->curr);
825 strcpy(dirp->dirstr.d_name, dirp->curr);
826 dirp->dirstr.d_namlen = len;
829 dirp->dirstr.d_ino = dirp->curr - dirp->start;
831 /* Now set up for the next call to readdir */
832 dirp->curr += len + 1;
833 if (dirp->curr >= dirp->end) {
837 WIN32_FIND_DATAW wFindData;
838 WIN32_FIND_DATAA aFindData;
839 char buffer[MAX_PATH*2];
841 /* finding the next file that matches the wildcard
842 * (which should be all of them in this directory!).
845 res = FindNextFileW(dirp->handle, &wFindData);
847 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
852 res = FindNextFileA(dirp->handle, &aFindData);
854 ptr = aFindData.cFileName;
857 long endpos = dirp->end - dirp->start;
858 long newsize = endpos + strlen(ptr) + 1;
859 /* bump the string table size by enough for the
860 * new name and its null terminator */
861 while (newsize > dirp->size) {
862 long curpos = dirp->curr - dirp->start;
864 Renew(dirp->start, dirp->size, char);
865 dirp->curr = dirp->start + curpos;
867 strcpy(dirp->start + endpos, ptr);
868 dirp->end = dirp->start + newsize;
874 return &(dirp->dirstr);
880 /* Telldir returns the current string pointer position */
882 win32_telldir(DIR *dirp)
884 return (dirp->curr - dirp->start);
888 /* Seekdir moves the string pointer to a previously saved position
889 * (returned by telldir).
892 win32_seekdir(DIR *dirp, long loc)
894 dirp->curr = dirp->start + loc;
897 /* Rewinddir resets the string pointer to the start */
899 win32_rewinddir(DIR *dirp)
901 dirp->curr = dirp->start;
904 /* free the memory allocated by opendir */
906 win32_closedir(DIR *dirp)
909 if (dirp->handle != INVALID_HANDLE_VALUE)
910 FindClose(dirp->handle);
911 Safefree(dirp->start);
924 * Just pretend that everyone is a superuser. NT will let us know if
925 * we don\'t really have permission to do something.
928 #define ROOT_UID ((uid_t)0)
929 #define ROOT_GID ((gid_t)0)
958 return (auid == ROOT_UID ? 0 : -1);
964 return (agid == ROOT_GID ? 0 : -1);
971 char *buf = w32_getlogin_buffer;
972 DWORD size = sizeof(w32_getlogin_buffer);
973 if (GetUserName(buf,&size))
979 chown(const char *path, uid_t owner, gid_t group)
986 * XXX this needs strengthening (for PerlIO)
989 int mkstemp(const char *path)
992 char buf[MAX_PATH+1];
996 if (i++ > 10) { /* give up */
1000 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1004 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1014 long child = w32_num_children;
1015 while (--child >= 0) {
1016 if ((int)w32_child_pids[child] == pid)
1023 remove_dead_process(long child)
1027 CloseHandle(w32_child_handles[child]);
1028 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1029 (w32_num_children-child-1), HANDLE);
1030 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1031 (w32_num_children-child-1), DWORD);
1038 find_pseudo_pid(int pid)
1041 long child = w32_num_pseudo_children;
1042 while (--child >= 0) {
1043 if ((int)w32_pseudo_child_pids[child] == pid)
1050 remove_dead_pseudo_process(long child)
1054 CloseHandle(w32_pseudo_child_handles[child]);
1055 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1056 (w32_num_pseudo_children-child-1), HANDLE);
1057 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1058 (w32_num_pseudo_children-child-1), DWORD);
1059 w32_num_pseudo_children--;
1065 win32_kill(int pid, int sig)
1073 /* it is a pseudo-forked child */
1074 child = find_pseudo_pid(-pid);
1076 hProcess = w32_pseudo_child_handles[child];
1079 /* "Does process exist?" use of kill */
1082 /* kill -9 style un-graceful exit */
1083 if (TerminateThread(hProcess, sig)) {
1084 remove_dead_pseudo_process(child);
1089 /* We fake signals to pseudo-processes using Win32
1090 * message queue. In Win9X the pids are negative already. */
1091 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1092 /* It might be us ... */
1099 else if (IsWin95()) {
1107 child = find_pid(pid);
1109 hProcess = w32_child_handles[child];
1112 /* "Does process exist?" use of kill */
1115 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1118 default: /* For now be backwards compatible with perl5.6 */
1120 if (TerminateProcess(hProcess, sig)) {
1121 remove_dead_process(child);
1130 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1131 (IsWin95() ? -pid : pid));
1135 /* "Does process exist?" use of kill */
1139 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1142 default: /* For now be backwards compatible with perl5.6 */
1144 if (TerminateProcess(hProcess, sig))
1149 CloseHandle(hProcess);
1159 win32_stat(const char *path, Stat_t *sbuf)
1162 char buffer[MAX_PATH+1];
1163 int l = strlen(path);
1165 WCHAR wbuffer[MAX_PATH+1];
1171 switch(path[l - 1]) {
1172 /* FindFirstFile() and stat() are buggy with a trailing
1173 * backslash, so change it to a forward slash :-( */
1175 strncpy(buffer, path, l-1);
1176 buffer[l - 1] = '/';
1180 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1182 if (l == 2 && isALPHA(path[0])) {
1183 buffer[0] = path[0];
1194 /* We *must* open & close the file once; otherwise file attribute changes */
1195 /* might not yet have propagated to "other" hard links of the same file. */
1196 /* This also gives us an opportunity to determine the number of links. */
1198 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1199 pwbuffer = PerlDir_mapW(wbuffer);
1200 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1203 path = PerlDir_mapA(path);
1205 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1207 if (handle != INVALID_HANDLE_VALUE) {
1208 BY_HANDLE_FILE_INFORMATION bhi;
1209 if (GetFileInformationByHandle(handle, &bhi))
1210 nlink = bhi.nNumberOfLinks;
1211 CloseHandle(handle);
1214 /* pwbuffer or path will be mapped correctly above */
1216 #if defined(WIN64) || defined(USE_LARGE_FILES)
1217 res = _wstati64(pwbuffer, sbuf);
1219 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1223 #if defined(WIN64) || defined(USE_LARGE_FILES)
1224 res = _stati64(path, sbuf);
1226 res = stat(path, sbuf);
1229 sbuf->st_nlink = nlink;
1232 /* CRT is buggy on sharenames, so make sure it really isn't.
1233 * XXX using GetFileAttributesEx() will enable us to set
1234 * sbuf->st_*time (but note that's not available on the
1235 * Windows of 1995) */
1238 r = GetFileAttributesW(pwbuffer);
1241 r = GetFileAttributesA(path);
1243 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1244 /* sbuf may still contain old garbage since stat() failed */
1245 Zero(sbuf, 1, Stat_t);
1246 sbuf->st_mode = S_IFDIR | S_IREAD;
1248 if (!(r & FILE_ATTRIBUTE_READONLY))
1249 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1254 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1255 && (path[2] == '\\' || path[2] == '/'))
1257 /* The drive can be inaccessible, some _stat()s are buggy */
1259 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1260 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1266 if (S_ISDIR(sbuf->st_mode))
1267 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1268 else if (S_ISREG(sbuf->st_mode)) {
1270 if (l >= 4 && path[l-4] == '.') {
1271 const char *e = path + l - 3;
1272 if (strnicmp(e,"exe",3)
1273 && strnicmp(e,"bat",3)
1274 && strnicmp(e,"com",3)
1275 && (IsWin95() || strnicmp(e,"cmd",3)))
1276 sbuf->st_mode &= ~S_IEXEC;
1278 sbuf->st_mode |= S_IEXEC;
1281 sbuf->st_mode &= ~S_IEXEC;
1282 /* Propagate permissions to _group_ and _others_ */
1283 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1284 sbuf->st_mode |= (perms>>3) | (perms>>6);
1291 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1292 #define SKIP_SLASHES(s) \
1294 while (*(s) && isSLASH(*(s))) \
1297 #define COPY_NONSLASHES(d,s) \
1299 while (*(s) && !isSLASH(*(s))) \
1303 /* Find the longname of a given path. path is destructively modified.
1304 * It should have space for at least MAX_PATH characters. */
1306 win32_longpath(char *path)
1308 WIN32_FIND_DATA fdata;
1310 char tmpbuf[MAX_PATH+1];
1311 char *tmpstart = tmpbuf;
1318 if (isALPHA(path[0]) && path[1] == ':') {
1320 *tmpstart++ = path[0];
1324 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1326 *tmpstart++ = path[0];
1327 *tmpstart++ = path[1];
1328 SKIP_SLASHES(start);
1329 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1331 *tmpstart++ = *start++;
1332 SKIP_SLASHES(start);
1333 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1338 /* copy initial slash, if any */
1339 if (isSLASH(*start)) {
1340 *tmpstart++ = *start++;
1342 SKIP_SLASHES(start);
1345 /* FindFirstFile() expands "." and "..", so we need to pass
1346 * those through unmolested */
1348 && (!start[1] || isSLASH(start[1])
1349 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1351 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1356 /* if this is the end, bust outta here */
1360 /* now we're at a non-slash; walk up to next slash */
1361 while (*start && !isSLASH(*start))
1364 /* stop and find full name of component */
1367 fhand = FindFirstFile(path,&fdata);
1369 if (fhand != INVALID_HANDLE_VALUE) {
1370 STRLEN len = strlen(fdata.cFileName);
1371 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1372 strcpy(tmpstart, fdata.cFileName);
1383 /* failed a step, just return without side effects */
1384 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1389 strcpy(path,tmpbuf);
1394 win32_getenv(const char *name)
1397 WCHAR wBuffer[MAX_PATH+1];
1399 SV *curitem = Nullsv;
1402 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1403 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1406 needlen = GetEnvironmentVariableA(name,NULL,0);
1408 curitem = sv_2mortal(newSVpvn("", 0));
1412 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1413 needlen = GetEnvironmentVariableW(wBuffer,
1414 (WCHAR*)SvPVX(curitem),
1416 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1417 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1418 acuritem = sv_2mortal(newSVsv(curitem));
1419 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1423 SvGROW(curitem, needlen+1);
1424 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1426 } while (needlen >= SvLEN(curitem));
1427 SvCUR_set(curitem, needlen);
1431 /* allow any environment variables that begin with 'PERL'
1432 to be stored in the registry */
1433 if (strncmp(name, "PERL", 4) == 0)
1434 (void)get_regstr(name, &curitem);
1436 if (curitem && SvCUR(curitem))
1437 return SvPVX(curitem);
1443 win32_putenv(const char *name)
1450 int length, relval = -1;
1454 length = strlen(name)+1;
1455 New(1309,wCuritem,length,WCHAR);
1456 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1457 wVal = wcschr(wCuritem, '=');
1460 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1466 New(1309,curitem,strlen(name)+1,char);
1467 strcpy(curitem, name);
1468 val = strchr(curitem, '=');
1470 /* The sane way to deal with the environment.
1471 * Has these advantages over putenv() & co.:
1472 * * enables us to store a truly empty value in the
1473 * environment (like in UNIX).
1474 * * we don't have to deal with RTL globals, bugs and leaks.
1476 * Why you may want to enable USE_WIN32_RTL_ENV:
1477 * * environ[] and RTL functions will not reflect changes,
1478 * which might be an issue if extensions want to access
1479 * the env. via RTL. This cuts both ways, since RTL will
1480 * not see changes made by extensions that call the Win32
1481 * functions directly, either.
1485 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1495 filetime_to_clock(PFILETIME ft)
1497 __int64 qw = ft->dwHighDateTime;
1499 qw |= ft->dwLowDateTime;
1500 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1505 win32_times(struct tms *timebuf)
1510 clock_t process_time_so_far = clock();
1511 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1513 timebuf->tms_utime = filetime_to_clock(&user);
1514 timebuf->tms_stime = filetime_to_clock(&kernel);
1515 timebuf->tms_cutime = 0;
1516 timebuf->tms_cstime = 0;
1518 /* That failed - e.g. Win95 fallback to clock() */
1519 timebuf->tms_utime = process_time_so_far;
1520 timebuf->tms_stime = 0;
1521 timebuf->tms_cutime = 0;
1522 timebuf->tms_cstime = 0;
1524 return process_time_so_far;
1527 /* fix utime() so it works on directories in NT */
1529 filetime_from_time(PFILETIME pFileTime, time_t Time)
1531 struct tm *pTM = localtime(&Time);
1532 SYSTEMTIME SystemTime;
1538 SystemTime.wYear = pTM->tm_year + 1900;
1539 SystemTime.wMonth = pTM->tm_mon + 1;
1540 SystemTime.wDay = pTM->tm_mday;
1541 SystemTime.wHour = pTM->tm_hour;
1542 SystemTime.wMinute = pTM->tm_min;
1543 SystemTime.wSecond = pTM->tm_sec;
1544 SystemTime.wMilliseconds = 0;
1546 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1547 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1551 win32_unlink(const char *filename)
1558 WCHAR wBuffer[MAX_PATH+1];
1561 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1562 pwBuffer = PerlDir_mapW(wBuffer);
1563 attrs = GetFileAttributesW(pwBuffer);
1564 if (attrs == 0xFFFFFFFF)
1566 if (attrs & FILE_ATTRIBUTE_READONLY) {
1567 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1568 ret = _wunlink(pwBuffer);
1570 (void)SetFileAttributesW(pwBuffer, attrs);
1573 ret = _wunlink(pwBuffer);
1576 filename = PerlDir_mapA(filename);
1577 attrs = GetFileAttributesA(filename);
1578 if (attrs == 0xFFFFFFFF)
1580 if (attrs & FILE_ATTRIBUTE_READONLY) {
1581 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1582 ret = unlink(filename);
1584 (void)SetFileAttributesA(filename, attrs);
1587 ret = unlink(filename);
1596 win32_utime(const char *filename, struct utimbuf *times)
1603 struct utimbuf TimeBuffer;
1604 WCHAR wbuffer[MAX_PATH+1];
1609 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1610 pwbuffer = PerlDir_mapW(wbuffer);
1611 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1614 filename = PerlDir_mapA(filename);
1615 rc = utime(filename, times);
1617 /* EACCES: path specifies directory or readonly file */
1618 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1621 if (times == NULL) {
1622 times = &TimeBuffer;
1623 time(×->actime);
1624 times->modtime = times->actime;
1627 /* This will (and should) still fail on readonly files */
1629 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1630 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1631 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1634 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1635 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1636 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1638 if (handle == INVALID_HANDLE_VALUE)
1641 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1642 filetime_from_time(&ftAccess, times->actime) &&
1643 filetime_from_time(&ftWrite, times->modtime) &&
1644 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1649 CloseHandle(handle);
1654 unsigned __int64 ft_i64;
1659 #define Const64(x) x##LL
1661 #define Const64(x) x##i64
1663 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1664 #define EPOCH_BIAS Const64(116444736000000000)
1666 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1667 * and appears to be unsupported even by glibc) */
1669 win32_gettimeofday(struct timeval *tp, void *not_used)
1673 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1674 GetSystemTimeAsFileTime(&ft.ft_val);
1676 /* seconds since epoch */
1677 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1679 /* microseconds remaining */
1680 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1686 win32_uname(struct utsname *name)
1688 struct hostent *hep;
1689 STRLEN nodemax = sizeof(name->nodename)-1;
1690 OSVERSIONINFO osver;
1692 memset(&osver, 0, sizeof(OSVERSIONINFO));
1693 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1694 if (GetVersionEx(&osver)) {
1696 switch (osver.dwPlatformId) {
1697 case VER_PLATFORM_WIN32_WINDOWS:
1698 strcpy(name->sysname, "Windows");
1700 case VER_PLATFORM_WIN32_NT:
1701 strcpy(name->sysname, "Windows NT");
1703 case VER_PLATFORM_WIN32s:
1704 strcpy(name->sysname, "Win32s");
1707 strcpy(name->sysname, "Win32 Unknown");
1712 sprintf(name->release, "%d.%d",
1713 osver.dwMajorVersion, osver.dwMinorVersion);
1716 sprintf(name->version, "Build %d",
1717 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1718 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1719 if (osver.szCSDVersion[0]) {
1720 char *buf = name->version + strlen(name->version);
1721 sprintf(buf, " (%s)", osver.szCSDVersion);
1725 *name->sysname = '\0';
1726 *name->version = '\0';
1727 *name->release = '\0';
1731 hep = win32_gethostbyname("localhost");
1733 STRLEN len = strlen(hep->h_name);
1734 if (len <= nodemax) {
1735 strcpy(name->nodename, hep->h_name);
1738 strncpy(name->nodename, hep->h_name, nodemax);
1739 name->nodename[nodemax] = '\0';
1744 if (!GetComputerName(name->nodename, &sz))
1745 *name->nodename = '\0';
1748 /* machine (architecture) */
1753 GetSystemInfo(&info);
1755 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1756 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1757 procarch = info.u.s.wProcessorArchitecture;
1759 procarch = info.wProcessorArchitecture;
1762 case PROCESSOR_ARCHITECTURE_INTEL:
1763 arch = "x86"; break;
1764 case PROCESSOR_ARCHITECTURE_MIPS:
1765 arch = "mips"; break;
1766 case PROCESSOR_ARCHITECTURE_ALPHA:
1767 arch = "alpha"; break;
1768 case PROCESSOR_ARCHITECTURE_PPC:
1769 arch = "ppc"; break;
1770 #ifdef PROCESSOR_ARCHITECTURE_SHX
1771 case PROCESSOR_ARCHITECTURE_SHX:
1772 arch = "shx"; break;
1774 #ifdef PROCESSOR_ARCHITECTURE_ARM
1775 case PROCESSOR_ARCHITECTURE_ARM:
1776 arch = "arm"; break;
1778 #ifdef PROCESSOR_ARCHITECTURE_IA64
1779 case PROCESSOR_ARCHITECTURE_IA64:
1780 arch = "ia64"; break;
1782 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1783 case PROCESSOR_ARCHITECTURE_ALPHA64:
1784 arch = "alpha64"; break;
1786 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1787 case PROCESSOR_ARCHITECTURE_MSIL:
1788 arch = "msil"; break;
1790 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1791 case PROCESSOR_ARCHITECTURE_AMD64:
1792 arch = "amd64"; break;
1794 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1795 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1796 arch = "ia32-64"; break;
1798 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1799 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1800 arch = "unknown"; break;
1803 sprintf(name->machine, "unknown(0x%x)", procarch);
1804 arch = name->machine;
1807 if (name->machine != arch)
1808 strcpy(name->machine, arch);
1813 /* Timing related stuff */
1816 do_raise(pTHX_ int sig)
1818 if (sig < SIG_SIZE) {
1819 Sighandler_t handler = w32_sighandler[sig];
1820 if (handler == SIG_IGN) {
1823 else if (handler != SIG_DFL) {
1828 /* Choose correct default behaviour */
1844 /* Tell caller to exit thread/process as approriate */
1849 sig_terminate(pTHX_ int sig)
1851 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1852 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1859 win32_async_check(pTHX)
1863 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1864 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1866 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1868 switch(msg.message) {
1871 /* Perhaps some other messages could map to signals ? ... */
1874 /* Treat WM_QUIT like SIGHUP? */
1880 /* We use WM_USER to fake kill() with other signals */
1884 if (do_raise(aTHX_ sig)) {
1885 sig_terminate(aTHX_ sig);
1891 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1892 if (w32_timerid && w32_timerid==msg.wParam) {
1893 KillTimer(NULL,w32_timerid);
1898 /* Now fake a call to signal handler */
1899 if (do_raise(aTHX_ 14)) {
1900 sig_terminate(aTHX_ 14);
1905 /* Otherwise do normal Win32 thing - in case it is useful */
1908 TranslateMessage(&msg);
1909 DispatchMessage(&msg);
1916 /* Above or other stuff may have set a signal flag */
1917 if (PL_sig_pending) {
1923 /* This function will not return until the timeout has elapsed, or until
1924 * one of the handles is ready. */
1926 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1928 /* We may need several goes at this - so compute when we stop */
1930 if (timeout != INFINITE) {
1931 ticks = GetTickCount();
1935 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1938 if (result == WAIT_TIMEOUT) {
1939 /* Ran out of time - explicit return of zero to avoid -ve if we
1940 have scheduling issues
1944 if (timeout != INFINITE) {
1945 ticks = GetTickCount();
1947 if (result == WAIT_OBJECT_0 + count) {
1948 /* Message has arrived - check it */
1949 (void)win32_async_check(aTHX);
1952 /* Not timeout or message - one of handles is ready */
1956 /* compute time left to wait */
1957 ticks = timeout - ticks;
1958 /* If we are past the end say zero */
1959 return (ticks > 0) ? ticks : 0;
1963 win32_internal_wait(int *status, DWORD timeout)
1965 /* XXX this wait emulation only knows about processes
1966 * spawned via win32_spawnvp(P_NOWAIT, ...).
1970 DWORD exitcode, waitcode;
1973 if (w32_num_pseudo_children) {
1974 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1975 timeout, &waitcode);
1976 /* Time out here if there are no other children to wait for. */
1977 if (waitcode == WAIT_TIMEOUT) {
1978 if (!w32_num_children) {
1982 else if (waitcode != WAIT_FAILED) {
1983 if (waitcode >= WAIT_ABANDONED_0
1984 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1985 i = waitcode - WAIT_ABANDONED_0;
1987 i = waitcode - WAIT_OBJECT_0;
1988 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1989 *status = (int)((exitcode & 0xff) << 8);
1990 retval = (int)w32_pseudo_child_pids[i];
1991 remove_dead_pseudo_process(i);
1998 if (!w32_num_children) {
2003 /* if a child exists, wait for it to die */
2004 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2005 if (waitcode == WAIT_TIMEOUT) {
2008 if (waitcode != WAIT_FAILED) {
2009 if (waitcode >= WAIT_ABANDONED_0
2010 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2011 i = waitcode - WAIT_ABANDONED_0;
2013 i = waitcode - WAIT_OBJECT_0;
2014 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2015 *status = (int)((exitcode & 0xff) << 8);
2016 retval = (int)w32_child_pids[i];
2017 remove_dead_process(i);
2022 errno = GetLastError();
2027 win32_waitpid(int pid, int *status, int flags)
2030 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2033 if (pid == -1) /* XXX threadid == 1 ? */
2034 return win32_internal_wait(status, timeout);
2037 child = find_pseudo_pid(-pid);
2039 HANDLE hThread = w32_pseudo_child_handles[child];
2041 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2042 if (waitcode == WAIT_TIMEOUT) {
2045 else if (waitcode == WAIT_OBJECT_0) {
2046 if (GetExitCodeThread(hThread, &waitcode)) {
2047 *status = (int)((waitcode & 0xff) << 8);
2048 retval = (int)w32_pseudo_child_pids[child];
2049 remove_dead_pseudo_process(child);
2056 else if (IsWin95()) {
2065 child = find_pid(pid);
2067 hProcess = w32_child_handles[child];
2068 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2069 if (waitcode == WAIT_TIMEOUT) {
2072 else if (waitcode == WAIT_OBJECT_0) {
2073 if (GetExitCodeProcess(hProcess, &waitcode)) {
2074 *status = (int)((waitcode & 0xff) << 8);
2075 retval = (int)w32_child_pids[child];
2076 remove_dead_process(child);
2085 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2086 (IsWin95() ? -pid : pid));
2088 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2089 if (waitcode == WAIT_TIMEOUT) {
2090 CloseHandle(hProcess);
2093 else if (waitcode == WAIT_OBJECT_0) {
2094 if (GetExitCodeProcess(hProcess, &waitcode)) {
2095 *status = (int)((waitcode & 0xff) << 8);
2096 CloseHandle(hProcess);
2100 CloseHandle(hProcess);
2106 return retval >= 0 ? pid : retval;
2110 win32_wait(int *status)
2112 return win32_internal_wait(status, INFINITE);
2115 DllExport unsigned int
2116 win32_sleep(unsigned int t)
2119 /* Win32 times are in ms so *1000 in and /1000 out */
2120 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2123 DllExport unsigned int
2124 win32_alarm(unsigned int sec)
2127 * the 'obvious' implentation is SetTimer() with a callback
2128 * which does whatever receiving SIGALRM would do
2129 * we cannot use SIGALRM even via raise() as it is not
2130 * one of the supported codes in <signal.h>
2134 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2138 KillTimer(NULL,w32_timerid);
2145 #ifdef HAVE_DES_FCRYPT
2146 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2150 win32_crypt(const char *txt, const char *salt)
2153 #ifdef HAVE_DES_FCRYPT
2154 return des_fcrypt(txt, salt, w32_crypt_buffer);
2156 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2161 #ifdef USE_FIXED_OSFHANDLE
2163 #define FOPEN 0x01 /* file handle open */
2164 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2165 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2166 #define FDEV 0x40 /* file handle refers to device */
2167 #define FTEXT 0x80 /* file handle is in text mode */
2170 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2173 * This function allocates a free C Runtime file handle and associates
2174 * it with the Win32 HANDLE specified by the first parameter. This is a
2175 * temperary fix for WIN95's brain damage GetFileType() error on socket
2176 * we just bypass that call for socket
2178 * This works with MSVC++ 4.0+ or GCC/Mingw32
2181 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2182 * int flags - flags to associate with C Runtime file handle.
2185 * returns index of entry in fh, if successful
2186 * return -1, if no free entry is found
2190 *******************************************************************************/
2193 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2194 * this lets sockets work on Win9X with GCC and should fix the problems
2199 /* create an ioinfo entry, kill its handle, and steal the entry */
2204 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2205 int fh = _open_osfhandle((intptr_t)hF, 0);
2209 EnterCriticalSection(&(_pioinfo(fh)->lock));
2214 my_open_osfhandle(intptr_t osfhandle, int flags)
2217 char fileflags; /* _osfile flags */
2219 /* copy relevant flags from second parameter */
2222 if (flags & O_APPEND)
2223 fileflags |= FAPPEND;
2228 if (flags & O_NOINHERIT)
2229 fileflags |= FNOINHERIT;
2231 /* attempt to allocate a C Runtime file handle */
2232 if ((fh = _alloc_osfhnd()) == -1) {
2233 errno = EMFILE; /* too many open files */
2234 _doserrno = 0L; /* not an OS error */
2235 return -1; /* return error to caller */
2238 /* the file is open. now, set the info in _osfhnd array */
2239 _set_osfhnd(fh, osfhandle);
2241 fileflags |= FOPEN; /* mark as open */
2243 _osfile(fh) = fileflags; /* set osfile entry */
2244 LeaveCriticalSection(&_pioinfo(fh)->lock);
2246 return fh; /* return handle */
2249 #endif /* USE_FIXED_OSFHANDLE */
2251 /* simulate flock by locking a range on the file */
2253 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2254 #define LK_LEN 0xffff0000
2257 win32_flock(int fd, int oper)
2265 Perl_croak_nocontext("flock() unimplemented on this platform");
2268 fh = (HANDLE)_get_osfhandle(fd);
2269 memset(&o, 0, sizeof(o));
2272 case LOCK_SH: /* shared lock */
2273 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2275 case LOCK_EX: /* exclusive lock */
2276 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2278 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2279 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2281 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2282 LK_ERR(LockFileEx(fh,
2283 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2284 0, LK_LEN, 0, &o),i);
2286 case LOCK_UN: /* unlock lock */
2287 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2289 default: /* unknown */
2300 * redirected io subsystem for all XS modules
2313 return (&(_environ));
2316 /* the rest are the remapped stdio routines */
2336 win32_ferror(FILE *fp)
2338 return (ferror(fp));
2343 win32_feof(FILE *fp)
2349 * Since the errors returned by the socket error function
2350 * WSAGetLastError() are not known by the library routine strerror
2351 * we have to roll our own.
2355 win32_strerror(int e)
2357 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2358 extern int sys_nerr;
2362 if (e < 0 || e > sys_nerr) {
2367 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2368 w32_strerror_buffer,
2369 sizeof(w32_strerror_buffer), NULL) == 0)
2370 strcpy(w32_strerror_buffer, "Unknown Error");
2372 return w32_strerror_buffer;
2378 win32_str_os_error(void *sv, DWORD dwErr)
2382 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2383 |FORMAT_MESSAGE_IGNORE_INSERTS
2384 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2385 dwErr, 0, (char *)&sMsg, 1, NULL);
2386 /* strip trailing whitespace and period */
2389 --dwLen; /* dwLen doesn't include trailing null */
2390 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2391 if ('.' != sMsg[dwLen])
2396 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2398 dwLen = sprintf(sMsg,
2399 "Unknown error #0x%lX (lookup 0x%lX)",
2400 dwErr, GetLastError());
2404 sv_setpvn((SV*)sv, sMsg, dwLen);
2410 win32_fprintf(FILE *fp, const char *format, ...)
2413 va_start(marker, format); /* Initialize variable arguments. */
2415 return (vfprintf(fp, format, marker));
2419 win32_printf(const char *format, ...)
2422 va_start(marker, format); /* Initialize variable arguments. */
2424 return (vprintf(format, marker));
2428 win32_vfprintf(FILE *fp, const char *format, va_list args)
2430 return (vfprintf(fp, format, args));
2434 win32_vprintf(const char *format, va_list args)
2436 return (vprintf(format, args));
2440 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2442 return fread(buf, size, count, fp);
2446 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2448 return fwrite(buf, size, count, fp);
2451 #define MODE_SIZE 10
2454 win32_fopen(const char *filename, const char *mode)
2457 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2463 if (stricmp(filename, "/dev/null")==0)
2467 A2WHELPER(mode, wMode, sizeof(wMode));
2468 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2469 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2472 f = fopen(PerlDir_mapA(filename), mode);
2473 /* avoid buffering headaches for child processes */
2474 if (f && *mode == 'a')
2475 win32_fseek(f, 0, SEEK_END);
2479 #ifndef USE_SOCKETS_AS_HANDLES
2481 #define fdopen my_fdopen
2485 win32_fdopen(int handle, const char *mode)
2488 WCHAR wMode[MODE_SIZE];
2491 A2WHELPER(mode, wMode, sizeof(wMode));
2492 f = _wfdopen(handle, wMode);
2495 f = fdopen(handle, (char *) mode);
2496 /* avoid buffering headaches for child processes */
2497 if (f && *mode == 'a')
2498 win32_fseek(f, 0, SEEK_END);
2503 win32_freopen(const char *path, const char *mode, FILE *stream)
2506 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2507 if (stricmp(path, "/dev/null")==0)
2511 A2WHELPER(mode, wMode, sizeof(wMode));
2512 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2513 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2515 return freopen(PerlDir_mapA(path), mode, stream);
2519 win32_fclose(FILE *pf)
2521 return my_fclose(pf); /* defined in win32sck.c */
2525 win32_fputs(const char *s,FILE *pf)
2527 return fputs(s, pf);
2531 win32_fputc(int c,FILE *pf)
2537 win32_ungetc(int c,FILE *pf)
2539 return ungetc(c,pf);
2543 win32_getc(FILE *pf)
2549 win32_fileno(FILE *pf)
2555 win32_clearerr(FILE *pf)
2562 win32_fflush(FILE *pf)
2568 win32_ftell(FILE *pf)
2570 #if defined(WIN64) || defined(USE_LARGE_FILES)
2572 if (fgetpos(pf, &pos))
2581 win32_fseek(FILE *pf, Off_t offset,int origin)
2583 #if defined(WIN64) || defined(USE_LARGE_FILES)
2587 if (fgetpos(pf, &pos))
2592 fseek(pf, 0, SEEK_END);
2593 pos = _telli64(fileno(pf));
2602 return fsetpos(pf, &offset);
2604 return fseek(pf, offset, origin);
2609 win32_fgetpos(FILE *pf,fpos_t *p)
2611 return fgetpos(pf, p);
2615 win32_fsetpos(FILE *pf,const fpos_t *p)
2617 return fsetpos(pf, p);
2621 win32_rewind(FILE *pf)
2631 char prefix[MAX_PATH+1];
2632 char filename[MAX_PATH+1];
2633 DWORD len = GetTempPath(MAX_PATH, prefix);
2634 if (len && len < MAX_PATH) {
2635 if (GetTempFileName(prefix, "plx", 0, filename)) {
2636 HANDLE fh = CreateFile(filename,
2637 DELETE | GENERIC_READ | GENERIC_WRITE,
2641 FILE_ATTRIBUTE_NORMAL
2642 | FILE_FLAG_DELETE_ON_CLOSE,
2644 if (fh != INVALID_HANDLE_VALUE) {
2645 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2647 #if defined(__BORLANDC__)
2648 setmode(fd,O_BINARY);
2650 DEBUG_p(PerlIO_printf(Perl_debug_log,
2651 "Created tmpfile=%s\n",filename));
2663 int fd = win32_tmpfd();
2665 return win32_fdopen(fd, "w+b");
2677 win32_fstat(int fd, Stat_t *sbufptr)
2680 /* A file designated by filehandle is not shown as accessible
2681 * for write operations, probably because it is opened for reading.
2684 int rc = fstat(fd,sbufptr);
2685 BY_HANDLE_FILE_INFORMATION bhfi;
2686 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2687 sbufptr->st_mode &= 0xFE00;
2688 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2689 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2691 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2692 + ((S_IREAD|S_IWRITE) >> 6));
2696 return my_fstat(fd,sbufptr);
2701 win32_pipe(int *pfd, unsigned int size, int mode)
2703 return _pipe(pfd, size, mode);
2707 win32_popenlist(const char *mode, IV narg, SV **args)
2710 Perl_croak(aTHX_ "List form of pipe open not implemented");
2715 * a popen() clone that respects PERL5SHELL
2717 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2721 win32_popen(const char *command, const char *mode)
2723 #ifdef USE_RTL_POPEN
2724 return _popen(command, mode);
2736 /* establish which ends read and write */
2737 if (strchr(mode,'w')) {
2738 stdfd = 0; /* stdin */
2741 nhandle = STD_INPUT_HANDLE;
2743 else if (strchr(mode,'r')) {
2744 stdfd = 1; /* stdout */
2747 nhandle = STD_OUTPUT_HANDLE;
2752 /* set the correct mode */
2753 if (strchr(mode,'b'))
2755 else if (strchr(mode,'t'))
2758 ourmode = _fmode & (O_TEXT | O_BINARY);
2760 /* the child doesn't inherit handles */
2761 ourmode |= O_NOINHERIT;
2763 if (win32_pipe(p, 512, ourmode) == -1)
2766 /* save current stdfd */
2767 if ((oldfd = win32_dup(stdfd)) == -1)
2770 /* save the old std handle (this needs to happen before the
2771 * dup2(), since that might call SetStdHandle() too) */
2774 old_h = GetStdHandle(nhandle);
2776 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2777 /* stdfd will be inherited by the child */
2778 if (win32_dup2(p[child], stdfd) == -1)
2781 /* close the child end in parent */
2782 win32_close(p[child]);
2784 /* set the new std handle (in case dup2() above didn't) */
2785 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2787 /* start the child */
2790 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2793 /* revert stdfd to whatever it was before */
2794 if (win32_dup2(oldfd, stdfd) == -1)
2797 /* restore the old std handle (this needs to happen after the
2798 * dup2(), since that might call SetStdHandle() too */
2800 SetStdHandle(nhandle, old_h);
2805 /* close saved handle */
2809 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2812 /* set process id so that it can be returned by perl's open() */
2813 PL_forkprocess = childpid;
2816 /* we have an fd, return a file stream */
2817 return (PerlIO_fdopen(p[parent], (char *)mode));
2820 /* we don't need to check for errors here */
2824 SetStdHandle(nhandle, old_h);
2829 win32_dup2(oldfd, stdfd);
2834 #endif /* USE_RTL_POPEN */
2842 win32_pclose(PerlIO *pf)
2844 #ifdef USE_RTL_POPEN
2848 int childpid, status;
2852 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2855 childpid = SvIVX(sv);
2872 if (win32_waitpid(childpid, &status, 0) == -1)
2877 #endif /* USE_RTL_POPEN */
2883 LPCWSTR lpExistingFileName,
2884 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2887 WCHAR wFullName[MAX_PATH+1];
2888 LPVOID lpContext = NULL;
2889 WIN32_STREAM_ID StreamId;
2890 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2895 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2896 BOOL, BOOL, LPVOID*) =
2897 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2898 BOOL, BOOL, LPVOID*))
2899 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2900 if (pfnBackupWrite == NULL)
2903 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2906 dwLen = (dwLen+1)*sizeof(WCHAR);
2908 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2909 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2910 NULL, OPEN_EXISTING, 0, NULL);
2911 if (handle == INVALID_HANDLE_VALUE)
2914 StreamId.dwStreamId = BACKUP_LINK;
2915 StreamId.dwStreamAttributes = 0;
2916 StreamId.dwStreamNameSize = 0;
2917 #if defined(__BORLANDC__) \
2918 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2919 StreamId.Size.u.HighPart = 0;
2920 StreamId.Size.u.LowPart = dwLen;
2922 StreamId.Size.HighPart = 0;
2923 StreamId.Size.LowPart = dwLen;
2926 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2927 FALSE, FALSE, &lpContext);
2929 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2930 FALSE, FALSE, &lpContext);
2931 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2934 CloseHandle(handle);
2939 win32_link(const char *oldname, const char *newname)
2942 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2943 WCHAR wOldName[MAX_PATH+1];
2944 WCHAR wNewName[MAX_PATH+1];
2947 Perl_croak(aTHX_ PL_no_func, "link");
2949 pfnCreateHardLinkW =
2950 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2951 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2952 if (pfnCreateHardLinkW == NULL)
2953 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2955 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2956 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2957 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2958 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2962 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2967 win32_rename(const char *oname, const char *newname)
2969 WCHAR wOldName[MAX_PATH+1];
2970 WCHAR wNewName[MAX_PATH+1];
2971 char szOldName[MAX_PATH+1];
2972 char szNewName[MAX_PATH+1];
2976 /* XXX despite what the documentation says about MoveFileEx(),
2977 * it doesn't work under Windows95!
2980 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2982 A2WHELPER(oname, wOldName, sizeof(wOldName));
2983 A2WHELPER(newname, wNewName, sizeof(wNewName));
2984 if (wcsicmp(wNewName, wOldName))
2985 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2986 wcscpy(wOldName, PerlDir_mapW(wOldName));
2987 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2990 if (stricmp(newname, oname))
2991 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2992 strcpy(szOldName, PerlDir_mapA(oname));
2993 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2996 DWORD err = GetLastError();
2998 case ERROR_BAD_NET_NAME:
2999 case ERROR_BAD_NETPATH:
3000 case ERROR_BAD_PATHNAME:
3001 case ERROR_FILE_NOT_FOUND:
3002 case ERROR_FILENAME_EXCED_RANGE:
3003 case ERROR_INVALID_DRIVE:
3004 case ERROR_NO_MORE_FILES:
3005 case ERROR_PATH_NOT_FOUND:
3018 char szTmpName[MAX_PATH+1];
3019 char dname[MAX_PATH+1];
3020 char *endname = Nullch;
3022 DWORD from_attr, to_attr;
3024 strcpy(szOldName, PerlDir_mapA(oname));
3025 strcpy(szNewName, PerlDir_mapA(newname));
3027 /* if oname doesn't exist, do nothing */
3028 from_attr = GetFileAttributes(szOldName);
3029 if (from_attr == 0xFFFFFFFF) {
3034 /* if newname exists, rename it to a temporary name so that we
3035 * don't delete it in case oname happens to be the same file
3036 * (but perhaps accessed via a different path)
3038 to_attr = GetFileAttributes(szNewName);
3039 if (to_attr != 0xFFFFFFFF) {
3040 /* if newname is a directory, we fail
3041 * XXX could overcome this with yet more convoluted logic */
3042 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3046 tmplen = strlen(szNewName);
3047 strcpy(szTmpName,szNewName);
3048 endname = szTmpName+tmplen;
3049 for (; endname > szTmpName ; --endname) {
3050 if (*endname == '/' || *endname == '\\') {
3055 if (endname > szTmpName)
3056 endname = strcpy(dname,szTmpName);
3060 /* get a temporary filename in same directory
3061 * XXX is this really the best we can do? */
3062 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3066 DeleteFile(szTmpName);
3068 retval = rename(szNewName, szTmpName);
3075 /* rename oname to newname */
3076 retval = rename(szOldName, szNewName);
3078 /* if we created a temporary file before ... */
3079 if (endname != Nullch) {
3080 /* ...and rename succeeded, delete temporary file/directory */
3082 DeleteFile(szTmpName);
3083 /* else restore it to what it was */
3085 (void)rename(szTmpName, szNewName);
3092 win32_setmode(int fd, int mode)
3094 return setmode(fd, mode);
3098 win32_chsize(int fd, Off_t size)
3100 #if defined(WIN64) || defined(USE_LARGE_FILES)
3102 Off_t cur, end, extend;
3104 cur = win32_tell(fd);
3107 end = win32_lseek(fd, 0, SEEK_END);
3110 extend = size - end;
3114 else if (extend > 0) {
3115 /* must grow the file, padding with nulls */
3117 int oldmode = win32_setmode(fd, O_BINARY);
3119 memset(b, '\0', sizeof(b));
3121 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3122 count = win32_write(fd, b, count);
3127 } while ((extend -= count) > 0);
3128 win32_setmode(fd, oldmode);
3131 /* shrink the file */
3132 win32_lseek(fd, size, SEEK_SET);
3133 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3139 win32_lseek(fd, cur, SEEK_SET);
3142 return chsize(fd, size);
3147 win32_lseek(int fd, Off_t offset, int origin)
3149 #if defined(WIN64) || defined(USE_LARGE_FILES)
3150 return _lseeki64(fd, offset, origin);
3152 return lseek(fd, offset, origin);
3159 #if defined(WIN64) || defined(USE_LARGE_FILES)
3160 return _telli64(fd);
3167 win32_open(const char *path, int flag, ...)
3172 WCHAR wBuffer[MAX_PATH+1];
3175 pmode = va_arg(ap, int);
3178 if (stricmp(path, "/dev/null")==0)
3182 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3183 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3185 return open(PerlDir_mapA(path), flag, pmode);
3188 /* close() that understands socket */
3189 extern int my_close(int); /* in win32sck.c */
3194 return my_close(fd);
3210 win32_dup2(int fd1,int fd2)
3212 return dup2(fd1,fd2);
3215 #ifdef PERL_MSVCRT_READFIX
3217 #define LF 10 /* line feed */
3218 #define CR 13 /* carriage return */
3219 #define CTRLZ 26 /* ctrl-z means eof for text */
3220 #define FOPEN 0x01 /* file handle open */
3221 #define FEOFLAG 0x02 /* end of file has been encountered */
3222 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3223 #define FPIPE 0x08 /* file handle refers to a pipe */
3224 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3225 #define FDEV 0x40 /* file handle refers to device */
3226 #define FTEXT 0x80 /* file handle is in text mode */
3227 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3230 _fixed_read(int fh, void *buf, unsigned cnt)
3232 int bytes_read; /* number of bytes read */
3233 char *buffer; /* buffer to read to */
3234 int os_read; /* bytes read on OS call */
3235 char *p, *q; /* pointers into buffer */
3236 char peekchr; /* peek-ahead character */
3237 ULONG filepos; /* file position after seek */
3238 ULONG dosretval; /* o.s. return value */
3240 /* validate handle */
3241 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3242 !(_osfile(fh) & FOPEN))
3244 /* out of range -- return error */
3246 _doserrno = 0; /* not o.s. error */
3251 * If lockinitflag is FALSE, assume fd is device
3252 * lockinitflag is set to TRUE by open.
3254 if (_pioinfo(fh)->lockinitflag)
3255 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3257 bytes_read = 0; /* nothing read yet */
3258 buffer = (char*)buf;
3260 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3261 /* nothing to read or at EOF, so return 0 read */
3265 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3266 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3268 *buffer++ = _pipech(fh);
3271 _pipech(fh) = LF; /* mark as empty */
3276 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3278 /* ReadFile has reported an error. recognize two special cases.
3280 * 1. map ERROR_ACCESS_DENIED to EBADF
3282 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3283 * means the handle is a read-handle on a pipe for which
3284 * all write-handles have been closed and all data has been
3287 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3288 /* wrong read/write mode should return EBADF, not EACCES */
3290 _doserrno = dosretval;
3294 else if (dosretval == ERROR_BROKEN_PIPE) {
3304 bytes_read += os_read; /* update bytes read */
3306 if (_osfile(fh) & FTEXT) {
3307 /* now must translate CR-LFs to LFs in the buffer */
3309 /* set CRLF flag to indicate LF at beginning of buffer */
3310 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3311 /* _osfile(fh) |= FCRLF; */
3313 /* _osfile(fh) &= ~FCRLF; */
3315 _osfile(fh) &= ~FCRLF;
3317 /* convert chars in the buffer: p is src, q is dest */
3319 while (p < (char *)buf + bytes_read) {
3321 /* if fh is not a device, set ctrl-z flag */
3322 if (!(_osfile(fh) & FDEV))
3323 _osfile(fh) |= FEOFLAG;
3324 break; /* stop translating */
3329 /* *p is CR, so must check next char for LF */
3330 if (p < (char *)buf + bytes_read - 1) {
3333 *q++ = LF; /* convert CR-LF to LF */
3336 *q++ = *p++; /* store char normally */
3339 /* This is the hard part. We found a CR at end of
3340 buffer. We must peek ahead to see if next char
3345 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3346 (LPDWORD)&os_read, NULL))
3347 dosretval = GetLastError();
3349 if (dosretval != 0 || os_read == 0) {
3350 /* couldn't read ahead, store CR */
3354 /* peekchr now has the extra character -- we now
3355 have several possibilities:
3356 1. disk file and char is not LF; just seek back
3358 2. disk file and char is LF; store LF, don't seek back
3359 3. pipe/device and char is LF; store LF.
3360 4. pipe/device and char isn't LF, store CR and
3361 put char in pipe lookahead buffer. */
3362 if (_osfile(fh) & (FDEV|FPIPE)) {
3363 /* non-seekable device */
3368 _pipech(fh) = peekchr;
3373 if (peekchr == LF) {
3374 /* nothing read yet; must make some
3377 /* turn on this flag for tell routine */
3378 _osfile(fh) |= FCRLF;
3381 HANDLE osHandle; /* o.s. handle value */
3383 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3385 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3386 dosretval = GetLastError();
3397 /* we now change bytes_read to reflect the true number of chars
3399 bytes_read = q - (char *)buf;
3403 if (_pioinfo(fh)->lockinitflag)
3404 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3409 #endif /* PERL_MSVCRT_READFIX */
3412 win32_read(int fd, void *buf, unsigned int cnt)
3414 #ifdef PERL_MSVCRT_READFIX
3415 return _fixed_read(fd, buf, cnt);
3417 return read(fd, buf, cnt);
3422 win32_write(int fd, const void *buf, unsigned int cnt)
3424 return write(fd, buf, cnt);
3428 win32_mkdir(const char *dir, int mode)
3432 WCHAR wBuffer[MAX_PATH+1];
3433 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3434 return _wmkdir(PerlDir_mapW(wBuffer));
3436 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3440 win32_rmdir(const char *dir)
3444 WCHAR wBuffer[MAX_PATH+1];
3445 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3446 return _wrmdir(PerlDir_mapW(wBuffer));
3448 return rmdir(PerlDir_mapA(dir));
3452 win32_chdir(const char *dir)
3460 WCHAR wBuffer[MAX_PATH+1];
3461 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3462 return _wchdir(wBuffer);
3468 win32_access(const char *path, int mode)
3472 WCHAR wBuffer[MAX_PATH+1];
3473 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3474 return _waccess(PerlDir_mapW(wBuffer), mode);
3476 return access(PerlDir_mapA(path), mode);
3480 win32_chmod(const char *path, int mode)
3484 WCHAR wBuffer[MAX_PATH+1];
3485 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3486 return _wchmod(PerlDir_mapW(wBuffer), mode);
3488 return chmod(PerlDir_mapA(path), mode);
3493 create_command_line(char *cname, STRLEN clen, const char * const *args)
3500 bool bat_file = FALSE;
3501 bool cmd_shell = FALSE;
3502 bool dumb_shell = FALSE;
3503 bool extra_quotes = FALSE;
3504 bool quote_next = FALSE;
3507 cname = (char*)args[0];
3509 /* The NT cmd.exe shell has the following peculiarity that needs to be
3510 * worked around. It strips a leading and trailing dquote when any
3511 * of the following is true:
3512 * 1. the /S switch was used
3513 * 2. there are more than two dquotes
3514 * 3. there is a special character from this set: &<>()@^|
3515 * 4. no whitespace characters within the two dquotes
3516 * 5. string between two dquotes isn't an executable file
3517 * To work around this, we always add a leading and trailing dquote
3518 * to the string, if the first argument is either "cmd.exe" or "cmd",
3519 * and there were at least two or more arguments passed to cmd.exe
3520 * (not including switches).
3521 * XXX the above rules (from "cmd /?") don't seem to be applied
3522 * always, making for the convolutions below :-(
3526 clen = strlen(cname);
3529 && (stricmp(&cname[clen-4], ".bat") == 0
3530 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3536 char *exe = strrchr(cname, '/');
3537 char *exe2 = strrchr(cname, '\\');
3544 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3548 else if (stricmp(exe, "command.com") == 0
3549 || stricmp(exe, "command") == 0)
3556 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3557 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3558 STRLEN curlen = strlen(arg);
3559 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3560 len += 2; /* assume quoting needed (worst case) */
3562 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3564 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3567 New(1310, cmd, len, char);
3572 extra_quotes = TRUE;
3575 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3577 STRLEN curlen = strlen(arg);
3579 /* we want to protect empty arguments and ones with spaces with
3580 * dquotes, but only if they aren't already there */
3585 else if (quote_next) {
3586 /* see if it really is multiple arguments pretending to
3587 * be one and force a set of quotes around it */
3588 if (*find_next_space(arg))
3591 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3593 while (i < curlen) {
3594 if (isSPACE(arg[i])) {
3597 else if (arg[i] == '"') {
3621 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3622 && stricmp(arg+curlen-2, "/c") == 0)
3624 /* is there a next argument? */
3625 if (args[index+1]) {
3626 /* are there two or more next arguments? */
3627 if (args[index+2]) {
3629 extra_quotes = TRUE;
3632 /* single argument, force quoting if it has spaces */
3648 qualified_path(const char *cmd)
3652 char *fullcmd, *curfullcmd;
3658 fullcmd = (char*)cmd;
3660 if (*fullcmd == '/' || *fullcmd == '\\')
3667 pathstr = PerlEnv_getenv("PATH");
3668 New(0, fullcmd, MAX_PATH+1, char);
3669 curfullcmd = fullcmd;
3674 /* start by appending the name to the current prefix */
3675 strcpy(curfullcmd, cmd);
3676 curfullcmd += cmdlen;
3678 /* if it doesn't end with '.', or has no extension, try adding
3679 * a trailing .exe first */
3680 if (cmd[cmdlen-1] != '.'
3681 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3683 strcpy(curfullcmd, ".exe");
3684 res = GetFileAttributes(fullcmd);
3685 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3690 /* that failed, try the bare name */
3691 res = GetFileAttributes(fullcmd);
3692 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3695 /* quit if no other path exists, or if cmd already has path */
3696 if (!pathstr || !*pathstr || has_slash)
3699 /* skip leading semis */
3700 while (*pathstr == ';')
3703 /* build a new prefix from scratch */
3704 curfullcmd = fullcmd;
3705 while (*pathstr && *pathstr != ';') {
3706 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3707 pathstr++; /* skip initial '"' */
3708 while (*pathstr && *pathstr != '"') {
3709 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3710 *curfullcmd++ = *pathstr;
3714 pathstr++; /* skip trailing '"' */
3717 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3718 *curfullcmd++ = *pathstr;
3723 pathstr++; /* skip trailing semi */
3724 if (curfullcmd > fullcmd /* append a dir separator */
3725 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3727 *curfullcmd++ = '\\';
3735 /* The following are just place holders.
3736 * Some hosts may provide and environment that the OS is
3737 * not tracking, therefore, these host must provide that
3738 * environment and the current directory to CreateProcess
3742 win32_get_childenv(void)
3748 win32_free_childenv(void* d)
3753 win32_clearenv(void)
3755 char *envv = GetEnvironmentStrings();
3759 char *end = strchr(cur,'=');
3760 if (end && end != cur) {
3762 SetEnvironmentVariable(cur, NULL);
3764 cur = end + strlen(end+1)+2;
3766 else if ((len = strlen(cur)))
3769 FreeEnvironmentStrings(envv);
3773 win32_get_childdir(void)
3777 char szfilename[(MAX_PATH+1)*2];
3779 WCHAR wfilename[MAX_PATH+1];
3780 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3781 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3784 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3787 New(0, ptr, strlen(szfilename)+1, char);
3788 strcpy(ptr, szfilename);
3793 win32_free_childdir(char* d)
3800 /* XXX this needs to be made more compatible with the spawnvp()
3801 * provided by the various RTLs. In particular, searching for
3802 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3803 * This doesn't significantly affect perl itself, because we
3804 * always invoke things using PERL5SHELL if a direct attempt to
3805 * spawn the executable fails.
3807 * XXX splitting and rejoining the commandline between do_aspawn()
3808 * and win32_spawnvp() could also be avoided.
3812 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3814 #ifdef USE_RTL_SPAWNVP
3815 return spawnvp(mode, cmdname, (char * const *)argv);
3822 STARTUPINFO StartupInfo;
3823 PROCESS_INFORMATION ProcessInformation;
3826 char *fullcmd = Nullch;
3827 char *cname = (char *)cmdname;
3831 clen = strlen(cname);
3832 /* if command name contains dquotes, must remove them */
3833 if (strchr(cname, '"')) {
3835 New(0,cname,clen+1,char);
3848 cmd = create_command_line(cname, clen, argv);
3850 env = PerlEnv_get_childenv();
3851 dir = PerlEnv_get_childdir();
3854 case P_NOWAIT: /* asynch + remember result */
3855 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3860 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3863 create |= CREATE_NEW_PROCESS_GROUP;
3866 case P_WAIT: /* synchronous execution */
3868 default: /* invalid mode */
3873 memset(&StartupInfo,0,sizeof(StartupInfo));
3874 StartupInfo.cb = sizeof(StartupInfo);
3875 memset(&tbl,0,sizeof(tbl));
3876 PerlEnv_get_child_IO(&tbl);
3877 StartupInfo.dwFlags = tbl.dwFlags;
3878 StartupInfo.dwX = tbl.dwX;
3879 StartupInfo.dwY = tbl.dwY;
3880 StartupInfo.dwXSize = tbl.dwXSize;
3881 StartupInfo.dwYSize = tbl.dwYSize;
3882 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3883 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3884 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3885 StartupInfo.wShowWindow = tbl.wShowWindow;
3886 StartupInfo.hStdInput = tbl.childStdIn;
3887 StartupInfo.hStdOutput = tbl.childStdOut;
3888 StartupInfo.hStdError = tbl.childStdErr;
3889 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3890 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3891 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3893 create |= CREATE_NEW_CONSOLE;
3896 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3898 if (w32_use_showwindow) {
3899 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3900 StartupInfo.wShowWindow = w32_showwindow;
3903 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3906 if (!CreateProcess(cname, /* search PATH to find executable */
3907 cmd, /* executable, and its arguments */
3908 NULL, /* process attributes */
3909 NULL, /* thread attributes */
3910 TRUE, /* inherit handles */
3911 create, /* creation flags */
3912 (LPVOID)env, /* inherit environment */
3913 dir, /* inherit cwd */
3915 &ProcessInformation))
3917 /* initial NULL argument to CreateProcess() does a PATH
3918 * search, but it always first looks in the directory
3919 * where the current process was started, which behavior
3920 * is undesirable for backward compatibility. So we
3921 * jump through our own hoops by picking out the path
3922 * we really want it to use. */
3924 fullcmd = qualified_path(cname);
3926 if (cname != cmdname)
3929 DEBUG_p(PerlIO_printf(Perl_debug_log,
3930 "Retrying [%s] with same args\n",
3940 if (mode == P_NOWAIT) {
3941 /* asynchronous spawn -- store handle, return PID */
3942 ret = (int)ProcessInformation.dwProcessId;
3943 if (IsWin95() && ret < 0)
3946 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3947 w32_child_pids[w32_num_children] = (DWORD)ret;
3952 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3953 /* FIXME: if msgwait returned due to message perhaps forward the
3954 "signal" to the process
3956 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3958 CloseHandle(ProcessInformation.hProcess);
3961 CloseHandle(ProcessInformation.hThread);
3964 PerlEnv_free_childenv(env);
3965 PerlEnv_free_childdir(dir);
3967 if (cname != cmdname)
3974 win32_execv(const char *cmdname, const char *const *argv)
3978 /* if this is a pseudo-forked child, we just want to spawn
3979 * the new program, and return */
3981 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3983 return execv(cmdname, (char *const *)argv);
3987 win32_execvp(const char *cmdname, const char *const *argv)
3991 /* if this is a pseudo-forked child, we just want to spawn
3992 * the new program, and return */
3993 if (w32_pseudo_id) {
3994 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4003 return execvp(cmdname, (char *const *)argv);
4007 win32_perror(const char *str)
4013 win32_setbuf(FILE *pf, char *buf)
4019 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4021 return setvbuf(pf, buf, type, size);
4025 win32_flushall(void)
4031 win32_fcloseall(void)
4037 win32_fgets(char *s, int n, FILE *pf)
4039 return fgets(s, n, pf);
4049 win32_fgetc(FILE *pf)
4055 win32_putc(int c, FILE *pf)
4061 win32_puts(const char *s)
4073 win32_putchar(int c)
4080 #ifndef USE_PERL_SBRK
4082 static char *committed = NULL; /* XXX threadead */
4083 static char *base = NULL; /* XXX threadead */
4084 static char *reserved = NULL; /* XXX threadead */
4085 static char *brk = NULL; /* XXX threadead */
4086 static DWORD pagesize = 0; /* XXX threadead */
4087 static DWORD allocsize = 0; /* XXX threadead */
4090 sbrk(ptrdiff_t need)
4095 GetSystemInfo(&info);
4096 /* Pretend page size is larger so we don't perpetually
4097 * call the OS to commit just one page ...
4099 pagesize = info.dwPageSize << 3;
4100 allocsize = info.dwAllocationGranularity;
4102 /* This scheme fails eventually if request for contiguous
4103 * block is denied so reserve big blocks - this is only
4104 * address space not memory ...
4106 if (brk+need >= reserved)
4108 DWORD size = 64*1024*1024;
4110 if (committed && reserved && committed < reserved)
4112 /* Commit last of previous chunk cannot span allocations */
4113 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4115 committed = reserved;
4117 /* Reserve some (more) space
4118 * Note this is a little sneaky, 1st call passes NULL as reserved
4119 * so lets system choose where we start, subsequent calls pass
4120 * the old end address so ask for a contiguous block
4122 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4125 reserved = addr+size;
4140 if (brk > committed)
4142 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4143 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4158 win32_malloc(size_t size)
4160 return malloc(size);
4164 win32_calloc(size_t numitems, size_t size)
4166 return calloc(numitems,size);
4170 win32_realloc(void *block, size_t size)
4172 return realloc(block,size);
4176 win32_free(void *block)
4183 win32_open_osfhandle(intptr_t handle, int flags)
4185 #ifdef USE_FIXED_OSFHANDLE
4187 return my_open_osfhandle(handle, flags);
4189 return _open_osfhandle(handle, flags);
4193 win32_get_osfhandle(int fd)
4195 return (intptr_t)_get_osfhandle(fd);
4199 win32_fdupopen(FILE *pf)
4204 int fileno = win32_dup(win32_fileno(pf));
4206 /* open the file in the same mode */
4208 if((pf)->flags & _F_READ) {
4212 else if((pf)->flags & _F_WRIT) {
4216 else if((pf)->flags & _F_RDWR) {
4222 if((pf)->_flag & _IOREAD) {
4226 else if((pf)->_flag & _IOWRT) {
4230 else if((pf)->_flag & _IORW) {
4237 /* it appears that the binmode is attached to the
4238 * file descriptor so binmode files will be handled
4241 pfdup = win32_fdopen(fileno, mode);
4243 /* move the file pointer to the same position */
4244 if (!fgetpos(pf, &pos)) {
4245 fsetpos(pfdup, &pos);
4251 win32_dynaload(const char* filename)
4255 char buf[MAX_PATH+1];
4258 /* LoadLibrary() doesn't recognize forward slashes correctly,
4259 * so turn 'em back. */
4260 first = strchr(filename, '/');
4262 STRLEN len = strlen(filename);
4263 if (len <= MAX_PATH) {
4264 strcpy(buf, filename);
4265 filename = &buf[first - filename];
4267 if (*filename == '/')
4268 *(char*)filename = '\\';
4275 WCHAR wfilename[MAX_PATH+1];
4276 A2WHELPER(filename, wfilename, sizeof(wfilename));
4277 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4280 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4290 XS(w32_SetChildShowWindow)
4293 BOOL use_showwindow = w32_use_showwindow;
4294 /* use "unsigned short" because Perl has redefined "WORD" */
4295 unsigned short showwindow = w32_showwindow;
4298 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4300 if (items == 0 || !SvOK(ST(0)))
4301 w32_use_showwindow = FALSE;
4303 w32_use_showwindow = TRUE;
4304 w32_showwindow = (unsigned short)SvIV(ST(0));
4309 ST(0) = sv_2mortal(newSViv(showwindow));
4311 ST(0) = &PL_sv_undef;
4319 /* Make the host for current directory */
4320 char* ptr = PerlEnv_get_childdir();
4323 * then it worked, set PV valid,
4324 * else return 'undef'
4327 SV *sv = sv_newmortal();
4329 PerlEnv_free_childdir(ptr);
4331 #ifndef INCOMPLETE_TAINTS
4348 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4349 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4356 XS(w32_GetNextAvailDrive)
4360 char root[] = "_:\\";
4365 if (GetDriveType(root) == 1) {
4374 XS(w32_GetLastError)
4378 XSRETURN_IV(GetLastError());
4382 XS(w32_SetLastError)
4386 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4387 SetLastError(SvIV(ST(0)));
4395 char *name = w32_getlogin_buffer;
4396 DWORD size = sizeof(w32_getlogin_buffer);
4398 if (GetUserName(name,&size)) {
4399 /* size includes NULL */
4400 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4410 char name[MAX_COMPUTERNAME_LENGTH+1];
4411 DWORD size = sizeof(name);
4413 if (GetComputerName(name,&size)) {
4414 /* size does NOT include NULL :-( */
4415 ST(0) = sv_2mortal(newSVpvn(name,size));
4426 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4427 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4428 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4432 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4433 GetProcAddress(hNetApi32, "NetApiBufferFree");
4434 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4435 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4438 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4439 /* this way is more reliable, in case user has a local account. */
4441 DWORD dnamelen = sizeof(dname);
4443 DWORD wki100_platform_id;
4444 LPWSTR wki100_computername;
4445 LPWSTR wki100_langroup;
4446 DWORD wki100_ver_major;
4447 DWORD wki100_ver_minor;
4449 /* NERR_Success *is* 0*/
4450 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4451 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4452 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4453 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4456 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4457 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4459 pfnNetApiBufferFree(pwi);
4460 FreeLibrary(hNetApi32);
4463 FreeLibrary(hNetApi32);
4466 /* Win95 doesn't have NetWksta*(), so do it the old way */
4468 DWORD size = sizeof(name);
4470 FreeLibrary(hNetApi32);
4471 if (GetUserName(name,&size)) {
4472 char sid[ONE_K_BUFSIZE];
4473 DWORD sidlen = sizeof(sid);
4475 DWORD dnamelen = sizeof(dname);
4477 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4478 dname, &dnamelen, &snu)) {
4479 XSRETURN_PV(dname); /* all that for this */
4491 DWORD flags, filecomplen;
4492 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4493 &flags, fsname, sizeof(fsname))) {
4494 if (GIMME_V == G_ARRAY) {
4495 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4496 XPUSHs(sv_2mortal(newSViv(flags)));
4497 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4502 XSRETURN_PV(fsname);
4508 XS(w32_GetOSVersion)
4511 /* Use explicit struct definition because wSuiteMask and
4512 * wProductType are not defined in the VC++ 6.0 headers.
4513 * WORD type has been replaced by unsigned short because
4514 * WORD is already used by Perl itself.
4517 DWORD dwOSVersionInfoSize;
4518 DWORD dwMajorVersion;
4519 DWORD dwMinorVersion;
4520 DWORD dwBuildNumber;
4522 CHAR szCSDVersion[128];
4523 unsigned short wServicePackMajor;
4524 unsigned short wServicePackMinor;
4525 unsigned short wSuiteMask;
4533 DWORD dwOSVersionInfoSize;
4534 DWORD dwMajorVersion;
4535 DWORD dwMinorVersion;
4536 DWORD dwBuildNumber;
4538 WCHAR szCSDVersion[128];
4539 unsigned short wServicePackMajor;
4540 unsigned short wServicePackMinor;
4541 unsigned short wSuiteMask;
4545 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4546 osverw.dwOSVersionInfoSize = sizeof(osverw);
4547 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4549 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4550 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4554 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4555 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4556 osver.dwMajorVersion = osverw.dwMajorVersion;
4557 osver.dwMinorVersion = osverw.dwMinorVersion;
4558 osver.dwBuildNumber = osverw.dwBuildNumber;
4559 osver.dwPlatformId = osverw.dwPlatformId;
4560 osver.wServicePackMajor = osverw.wServicePackMajor;
4561 osver.wServicePackMinor = osverw.wServicePackMinor;
4562 osver.wSuiteMask = osverw.wSuiteMask;
4563 osver.wProductType = osverw.wProductType;
4566 osver.dwOSVersionInfoSize = sizeof(osver);
4567 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4569 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4570 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4574 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4576 XPUSHs(newSViv(osver.dwMajorVersion));
4577 XPUSHs(newSViv(osver.dwMinorVersion));
4578 XPUSHs(newSViv(osver.dwBuildNumber));
4579 XPUSHs(newSViv(osver.dwPlatformId));
4581 XPUSHs(newSViv(osver.wServicePackMajor));
4582 XPUSHs(newSViv(osver.wServicePackMinor));
4583 XPUSHs(newSViv(osver.wSuiteMask));
4584 XPUSHs(newSViv(osver.wProductType));
4594 XSRETURN_IV(IsWinNT());
4602 XSRETURN_IV(IsWin95());
4606 XS(w32_FormatMessage)
4610 char msgbuf[ONE_K_BUFSIZE];
4613 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4616 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4617 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4618 &source, SvIV(ST(0)), 0,
4619 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4621 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4622 XSRETURN_PV(msgbuf);
4626 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4627 &source, SvIV(ST(0)), 0,
4628 msgbuf, sizeof(msgbuf)-1, NULL))
4629 XSRETURN_PV(msgbuf);
4642 PROCESS_INFORMATION stProcInfo;
4643 STARTUPINFO stStartInfo;
4644 BOOL bSuccess = FALSE;
4647 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4649 cmd = SvPV_nolen(ST(0));
4650 args = SvPV_nolen(ST(1));
4652 env = PerlEnv_get_childenv();
4653 dir = PerlEnv_get_childdir();
4655 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4656 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4657 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4658 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4661 cmd, /* Image path */
4662 args, /* Arguments for command line */
4663 NULL, /* Default process security */
4664 NULL, /* Default thread security */
4665 FALSE, /* Must be TRUE to use std handles */
4666 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4667 env, /* Inherit our environment block */
4668 dir, /* Inherit our currrent directory */
4669 &stStartInfo, /* -> Startup info */
4670 &stProcInfo)) /* <- Process info (if OK) */
4672 int pid = (int)stProcInfo.dwProcessId;
4673 if (IsWin95() && pid < 0)
4675 sv_setiv(ST(2), pid);
4676 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4679 PerlEnv_free_childenv(env);
4680 PerlEnv_free_childdir(dir);
4681 XSRETURN_IV(bSuccess);
4685 XS(w32_GetTickCount)
4688 DWORD msec = GetTickCount();
4696 XS(w32_GetShortPathName)
4703 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4705 shortpath = sv_mortalcopy(ST(0));
4706 SvUPGRADE(shortpath, SVt_PV);
4707 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4710 /* src == target is allowed */
4712 len = GetShortPathName(SvPVX(shortpath),
4715 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4717 SvCUR_set(shortpath,len);
4718 *SvEND(shortpath) = '\0';
4726 XS(w32_GetFullPathName)
4735 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4738 fullpath = sv_mortalcopy(filename);
4739 SvUPGRADE(fullpath, SVt_PV);
4740 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4744 len = GetFullPathName(SvPVX(filename),
4748 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4750 if (GIMME_V == G_ARRAY) {
4753 XST_mPV(1,filepart);
4754 len = filepart - SvPVX(fullpath);
4761 SvCUR_set(fullpath,len);
4762 *SvEND(fullpath) = '\0';
4770 XS(w32_GetLongPathName)
4774 char tmpbuf[MAX_PATH+1];
4779 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4782 pathstr = SvPV(path,len);
4783 strcpy(tmpbuf, pathstr);
4784 pathstr = win32_longpath(tmpbuf);
4786 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4797 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4808 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4810 WCHAR wSourceFile[MAX_PATH+1];
4811 WCHAR wDestFile[MAX_PATH+1];
4812 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4813 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4814 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4815 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4818 char szSourceFile[MAX_PATH+1];
4819 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4820 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4829 Perl_init_os_extras(void)
4832 char *file = __FILE__;
4835 /* these names are Activeware compatible */
4836 newXS("Win32::GetCwd", w32_GetCwd, file);
4837 newXS("Win32::SetCwd", w32_SetCwd, file);
4838 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4839 newXS("Win32::GetLastError", w32_GetLastError, file);
4840 newXS("Win32::SetLastError", w32_SetLastError, file);
4841 newXS("Win32::LoginName", w32_LoginName, file);
4842 newXS("Win32::NodeName", w32_NodeName, file);
4843 newXS("Win32::DomainName", w32_DomainName, file);
4844 newXS("Win32::FsType", w32_FsType, file);
4845 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4846 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4847 newXS("Win32::IsWin95", w32_IsWin95, file);
4848 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4849 newXS("Win32::Spawn", w32_Spawn, file);
4850 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4851 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4852 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4853 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4854 newXS("Win32::CopyFile", w32_CopyFile, file);
4855 newXS("Win32::Sleep", w32_Sleep, file);
4856 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4858 /* XXX Bloat Alert! The following Activeware preloads really
4859 * ought to be part of Win32::Sys::*, so they're not included
4862 /* LookupAccountName
4864 * InitiateSystemShutdown
4865 * AbortSystemShutdown
4866 * ExpandEnvrironmentStrings
4871 win32_signal_context(void)
4876 my_perl = PL_curinterp;
4877 PERL_SET_THX(my_perl);
4881 return PL_curinterp;
4887 win32_ctrlhandler(DWORD dwCtrlType)
4890 dTHXa(PERL_GET_SIG_CONTEXT);
4896 switch(dwCtrlType) {
4897 case CTRL_CLOSE_EVENT:
4898 /* A signal that the system sends to all processes attached to a console when
4899 the user closes the console (either by choosing the Close command from the
4900 console window's System menu, or by choosing the End Task command from the
4903 if (do_raise(aTHX_ 1)) /* SIGHUP */
4904 sig_terminate(aTHX_ 1);
4908 /* A CTRL+c signal was received */
4909 if (do_raise(aTHX_ SIGINT))
4910 sig_terminate(aTHX_ SIGINT);
4913 case CTRL_BREAK_EVENT:
4914 /* A CTRL+BREAK signal was received */
4915 if (do_raise(aTHX_ SIGBREAK))
4916 sig_terminate(aTHX_ SIGBREAK);
4919 case CTRL_LOGOFF_EVENT:
4920 /* A signal that the system sends to all console processes when a user is logging
4921 off. This signal does not indicate which user is logging off, so no
4922 assumptions can be made.
4925 case CTRL_SHUTDOWN_EVENT:
4926 /* A signal that the system sends to all console processes when the system is
4929 if (do_raise(aTHX_ SIGTERM))
4930 sig_terminate(aTHX_ SIGTERM);
4940 Perl_win32_init(int *argcp, char ***argvp)
4942 /* Disable floating point errors, Perl will trap the ones we
4943 * care about. VC++ RTL defaults to switching these off
4944 * already, but the Borland RTL doesn't. Since we don't
4945 * want to be at the vendor's whim on the default, we set
4946 * it explicitly here.
4948 #if !defined(_ALPHA_) && !defined(__GNUC__)
4949 _control87(MCW_EM, MCW_EM);
4955 Perl_win32_term(void)
4962 win32_get_child_IO(child_IO_table* ptbl)
4964 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4965 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4966 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4970 win32_signal(int sig, Sighandler_t subcode)
4973 if (sig < SIG_SIZE) {
4974 int save_errno = errno;
4975 Sighandler_t result = signal(sig, subcode);
4976 if (result == SIG_ERR) {
4977 result = w32_sighandler[sig];
4980 w32_sighandler[sig] = subcode;
4990 #ifdef HAVE_INTERP_INTERN
4994 win32_csighandler(int sig)
4997 dTHXa(PERL_GET_SIG_CONTEXT);
4998 Perl_warn(aTHX_ "Got signal %d",sig);
5004 Perl_sys_intern_init(pTHX)
5007 w32_perlshell_tokens = Nullch;
5008 w32_perlshell_vec = (char**)NULL;
5009 w32_perlshell_items = 0;
5010 w32_fdpid = newAV();
5011 New(1313, w32_children, 1, child_tab);
5012 w32_num_children = 0;
5013 # ifdef USE_ITHREADS
5015 New(1313, w32_pseudo_children, 1, child_tab);
5016 w32_num_pseudo_children = 0;
5018 w32_init_socktype = 0;
5021 for (i=0; i < SIG_SIZE; i++) {
5022 w32_sighandler[i] = SIG_DFL;
5025 if (my_perl == PL_curinterp) {
5029 /* Force C runtime signal stuff to set its console handler */
5030 signal(SIGINT,&win32_csighandler);
5031 signal(SIGBREAK,&win32_csighandler);
5032 /* Push our handler on top */
5033 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5038 Perl_sys_intern_clear(pTHX)
5040 Safefree(w32_perlshell_tokens);
5041 Safefree(w32_perlshell_vec);
5042 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5043 Safefree(w32_children);
5045 KillTimer(NULL,w32_timerid);
5048 # ifdef MULTIPLICITY
5049 if (my_perl == PL_curinterp) {
5053 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5055 # ifdef USE_ITHREADS
5056 Safefree(w32_pseudo_children);
5060 # ifdef USE_ITHREADS
5063 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5065 dst->perlshell_tokens = Nullch;
5066 dst->perlshell_vec = (char**)NULL;
5067 dst->perlshell_items = 0;
5068 dst->fdpid = newAV();
5069 Newz(1313, dst->children, 1, child_tab);
5071 Newz(1313, dst->pseudo_children, 1, child_tab);
5072 dst->thr_intern.Winit_socktype = 0;
5074 dst->poll_count = 0;
5075 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5077 # endif /* USE_ITHREADS */
5078 #endif /* HAVE_INTERP_INTERN */
5081 win32_free_argvw(pTHX_ void *ptr)
5083 char** argv = (char**)ptr;
5091 win32_argv2utf8(int argc, char** argv)
5096 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5097 if (lpwStr && argc) {
5099 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5100 Newz(0, psz, length, char);
5101 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5104 call_atexit(win32_free_argvw, argv);
5106 GlobalFree((HGLOBAL)lpwStr);