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)
1072 /* it is a pseudo-forked child */
1073 child = find_pseudo_pid(-pid);
1075 hProcess = w32_pseudo_child_handles[child];
1078 /* "Does process exist?" use of kill */
1081 /* kill -9 style un-graceful exit */
1082 if (TerminateThread(hProcess, sig)) {
1083 remove_dead_pseudo_process(child);
1088 /* We fake signals to pseudo-processes using Win32
1089 * message queue. In Win9X the pids are negative already. */
1090 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1091 /* It might be us ... */
1098 else if (IsWin95()) {
1106 child = find_pid(pid);
1108 hProcess = w32_child_handles[child];
1111 /* "Does process exist?" use of kill */
1114 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1117 default: /* For now be backwards compatible with perl5.6 */
1119 if (TerminateProcess(hProcess, sig)) {
1120 remove_dead_process(child);
1128 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1129 (IsWin95() ? -pid : pid));
1133 /* "Does process exist?" use of kill */
1136 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1139 default: /* For now be backwards compatible with perl5.6 */
1141 if (TerminateProcess(hProcess, sig)) {
1142 CloseHandle(hProcess);
1154 win32_stat(const char *path, Stat_t *sbuf)
1157 char buffer[MAX_PATH+1];
1158 int l = strlen(path);
1160 WCHAR wbuffer[MAX_PATH+1];
1166 switch(path[l - 1]) {
1167 /* FindFirstFile() and stat() are buggy with a trailing
1168 * backslash, so change it to a forward slash :-( */
1170 strncpy(buffer, path, l-1);
1171 buffer[l - 1] = '/';
1175 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1177 if (l == 2 && isALPHA(path[0])) {
1178 buffer[0] = path[0];
1189 /* We *must* open & close the file once; otherwise file attribute changes */
1190 /* might not yet have propagated to "other" hard links of the same file. */
1191 /* This also gives us an opportunity to determine the number of links. */
1193 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1194 pwbuffer = PerlDir_mapW(wbuffer);
1195 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1198 path = PerlDir_mapA(path);
1200 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1202 if (handle != INVALID_HANDLE_VALUE) {
1203 BY_HANDLE_FILE_INFORMATION bhi;
1204 if (GetFileInformationByHandle(handle, &bhi))
1205 nlink = bhi.nNumberOfLinks;
1206 CloseHandle(handle);
1209 /* pwbuffer or path will be mapped correctly above */
1211 #if defined(WIN64) || defined(USE_LARGE_FILES)
1212 res = _wstati64(pwbuffer, sbuf);
1214 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1218 #if defined(WIN64) || defined(USE_LARGE_FILES)
1219 res = _stati64(path, sbuf);
1221 res = stat(path, sbuf);
1224 sbuf->st_nlink = nlink;
1227 /* CRT is buggy on sharenames, so make sure it really isn't.
1228 * XXX using GetFileAttributesEx() will enable us to set
1229 * sbuf->st_*time (but note that's not available on the
1230 * Windows of 1995) */
1233 r = GetFileAttributesW(pwbuffer);
1236 r = GetFileAttributesA(path);
1238 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1239 /* sbuf may still contain old garbage since stat() failed */
1240 Zero(sbuf, 1, Stat_t);
1241 sbuf->st_mode = S_IFDIR | S_IREAD;
1243 if (!(r & FILE_ATTRIBUTE_READONLY))
1244 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1249 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1250 && (path[2] == '\\' || path[2] == '/'))
1252 /* The drive can be inaccessible, some _stat()s are buggy */
1254 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1255 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1261 if (S_ISDIR(sbuf->st_mode))
1262 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1263 else if (S_ISREG(sbuf->st_mode)) {
1265 if (l >= 4 && path[l-4] == '.') {
1266 const char *e = path + l - 3;
1267 if (strnicmp(e,"exe",3)
1268 && strnicmp(e,"bat",3)
1269 && strnicmp(e,"com",3)
1270 && (IsWin95() || strnicmp(e,"cmd",3)))
1271 sbuf->st_mode &= ~S_IEXEC;
1273 sbuf->st_mode |= S_IEXEC;
1276 sbuf->st_mode &= ~S_IEXEC;
1277 /* Propagate permissions to _group_ and _others_ */
1278 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1279 sbuf->st_mode |= (perms>>3) | (perms>>6);
1286 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1287 #define SKIP_SLASHES(s) \
1289 while (*(s) && isSLASH(*(s))) \
1292 #define COPY_NONSLASHES(d,s) \
1294 while (*(s) && !isSLASH(*(s))) \
1298 /* Find the longname of a given path. path is destructively modified.
1299 * It should have space for at least MAX_PATH characters. */
1301 win32_longpath(char *path)
1303 WIN32_FIND_DATA fdata;
1305 char tmpbuf[MAX_PATH+1];
1306 char *tmpstart = tmpbuf;
1313 if (isALPHA(path[0]) && path[1] == ':') {
1315 *tmpstart++ = path[0];
1319 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1321 *tmpstart++ = path[0];
1322 *tmpstart++ = path[1];
1323 SKIP_SLASHES(start);
1324 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1326 *tmpstart++ = *start++;
1327 SKIP_SLASHES(start);
1328 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1333 /* copy initial slash, if any */
1334 if (isSLASH(*start)) {
1335 *tmpstart++ = *start++;
1337 SKIP_SLASHES(start);
1340 /* FindFirstFile() expands "." and "..", so we need to pass
1341 * those through unmolested */
1343 && (!start[1] || isSLASH(start[1])
1344 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1346 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1351 /* if this is the end, bust outta here */
1355 /* now we're at a non-slash; walk up to next slash */
1356 while (*start && !isSLASH(*start))
1359 /* stop and find full name of component */
1362 fhand = FindFirstFile(path,&fdata);
1364 if (fhand != INVALID_HANDLE_VALUE) {
1365 STRLEN len = strlen(fdata.cFileName);
1366 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1367 strcpy(tmpstart, fdata.cFileName);
1378 /* failed a step, just return without side effects */
1379 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1384 strcpy(path,tmpbuf);
1389 win32_getenv(const char *name)
1392 WCHAR wBuffer[MAX_PATH+1];
1394 SV *curitem = Nullsv;
1397 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1398 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1401 needlen = GetEnvironmentVariableA(name,NULL,0);
1403 curitem = sv_2mortal(newSVpvn("", 0));
1407 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1408 needlen = GetEnvironmentVariableW(wBuffer,
1409 (WCHAR*)SvPVX(curitem),
1411 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1412 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1413 acuritem = sv_2mortal(newSVsv(curitem));
1414 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1418 SvGROW(curitem, needlen+1);
1419 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1421 } while (needlen >= SvLEN(curitem));
1422 SvCUR_set(curitem, needlen);
1426 /* allow any environment variables that begin with 'PERL'
1427 to be stored in the registry */
1428 if (strncmp(name, "PERL", 4) == 0)
1429 (void)get_regstr(name, &curitem);
1431 if (curitem && SvCUR(curitem))
1432 return SvPVX(curitem);
1438 win32_putenv(const char *name)
1445 int length, relval = -1;
1449 length = strlen(name)+1;
1450 New(1309,wCuritem,length,WCHAR);
1451 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1452 wVal = wcschr(wCuritem, '=');
1455 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1461 New(1309,curitem,strlen(name)+1,char);
1462 strcpy(curitem, name);
1463 val = strchr(curitem, '=');
1465 /* The sane way to deal with the environment.
1466 * Has these advantages over putenv() & co.:
1467 * * enables us to store a truly empty value in the
1468 * environment (like in UNIX).
1469 * * we don't have to deal with RTL globals, bugs and leaks.
1471 * Why you may want to enable USE_WIN32_RTL_ENV:
1472 * * environ[] and RTL functions will not reflect changes,
1473 * which might be an issue if extensions want to access
1474 * the env. via RTL. This cuts both ways, since RTL will
1475 * not see changes made by extensions that call the Win32
1476 * functions directly, either.
1480 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1490 filetime_to_clock(PFILETIME ft)
1492 __int64 qw = ft->dwHighDateTime;
1494 qw |= ft->dwLowDateTime;
1495 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1500 win32_times(struct tms *timebuf)
1505 clock_t process_time_so_far = clock();
1506 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1508 timebuf->tms_utime = filetime_to_clock(&user);
1509 timebuf->tms_stime = filetime_to_clock(&kernel);
1510 timebuf->tms_cutime = 0;
1511 timebuf->tms_cstime = 0;
1513 /* That failed - e.g. Win95 fallback to clock() */
1514 timebuf->tms_utime = process_time_so_far;
1515 timebuf->tms_stime = 0;
1516 timebuf->tms_cutime = 0;
1517 timebuf->tms_cstime = 0;
1519 return process_time_so_far;
1522 /* fix utime() so it works on directories in NT */
1524 filetime_from_time(PFILETIME pFileTime, time_t Time)
1526 struct tm *pTM = localtime(&Time);
1527 SYSTEMTIME SystemTime;
1533 SystemTime.wYear = pTM->tm_year + 1900;
1534 SystemTime.wMonth = pTM->tm_mon + 1;
1535 SystemTime.wDay = pTM->tm_mday;
1536 SystemTime.wHour = pTM->tm_hour;
1537 SystemTime.wMinute = pTM->tm_min;
1538 SystemTime.wSecond = pTM->tm_sec;
1539 SystemTime.wMilliseconds = 0;
1541 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1542 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1546 win32_unlink(const char *filename)
1553 WCHAR wBuffer[MAX_PATH+1];
1556 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1557 pwBuffer = PerlDir_mapW(wBuffer);
1558 attrs = GetFileAttributesW(pwBuffer);
1559 if (attrs == 0xFFFFFFFF)
1561 if (attrs & FILE_ATTRIBUTE_READONLY) {
1562 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1563 ret = _wunlink(pwBuffer);
1565 (void)SetFileAttributesW(pwBuffer, attrs);
1568 ret = _wunlink(pwBuffer);
1571 filename = PerlDir_mapA(filename);
1572 attrs = GetFileAttributesA(filename);
1573 if (attrs == 0xFFFFFFFF)
1575 if (attrs & FILE_ATTRIBUTE_READONLY) {
1576 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1577 ret = unlink(filename);
1579 (void)SetFileAttributesA(filename, attrs);
1582 ret = unlink(filename);
1591 win32_utime(const char *filename, struct utimbuf *times)
1598 struct utimbuf TimeBuffer;
1599 WCHAR wbuffer[MAX_PATH+1];
1604 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1605 pwbuffer = PerlDir_mapW(wbuffer);
1606 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1609 filename = PerlDir_mapA(filename);
1610 rc = utime(filename, times);
1612 /* EACCES: path specifies directory or readonly file */
1613 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1616 if (times == NULL) {
1617 times = &TimeBuffer;
1618 time(×->actime);
1619 times->modtime = times->actime;
1622 /* This will (and should) still fail on readonly files */
1624 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1625 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1626 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1629 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1630 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1631 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1633 if (handle == INVALID_HANDLE_VALUE)
1636 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1637 filetime_from_time(&ftAccess, times->actime) &&
1638 filetime_from_time(&ftWrite, times->modtime) &&
1639 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1644 CloseHandle(handle);
1649 unsigned __int64 ft_i64;
1654 #define Const64(x) x##LL
1656 #define Const64(x) x##i64
1658 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1659 #define EPOCH_BIAS Const64(116444736000000000)
1661 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1662 * and appears to be unsupported even by glibc) */
1664 win32_gettimeofday(struct timeval *tp, void *not_used)
1668 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1669 GetSystemTimeAsFileTime(&ft.ft_val);
1671 /* seconds since epoch */
1672 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1674 /* microseconds remaining */
1675 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1681 win32_uname(struct utsname *name)
1683 struct hostent *hep;
1684 STRLEN nodemax = sizeof(name->nodename)-1;
1685 OSVERSIONINFO osver;
1687 memset(&osver, 0, sizeof(OSVERSIONINFO));
1688 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1689 if (GetVersionEx(&osver)) {
1691 switch (osver.dwPlatformId) {
1692 case VER_PLATFORM_WIN32_WINDOWS:
1693 strcpy(name->sysname, "Windows");
1695 case VER_PLATFORM_WIN32_NT:
1696 strcpy(name->sysname, "Windows NT");
1698 case VER_PLATFORM_WIN32s:
1699 strcpy(name->sysname, "Win32s");
1702 strcpy(name->sysname, "Win32 Unknown");
1707 sprintf(name->release, "%d.%d",
1708 osver.dwMajorVersion, osver.dwMinorVersion);
1711 sprintf(name->version, "Build %d",
1712 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1713 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1714 if (osver.szCSDVersion[0]) {
1715 char *buf = name->version + strlen(name->version);
1716 sprintf(buf, " (%s)", osver.szCSDVersion);
1720 *name->sysname = '\0';
1721 *name->version = '\0';
1722 *name->release = '\0';
1726 hep = win32_gethostbyname("localhost");
1728 STRLEN len = strlen(hep->h_name);
1729 if (len <= nodemax) {
1730 strcpy(name->nodename, hep->h_name);
1733 strncpy(name->nodename, hep->h_name, nodemax);
1734 name->nodename[nodemax] = '\0';
1739 if (!GetComputerName(name->nodename, &sz))
1740 *name->nodename = '\0';
1743 /* machine (architecture) */
1748 GetSystemInfo(&info);
1750 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1751 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1752 procarch = info.u.s.wProcessorArchitecture;
1754 procarch = info.wProcessorArchitecture;
1757 case PROCESSOR_ARCHITECTURE_INTEL:
1758 arch = "x86"; break;
1759 case PROCESSOR_ARCHITECTURE_MIPS:
1760 arch = "mips"; break;
1761 case PROCESSOR_ARCHITECTURE_ALPHA:
1762 arch = "alpha"; break;
1763 case PROCESSOR_ARCHITECTURE_PPC:
1764 arch = "ppc"; break;
1765 #ifdef PROCESSOR_ARCHITECTURE_SHX
1766 case PROCESSOR_ARCHITECTURE_SHX:
1767 arch = "shx"; break;
1769 #ifdef PROCESSOR_ARCHITECTURE_ARM
1770 case PROCESSOR_ARCHITECTURE_ARM:
1771 arch = "arm"; break;
1773 #ifdef PROCESSOR_ARCHITECTURE_IA64
1774 case PROCESSOR_ARCHITECTURE_IA64:
1775 arch = "ia64"; break;
1777 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1778 case PROCESSOR_ARCHITECTURE_ALPHA64:
1779 arch = "alpha64"; break;
1781 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1782 case PROCESSOR_ARCHITECTURE_MSIL:
1783 arch = "msil"; break;
1785 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1786 case PROCESSOR_ARCHITECTURE_AMD64:
1787 arch = "amd64"; break;
1789 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1790 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1791 arch = "ia32-64"; break;
1793 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1794 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1795 arch = "unknown"; break;
1798 sprintf(name->machine, "unknown(0x%x)", procarch);
1799 arch = name->machine;
1802 if (name->machine != arch)
1803 strcpy(name->machine, arch);
1808 /* Timing related stuff */
1811 do_raise(pTHX_ int sig)
1813 if (sig < SIG_SIZE) {
1814 Sighandler_t handler = w32_sighandler[sig];
1815 if (handler == SIG_IGN) {
1818 else if (handler != SIG_DFL) {
1823 /* Choose correct default behaviour */
1839 /* Tell caller to exit thread/process as approriate */
1844 sig_terminate(pTHX_ int sig)
1846 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1847 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1854 win32_async_check(pTHX)
1858 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1859 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1861 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1863 switch(msg.message) {
1866 /* Perhaps some other messages could map to signals ? ... */
1869 /* Treat WM_QUIT like SIGHUP? */
1875 /* We use WM_USER to fake kill() with other signals */
1879 if (do_raise(aTHX_ sig)) {
1880 sig_terminate(aTHX_ sig);
1886 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1887 if (w32_timerid && w32_timerid==msg.wParam) {
1888 KillTimer(NULL,w32_timerid);
1893 /* Now fake a call to signal handler */
1894 if (do_raise(aTHX_ 14)) {
1895 sig_terminate(aTHX_ 14);
1900 /* Otherwise do normal Win32 thing - in case it is useful */
1903 TranslateMessage(&msg);
1904 DispatchMessage(&msg);
1911 /* Above or other stuff may have set a signal flag */
1912 if (PL_sig_pending) {
1918 /* This function will not return until the timeout has elapsed, or until
1919 * one of the handles is ready. */
1921 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1923 /* We may need several goes at this - so compute when we stop */
1925 if (timeout != INFINITE) {
1926 ticks = GetTickCount();
1930 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1933 if (result == WAIT_TIMEOUT) {
1934 /* Ran out of time - explicit return of zero to avoid -ve if we
1935 have scheduling issues
1939 if (timeout != INFINITE) {
1940 ticks = GetTickCount();
1942 if (result == WAIT_OBJECT_0 + count) {
1943 /* Message has arrived - check it */
1944 (void)win32_async_check(aTHX);
1947 /* Not timeout or message - one of handles is ready */
1951 /* compute time left to wait */
1952 ticks = timeout - ticks;
1953 /* If we are past the end say zero */
1954 return (ticks > 0) ? ticks : 0;
1958 win32_internal_wait(int *status, DWORD timeout)
1960 /* XXX this wait emulation only knows about processes
1961 * spawned via win32_spawnvp(P_NOWAIT, ...).
1965 DWORD exitcode, waitcode;
1968 if (w32_num_pseudo_children) {
1969 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1970 timeout, &waitcode);
1971 /* Time out here if there are no other children to wait for. */
1972 if (waitcode == WAIT_TIMEOUT) {
1973 if (!w32_num_children) {
1977 else if (waitcode != WAIT_FAILED) {
1978 if (waitcode >= WAIT_ABANDONED_0
1979 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1980 i = waitcode - WAIT_ABANDONED_0;
1982 i = waitcode - WAIT_OBJECT_0;
1983 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1984 *status = (int)((exitcode & 0xff) << 8);
1985 retval = (int)w32_pseudo_child_pids[i];
1986 remove_dead_pseudo_process(i);
1993 if (!w32_num_children) {
1998 /* if a child exists, wait for it to die */
1999 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2000 if (waitcode == WAIT_TIMEOUT) {
2003 if (waitcode != WAIT_FAILED) {
2004 if (waitcode >= WAIT_ABANDONED_0
2005 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2006 i = waitcode - WAIT_ABANDONED_0;
2008 i = waitcode - WAIT_OBJECT_0;
2009 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2010 *status = (int)((exitcode & 0xff) << 8);
2011 retval = (int)w32_child_pids[i];
2012 remove_dead_process(i);
2017 errno = GetLastError();
2022 win32_waitpid(int pid, int *status, int flags)
2025 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2028 if (pid == -1) /* XXX threadid == 1 ? */
2029 return win32_internal_wait(status, timeout);
2032 child = find_pseudo_pid(-pid);
2034 HANDLE hThread = w32_pseudo_child_handles[child];
2036 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2037 if (waitcode == WAIT_TIMEOUT) {
2040 else if (waitcode == WAIT_OBJECT_0) {
2041 if (GetExitCodeThread(hThread, &waitcode)) {
2042 *status = (int)((waitcode & 0xff) << 8);
2043 retval = (int)w32_pseudo_child_pids[child];
2044 remove_dead_pseudo_process(child);
2051 else if (IsWin95()) {
2060 child = find_pid(pid);
2062 hProcess = w32_child_handles[child];
2063 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2064 if (waitcode == WAIT_TIMEOUT) {
2067 else if (waitcode == WAIT_OBJECT_0) {
2068 if (GetExitCodeProcess(hProcess, &waitcode)) {
2069 *status = (int)((waitcode & 0xff) << 8);
2070 retval = (int)w32_child_pids[child];
2071 remove_dead_process(child);
2080 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2081 (IsWin95() ? -pid : pid));
2083 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2084 if (waitcode == WAIT_TIMEOUT) {
2087 else if (waitcode == WAIT_OBJECT_0) {
2088 if (GetExitCodeProcess(hProcess, &waitcode)) {
2089 *status = (int)((waitcode & 0xff) << 8);
2090 CloseHandle(hProcess);
2094 CloseHandle(hProcess);
2100 return retval >= 0 ? pid : retval;
2104 win32_wait(int *status)
2106 return win32_internal_wait(status, INFINITE);
2109 DllExport unsigned int
2110 win32_sleep(unsigned int t)
2113 /* Win32 times are in ms so *1000 in and /1000 out */
2114 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2117 DllExport unsigned int
2118 win32_alarm(unsigned int sec)
2121 * the 'obvious' implentation is SetTimer() with a callback
2122 * which does whatever receiving SIGALRM would do
2123 * we cannot use SIGALRM even via raise() as it is not
2124 * one of the supported codes in <signal.h>
2128 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2132 KillTimer(NULL,w32_timerid);
2139 #ifdef HAVE_DES_FCRYPT
2140 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2144 win32_crypt(const char *txt, const char *salt)
2147 #ifdef HAVE_DES_FCRYPT
2148 return des_fcrypt(txt, salt, w32_crypt_buffer);
2150 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2155 #ifdef USE_FIXED_OSFHANDLE
2157 #define FOPEN 0x01 /* file handle open */
2158 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2159 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2160 #define FDEV 0x40 /* file handle refers to device */
2161 #define FTEXT 0x80 /* file handle is in text mode */
2164 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2167 * This function allocates a free C Runtime file handle and associates
2168 * it with the Win32 HANDLE specified by the first parameter. This is a
2169 * temperary fix for WIN95's brain damage GetFileType() error on socket
2170 * we just bypass that call for socket
2172 * This works with MSVC++ 4.0+ or GCC/Mingw32
2175 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2176 * int flags - flags to associate with C Runtime file handle.
2179 * returns index of entry in fh, if successful
2180 * return -1, if no free entry is found
2184 *******************************************************************************/
2187 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2188 * this lets sockets work on Win9X with GCC and should fix the problems
2193 /* create an ioinfo entry, kill its handle, and steal the entry */
2198 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2199 int fh = _open_osfhandle((intptr_t)hF, 0);
2203 EnterCriticalSection(&(_pioinfo(fh)->lock));
2208 my_open_osfhandle(intptr_t osfhandle, int flags)
2211 char fileflags; /* _osfile flags */
2213 /* copy relevant flags from second parameter */
2216 if (flags & O_APPEND)
2217 fileflags |= FAPPEND;
2222 if (flags & O_NOINHERIT)
2223 fileflags |= FNOINHERIT;
2225 /* attempt to allocate a C Runtime file handle */
2226 if ((fh = _alloc_osfhnd()) == -1) {
2227 errno = EMFILE; /* too many open files */
2228 _doserrno = 0L; /* not an OS error */
2229 return -1; /* return error to caller */
2232 /* the file is open. now, set the info in _osfhnd array */
2233 _set_osfhnd(fh, osfhandle);
2235 fileflags |= FOPEN; /* mark as open */
2237 _osfile(fh) = fileflags; /* set osfile entry */
2238 LeaveCriticalSection(&_pioinfo(fh)->lock);
2240 return fh; /* return handle */
2243 #endif /* USE_FIXED_OSFHANDLE */
2245 /* simulate flock by locking a range on the file */
2247 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2248 #define LK_LEN 0xffff0000
2251 win32_flock(int fd, int oper)
2259 Perl_croak_nocontext("flock() unimplemented on this platform");
2262 fh = (HANDLE)_get_osfhandle(fd);
2263 memset(&o, 0, sizeof(o));
2266 case LOCK_SH: /* shared lock */
2267 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2269 case LOCK_EX: /* exclusive lock */
2270 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2272 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2273 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2275 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2276 LK_ERR(LockFileEx(fh,
2277 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2278 0, LK_LEN, 0, &o),i);
2280 case LOCK_UN: /* unlock lock */
2281 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2283 default: /* unknown */
2294 * redirected io subsystem for all XS modules
2307 return (&(_environ));
2310 /* the rest are the remapped stdio routines */
2330 win32_ferror(FILE *fp)
2332 return (ferror(fp));
2337 win32_feof(FILE *fp)
2343 * Since the errors returned by the socket error function
2344 * WSAGetLastError() are not known by the library routine strerror
2345 * we have to roll our own.
2349 win32_strerror(int e)
2351 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2352 extern int sys_nerr;
2356 if (e < 0 || e > sys_nerr) {
2361 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2362 w32_strerror_buffer,
2363 sizeof(w32_strerror_buffer), NULL) == 0)
2364 strcpy(w32_strerror_buffer, "Unknown Error");
2366 return w32_strerror_buffer;
2372 win32_str_os_error(void *sv, DWORD dwErr)
2376 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2377 |FORMAT_MESSAGE_IGNORE_INSERTS
2378 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2379 dwErr, 0, (char *)&sMsg, 1, NULL);
2380 /* strip trailing whitespace and period */
2383 --dwLen; /* dwLen doesn't include trailing null */
2384 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2385 if ('.' != sMsg[dwLen])
2390 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2392 dwLen = sprintf(sMsg,
2393 "Unknown error #0x%lX (lookup 0x%lX)",
2394 dwErr, GetLastError());
2398 sv_setpvn((SV*)sv, sMsg, dwLen);
2404 win32_fprintf(FILE *fp, const char *format, ...)
2407 va_start(marker, format); /* Initialize variable arguments. */
2409 return (vfprintf(fp, format, marker));
2413 win32_printf(const char *format, ...)
2416 va_start(marker, format); /* Initialize variable arguments. */
2418 return (vprintf(format, marker));
2422 win32_vfprintf(FILE *fp, const char *format, va_list args)
2424 return (vfprintf(fp, format, args));
2428 win32_vprintf(const char *format, va_list args)
2430 return (vprintf(format, args));
2434 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2436 return fread(buf, size, count, fp);
2440 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2442 return fwrite(buf, size, count, fp);
2445 #define MODE_SIZE 10
2448 win32_fopen(const char *filename, const char *mode)
2451 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2457 if (stricmp(filename, "/dev/null")==0)
2461 A2WHELPER(mode, wMode, sizeof(wMode));
2462 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2463 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2466 f = fopen(PerlDir_mapA(filename), mode);
2467 /* avoid buffering headaches for child processes */
2468 if (f && *mode == 'a')
2469 win32_fseek(f, 0, SEEK_END);
2473 #ifndef USE_SOCKETS_AS_HANDLES
2475 #define fdopen my_fdopen
2479 win32_fdopen(int handle, const char *mode)
2482 WCHAR wMode[MODE_SIZE];
2485 A2WHELPER(mode, wMode, sizeof(wMode));
2486 f = _wfdopen(handle, wMode);
2489 f = fdopen(handle, (char *) mode);
2490 /* avoid buffering headaches for child processes */
2491 if (f && *mode == 'a')
2492 win32_fseek(f, 0, SEEK_END);
2497 win32_freopen(const char *path, const char *mode, FILE *stream)
2500 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2501 if (stricmp(path, "/dev/null")==0)
2505 A2WHELPER(mode, wMode, sizeof(wMode));
2506 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2507 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2509 return freopen(PerlDir_mapA(path), mode, stream);
2513 win32_fclose(FILE *pf)
2515 return my_fclose(pf); /* defined in win32sck.c */
2519 win32_fputs(const char *s,FILE *pf)
2521 return fputs(s, pf);
2525 win32_fputc(int c,FILE *pf)
2531 win32_ungetc(int c,FILE *pf)
2533 return ungetc(c,pf);
2537 win32_getc(FILE *pf)
2543 win32_fileno(FILE *pf)
2549 win32_clearerr(FILE *pf)
2556 win32_fflush(FILE *pf)
2562 win32_ftell(FILE *pf)
2564 #if defined(WIN64) || defined(USE_LARGE_FILES)
2566 if (fgetpos(pf, &pos))
2575 win32_fseek(FILE *pf, Off_t offset,int origin)
2577 #if defined(WIN64) || defined(USE_LARGE_FILES)
2581 if (fgetpos(pf, &pos))
2586 fseek(pf, 0, SEEK_END);
2587 pos = _telli64(fileno(pf));
2596 return fsetpos(pf, &offset);
2598 return fseek(pf, offset, origin);
2603 win32_fgetpos(FILE *pf,fpos_t *p)
2605 return fgetpos(pf, p);
2609 win32_fsetpos(FILE *pf,const fpos_t *p)
2611 return fsetpos(pf, p);
2615 win32_rewind(FILE *pf)
2625 char prefix[MAX_PATH+1];
2626 char filename[MAX_PATH+1];
2627 DWORD len = GetTempPath(MAX_PATH, prefix);
2628 if (len && len < MAX_PATH) {
2629 if (GetTempFileName(prefix, "plx", 0, filename)) {
2630 HANDLE fh = CreateFile(filename,
2631 DELETE | GENERIC_READ | GENERIC_WRITE,
2635 FILE_ATTRIBUTE_NORMAL
2636 | FILE_FLAG_DELETE_ON_CLOSE,
2638 if (fh != INVALID_HANDLE_VALUE) {
2639 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2641 #if defined(__BORLANDC__)
2642 setmode(fd,O_BINARY);
2644 DEBUG_p(PerlIO_printf(Perl_debug_log,
2645 "Created tmpfile=%s\n",filename));
2657 int fd = win32_tmpfd();
2659 return win32_fdopen(fd, "w+b");
2671 win32_fstat(int fd, Stat_t *sbufptr)
2674 /* A file designated by filehandle is not shown as accessible
2675 * for write operations, probably because it is opened for reading.
2678 int rc = fstat(fd,sbufptr);
2679 BY_HANDLE_FILE_INFORMATION bhfi;
2680 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2681 sbufptr->st_mode &= 0xFE00;
2682 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2683 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2685 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2686 + ((S_IREAD|S_IWRITE) >> 6));
2690 return my_fstat(fd,sbufptr);
2695 win32_pipe(int *pfd, unsigned int size, int mode)
2697 return _pipe(pfd, size, mode);
2701 win32_popenlist(const char *mode, IV narg, SV **args)
2704 Perl_croak(aTHX_ "List form of pipe open not implemented");
2709 * a popen() clone that respects PERL5SHELL
2711 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2715 win32_popen(const char *command, const char *mode)
2717 #ifdef USE_RTL_POPEN
2718 return _popen(command, mode);
2730 /* establish which ends read and write */
2731 if (strchr(mode,'w')) {
2732 stdfd = 0; /* stdin */
2735 nhandle = STD_INPUT_HANDLE;
2737 else if (strchr(mode,'r')) {
2738 stdfd = 1; /* stdout */
2741 nhandle = STD_OUTPUT_HANDLE;
2746 /* set the correct mode */
2747 if (strchr(mode,'b'))
2749 else if (strchr(mode,'t'))
2752 ourmode = _fmode & (O_TEXT | O_BINARY);
2754 /* the child doesn't inherit handles */
2755 ourmode |= O_NOINHERIT;
2757 if (win32_pipe(p, 512, ourmode) == -1)
2760 /* save current stdfd */
2761 if ((oldfd = win32_dup(stdfd)) == -1)
2764 /* save the old std handle (this needs to happen before the
2765 * dup2(), since that might call SetStdHandle() too) */
2768 old_h = GetStdHandle(nhandle);
2770 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2771 /* stdfd will be inherited by the child */
2772 if (win32_dup2(p[child], stdfd) == -1)
2775 /* close the child end in parent */
2776 win32_close(p[child]);
2778 /* set the new std handle (in case dup2() above didn't) */
2779 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2781 /* start the child */
2784 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2787 /* revert stdfd to whatever it was before */
2788 if (win32_dup2(oldfd, stdfd) == -1)
2791 /* restore the old std handle (this needs to happen after the
2792 * dup2(), since that might call SetStdHandle() too */
2794 SetStdHandle(nhandle, old_h);
2799 /* close saved handle */
2803 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2806 /* set process id so that it can be returned by perl's open() */
2807 PL_forkprocess = childpid;
2810 /* we have an fd, return a file stream */
2811 return (PerlIO_fdopen(p[parent], (char *)mode));
2814 /* we don't need to check for errors here */
2818 SetStdHandle(nhandle, old_h);
2823 win32_dup2(oldfd, stdfd);
2828 #endif /* USE_RTL_POPEN */
2836 win32_pclose(PerlIO *pf)
2838 #ifdef USE_RTL_POPEN
2842 int childpid, status;
2846 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2849 childpid = SvIVX(sv);
2866 if (win32_waitpid(childpid, &status, 0) == -1)
2871 #endif /* USE_RTL_POPEN */
2877 LPCWSTR lpExistingFileName,
2878 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2881 WCHAR wFullName[MAX_PATH+1];
2882 LPVOID lpContext = NULL;
2883 WIN32_STREAM_ID StreamId;
2884 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2889 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2890 BOOL, BOOL, LPVOID*) =
2891 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2892 BOOL, BOOL, LPVOID*))
2893 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2894 if (pfnBackupWrite == NULL)
2897 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2900 dwLen = (dwLen+1)*sizeof(WCHAR);
2902 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2903 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2904 NULL, OPEN_EXISTING, 0, NULL);
2905 if (handle == INVALID_HANDLE_VALUE)
2908 StreamId.dwStreamId = BACKUP_LINK;
2909 StreamId.dwStreamAttributes = 0;
2910 StreamId.dwStreamNameSize = 0;
2911 #if defined(__BORLANDC__) \
2912 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2913 StreamId.Size.u.HighPart = 0;
2914 StreamId.Size.u.LowPart = dwLen;
2916 StreamId.Size.HighPart = 0;
2917 StreamId.Size.LowPart = dwLen;
2920 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2921 FALSE, FALSE, &lpContext);
2923 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2924 FALSE, FALSE, &lpContext);
2925 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2928 CloseHandle(handle);
2933 win32_link(const char *oldname, const char *newname)
2936 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2937 WCHAR wOldName[MAX_PATH+1];
2938 WCHAR wNewName[MAX_PATH+1];
2941 Perl_croak(aTHX_ PL_no_func, "link");
2943 pfnCreateHardLinkW =
2944 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2945 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2946 if (pfnCreateHardLinkW == NULL)
2947 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2949 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2950 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2951 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2952 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2956 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2961 win32_rename(const char *oname, const char *newname)
2963 WCHAR wOldName[MAX_PATH+1];
2964 WCHAR wNewName[MAX_PATH+1];
2965 char szOldName[MAX_PATH+1];
2966 char szNewName[MAX_PATH+1];
2970 /* XXX despite what the documentation says about MoveFileEx(),
2971 * it doesn't work under Windows95!
2974 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2976 A2WHELPER(oname, wOldName, sizeof(wOldName));
2977 A2WHELPER(newname, wNewName, sizeof(wNewName));
2978 if (wcsicmp(wNewName, wOldName))
2979 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2980 wcscpy(wOldName, PerlDir_mapW(wOldName));
2981 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2984 if (stricmp(newname, oname))
2985 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2986 strcpy(szOldName, PerlDir_mapA(oname));
2987 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2990 DWORD err = GetLastError();
2992 case ERROR_BAD_NET_NAME:
2993 case ERROR_BAD_NETPATH:
2994 case ERROR_BAD_PATHNAME:
2995 case ERROR_FILE_NOT_FOUND:
2996 case ERROR_FILENAME_EXCED_RANGE:
2997 case ERROR_INVALID_DRIVE:
2998 case ERROR_NO_MORE_FILES:
2999 case ERROR_PATH_NOT_FOUND:
3012 char szTmpName[MAX_PATH+1];
3013 char dname[MAX_PATH+1];
3014 char *endname = Nullch;
3016 DWORD from_attr, to_attr;
3018 strcpy(szOldName, PerlDir_mapA(oname));
3019 strcpy(szNewName, PerlDir_mapA(newname));
3021 /* if oname doesn't exist, do nothing */
3022 from_attr = GetFileAttributes(szOldName);
3023 if (from_attr == 0xFFFFFFFF) {
3028 /* if newname exists, rename it to a temporary name so that we
3029 * don't delete it in case oname happens to be the same file
3030 * (but perhaps accessed via a different path)
3032 to_attr = GetFileAttributes(szNewName);
3033 if (to_attr != 0xFFFFFFFF) {
3034 /* if newname is a directory, we fail
3035 * XXX could overcome this with yet more convoluted logic */
3036 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3040 tmplen = strlen(szNewName);
3041 strcpy(szTmpName,szNewName);
3042 endname = szTmpName+tmplen;
3043 for (; endname > szTmpName ; --endname) {
3044 if (*endname == '/' || *endname == '\\') {
3049 if (endname > szTmpName)
3050 endname = strcpy(dname,szTmpName);
3054 /* get a temporary filename in same directory
3055 * XXX is this really the best we can do? */
3056 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3060 DeleteFile(szTmpName);
3062 retval = rename(szNewName, szTmpName);
3069 /* rename oname to newname */
3070 retval = rename(szOldName, szNewName);
3072 /* if we created a temporary file before ... */
3073 if (endname != Nullch) {
3074 /* ...and rename succeeded, delete temporary file/directory */
3076 DeleteFile(szTmpName);
3077 /* else restore it to what it was */
3079 (void)rename(szTmpName, szNewName);
3086 win32_setmode(int fd, int mode)
3088 return setmode(fd, mode);
3092 win32_chsize(int fd, Off_t size)
3094 #if defined(WIN64) || defined(USE_LARGE_FILES)
3096 Off_t cur, end, extend;
3098 cur = win32_tell(fd);
3101 end = win32_lseek(fd, 0, SEEK_END);
3104 extend = size - end;
3108 else if (extend > 0) {
3109 /* must grow the file, padding with nulls */
3111 int oldmode = win32_setmode(fd, O_BINARY);
3113 memset(b, '\0', sizeof(b));
3115 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3116 count = win32_write(fd, b, count);
3121 } while ((extend -= count) > 0);
3122 win32_setmode(fd, oldmode);
3125 /* shrink the file */
3126 win32_lseek(fd, size, SEEK_SET);
3127 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3133 win32_lseek(fd, cur, SEEK_SET);
3136 return chsize(fd, size);
3141 win32_lseek(int fd, Off_t offset, int origin)
3143 #if defined(WIN64) || defined(USE_LARGE_FILES)
3144 return _lseeki64(fd, offset, origin);
3146 return lseek(fd, offset, origin);
3153 #if defined(WIN64) || defined(USE_LARGE_FILES)
3154 return _telli64(fd);
3161 win32_open(const char *path, int flag, ...)
3166 WCHAR wBuffer[MAX_PATH+1];
3169 pmode = va_arg(ap, int);
3172 if (stricmp(path, "/dev/null")==0)
3176 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3177 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3179 return open(PerlDir_mapA(path), flag, pmode);
3182 /* close() that understands socket */
3183 extern int my_close(int); /* in win32sck.c */
3188 return my_close(fd);
3204 win32_dup2(int fd1,int fd2)
3206 return dup2(fd1,fd2);
3209 #ifdef PERL_MSVCRT_READFIX
3211 #define LF 10 /* line feed */
3212 #define CR 13 /* carriage return */
3213 #define CTRLZ 26 /* ctrl-z means eof for text */
3214 #define FOPEN 0x01 /* file handle open */
3215 #define FEOFLAG 0x02 /* end of file has been encountered */
3216 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3217 #define FPIPE 0x08 /* file handle refers to a pipe */
3218 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3219 #define FDEV 0x40 /* file handle refers to device */
3220 #define FTEXT 0x80 /* file handle is in text mode */
3221 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3224 _fixed_read(int fh, void *buf, unsigned cnt)
3226 int bytes_read; /* number of bytes read */
3227 char *buffer; /* buffer to read to */
3228 int os_read; /* bytes read on OS call */
3229 char *p, *q; /* pointers into buffer */
3230 char peekchr; /* peek-ahead character */
3231 ULONG filepos; /* file position after seek */
3232 ULONG dosretval; /* o.s. return value */
3234 /* validate handle */
3235 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3236 !(_osfile(fh) & FOPEN))
3238 /* out of range -- return error */
3240 _doserrno = 0; /* not o.s. error */
3245 * If lockinitflag is FALSE, assume fd is device
3246 * lockinitflag is set to TRUE by open.
3248 if (_pioinfo(fh)->lockinitflag)
3249 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3251 bytes_read = 0; /* nothing read yet */
3252 buffer = (char*)buf;
3254 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3255 /* nothing to read or at EOF, so return 0 read */
3259 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3260 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3262 *buffer++ = _pipech(fh);
3265 _pipech(fh) = LF; /* mark as empty */
3270 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3272 /* ReadFile has reported an error. recognize two special cases.
3274 * 1. map ERROR_ACCESS_DENIED to EBADF
3276 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3277 * means the handle is a read-handle on a pipe for which
3278 * all write-handles have been closed and all data has been
3281 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3282 /* wrong read/write mode should return EBADF, not EACCES */
3284 _doserrno = dosretval;
3288 else if (dosretval == ERROR_BROKEN_PIPE) {
3298 bytes_read += os_read; /* update bytes read */
3300 if (_osfile(fh) & FTEXT) {
3301 /* now must translate CR-LFs to LFs in the buffer */
3303 /* set CRLF flag to indicate LF at beginning of buffer */
3304 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3305 /* _osfile(fh) |= FCRLF; */
3307 /* _osfile(fh) &= ~FCRLF; */
3309 _osfile(fh) &= ~FCRLF;
3311 /* convert chars in the buffer: p is src, q is dest */
3313 while (p < (char *)buf + bytes_read) {
3315 /* if fh is not a device, set ctrl-z flag */
3316 if (!(_osfile(fh) & FDEV))
3317 _osfile(fh) |= FEOFLAG;
3318 break; /* stop translating */
3323 /* *p is CR, so must check next char for LF */
3324 if (p < (char *)buf + bytes_read - 1) {
3327 *q++ = LF; /* convert CR-LF to LF */
3330 *q++ = *p++; /* store char normally */
3333 /* This is the hard part. We found a CR at end of
3334 buffer. We must peek ahead to see if next char
3339 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3340 (LPDWORD)&os_read, NULL))
3341 dosretval = GetLastError();
3343 if (dosretval != 0 || os_read == 0) {
3344 /* couldn't read ahead, store CR */
3348 /* peekchr now has the extra character -- we now
3349 have several possibilities:
3350 1. disk file and char is not LF; just seek back
3352 2. disk file and char is LF; store LF, don't seek back
3353 3. pipe/device and char is LF; store LF.
3354 4. pipe/device and char isn't LF, store CR and
3355 put char in pipe lookahead buffer. */
3356 if (_osfile(fh) & (FDEV|FPIPE)) {
3357 /* non-seekable device */
3362 _pipech(fh) = peekchr;
3367 if (peekchr == LF) {
3368 /* nothing read yet; must make some
3371 /* turn on this flag for tell routine */
3372 _osfile(fh) |= FCRLF;
3375 HANDLE osHandle; /* o.s. handle value */
3377 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3379 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3380 dosretval = GetLastError();
3391 /* we now change bytes_read to reflect the true number of chars
3393 bytes_read = q - (char *)buf;
3397 if (_pioinfo(fh)->lockinitflag)
3398 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3403 #endif /* PERL_MSVCRT_READFIX */
3406 win32_read(int fd, void *buf, unsigned int cnt)
3408 #ifdef PERL_MSVCRT_READFIX
3409 return _fixed_read(fd, buf, cnt);
3411 return read(fd, buf, cnt);
3416 win32_write(int fd, const void *buf, unsigned int cnt)
3418 return write(fd, buf, cnt);
3422 win32_mkdir(const char *dir, int mode)
3426 WCHAR wBuffer[MAX_PATH+1];
3427 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3428 return _wmkdir(PerlDir_mapW(wBuffer));
3430 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3434 win32_rmdir(const char *dir)
3438 WCHAR wBuffer[MAX_PATH+1];
3439 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3440 return _wrmdir(PerlDir_mapW(wBuffer));
3442 return rmdir(PerlDir_mapA(dir));
3446 win32_chdir(const char *dir)
3454 WCHAR wBuffer[MAX_PATH+1];
3455 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3456 return _wchdir(wBuffer);
3462 win32_access(const char *path, int mode)
3466 WCHAR wBuffer[MAX_PATH+1];
3467 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3468 return _waccess(PerlDir_mapW(wBuffer), mode);
3470 return access(PerlDir_mapA(path), mode);
3474 win32_chmod(const char *path, int mode)
3478 WCHAR wBuffer[MAX_PATH+1];
3479 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3480 return _wchmod(PerlDir_mapW(wBuffer), mode);
3482 return chmod(PerlDir_mapA(path), mode);
3487 create_command_line(char *cname, STRLEN clen, const char * const *args)
3494 bool bat_file = FALSE;
3495 bool cmd_shell = FALSE;
3496 bool dumb_shell = FALSE;
3497 bool extra_quotes = FALSE;
3498 bool quote_next = FALSE;
3501 cname = (char*)args[0];
3503 /* The NT cmd.exe shell has the following peculiarity that needs to be
3504 * worked around. It strips a leading and trailing dquote when any
3505 * of the following is true:
3506 * 1. the /S switch was used
3507 * 2. there are more than two dquotes
3508 * 3. there is a special character from this set: &<>()@^|
3509 * 4. no whitespace characters within the two dquotes
3510 * 5. string between two dquotes isn't an executable file
3511 * To work around this, we always add a leading and trailing dquote
3512 * to the string, if the first argument is either "cmd.exe" or "cmd",
3513 * and there were at least two or more arguments passed to cmd.exe
3514 * (not including switches).
3515 * XXX the above rules (from "cmd /?") don't seem to be applied
3516 * always, making for the convolutions below :-(
3520 clen = strlen(cname);
3523 && (stricmp(&cname[clen-4], ".bat") == 0
3524 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3530 char *exe = strrchr(cname, '/');
3531 char *exe2 = strrchr(cname, '\\');
3538 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3542 else if (stricmp(exe, "command.com") == 0
3543 || stricmp(exe, "command") == 0)
3550 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3551 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3552 STRLEN curlen = strlen(arg);
3553 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3554 len += 2; /* assume quoting needed (worst case) */
3556 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3558 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3561 New(1310, cmd, len, char);
3566 extra_quotes = TRUE;
3569 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3571 STRLEN curlen = strlen(arg);
3573 /* we want to protect empty arguments and ones with spaces with
3574 * dquotes, but only if they aren't already there */
3579 else if (quote_next) {
3580 /* see if it really is multiple arguments pretending to
3581 * be one and force a set of quotes around it */
3582 if (*find_next_space(arg))
3585 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3587 while (i < curlen) {
3588 if (isSPACE(arg[i])) {
3591 else if (arg[i] == '"') {
3615 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3616 && stricmp(arg+curlen-2, "/c") == 0)
3618 /* is there a next argument? */
3619 if (args[index+1]) {
3620 /* are there two or more next arguments? */
3621 if (args[index+2]) {
3623 extra_quotes = TRUE;
3626 /* single argument, force quoting if it has spaces */
3642 qualified_path(const char *cmd)
3646 char *fullcmd, *curfullcmd;
3652 fullcmd = (char*)cmd;
3654 if (*fullcmd == '/' || *fullcmd == '\\')
3661 pathstr = PerlEnv_getenv("PATH");
3662 New(0, fullcmd, MAX_PATH+1, char);
3663 curfullcmd = fullcmd;
3668 /* start by appending the name to the current prefix */
3669 strcpy(curfullcmd, cmd);
3670 curfullcmd += cmdlen;
3672 /* if it doesn't end with '.', or has no extension, try adding
3673 * a trailing .exe first */
3674 if (cmd[cmdlen-1] != '.'
3675 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3677 strcpy(curfullcmd, ".exe");
3678 res = GetFileAttributes(fullcmd);
3679 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3684 /* that failed, try the bare name */
3685 res = GetFileAttributes(fullcmd);
3686 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3689 /* quit if no other path exists, or if cmd already has path */
3690 if (!pathstr || !*pathstr || has_slash)
3693 /* skip leading semis */
3694 while (*pathstr == ';')
3697 /* build a new prefix from scratch */
3698 curfullcmd = fullcmd;
3699 while (*pathstr && *pathstr != ';') {
3700 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3701 pathstr++; /* skip initial '"' */
3702 while (*pathstr && *pathstr != '"') {
3703 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3704 *curfullcmd++ = *pathstr;
3708 pathstr++; /* skip trailing '"' */
3711 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3712 *curfullcmd++ = *pathstr;
3717 pathstr++; /* skip trailing semi */
3718 if (curfullcmd > fullcmd /* append a dir separator */
3719 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3721 *curfullcmd++ = '\\';
3729 /* The following are just place holders.
3730 * Some hosts may provide and environment that the OS is
3731 * not tracking, therefore, these host must provide that
3732 * environment and the current directory to CreateProcess
3736 win32_get_childenv(void)
3742 win32_free_childenv(void* d)
3747 win32_clearenv(void)
3749 char *envv = GetEnvironmentStrings();
3753 char *end = strchr(cur,'=');
3754 if (end && end != cur) {
3756 SetEnvironmentVariable(cur, NULL);
3758 cur = end + strlen(end+1)+2;
3760 else if ((len = strlen(cur)))
3763 FreeEnvironmentStrings(envv);
3767 win32_get_childdir(void)
3771 char szfilename[(MAX_PATH+1)*2];
3773 WCHAR wfilename[MAX_PATH+1];
3774 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3775 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3778 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3781 New(0, ptr, strlen(szfilename)+1, char);
3782 strcpy(ptr, szfilename);
3787 win32_free_childdir(char* d)
3794 /* XXX this needs to be made more compatible with the spawnvp()
3795 * provided by the various RTLs. In particular, searching for
3796 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3797 * This doesn't significantly affect perl itself, because we
3798 * always invoke things using PERL5SHELL if a direct attempt to
3799 * spawn the executable fails.
3801 * XXX splitting and rejoining the commandline between do_aspawn()
3802 * and win32_spawnvp() could also be avoided.
3806 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3808 #ifdef USE_RTL_SPAWNVP
3809 return spawnvp(mode, cmdname, (char * const *)argv);
3816 STARTUPINFO StartupInfo;
3817 PROCESS_INFORMATION ProcessInformation;
3820 char *fullcmd = Nullch;
3821 char *cname = (char *)cmdname;
3825 clen = strlen(cname);
3826 /* if command name contains dquotes, must remove them */
3827 if (strchr(cname, '"')) {
3829 New(0,cname,clen+1,char);
3842 cmd = create_command_line(cname, clen, argv);
3844 env = PerlEnv_get_childenv();
3845 dir = PerlEnv_get_childdir();
3848 case P_NOWAIT: /* asynch + remember result */
3849 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3854 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3857 create |= CREATE_NEW_PROCESS_GROUP;
3860 case P_WAIT: /* synchronous execution */
3862 default: /* invalid mode */
3867 memset(&StartupInfo,0,sizeof(StartupInfo));
3868 StartupInfo.cb = sizeof(StartupInfo);
3869 memset(&tbl,0,sizeof(tbl));
3870 PerlEnv_get_child_IO(&tbl);
3871 StartupInfo.dwFlags = tbl.dwFlags;
3872 StartupInfo.dwX = tbl.dwX;
3873 StartupInfo.dwY = tbl.dwY;
3874 StartupInfo.dwXSize = tbl.dwXSize;
3875 StartupInfo.dwYSize = tbl.dwYSize;
3876 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3877 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3878 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3879 StartupInfo.wShowWindow = tbl.wShowWindow;
3880 StartupInfo.hStdInput = tbl.childStdIn;
3881 StartupInfo.hStdOutput = tbl.childStdOut;
3882 StartupInfo.hStdError = tbl.childStdErr;
3883 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3884 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3885 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3887 create |= CREATE_NEW_CONSOLE;
3890 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3892 if (w32_use_showwindow) {
3893 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3894 StartupInfo.wShowWindow = w32_showwindow;
3897 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3900 if (!CreateProcess(cname, /* search PATH to find executable */
3901 cmd, /* executable, and its arguments */
3902 NULL, /* process attributes */
3903 NULL, /* thread attributes */
3904 TRUE, /* inherit handles */
3905 create, /* creation flags */
3906 (LPVOID)env, /* inherit environment */
3907 dir, /* inherit cwd */
3909 &ProcessInformation))
3911 /* initial NULL argument to CreateProcess() does a PATH
3912 * search, but it always first looks in the directory
3913 * where the current process was started, which behavior
3914 * is undesirable for backward compatibility. So we
3915 * jump through our own hoops by picking out the path
3916 * we really want it to use. */
3918 fullcmd = qualified_path(cname);
3920 if (cname != cmdname)
3923 DEBUG_p(PerlIO_printf(Perl_debug_log,
3924 "Retrying [%s] with same args\n",
3934 if (mode == P_NOWAIT) {
3935 /* asynchronous spawn -- store handle, return PID */
3936 ret = (int)ProcessInformation.dwProcessId;
3937 if (IsWin95() && ret < 0)
3940 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3941 w32_child_pids[w32_num_children] = (DWORD)ret;
3946 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3947 /* FIXME: if msgwait returned due to message perhaps forward the
3948 "signal" to the process
3950 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3952 CloseHandle(ProcessInformation.hProcess);
3955 CloseHandle(ProcessInformation.hThread);
3958 PerlEnv_free_childenv(env);
3959 PerlEnv_free_childdir(dir);
3961 if (cname != cmdname)
3968 win32_execv(const char *cmdname, const char *const *argv)
3972 /* if this is a pseudo-forked child, we just want to spawn
3973 * the new program, and return */
3975 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3977 return execv(cmdname, (char *const *)argv);
3981 win32_execvp(const char *cmdname, const char *const *argv)
3985 /* if this is a pseudo-forked child, we just want to spawn
3986 * the new program, and return */
3987 if (w32_pseudo_id) {
3988 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3997 return execvp(cmdname, (char *const *)argv);
4001 win32_perror(const char *str)
4007 win32_setbuf(FILE *pf, char *buf)
4013 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4015 return setvbuf(pf, buf, type, size);
4019 win32_flushall(void)
4025 win32_fcloseall(void)
4031 win32_fgets(char *s, int n, FILE *pf)
4033 return fgets(s, n, pf);
4043 win32_fgetc(FILE *pf)
4049 win32_putc(int c, FILE *pf)
4055 win32_puts(const char *s)
4067 win32_putchar(int c)
4074 #ifndef USE_PERL_SBRK
4076 static char *committed = NULL; /* XXX threadead */
4077 static char *base = NULL; /* XXX threadead */
4078 static char *reserved = NULL; /* XXX threadead */
4079 static char *brk = NULL; /* XXX threadead */
4080 static DWORD pagesize = 0; /* XXX threadead */
4081 static DWORD allocsize = 0; /* XXX threadead */
4084 sbrk(ptrdiff_t need)
4089 GetSystemInfo(&info);
4090 /* Pretend page size is larger so we don't perpetually
4091 * call the OS to commit just one page ...
4093 pagesize = info.dwPageSize << 3;
4094 allocsize = info.dwAllocationGranularity;
4096 /* This scheme fails eventually if request for contiguous
4097 * block is denied so reserve big blocks - this is only
4098 * address space not memory ...
4100 if (brk+need >= reserved)
4102 DWORD size = 64*1024*1024;
4104 if (committed && reserved && committed < reserved)
4106 /* Commit last of previous chunk cannot span allocations */
4107 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4109 committed = reserved;
4111 /* Reserve some (more) space
4112 * Note this is a little sneaky, 1st call passes NULL as reserved
4113 * so lets system choose where we start, subsequent calls pass
4114 * the old end address so ask for a contiguous block
4116 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4119 reserved = addr+size;
4134 if (brk > committed)
4136 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4137 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4152 win32_malloc(size_t size)
4154 return malloc(size);
4158 win32_calloc(size_t numitems, size_t size)
4160 return calloc(numitems,size);
4164 win32_realloc(void *block, size_t size)
4166 return realloc(block,size);
4170 win32_free(void *block)
4177 win32_open_osfhandle(intptr_t handle, int flags)
4179 #ifdef USE_FIXED_OSFHANDLE
4181 return my_open_osfhandle(handle, flags);
4183 return _open_osfhandle(handle, flags);
4187 win32_get_osfhandle(int fd)
4189 return (intptr_t)_get_osfhandle(fd);
4193 win32_fdupopen(FILE *pf)
4198 int fileno = win32_dup(win32_fileno(pf));
4200 /* open the file in the same mode */
4202 if((pf)->flags & _F_READ) {
4206 else if((pf)->flags & _F_WRIT) {
4210 else if((pf)->flags & _F_RDWR) {
4216 if((pf)->_flag & _IOREAD) {
4220 else if((pf)->_flag & _IOWRT) {
4224 else if((pf)->_flag & _IORW) {
4231 /* it appears that the binmode is attached to the
4232 * file descriptor so binmode files will be handled
4235 pfdup = win32_fdopen(fileno, mode);
4237 /* move the file pointer to the same position */
4238 if (!fgetpos(pf, &pos)) {
4239 fsetpos(pfdup, &pos);
4245 win32_dynaload(const char* filename)
4249 char buf[MAX_PATH+1];
4252 /* LoadLibrary() doesn't recognize forward slashes correctly,
4253 * so turn 'em back. */
4254 first = strchr(filename, '/');
4256 STRLEN len = strlen(filename);
4257 if (len <= MAX_PATH) {
4258 strcpy(buf, filename);
4259 filename = &buf[first - filename];
4261 if (*filename == '/')
4262 *(char*)filename = '\\';
4269 WCHAR wfilename[MAX_PATH+1];
4270 A2WHELPER(filename, wfilename, sizeof(wfilename));
4271 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4274 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4284 XS(w32_SetChildShowWindow)
4287 BOOL use_showwindow = w32_use_showwindow;
4288 /* use "unsigned short" because Perl has redefined "WORD" */
4289 unsigned short showwindow = w32_showwindow;
4292 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4294 if (items == 0 || !SvOK(ST(0)))
4295 w32_use_showwindow = FALSE;
4297 w32_use_showwindow = TRUE;
4298 w32_showwindow = (unsigned short)SvIV(ST(0));
4303 ST(0) = sv_2mortal(newSViv(showwindow));
4305 ST(0) = &PL_sv_undef;
4313 /* Make the host for current directory */
4314 char* ptr = PerlEnv_get_childdir();
4317 * then it worked, set PV valid,
4318 * else return 'undef'
4321 SV *sv = sv_newmortal();
4323 PerlEnv_free_childdir(ptr);
4325 #ifndef INCOMPLETE_TAINTS
4342 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4343 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4350 XS(w32_GetNextAvailDrive)
4354 char root[] = "_:\\";
4359 if (GetDriveType(root) == 1) {
4368 XS(w32_GetLastError)
4372 XSRETURN_IV(GetLastError());
4376 XS(w32_SetLastError)
4380 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4381 SetLastError(SvIV(ST(0)));
4389 char *name = w32_getlogin_buffer;
4390 DWORD size = sizeof(w32_getlogin_buffer);
4392 if (GetUserName(name,&size)) {
4393 /* size includes NULL */
4394 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4404 char name[MAX_COMPUTERNAME_LENGTH+1];
4405 DWORD size = sizeof(name);
4407 if (GetComputerName(name,&size)) {
4408 /* size does NOT include NULL :-( */
4409 ST(0) = sv_2mortal(newSVpvn(name,size));
4420 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4421 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4422 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4426 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4427 GetProcAddress(hNetApi32, "NetApiBufferFree");
4428 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4429 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4432 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4433 /* this way is more reliable, in case user has a local account. */
4435 DWORD dnamelen = sizeof(dname);
4437 DWORD wki100_platform_id;
4438 LPWSTR wki100_computername;
4439 LPWSTR wki100_langroup;
4440 DWORD wki100_ver_major;
4441 DWORD wki100_ver_minor;
4443 /* NERR_Success *is* 0*/
4444 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4445 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4446 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4447 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4450 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4451 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4453 pfnNetApiBufferFree(pwi);
4454 FreeLibrary(hNetApi32);
4457 FreeLibrary(hNetApi32);
4460 /* Win95 doesn't have NetWksta*(), so do it the old way */
4462 DWORD size = sizeof(name);
4464 FreeLibrary(hNetApi32);
4465 if (GetUserName(name,&size)) {
4466 char sid[ONE_K_BUFSIZE];
4467 DWORD sidlen = sizeof(sid);
4469 DWORD dnamelen = sizeof(dname);
4471 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4472 dname, &dnamelen, &snu)) {
4473 XSRETURN_PV(dname); /* all that for this */
4485 DWORD flags, filecomplen;
4486 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4487 &flags, fsname, sizeof(fsname))) {
4488 if (GIMME_V == G_ARRAY) {
4489 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4490 XPUSHs(sv_2mortal(newSViv(flags)));
4491 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4496 XSRETURN_PV(fsname);
4502 XS(w32_GetOSVersion)
4505 /* Use explicit struct definition because wSuiteMask and
4506 * wProductType are not defined in the VC++ 6.0 headers.
4507 * WORD type has been replaced by unsigned short because
4508 * WORD is already used by Perl itself.
4511 DWORD dwOSVersionInfoSize;
4512 DWORD dwMajorVersion;
4513 DWORD dwMinorVersion;
4514 DWORD dwBuildNumber;
4516 CHAR szCSDVersion[128];
4517 unsigned short wServicePackMajor;
4518 unsigned short wServicePackMinor;
4519 unsigned short wSuiteMask;
4527 DWORD dwOSVersionInfoSize;
4528 DWORD dwMajorVersion;
4529 DWORD dwMinorVersion;
4530 DWORD dwBuildNumber;
4532 WCHAR szCSDVersion[128];
4533 unsigned short wServicePackMajor;
4534 unsigned short wServicePackMinor;
4535 unsigned short wSuiteMask;
4539 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4540 osverw.dwOSVersionInfoSize = sizeof(osverw);
4541 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4543 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4544 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4548 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4549 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4550 osver.dwMajorVersion = osverw.dwMajorVersion;
4551 osver.dwMinorVersion = osverw.dwMinorVersion;
4552 osver.dwBuildNumber = osverw.dwBuildNumber;
4553 osver.dwPlatformId = osverw.dwPlatformId;
4554 osver.wServicePackMajor = osverw.wServicePackMajor;
4555 osver.wServicePackMinor = osverw.wServicePackMinor;
4556 osver.wSuiteMask = osverw.wSuiteMask;
4557 osver.wProductType = osverw.wProductType;
4560 osver.dwOSVersionInfoSize = sizeof(osver);
4561 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4563 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4564 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4568 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4570 XPUSHs(newSViv(osver.dwMajorVersion));
4571 XPUSHs(newSViv(osver.dwMinorVersion));
4572 XPUSHs(newSViv(osver.dwBuildNumber));
4573 XPUSHs(newSViv(osver.dwPlatformId));
4575 XPUSHs(newSViv(osver.wServicePackMajor));
4576 XPUSHs(newSViv(osver.wServicePackMinor));
4577 XPUSHs(newSViv(osver.wSuiteMask));
4578 XPUSHs(newSViv(osver.wProductType));
4588 XSRETURN_IV(IsWinNT());
4596 XSRETURN_IV(IsWin95());
4600 XS(w32_FormatMessage)
4604 char msgbuf[ONE_K_BUFSIZE];
4607 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4610 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4611 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4612 &source, SvIV(ST(0)), 0,
4613 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4615 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4616 XSRETURN_PV(msgbuf);
4620 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4621 &source, SvIV(ST(0)), 0,
4622 msgbuf, sizeof(msgbuf)-1, NULL))
4623 XSRETURN_PV(msgbuf);
4636 PROCESS_INFORMATION stProcInfo;
4637 STARTUPINFO stStartInfo;
4638 BOOL bSuccess = FALSE;
4641 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4643 cmd = SvPV_nolen(ST(0));
4644 args = SvPV_nolen(ST(1));
4646 env = PerlEnv_get_childenv();
4647 dir = PerlEnv_get_childdir();
4649 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4650 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4651 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4652 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4655 cmd, /* Image path */
4656 args, /* Arguments for command line */
4657 NULL, /* Default process security */
4658 NULL, /* Default thread security */
4659 FALSE, /* Must be TRUE to use std handles */
4660 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4661 env, /* Inherit our environment block */
4662 dir, /* Inherit our currrent directory */
4663 &stStartInfo, /* -> Startup info */
4664 &stProcInfo)) /* <- Process info (if OK) */
4666 int pid = (int)stProcInfo.dwProcessId;
4667 if (IsWin95() && pid < 0)
4669 sv_setiv(ST(2), pid);
4670 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4673 PerlEnv_free_childenv(env);
4674 PerlEnv_free_childdir(dir);
4675 XSRETURN_IV(bSuccess);
4679 XS(w32_GetTickCount)
4682 DWORD msec = GetTickCount();
4690 XS(w32_GetShortPathName)
4697 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4699 shortpath = sv_mortalcopy(ST(0));
4700 SvUPGRADE(shortpath, SVt_PV);
4701 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4704 /* src == target is allowed */
4706 len = GetShortPathName(SvPVX(shortpath),
4709 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4711 SvCUR_set(shortpath,len);
4712 *SvEND(shortpath) = '\0';
4720 XS(w32_GetFullPathName)
4729 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4732 fullpath = sv_mortalcopy(filename);
4733 SvUPGRADE(fullpath, SVt_PV);
4734 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4738 len = GetFullPathName(SvPVX(filename),
4742 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4744 if (GIMME_V == G_ARRAY) {
4747 XST_mPV(1,filepart);
4748 len = filepart - SvPVX(fullpath);
4755 SvCUR_set(fullpath,len);
4756 *SvEND(fullpath) = '\0';
4764 XS(w32_GetLongPathName)
4768 char tmpbuf[MAX_PATH+1];
4773 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4776 pathstr = SvPV(path,len);
4777 strcpy(tmpbuf, pathstr);
4778 pathstr = win32_longpath(tmpbuf);
4780 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4791 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4802 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4804 WCHAR wSourceFile[MAX_PATH+1];
4805 WCHAR wDestFile[MAX_PATH+1];
4806 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4807 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4808 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4809 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4812 char szSourceFile[MAX_PATH+1];
4813 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4814 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4823 Perl_init_os_extras(void)
4826 char *file = __FILE__;
4829 /* these names are Activeware compatible */
4830 newXS("Win32::GetCwd", w32_GetCwd, file);
4831 newXS("Win32::SetCwd", w32_SetCwd, file);
4832 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4833 newXS("Win32::GetLastError", w32_GetLastError, file);
4834 newXS("Win32::SetLastError", w32_SetLastError, file);
4835 newXS("Win32::LoginName", w32_LoginName, file);
4836 newXS("Win32::NodeName", w32_NodeName, file);
4837 newXS("Win32::DomainName", w32_DomainName, file);
4838 newXS("Win32::FsType", w32_FsType, file);
4839 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4840 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4841 newXS("Win32::IsWin95", w32_IsWin95, file);
4842 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4843 newXS("Win32::Spawn", w32_Spawn, file);
4844 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4845 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4846 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4847 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4848 newXS("Win32::CopyFile", w32_CopyFile, file);
4849 newXS("Win32::Sleep", w32_Sleep, file);
4850 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4852 /* XXX Bloat Alert! The following Activeware preloads really
4853 * ought to be part of Win32::Sys::*, so they're not included
4856 /* LookupAccountName
4858 * InitiateSystemShutdown
4859 * AbortSystemShutdown
4860 * ExpandEnvrironmentStrings
4865 win32_signal_context(void)
4870 my_perl = PL_curinterp;
4871 PERL_SET_THX(my_perl);
4875 return PL_curinterp;
4881 win32_ctrlhandler(DWORD dwCtrlType)
4884 dTHXa(PERL_GET_SIG_CONTEXT);
4890 switch(dwCtrlType) {
4891 case CTRL_CLOSE_EVENT:
4892 /* A signal that the system sends to all processes attached to a console when
4893 the user closes the console (either by choosing the Close command from the
4894 console window's System menu, or by choosing the End Task command from the
4897 if (do_raise(aTHX_ 1)) /* SIGHUP */
4898 sig_terminate(aTHX_ 1);
4902 /* A CTRL+c signal was received */
4903 if (do_raise(aTHX_ SIGINT))
4904 sig_terminate(aTHX_ SIGINT);
4907 case CTRL_BREAK_EVENT:
4908 /* A CTRL+BREAK signal was received */
4909 if (do_raise(aTHX_ SIGBREAK))
4910 sig_terminate(aTHX_ SIGBREAK);
4913 case CTRL_LOGOFF_EVENT:
4914 /* A signal that the system sends to all console processes when a user is logging
4915 off. This signal does not indicate which user is logging off, so no
4916 assumptions can be made.
4919 case CTRL_SHUTDOWN_EVENT:
4920 /* A signal that the system sends to all console processes when the system is
4923 if (do_raise(aTHX_ SIGTERM))
4924 sig_terminate(aTHX_ SIGTERM);
4934 Perl_win32_init(int *argcp, char ***argvp)
4936 /* Disable floating point errors, Perl will trap the ones we
4937 * care about. VC++ RTL defaults to switching these off
4938 * already, but the Borland RTL doesn't. Since we don't
4939 * want to be at the vendor's whim on the default, we set
4940 * it explicitly here.
4942 #if !defined(_ALPHA_) && !defined(__GNUC__)
4943 _control87(MCW_EM, MCW_EM);
4949 Perl_win32_term(void)
4956 win32_get_child_IO(child_IO_table* ptbl)
4958 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4959 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4960 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4964 win32_signal(int sig, Sighandler_t subcode)
4967 if (sig < SIG_SIZE) {
4968 int save_errno = errno;
4969 Sighandler_t result = signal(sig, subcode);
4970 if (result == SIG_ERR) {
4971 result = w32_sighandler[sig];
4974 w32_sighandler[sig] = subcode;
4984 #ifdef HAVE_INTERP_INTERN
4988 win32_csighandler(int sig)
4991 dTHXa(PERL_GET_SIG_CONTEXT);
4992 Perl_warn(aTHX_ "Got signal %d",sig);
4998 Perl_sys_intern_init(pTHX)
5001 w32_perlshell_tokens = Nullch;
5002 w32_perlshell_vec = (char**)NULL;
5003 w32_perlshell_items = 0;
5004 w32_fdpid = newAV();
5005 New(1313, w32_children, 1, child_tab);
5006 w32_num_children = 0;
5007 # ifdef USE_ITHREADS
5009 New(1313, w32_pseudo_children, 1, child_tab);
5010 w32_num_pseudo_children = 0;
5012 w32_init_socktype = 0;
5015 for (i=0; i < SIG_SIZE; i++) {
5016 w32_sighandler[i] = SIG_DFL;
5019 if (my_perl == PL_curinterp) {
5023 /* Force C runtime signal stuff to set its console handler */
5024 signal(SIGINT,&win32_csighandler);
5025 signal(SIGBREAK,&win32_csighandler);
5026 /* Push our handler on top */
5027 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5032 Perl_sys_intern_clear(pTHX)
5034 Safefree(w32_perlshell_tokens);
5035 Safefree(w32_perlshell_vec);
5036 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5037 Safefree(w32_children);
5039 KillTimer(NULL,w32_timerid);
5042 # ifdef MULTIPLICITY
5043 if (my_perl == PL_curinterp) {
5047 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5049 # ifdef USE_ITHREADS
5050 Safefree(w32_pseudo_children);
5054 # ifdef USE_ITHREADS
5057 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5059 dst->perlshell_tokens = Nullch;
5060 dst->perlshell_vec = (char**)NULL;
5061 dst->perlshell_items = 0;
5062 dst->fdpid = newAV();
5063 Newz(1313, dst->children, 1, child_tab);
5065 Newz(1313, dst->pseudo_children, 1, child_tab);
5066 dst->thr_intern.Winit_socktype = 0;
5068 dst->poll_count = 0;
5069 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5071 # endif /* USE_ITHREADS */
5072 #endif /* HAVE_INTERP_INTERN */
5075 win32_free_argvw(pTHX_ void *ptr)
5077 char** argv = (char**)ptr;
5085 win32_argv2utf8(int argc, char** argv)
5090 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5091 if (lpwStr && argc) {
5093 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5094 Newz(0, psz, length, char);
5095 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5098 call_atexit(win32_free_argvw, argv);
5100 GlobalFree((HGLOBAL)lpwStr);