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_ const char *cmd, int exectype);
96 static BOOL has_shell_metachars(const 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
121 /* Silence STDERR grumblings from Borland's math library. */
123 _matherr(struct _exception *a)
133 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
139 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
143 set_w32_module_name(void)
146 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
147 ? GetModuleHandle(NULL)
148 : w32_perldll_handle),
149 w32_module_name, sizeof(w32_module_name));
151 /* remove \\?\ prefix */
152 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
153 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
155 /* try to get full path to binary (which may be mangled when perl is
156 * run from a 16-bit app) */
157 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
158 (void)win32_longpath(w32_module_name);
159 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
161 /* normalize to forward slashes */
162 ptr = w32_module_name;
170 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
172 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
174 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
177 const char *subkey = "Software\\Perl";
181 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
182 if (retval == ERROR_SUCCESS) {
184 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
185 if (retval == ERROR_SUCCESS
186 && (type == REG_SZ || type == REG_EXPAND_SZ))
190 *svp = sv_2mortal(newSVpvn("",0));
191 SvGROW(*svp, datalen);
192 retval = RegQueryValueEx(handle, valuename, 0, NULL,
193 (PBYTE)SvPVX(*svp), &datalen);
194 if (retval == ERROR_SUCCESS) {
196 SvCUR_set(*svp,datalen-1);
204 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
206 get_regstr(const char *valuename, SV **svp)
208 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
210 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
214 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
216 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
220 char mod_name[MAX_PATH+1];
226 va_start(ap, trailing_path);
227 strip = va_arg(ap, char *);
229 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
230 baselen = strlen(base);
232 if (!*w32_module_name) {
233 set_w32_module_name();
235 strcpy(mod_name, w32_module_name);
236 ptr = strrchr(mod_name, '/');
237 while (ptr && strip) {
238 /* look for directories to skip back */
241 ptr = strrchr(mod_name, '/');
242 /* avoid stripping component if there is no slash,
243 * or it doesn't match ... */
244 if (!ptr || stricmp(ptr+1, strip) != 0) {
245 /* ... but not if component matches m|5\.$patchlevel.*| */
246 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
247 && strncmp(strip, base, baselen) == 0
248 && strncmp(ptr+1, base, baselen) == 0))
254 strip = va_arg(ap, char *);
262 strcpy(++ptr, trailing_path);
264 /* only add directory if it exists */
265 if (GetFileAttributes(mod_name) != (DWORD) -1) {
266 /* directory exists */
269 *prev_pathp = sv_2mortal(newSVpvn("",0));
270 else if (SvPVX(*prev_pathp))
271 sv_catpvn(*prev_pathp, ";", 1);
272 sv_catpv(*prev_pathp, mod_name);
273 return SvPVX(*prev_pathp);
280 win32_get_privlib(const char *pl)
283 char *stdlib = "lib";
284 char buffer[MAX_PATH+1];
287 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
288 sprintf(buffer, "%s-%s", stdlib, pl);
289 if (!get_regstr(buffer, &sv))
290 (void)get_regstr(stdlib, &sv);
292 /* $stdlib .= ";$EMD/../../lib" */
293 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
297 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
301 char pathstr[MAX_PATH+1];
305 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
306 sprintf(regstr, "%s-%s", xlib, pl);
307 (void)get_regstr(regstr, &sv1);
310 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
311 sprintf(pathstr, "%s/%s/lib", libname, pl);
312 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
314 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
315 (void)get_regstr(xlib, &sv2);
318 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
319 sprintf(pathstr, "%s/lib", libname);
320 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
329 sv_catpvn(sv1, ";", 1);
336 win32_get_sitelib(const char *pl)
338 return win32_get_xlib(pl, "sitelib", "site");
341 #ifndef PERL_VENDORLIB_NAME
342 # define PERL_VENDORLIB_NAME "vendor"
346 win32_get_vendorlib(const char *pl)
348 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
352 has_shell_metachars(const char *ptr)
358 * Scan string looking for redirection (< or >) or pipe
359 * characters (|) that are not in a quoted string.
360 * Shell variable interpolation (%VAR%) can also happen inside strings.
392 #if !defined(PERL_IMPLICIT_SYS)
393 /* since the current process environment is being updated in util.c
394 * the library functions will get the correct environment
397 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
400 #define fixcmd(x) { \
401 char *pspace = strchr((x),' '); \
404 while (p < pspace) { \
415 PERL_FLUSHALL_FOR_CHILD;
416 return win32_popen(cmd, mode);
420 Perl_my_pclose(pTHX_ PerlIO *fp)
422 return win32_pclose(fp);
426 DllExport unsigned long
429 static OSVERSIONINFO osver;
431 if (osver.dwPlatformId != w32_platform) {
432 memset(&osver, 0, sizeof(OSVERSIONINFO));
433 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
434 GetVersionEx(&osver);
435 w32_platform = osver.dwPlatformId;
437 return (unsigned long)w32_platform;
447 return -((int)w32_pseudo_id);
450 /* Windows 9x appears to always reports a pid for threads and processes
451 * that has the high bit set. So we treat the lower 31 bits as the
452 * "real" PID for Perl's purposes. */
453 if (IsWin95() && pid < 0)
458 /* Tokenize a string. Words are null-separated, and the list
459 * ends with a doubled null. Any character (except null and
460 * including backslash) may be escaped by preceding it with a
461 * backslash (the backslash will be stripped).
462 * Returns number of words in result buffer.
465 tokenize(const char *str, char **dest, char ***destv)
467 char *retstart = Nullch;
468 char **retvstart = 0;
472 int slen = strlen(str);
474 register char **retv;
475 Newx(ret, slen+2, char);
476 Newx(retv, (slen+3)/2, char*);
484 if (*ret == '\\' && *str)
486 else if (*ret == ' ') {
502 retvstart[items] = Nullch;
515 if (!w32_perlshell_tokens) {
516 /* we don't use COMSPEC here for two reasons:
517 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
518 * uncontrolled unportability of the ensuing scripts.
519 * 2. PERL5SHELL could be set to a shell that may not be fit for
520 * interactive use (which is what most programs look in COMSPEC
523 const char* defaultshell = (IsWinNT()
524 ? "cmd.exe /x/d/c" : "command.com /c");
525 const char *usershell = PerlEnv_getenv("PERL5SHELL");
526 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
527 &w32_perlshell_tokens,
533 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
545 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
547 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
552 while (++mark <= sp) {
553 if (*mark && (str = SvPV_nolen(*mark)))
560 status = win32_spawnvp(flag,
561 (const char*)(really ? SvPV_nolen(really) : argv[0]),
562 (const char* const*)argv);
564 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
565 /* possible shell-builtin, invoke with shell */
567 sh_items = w32_perlshell_items;
569 argv[index+sh_items] = argv[index];
570 while (--sh_items >= 0)
571 argv[sh_items] = w32_perlshell_vec[sh_items];
573 status = win32_spawnvp(flag,
574 (const char*)(really ? SvPV_nolen(really) : argv[0]),
575 (const char* const*)argv);
578 if (flag == P_NOWAIT) {
580 PL_statusvalue = -1; /* >16bits hint for pp_system() */
584 if (ckWARN(WARN_EXEC))
585 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
590 PL_statusvalue = status;
596 /* returns pointer to the next unquoted space or the end of the string */
598 find_next_space(const char *s)
600 bool in_quotes = FALSE;
602 /* ignore doubled backslashes, or backslash+quote */
603 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
606 /* keep track of when we're within quotes */
607 else if (*s == '"') {
609 in_quotes = !in_quotes;
611 /* break it up only at spaces that aren't in quotes */
612 else if (!in_quotes && isSPACE(*s))
621 do_spawn2(pTHX_ const char *cmd, int exectype)
627 BOOL needToTry = TRUE;
630 /* Save an extra exec if possible. See if there are shell
631 * metacharacters in it */
632 if (!has_shell_metachars(cmd)) {
633 Newx(argv, strlen(cmd) / 2 + 2, char*);
634 Newx(cmd2, strlen(cmd) + 1, char);
637 for (s = cmd2; *s;) {
638 while (*s && isSPACE(*s))
642 s = find_next_space(s);
650 status = win32_spawnvp(P_WAIT, argv[0],
651 (const char* const*)argv);
653 case EXECF_SPAWN_NOWAIT:
654 status = win32_spawnvp(P_NOWAIT, argv[0],
655 (const char* const*)argv);
658 status = win32_execvp(argv[0], (const char* const*)argv);
661 if (status != -1 || errno == 0)
671 Newx(argv, w32_perlshell_items + 2, char*);
672 while (++i < w32_perlshell_items)
673 argv[i] = w32_perlshell_vec[i];
674 argv[i++] = (char *)cmd;
678 status = win32_spawnvp(P_WAIT, argv[0],
679 (const char* const*)argv);
681 case EXECF_SPAWN_NOWAIT:
682 status = win32_spawnvp(P_NOWAIT, argv[0],
683 (const char* const*)argv);
686 status = win32_execvp(argv[0], (const char* const*)argv);
692 if (exectype == EXECF_SPAWN_NOWAIT) {
694 PL_statusvalue = -1; /* >16bits hint for pp_system() */
698 if (ckWARN(WARN_EXEC))
699 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
700 (exectype == EXECF_EXEC ? "exec" : "spawn"),
701 cmd, strerror(errno));
706 PL_statusvalue = status;
712 Perl_do_spawn(pTHX_ char *cmd)
714 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
718 Perl_do_spawn_nowait(pTHX_ char *cmd)
720 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
724 Perl_do_exec(pTHX_ const char *cmd)
726 do_spawn2(aTHX_ cmd, EXECF_EXEC);
730 /* The idea here is to read all the directory names into a string table
731 * (separated by nulls) and when one of the other dir functions is called
732 * return the pointer to the current file name.
735 win32_opendir(const char *filename)
741 char scanname[MAX_PATH+3];
743 WIN32_FIND_DATAA aFindData;
744 WIN32_FIND_DATAW wFindData;
746 char buffer[MAX_PATH*2];
747 WCHAR wbuffer[MAX_PATH+1];
750 len = strlen(filename);
754 /* check to see if filename is a directory */
755 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
758 /* Get us a DIR structure */
761 /* Create the search pattern */
762 strcpy(scanname, filename);
764 /* bare drive name means look in cwd for drive */
765 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
766 scanname[len++] = '.';
767 scanname[len++] = '/';
769 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
770 scanname[len++] = '/';
772 scanname[len++] = '*';
773 scanname[len] = '\0';
775 /* do the FindFirstFile call */
777 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
778 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
781 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
784 if (fh == INVALID_HANDLE_VALUE) {
785 DWORD err = GetLastError();
786 /* FindFirstFile() fails on empty drives! */
788 case ERROR_FILE_NOT_FOUND:
790 case ERROR_NO_MORE_FILES:
791 case ERROR_PATH_NOT_FOUND:
794 case ERROR_NOT_ENOUGH_MEMORY:
805 /* now allocate the first part of the string table for
806 * the filenames that we find.
809 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
813 ptr = aFindData.cFileName;
820 Newx(dirp->start, dirp->size, char);
821 strcpy(dirp->start, ptr);
823 dirp->end = dirp->curr = dirp->start;
829 /* Readdir just returns the current string pointer and bumps the
830 * string pointer to the nDllExport entry.
832 DllExport struct direct *
833 win32_readdir(DIR *dirp)
838 /* first set up the structure to return */
839 len = strlen(dirp->curr);
840 strcpy(dirp->dirstr.d_name, dirp->curr);
841 dirp->dirstr.d_namlen = len;
844 dirp->dirstr.d_ino = dirp->curr - dirp->start;
846 /* Now set up for the next call to readdir */
847 dirp->curr += len + 1;
848 if (dirp->curr >= dirp->end) {
852 WIN32_FIND_DATAW wFindData;
853 WIN32_FIND_DATAA aFindData;
854 char buffer[MAX_PATH*2];
856 /* finding the next file that matches the wildcard
857 * (which should be all of them in this directory!).
860 res = FindNextFileW(dirp->handle, &wFindData);
862 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
867 res = FindNextFileA(dirp->handle, &aFindData);
869 ptr = aFindData.cFileName;
872 long endpos = dirp->end - dirp->start;
873 long newsize = endpos + strlen(ptr) + 1;
874 /* bump the string table size by enough for the
875 * new name and its null terminator */
876 while (newsize > dirp->size) {
877 long curpos = dirp->curr - dirp->start;
879 Renew(dirp->start, dirp->size, char);
880 dirp->curr = dirp->start + curpos;
882 strcpy(dirp->start + endpos, ptr);
883 dirp->end = dirp->start + newsize;
889 return &(dirp->dirstr);
895 /* Telldir returns the current string pointer position */
897 win32_telldir(DIR *dirp)
899 return (dirp->curr - dirp->start);
903 /* Seekdir moves the string pointer to a previously saved position
904 * (returned by telldir).
907 win32_seekdir(DIR *dirp, long loc)
909 dirp->curr = dirp->start + loc;
912 /* Rewinddir resets the string pointer to the start */
914 win32_rewinddir(DIR *dirp)
916 dirp->curr = dirp->start;
919 /* free the memory allocated by opendir */
921 win32_closedir(DIR *dirp)
924 if (dirp->handle != INVALID_HANDLE_VALUE)
925 FindClose(dirp->handle);
926 Safefree(dirp->start);
939 * Just pretend that everyone is a superuser. NT will let us know if
940 * we don\'t really have permission to do something.
943 #define ROOT_UID ((uid_t)0)
944 #define ROOT_GID ((gid_t)0)
973 return (auid == ROOT_UID ? 0 : -1);
979 return (agid == ROOT_GID ? 0 : -1);
986 char *buf = w32_getlogin_buffer;
987 DWORD size = sizeof(w32_getlogin_buffer);
988 if (GetUserName(buf,&size))
994 chown(const char *path, uid_t owner, gid_t group)
1001 * XXX this needs strengthening (for PerlIO)
1004 int mkstemp(const char *path)
1007 char buf[MAX_PATH+1];
1011 if (i++ > 10) { /* give up */
1015 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1019 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1029 long child = w32_num_children;
1030 while (--child >= 0) {
1031 if ((int)w32_child_pids[child] == pid)
1038 remove_dead_process(long child)
1042 CloseHandle(w32_child_handles[child]);
1043 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1044 (w32_num_children-child-1), HANDLE);
1045 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1046 (w32_num_children-child-1), DWORD);
1053 find_pseudo_pid(int pid)
1056 long child = w32_num_pseudo_children;
1057 while (--child >= 0) {
1058 if ((int)w32_pseudo_child_pids[child] == pid)
1065 remove_dead_pseudo_process(long child)
1069 CloseHandle(w32_pseudo_child_handles[child]);
1070 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1071 (w32_num_pseudo_children-child-1), HANDLE);
1072 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1073 (w32_num_pseudo_children-child-1), DWORD);
1074 w32_num_pseudo_children--;
1080 win32_kill(int pid, int sig)
1088 /* it is a pseudo-forked child */
1089 child = find_pseudo_pid(-pid);
1091 hProcess = w32_pseudo_child_handles[child];
1094 /* "Does process exist?" use of kill */
1097 /* kill -9 style un-graceful exit */
1098 if (TerminateThread(hProcess, sig)) {
1099 remove_dead_pseudo_process(child);
1104 /* We fake signals to pseudo-processes using Win32
1105 * message queue. In Win9X the pids are negative already. */
1106 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1107 /* It might be us ... */
1114 else if (IsWin95()) {
1122 child = find_pid(pid);
1124 hProcess = w32_child_handles[child];
1127 /* "Does process exist?" use of kill */
1130 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1135 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1138 default: /* For now be backwards compatible with perl5.6 */
1140 if (TerminateProcess(hProcess, sig)) {
1141 remove_dead_process(child);
1150 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1151 (IsWin95() ? -pid : pid));
1155 /* "Does process exist?" use of kill */
1159 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1164 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1167 default: /* For now be backwards compatible with perl5.6 */
1169 if (TerminateProcess(hProcess, sig))
1174 CloseHandle(hProcess);
1184 win32_stat(const char *path, Stat_t *sbuf)
1187 char buffer[MAX_PATH+1];
1188 int l = strlen(path);
1190 WCHAR wbuffer[MAX_PATH+1];
1196 switch(path[l - 1]) {
1197 /* FindFirstFile() and stat() are buggy with a trailing
1198 * backslash, so change it to a forward slash :-( */
1200 if (l >= sizeof(buffer)) {
1201 errno = ENAMETOOLONG;
1204 strncpy(buffer, path, l-1);
1205 buffer[l - 1] = '/';
1209 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1211 if (l == 2 && isALPHA(path[0])) {
1212 buffer[0] = path[0];
1223 /* We *must* open & close the file once; otherwise file attribute changes */
1224 /* might not yet have propagated to "other" hard links of the same file. */
1225 /* This also gives us an opportunity to determine the number of links. */
1227 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1228 pwbuffer = PerlDir_mapW(wbuffer);
1229 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1232 path = PerlDir_mapA(path);
1234 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1236 if (handle != INVALID_HANDLE_VALUE) {
1237 BY_HANDLE_FILE_INFORMATION bhi;
1238 if (GetFileInformationByHandle(handle, &bhi))
1239 nlink = bhi.nNumberOfLinks;
1240 CloseHandle(handle);
1243 /* pwbuffer or path will be mapped correctly above */
1245 #if defined(WIN64) || defined(USE_LARGE_FILES)
1246 res = _wstati64(pwbuffer, sbuf);
1248 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1252 #if defined(WIN64) || defined(USE_LARGE_FILES)
1253 res = _stati64(path, sbuf);
1255 res = stat(path, sbuf);
1258 sbuf->st_nlink = nlink;
1261 /* CRT is buggy on sharenames, so make sure it really isn't.
1262 * XXX using GetFileAttributesEx() will enable us to set
1263 * sbuf->st_*time (but note that's not available on the
1264 * Windows of 1995) */
1267 r = GetFileAttributesW(pwbuffer);
1270 r = GetFileAttributesA(path);
1272 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1273 /* sbuf may still contain old garbage since stat() failed */
1274 Zero(sbuf, 1, Stat_t);
1275 sbuf->st_mode = S_IFDIR | S_IREAD;
1277 if (!(r & FILE_ATTRIBUTE_READONLY))
1278 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1283 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1284 && (path[2] == '\\' || path[2] == '/'))
1286 /* The drive can be inaccessible, some _stat()s are buggy */
1288 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1289 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1295 if (S_ISDIR(sbuf->st_mode))
1296 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1297 else if (S_ISREG(sbuf->st_mode)) {
1299 if (l >= 4 && path[l-4] == '.') {
1300 const char *e = path + l - 3;
1301 if (strnicmp(e,"exe",3)
1302 && strnicmp(e,"bat",3)
1303 && strnicmp(e,"com",3)
1304 && (IsWin95() || strnicmp(e,"cmd",3)))
1305 sbuf->st_mode &= ~S_IEXEC;
1307 sbuf->st_mode |= S_IEXEC;
1310 sbuf->st_mode &= ~S_IEXEC;
1311 /* Propagate permissions to _group_ and _others_ */
1312 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1313 sbuf->st_mode |= (perms>>3) | (perms>>6);
1320 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1321 #define SKIP_SLASHES(s) \
1323 while (*(s) && isSLASH(*(s))) \
1326 #define COPY_NONSLASHES(d,s) \
1328 while (*(s) && !isSLASH(*(s))) \
1332 /* Find the longname of a given path. path is destructively modified.
1333 * It should have space for at least MAX_PATH characters. */
1335 win32_longpath(char *path)
1337 WIN32_FIND_DATA fdata;
1339 char tmpbuf[MAX_PATH+1];
1340 char *tmpstart = tmpbuf;
1347 if (isALPHA(path[0]) && path[1] == ':') {
1349 *tmpstart++ = path[0];
1353 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1355 *tmpstart++ = path[0];
1356 *tmpstart++ = path[1];
1357 SKIP_SLASHES(start);
1358 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1360 *tmpstart++ = *start++;
1361 SKIP_SLASHES(start);
1362 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1367 /* copy initial slash, if any */
1368 if (isSLASH(*start)) {
1369 *tmpstart++ = *start++;
1371 SKIP_SLASHES(start);
1374 /* FindFirstFile() expands "." and "..", so we need to pass
1375 * those through unmolested */
1377 && (!start[1] || isSLASH(start[1])
1378 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1380 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1385 /* if this is the end, bust outta here */
1389 /* now we're at a non-slash; walk up to next slash */
1390 while (*start && !isSLASH(*start))
1393 /* stop and find full name of component */
1396 fhand = FindFirstFile(path,&fdata);
1398 if (fhand != INVALID_HANDLE_VALUE) {
1399 STRLEN len = strlen(fdata.cFileName);
1400 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1401 strcpy(tmpstart, fdata.cFileName);
1412 /* failed a step, just return without side effects */
1413 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1418 strcpy(path,tmpbuf);
1423 win32_getenv(const char *name)
1426 WCHAR wBuffer[MAX_PATH+1];
1428 SV *curitem = Nullsv;
1431 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1432 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1435 needlen = GetEnvironmentVariableA(name,NULL,0);
1437 curitem = sv_2mortal(newSVpvn("", 0));
1441 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1442 needlen = GetEnvironmentVariableW(wBuffer,
1443 (WCHAR*)SvPVX(curitem),
1445 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1446 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1447 acuritem = sv_2mortal(newSVsv(curitem));
1448 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1452 SvGROW(curitem, needlen+1);
1453 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1455 } while (needlen >= SvLEN(curitem));
1456 SvCUR_set(curitem, needlen);
1460 /* allow any environment variables that begin with 'PERL'
1461 to be stored in the registry */
1462 if (strncmp(name, "PERL", 4) == 0)
1463 (void)get_regstr(name, &curitem);
1465 if (curitem && SvCUR(curitem))
1466 return SvPVX(curitem);
1472 win32_putenv(const char *name)
1479 int length, relval = -1;
1483 length = strlen(name)+1;
1484 Newx(wCuritem,length,WCHAR);
1485 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1486 wVal = wcschr(wCuritem, '=');
1489 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1495 Newx(curitem,strlen(name)+1,char);
1496 strcpy(curitem, name);
1497 val = strchr(curitem, '=');
1499 /* The sane way to deal with the environment.
1500 * Has these advantages over putenv() & co.:
1501 * * enables us to store a truly empty value in the
1502 * environment (like in UNIX).
1503 * * we don't have to deal with RTL globals, bugs and leaks.
1505 * Why you may want to enable USE_WIN32_RTL_ENV:
1506 * * environ[] and RTL functions will not reflect changes,
1507 * which might be an issue if extensions want to access
1508 * the env. via RTL. This cuts both ways, since RTL will
1509 * not see changes made by extensions that call the Win32
1510 * functions directly, either.
1514 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1524 filetime_to_clock(PFILETIME ft)
1526 __int64 qw = ft->dwHighDateTime;
1528 qw |= ft->dwLowDateTime;
1529 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1534 win32_times(struct tms *timebuf)
1539 clock_t process_time_so_far = clock();
1540 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1542 timebuf->tms_utime = filetime_to_clock(&user);
1543 timebuf->tms_stime = filetime_to_clock(&kernel);
1544 timebuf->tms_cutime = 0;
1545 timebuf->tms_cstime = 0;
1547 /* That failed - e.g. Win95 fallback to clock() */
1548 timebuf->tms_utime = process_time_so_far;
1549 timebuf->tms_stime = 0;
1550 timebuf->tms_cutime = 0;
1551 timebuf->tms_cstime = 0;
1553 return process_time_so_far;
1556 /* fix utime() so it works on directories in NT */
1558 filetime_from_time(PFILETIME pFileTime, time_t Time)
1560 struct tm *pTM = localtime(&Time);
1561 SYSTEMTIME SystemTime;
1567 SystemTime.wYear = pTM->tm_year + 1900;
1568 SystemTime.wMonth = pTM->tm_mon + 1;
1569 SystemTime.wDay = pTM->tm_mday;
1570 SystemTime.wHour = pTM->tm_hour;
1571 SystemTime.wMinute = pTM->tm_min;
1572 SystemTime.wSecond = pTM->tm_sec;
1573 SystemTime.wMilliseconds = 0;
1575 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1576 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1580 win32_unlink(const char *filename)
1587 WCHAR wBuffer[MAX_PATH+1];
1590 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1591 pwBuffer = PerlDir_mapW(wBuffer);
1592 attrs = GetFileAttributesW(pwBuffer);
1593 if (attrs == 0xFFFFFFFF)
1595 if (attrs & FILE_ATTRIBUTE_READONLY) {
1596 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1597 ret = _wunlink(pwBuffer);
1599 (void)SetFileAttributesW(pwBuffer, attrs);
1602 ret = _wunlink(pwBuffer);
1605 filename = PerlDir_mapA(filename);
1606 attrs = GetFileAttributesA(filename);
1607 if (attrs == 0xFFFFFFFF)
1609 if (attrs & FILE_ATTRIBUTE_READONLY) {
1610 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1611 ret = unlink(filename);
1613 (void)SetFileAttributesA(filename, attrs);
1616 ret = unlink(filename);
1625 win32_utime(const char *filename, struct utimbuf *times)
1632 struct utimbuf TimeBuffer;
1633 WCHAR wbuffer[MAX_PATH+1];
1638 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1639 pwbuffer = PerlDir_mapW(wbuffer);
1640 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1643 filename = PerlDir_mapA(filename);
1644 rc = utime(filename, times);
1646 /* EACCES: path specifies directory or readonly file */
1647 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1650 if (times == NULL) {
1651 times = &TimeBuffer;
1652 time(×->actime);
1653 times->modtime = times->actime;
1656 /* This will (and should) still fail on readonly files */
1658 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1659 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1660 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1663 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1664 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1665 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1667 if (handle == INVALID_HANDLE_VALUE)
1670 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1671 filetime_from_time(&ftAccess, times->actime) &&
1672 filetime_from_time(&ftWrite, times->modtime) &&
1673 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1678 CloseHandle(handle);
1683 unsigned __int64 ft_i64;
1688 #define Const64(x) x##LL
1690 #define Const64(x) x##i64
1692 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1693 #define EPOCH_BIAS Const64(116444736000000000)
1695 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1696 * and appears to be unsupported even by glibc) */
1698 win32_gettimeofday(struct timeval *tp, void *not_used)
1702 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1703 GetSystemTimeAsFileTime(&ft.ft_val);
1705 /* seconds since epoch */
1706 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1708 /* microseconds remaining */
1709 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1715 win32_uname(struct utsname *name)
1717 struct hostent *hep;
1718 STRLEN nodemax = sizeof(name->nodename)-1;
1719 OSVERSIONINFO osver;
1721 memset(&osver, 0, sizeof(OSVERSIONINFO));
1722 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1723 if (GetVersionEx(&osver)) {
1725 switch (osver.dwPlatformId) {
1726 case VER_PLATFORM_WIN32_WINDOWS:
1727 strcpy(name->sysname, "Windows");
1729 case VER_PLATFORM_WIN32_NT:
1730 strcpy(name->sysname, "Windows NT");
1732 case VER_PLATFORM_WIN32s:
1733 strcpy(name->sysname, "Win32s");
1736 strcpy(name->sysname, "Win32 Unknown");
1741 sprintf(name->release, "%d.%d",
1742 osver.dwMajorVersion, osver.dwMinorVersion);
1745 sprintf(name->version, "Build %d",
1746 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1747 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1748 if (osver.szCSDVersion[0]) {
1749 char *buf = name->version + strlen(name->version);
1750 sprintf(buf, " (%s)", osver.szCSDVersion);
1754 *name->sysname = '\0';
1755 *name->version = '\0';
1756 *name->release = '\0';
1760 hep = win32_gethostbyname("localhost");
1762 STRLEN len = strlen(hep->h_name);
1763 if (len <= nodemax) {
1764 strcpy(name->nodename, hep->h_name);
1767 strncpy(name->nodename, hep->h_name, nodemax);
1768 name->nodename[nodemax] = '\0';
1773 if (!GetComputerName(name->nodename, &sz))
1774 *name->nodename = '\0';
1777 /* machine (architecture) */
1782 GetSystemInfo(&info);
1784 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1785 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1786 procarch = info.u.s.wProcessorArchitecture;
1788 procarch = info.wProcessorArchitecture;
1791 case PROCESSOR_ARCHITECTURE_INTEL:
1792 arch = "x86"; break;
1793 case PROCESSOR_ARCHITECTURE_MIPS:
1794 arch = "mips"; break;
1795 case PROCESSOR_ARCHITECTURE_ALPHA:
1796 arch = "alpha"; break;
1797 case PROCESSOR_ARCHITECTURE_PPC:
1798 arch = "ppc"; break;
1799 #ifdef PROCESSOR_ARCHITECTURE_SHX
1800 case PROCESSOR_ARCHITECTURE_SHX:
1801 arch = "shx"; break;
1803 #ifdef PROCESSOR_ARCHITECTURE_ARM
1804 case PROCESSOR_ARCHITECTURE_ARM:
1805 arch = "arm"; break;
1807 #ifdef PROCESSOR_ARCHITECTURE_IA64
1808 case PROCESSOR_ARCHITECTURE_IA64:
1809 arch = "ia64"; break;
1811 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1812 case PROCESSOR_ARCHITECTURE_ALPHA64:
1813 arch = "alpha64"; break;
1815 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1816 case PROCESSOR_ARCHITECTURE_MSIL:
1817 arch = "msil"; break;
1819 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1820 case PROCESSOR_ARCHITECTURE_AMD64:
1821 arch = "amd64"; break;
1823 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1824 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1825 arch = "ia32-64"; break;
1827 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1828 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1829 arch = "unknown"; break;
1832 sprintf(name->machine, "unknown(0x%x)", procarch);
1833 arch = name->machine;
1836 if (name->machine != arch)
1837 strcpy(name->machine, arch);
1842 /* Timing related stuff */
1845 do_raise(pTHX_ int sig)
1847 if (sig < SIG_SIZE) {
1848 Sighandler_t handler = w32_sighandler[sig];
1849 if (handler == SIG_IGN) {
1852 else if (handler != SIG_DFL) {
1857 /* Choose correct default behaviour */
1873 /* Tell caller to exit thread/process as approriate */
1878 sig_terminate(pTHX_ int sig)
1880 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1881 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1888 win32_async_check(pTHX)
1892 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1893 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1895 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1897 switch(msg.message) {
1900 /* Perhaps some other messages could map to signals ? ... */
1903 /* Treat WM_QUIT like SIGHUP? */
1909 /* We use WM_USER to fake kill() with other signals */
1913 if (do_raise(aTHX_ sig)) {
1914 sig_terminate(aTHX_ sig);
1920 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1921 if (w32_timerid && w32_timerid==msg.wParam) {
1922 KillTimer(NULL,w32_timerid);
1927 /* Now fake a call to signal handler */
1928 if (do_raise(aTHX_ 14)) {
1929 sig_terminate(aTHX_ 14);
1934 /* Otherwise do normal Win32 thing - in case it is useful */
1937 TranslateMessage(&msg);
1938 DispatchMessage(&msg);
1945 /* Above or other stuff may have set a signal flag */
1946 if (PL_sig_pending) {
1952 /* This function will not return until the timeout has elapsed, or until
1953 * one of the handles is ready. */
1955 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1957 /* We may need several goes at this - so compute when we stop */
1959 if (timeout != INFINITE) {
1960 ticks = GetTickCount();
1964 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1967 if (result == WAIT_TIMEOUT) {
1968 /* Ran out of time - explicit return of zero to avoid -ve if we
1969 have scheduling issues
1973 if (timeout != INFINITE) {
1974 ticks = GetTickCount();
1976 if (result == WAIT_OBJECT_0 + count) {
1977 /* Message has arrived - check it */
1978 (void)win32_async_check(aTHX);
1981 /* Not timeout or message - one of handles is ready */
1985 /* compute time left to wait */
1986 ticks = timeout - ticks;
1987 /* If we are past the end say zero */
1988 return (ticks > 0) ? ticks : 0;
1992 win32_internal_wait(int *status, DWORD timeout)
1994 /* XXX this wait emulation only knows about processes
1995 * spawned via win32_spawnvp(P_NOWAIT, ...).
1999 DWORD exitcode, waitcode;
2002 if (w32_num_pseudo_children) {
2003 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2004 timeout, &waitcode);
2005 /* Time out here if there are no other children to wait for. */
2006 if (waitcode == WAIT_TIMEOUT) {
2007 if (!w32_num_children) {
2011 else if (waitcode != WAIT_FAILED) {
2012 if (waitcode >= WAIT_ABANDONED_0
2013 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2014 i = waitcode - WAIT_ABANDONED_0;
2016 i = waitcode - WAIT_OBJECT_0;
2017 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2018 *status = (int)((exitcode & 0xff) << 8);
2019 retval = (int)w32_pseudo_child_pids[i];
2020 remove_dead_pseudo_process(i);
2027 if (!w32_num_children) {
2032 /* if a child exists, wait for it to die */
2033 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2034 if (waitcode == WAIT_TIMEOUT) {
2037 if (waitcode != WAIT_FAILED) {
2038 if (waitcode >= WAIT_ABANDONED_0
2039 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2040 i = waitcode - WAIT_ABANDONED_0;
2042 i = waitcode - WAIT_OBJECT_0;
2043 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2044 *status = (int)((exitcode & 0xff) << 8);
2045 retval = (int)w32_child_pids[i];
2046 remove_dead_process(i);
2051 errno = GetLastError();
2056 win32_waitpid(int pid, int *status, int flags)
2059 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2062 if (pid == -1) /* XXX threadid == 1 ? */
2063 return win32_internal_wait(status, timeout);
2066 child = find_pseudo_pid(-pid);
2068 HANDLE hThread = w32_pseudo_child_handles[child];
2070 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2071 if (waitcode == WAIT_TIMEOUT) {
2074 else if (waitcode == WAIT_OBJECT_0) {
2075 if (GetExitCodeThread(hThread, &waitcode)) {
2076 *status = (int)((waitcode & 0xff) << 8);
2077 retval = (int)w32_pseudo_child_pids[child];
2078 remove_dead_pseudo_process(child);
2085 else if (IsWin95()) {
2094 child = find_pid(pid);
2096 hProcess = w32_child_handles[child];
2097 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2098 if (waitcode == WAIT_TIMEOUT) {
2101 else if (waitcode == WAIT_OBJECT_0) {
2102 if (GetExitCodeProcess(hProcess, &waitcode)) {
2103 *status = (int)((waitcode & 0xff) << 8);
2104 retval = (int)w32_child_pids[child];
2105 remove_dead_process(child);
2114 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2115 (IsWin95() ? -pid : pid));
2117 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2118 if (waitcode == WAIT_TIMEOUT) {
2119 CloseHandle(hProcess);
2122 else if (waitcode == WAIT_OBJECT_0) {
2123 if (GetExitCodeProcess(hProcess, &waitcode)) {
2124 *status = (int)((waitcode & 0xff) << 8);
2125 CloseHandle(hProcess);
2129 CloseHandle(hProcess);
2135 return retval >= 0 ? pid : retval;
2139 win32_wait(int *status)
2141 return win32_internal_wait(status, INFINITE);
2144 DllExport unsigned int
2145 win32_sleep(unsigned int t)
2148 /* Win32 times are in ms so *1000 in and /1000 out */
2149 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2152 DllExport unsigned int
2153 win32_alarm(unsigned int sec)
2156 * the 'obvious' implentation is SetTimer() with a callback
2157 * which does whatever receiving SIGALRM would do
2158 * we cannot use SIGALRM even via raise() as it is not
2159 * one of the supported codes in <signal.h>
2163 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2167 KillTimer(NULL,w32_timerid);
2174 #ifdef HAVE_DES_FCRYPT
2175 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2179 win32_crypt(const char *txt, const char *salt)
2182 #ifdef HAVE_DES_FCRYPT
2183 return des_fcrypt(txt, salt, w32_crypt_buffer);
2185 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2190 #ifdef USE_FIXED_OSFHANDLE
2192 #define FOPEN 0x01 /* file handle open */
2193 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2194 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2195 #define FDEV 0x40 /* file handle refers to device */
2196 #define FTEXT 0x80 /* file handle is in text mode */
2199 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2202 * This function allocates a free C Runtime file handle and associates
2203 * it with the Win32 HANDLE specified by the first parameter. This is a
2204 * temperary fix for WIN95's brain damage GetFileType() error on socket
2205 * we just bypass that call for socket
2207 * This works with MSVC++ 4.0+ or GCC/Mingw32
2210 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2211 * int flags - flags to associate with C Runtime file handle.
2214 * returns index of entry in fh, if successful
2215 * return -1, if no free entry is found
2219 *******************************************************************************/
2222 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2223 * this lets sockets work on Win9X with GCC and should fix the problems
2228 /* create an ioinfo entry, kill its handle, and steal the entry */
2233 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2234 int fh = _open_osfhandle((intptr_t)hF, 0);
2238 EnterCriticalSection(&(_pioinfo(fh)->lock));
2243 my_open_osfhandle(intptr_t osfhandle, int flags)
2246 char fileflags; /* _osfile flags */
2248 /* copy relevant flags from second parameter */
2251 if (flags & O_APPEND)
2252 fileflags |= FAPPEND;
2257 if (flags & O_NOINHERIT)
2258 fileflags |= FNOINHERIT;
2260 /* attempt to allocate a C Runtime file handle */
2261 if ((fh = _alloc_osfhnd()) == -1) {
2262 errno = EMFILE; /* too many open files */
2263 _doserrno = 0L; /* not an OS error */
2264 return -1; /* return error to caller */
2267 /* the file is open. now, set the info in _osfhnd array */
2268 _set_osfhnd(fh, osfhandle);
2270 fileflags |= FOPEN; /* mark as open */
2272 _osfile(fh) = fileflags; /* set osfile entry */
2273 LeaveCriticalSection(&_pioinfo(fh)->lock);
2275 return fh; /* return handle */
2278 #endif /* USE_FIXED_OSFHANDLE */
2280 /* simulate flock by locking a range on the file */
2282 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2283 #define LK_LEN 0xffff0000
2286 win32_flock(int fd, int oper)
2294 Perl_croak_nocontext("flock() unimplemented on this platform");
2297 fh = (HANDLE)_get_osfhandle(fd);
2298 memset(&o, 0, sizeof(o));
2301 case LOCK_SH: /* shared lock */
2302 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2304 case LOCK_EX: /* exclusive lock */
2305 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2307 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2308 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2310 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2311 LK_ERR(LockFileEx(fh,
2312 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2313 0, LK_LEN, 0, &o),i);
2315 case LOCK_UN: /* unlock lock */
2316 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2318 default: /* unknown */
2329 * redirected io subsystem for all XS modules
2342 return (&(_environ));
2345 /* the rest are the remapped stdio routines */
2365 win32_ferror(FILE *fp)
2367 return (ferror(fp));
2372 win32_feof(FILE *fp)
2378 * Since the errors returned by the socket error function
2379 * WSAGetLastError() are not known by the library routine strerror
2380 * we have to roll our own.
2384 win32_strerror(int e)
2386 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2387 extern int sys_nerr;
2391 if (e < 0 || e > sys_nerr) {
2396 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2397 w32_strerror_buffer,
2398 sizeof(w32_strerror_buffer), NULL) == 0)
2399 strcpy(w32_strerror_buffer, "Unknown Error");
2401 return w32_strerror_buffer;
2407 win32_str_os_error(void *sv, DWORD dwErr)
2411 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2412 |FORMAT_MESSAGE_IGNORE_INSERTS
2413 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2414 dwErr, 0, (char *)&sMsg, 1, NULL);
2415 /* strip trailing whitespace and period */
2418 --dwLen; /* dwLen doesn't include trailing null */
2419 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2420 if ('.' != sMsg[dwLen])
2425 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2427 dwLen = sprintf(sMsg,
2428 "Unknown error #0x%lX (lookup 0x%lX)",
2429 dwErr, GetLastError());
2433 sv_setpvn((SV*)sv, sMsg, dwLen);
2439 win32_fprintf(FILE *fp, const char *format, ...)
2442 va_start(marker, format); /* Initialize variable arguments. */
2444 return (vfprintf(fp, format, marker));
2448 win32_printf(const char *format, ...)
2451 va_start(marker, format); /* Initialize variable arguments. */
2453 return (vprintf(format, marker));
2457 win32_vfprintf(FILE *fp, const char *format, va_list args)
2459 return (vfprintf(fp, format, args));
2463 win32_vprintf(const char *format, va_list args)
2465 return (vprintf(format, args));
2469 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2471 return fread(buf, size, count, fp);
2475 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2477 return fwrite(buf, size, count, fp);
2480 #define MODE_SIZE 10
2483 win32_fopen(const char *filename, const char *mode)
2486 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2492 if (stricmp(filename, "/dev/null")==0)
2496 A2WHELPER(mode, wMode, sizeof(wMode));
2497 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2498 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2501 f = fopen(PerlDir_mapA(filename), mode);
2502 /* avoid buffering headaches for child processes */
2503 if (f && *mode == 'a')
2504 win32_fseek(f, 0, SEEK_END);
2508 #ifndef USE_SOCKETS_AS_HANDLES
2510 #define fdopen my_fdopen
2514 win32_fdopen(int handle, const char *mode)
2517 WCHAR wMode[MODE_SIZE];
2520 A2WHELPER(mode, wMode, sizeof(wMode));
2521 f = _wfdopen(handle, wMode);
2524 f = fdopen(handle, (char *) mode);
2525 /* avoid buffering headaches for child processes */
2526 if (f && *mode == 'a')
2527 win32_fseek(f, 0, SEEK_END);
2532 win32_freopen(const char *path, const char *mode, FILE *stream)
2535 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2536 if (stricmp(path, "/dev/null")==0)
2540 A2WHELPER(mode, wMode, sizeof(wMode));
2541 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2542 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2544 return freopen(PerlDir_mapA(path), mode, stream);
2548 win32_fclose(FILE *pf)
2550 return my_fclose(pf); /* defined in win32sck.c */
2554 win32_fputs(const char *s,FILE *pf)
2556 return fputs(s, pf);
2560 win32_fputc(int c,FILE *pf)
2566 win32_ungetc(int c,FILE *pf)
2568 return ungetc(c,pf);
2572 win32_getc(FILE *pf)
2578 win32_fileno(FILE *pf)
2584 win32_clearerr(FILE *pf)
2591 win32_fflush(FILE *pf)
2597 win32_ftell(FILE *pf)
2599 #if defined(WIN64) || defined(USE_LARGE_FILES)
2600 #if defined(__BORLANDC__) /* buk */
2601 return win32_tell( fileno( pf ) );
2604 if (fgetpos(pf, &pos))
2614 win32_fseek(FILE *pf, Off_t offset,int origin)
2616 #if defined(WIN64) || defined(USE_LARGE_FILES)
2617 #if defined(__BORLANDC__) /* buk */
2627 if (fgetpos(pf, &pos))
2632 fseek(pf, 0, SEEK_END);
2633 pos = _telli64(fileno(pf));
2642 return fsetpos(pf, &offset);
2645 return fseek(pf, (long)offset, origin);
2650 win32_fgetpos(FILE *pf,fpos_t *p)
2652 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2653 if( win32_tell(fileno(pf)) == -1L ) {
2659 return fgetpos(pf, p);
2664 win32_fsetpos(FILE *pf,const fpos_t *p)
2666 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2667 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2669 return fsetpos(pf, p);
2674 win32_rewind(FILE *pf)
2684 char prefix[MAX_PATH+1];
2685 char filename[MAX_PATH+1];
2686 DWORD len = GetTempPath(MAX_PATH, prefix);
2687 if (len && len < MAX_PATH) {
2688 if (GetTempFileName(prefix, "plx", 0, filename)) {
2689 HANDLE fh = CreateFile(filename,
2690 DELETE | GENERIC_READ | GENERIC_WRITE,
2694 FILE_ATTRIBUTE_NORMAL
2695 | FILE_FLAG_DELETE_ON_CLOSE,
2697 if (fh != INVALID_HANDLE_VALUE) {
2698 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2700 #if defined(__BORLANDC__)
2701 setmode(fd,O_BINARY);
2703 DEBUG_p(PerlIO_printf(Perl_debug_log,
2704 "Created tmpfile=%s\n",filename));
2716 int fd = win32_tmpfd();
2718 return win32_fdopen(fd, "w+b");
2730 win32_fstat(int fd, Stat_t *sbufptr)
2733 /* A file designated by filehandle is not shown as accessible
2734 * for write operations, probably because it is opened for reading.
2737 int rc = fstat(fd,sbufptr);
2738 BY_HANDLE_FILE_INFORMATION bhfi;
2739 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2740 sbufptr->st_mode &= 0xFE00;
2741 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2742 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2744 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2745 + ((S_IREAD|S_IWRITE) >> 6));
2749 return my_fstat(fd,sbufptr);
2754 win32_pipe(int *pfd, unsigned int size, int mode)
2756 return _pipe(pfd, size, mode);
2760 win32_popenlist(const char *mode, IV narg, SV **args)
2763 Perl_croak(aTHX_ "List form of pipe open not implemented");
2768 * a popen() clone that respects PERL5SHELL
2770 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2774 win32_popen(const char *command, const char *mode)
2776 #ifdef USE_RTL_POPEN
2777 return _popen(command, mode);
2789 /* establish which ends read and write */
2790 if (strchr(mode,'w')) {
2791 stdfd = 0; /* stdin */
2794 nhandle = STD_INPUT_HANDLE;
2796 else if (strchr(mode,'r')) {
2797 stdfd = 1; /* stdout */
2800 nhandle = STD_OUTPUT_HANDLE;
2805 /* set the correct mode */
2806 if (strchr(mode,'b'))
2808 else if (strchr(mode,'t'))
2811 ourmode = _fmode & (O_TEXT | O_BINARY);
2813 /* the child doesn't inherit handles */
2814 ourmode |= O_NOINHERIT;
2816 if (win32_pipe(p, 512, ourmode) == -1)
2819 /* save current stdfd */
2820 if ((oldfd = win32_dup(stdfd)) == -1)
2823 /* save the old std handle (this needs to happen before the
2824 * dup2(), since that might call SetStdHandle() too) */
2827 old_h = GetStdHandle(nhandle);
2829 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2830 /* stdfd will be inherited by the child */
2831 if (win32_dup2(p[child], stdfd) == -1)
2834 /* close the child end in parent */
2835 win32_close(p[child]);
2837 /* set the new std handle (in case dup2() above didn't) */
2838 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2840 /* start the child */
2843 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2846 /* revert stdfd to whatever it was before */
2847 if (win32_dup2(oldfd, stdfd) == -1)
2850 /* restore the old std handle (this needs to happen after the
2851 * dup2(), since that might call SetStdHandle() too */
2853 SetStdHandle(nhandle, old_h);
2858 /* close saved handle */
2862 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2865 /* set process id so that it can be returned by perl's open() */
2866 PL_forkprocess = childpid;
2869 /* we have an fd, return a file stream */
2870 return (PerlIO_fdopen(p[parent], (char *)mode));
2873 /* we don't need to check for errors here */
2877 SetStdHandle(nhandle, old_h);
2882 win32_dup2(oldfd, stdfd);
2887 #endif /* USE_RTL_POPEN */
2895 win32_pclose(PerlIO *pf)
2897 #ifdef USE_RTL_POPEN
2901 int childpid, status;
2905 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2908 childpid = SvIVX(sv);
2925 if (win32_waitpid(childpid, &status, 0) == -1)
2930 #endif /* USE_RTL_POPEN */
2936 LPCWSTR lpExistingFileName,
2937 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2940 WCHAR wFullName[MAX_PATH+1];
2941 LPVOID lpContext = NULL;
2942 WIN32_STREAM_ID StreamId;
2943 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2948 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2949 BOOL, BOOL, LPVOID*) =
2950 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2951 BOOL, BOOL, LPVOID*))
2952 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2953 if (pfnBackupWrite == NULL)
2956 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2959 dwLen = (dwLen+1)*sizeof(WCHAR);
2961 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2962 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2963 NULL, OPEN_EXISTING, 0, NULL);
2964 if (handle == INVALID_HANDLE_VALUE)
2967 StreamId.dwStreamId = BACKUP_LINK;
2968 StreamId.dwStreamAttributes = 0;
2969 StreamId.dwStreamNameSize = 0;
2970 #if defined(__BORLANDC__) \
2971 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2972 StreamId.Size.u.HighPart = 0;
2973 StreamId.Size.u.LowPart = dwLen;
2975 StreamId.Size.HighPart = 0;
2976 StreamId.Size.LowPart = dwLen;
2979 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2980 FALSE, FALSE, &lpContext);
2982 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2983 FALSE, FALSE, &lpContext);
2984 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2987 CloseHandle(handle);
2992 win32_link(const char *oldname, const char *newname)
2995 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2996 WCHAR wOldName[MAX_PATH+1];
2997 WCHAR wNewName[MAX_PATH+1];
3000 Perl_croak(aTHX_ PL_no_func, "link");
3002 pfnCreateHardLinkW =
3003 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3004 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3005 if (pfnCreateHardLinkW == NULL)
3006 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3008 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
3009 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
3010 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3011 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3015 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3020 win32_rename(const char *oname, const char *newname)
3022 WCHAR wOldName[MAX_PATH+1];
3023 WCHAR wNewName[MAX_PATH+1];
3024 char szOldName[MAX_PATH+1];
3025 char szNewName[MAX_PATH+1];
3029 /* XXX despite what the documentation says about MoveFileEx(),
3030 * it doesn't work under Windows95!
3033 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3035 A2WHELPER(oname, wOldName, sizeof(wOldName));
3036 A2WHELPER(newname, wNewName, sizeof(wNewName));
3037 if (wcsicmp(wNewName, wOldName))
3038 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3039 wcscpy(wOldName, PerlDir_mapW(wOldName));
3040 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
3043 if (stricmp(newname, oname))
3044 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3045 strcpy(szOldName, PerlDir_mapA(oname));
3046 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3049 DWORD err = GetLastError();
3051 case ERROR_BAD_NET_NAME:
3052 case ERROR_BAD_NETPATH:
3053 case ERROR_BAD_PATHNAME:
3054 case ERROR_FILE_NOT_FOUND:
3055 case ERROR_FILENAME_EXCED_RANGE:
3056 case ERROR_INVALID_DRIVE:
3057 case ERROR_NO_MORE_FILES:
3058 case ERROR_PATH_NOT_FOUND:
3071 char szTmpName[MAX_PATH+1];
3072 char dname[MAX_PATH+1];
3073 char *endname = Nullch;
3075 DWORD from_attr, to_attr;
3077 strcpy(szOldName, PerlDir_mapA(oname));
3078 strcpy(szNewName, PerlDir_mapA(newname));
3080 /* if oname doesn't exist, do nothing */
3081 from_attr = GetFileAttributes(szOldName);
3082 if (from_attr == 0xFFFFFFFF) {
3087 /* if newname exists, rename it to a temporary name so that we
3088 * don't delete it in case oname happens to be the same file
3089 * (but perhaps accessed via a different path)
3091 to_attr = GetFileAttributes(szNewName);
3092 if (to_attr != 0xFFFFFFFF) {
3093 /* if newname is a directory, we fail
3094 * XXX could overcome this with yet more convoluted logic */
3095 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3099 tmplen = strlen(szNewName);
3100 strcpy(szTmpName,szNewName);
3101 endname = szTmpName+tmplen;
3102 for (; endname > szTmpName ; --endname) {
3103 if (*endname == '/' || *endname == '\\') {
3108 if (endname > szTmpName)
3109 endname = strcpy(dname,szTmpName);
3113 /* get a temporary filename in same directory
3114 * XXX is this really the best we can do? */
3115 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3119 DeleteFile(szTmpName);
3121 retval = rename(szNewName, szTmpName);
3128 /* rename oname to newname */
3129 retval = rename(szOldName, szNewName);
3131 /* if we created a temporary file before ... */
3132 if (endname != Nullch) {
3133 /* ...and rename succeeded, delete temporary file/directory */
3135 DeleteFile(szTmpName);
3136 /* else restore it to what it was */
3138 (void)rename(szTmpName, szNewName);
3145 win32_setmode(int fd, int mode)
3147 return setmode(fd, mode);
3151 win32_chsize(int fd, Off_t size)
3153 #if defined(WIN64) || defined(USE_LARGE_FILES)
3155 Off_t cur, end, extend;
3157 cur = win32_tell(fd);
3160 end = win32_lseek(fd, 0, SEEK_END);
3163 extend = size - end;
3167 else if (extend > 0) {
3168 /* must grow the file, padding with nulls */
3170 int oldmode = win32_setmode(fd, O_BINARY);
3172 memset(b, '\0', sizeof(b));
3174 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3175 count = win32_write(fd, b, count);
3176 if ((int)count < 0) {
3180 } while ((extend -= count) > 0);
3181 win32_setmode(fd, oldmode);
3184 /* shrink the file */
3185 win32_lseek(fd, size, SEEK_SET);
3186 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3192 win32_lseek(fd, cur, SEEK_SET);
3195 return chsize(fd, (long)size);
3200 win32_lseek(int fd, Off_t offset, int origin)
3202 #if defined(WIN64) || defined(USE_LARGE_FILES)
3203 #if defined(__BORLANDC__) /* buk */
3205 pos.QuadPart = offset;
3206 pos.LowPart = SetFilePointer(
3207 (HANDLE)_get_osfhandle(fd),
3212 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3216 return pos.QuadPart;
3218 return _lseeki64(fd, offset, origin);
3221 return lseek(fd, (long)offset, origin);
3228 #if defined(WIN64) || defined(USE_LARGE_FILES)
3229 #if defined(__BORLANDC__) /* buk */
3232 pos.LowPart = SetFilePointer(
3233 (HANDLE)_get_osfhandle(fd),
3238 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3242 return pos.QuadPart;
3243 /* return tell(fd); */
3245 return _telli64(fd);
3253 win32_open(const char *path, int flag, ...)
3258 WCHAR wBuffer[MAX_PATH+1];
3261 pmode = va_arg(ap, int);
3264 if (stricmp(path, "/dev/null")==0)
3268 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3269 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3271 return open(PerlDir_mapA(path), flag, pmode);
3274 /* close() that understands socket */
3275 extern int my_close(int); /* in win32sck.c */
3280 return my_close(fd);
3296 win32_dup2(int fd1,int fd2)
3298 return dup2(fd1,fd2);
3301 #ifdef PERL_MSVCRT_READFIX
3303 #define LF 10 /* line feed */
3304 #define CR 13 /* carriage return */
3305 #define CTRLZ 26 /* ctrl-z means eof for text */
3306 #define FOPEN 0x01 /* file handle open */
3307 #define FEOFLAG 0x02 /* end of file has been encountered */
3308 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3309 #define FPIPE 0x08 /* file handle refers to a pipe */
3310 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3311 #define FDEV 0x40 /* file handle refers to device */
3312 #define FTEXT 0x80 /* file handle is in text mode */
3313 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3316 _fixed_read(int fh, void *buf, unsigned cnt)
3318 int bytes_read; /* number of bytes read */
3319 char *buffer; /* buffer to read to */
3320 int os_read; /* bytes read on OS call */
3321 char *p, *q; /* pointers into buffer */
3322 char peekchr; /* peek-ahead character */
3323 ULONG filepos; /* file position after seek */
3324 ULONG dosretval; /* o.s. return value */
3326 /* validate handle */
3327 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3328 !(_osfile(fh) & FOPEN))
3330 /* out of range -- return error */
3332 _doserrno = 0; /* not o.s. error */
3337 * If lockinitflag is FALSE, assume fd is device
3338 * lockinitflag is set to TRUE by open.
3340 if (_pioinfo(fh)->lockinitflag)
3341 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3343 bytes_read = 0; /* nothing read yet */
3344 buffer = (char*)buf;
3346 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3347 /* nothing to read or at EOF, so return 0 read */
3351 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3352 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3354 *buffer++ = _pipech(fh);
3357 _pipech(fh) = LF; /* mark as empty */
3362 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3364 /* ReadFile has reported an error. recognize two special cases.
3366 * 1. map ERROR_ACCESS_DENIED to EBADF
3368 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3369 * means the handle is a read-handle on a pipe for which
3370 * all write-handles have been closed and all data has been
3373 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3374 /* wrong read/write mode should return EBADF, not EACCES */
3376 _doserrno = dosretval;
3380 else if (dosretval == ERROR_BROKEN_PIPE) {
3390 bytes_read += os_read; /* update bytes read */
3392 if (_osfile(fh) & FTEXT) {
3393 /* now must translate CR-LFs to LFs in the buffer */
3395 /* set CRLF flag to indicate LF at beginning of buffer */
3396 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3397 /* _osfile(fh) |= FCRLF; */
3399 /* _osfile(fh) &= ~FCRLF; */
3401 _osfile(fh) &= ~FCRLF;
3403 /* convert chars in the buffer: p is src, q is dest */
3405 while (p < (char *)buf + bytes_read) {
3407 /* if fh is not a device, set ctrl-z flag */
3408 if (!(_osfile(fh) & FDEV))
3409 _osfile(fh) |= FEOFLAG;
3410 break; /* stop translating */
3415 /* *p is CR, so must check next char for LF */
3416 if (p < (char *)buf + bytes_read - 1) {
3419 *q++ = LF; /* convert CR-LF to LF */
3422 *q++ = *p++; /* store char normally */
3425 /* This is the hard part. We found a CR at end of
3426 buffer. We must peek ahead to see if next char
3431 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3432 (LPDWORD)&os_read, NULL))
3433 dosretval = GetLastError();
3435 if (dosretval != 0 || os_read == 0) {
3436 /* couldn't read ahead, store CR */
3440 /* peekchr now has the extra character -- we now
3441 have several possibilities:
3442 1. disk file and char is not LF; just seek back
3444 2. disk file and char is LF; store LF, don't seek back
3445 3. pipe/device and char is LF; store LF.
3446 4. pipe/device and char isn't LF, store CR and
3447 put char in pipe lookahead buffer. */
3448 if (_osfile(fh) & (FDEV|FPIPE)) {
3449 /* non-seekable device */
3454 _pipech(fh) = peekchr;
3459 if (peekchr == LF) {
3460 /* nothing read yet; must make some
3463 /* turn on this flag for tell routine */
3464 _osfile(fh) |= FCRLF;
3467 HANDLE osHandle; /* o.s. handle value */
3469 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3471 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3472 dosretval = GetLastError();
3483 /* we now change bytes_read to reflect the true number of chars
3485 bytes_read = q - (char *)buf;
3489 if (_pioinfo(fh)->lockinitflag)
3490 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3495 #endif /* PERL_MSVCRT_READFIX */
3498 win32_read(int fd, void *buf, unsigned int cnt)
3500 #ifdef PERL_MSVCRT_READFIX
3501 return _fixed_read(fd, buf, cnt);
3503 return read(fd, buf, cnt);
3508 win32_write(int fd, const void *buf, unsigned int cnt)
3510 return write(fd, buf, cnt);
3514 win32_mkdir(const char *dir, int mode)
3518 WCHAR wBuffer[MAX_PATH+1];
3519 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3520 return _wmkdir(PerlDir_mapW(wBuffer));
3522 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3526 win32_rmdir(const char *dir)
3530 WCHAR wBuffer[MAX_PATH+1];
3531 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3532 return _wrmdir(PerlDir_mapW(wBuffer));
3534 return rmdir(PerlDir_mapA(dir));
3538 win32_chdir(const char *dir)
3546 WCHAR wBuffer[MAX_PATH+1];
3547 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3548 return _wchdir(wBuffer);
3554 win32_access(const char *path, int mode)
3558 WCHAR wBuffer[MAX_PATH+1];
3559 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3560 return _waccess(PerlDir_mapW(wBuffer), mode);
3562 return access(PerlDir_mapA(path), mode);
3566 win32_chmod(const char *path, int mode)
3570 WCHAR wBuffer[MAX_PATH+1];
3571 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3572 return _wchmod(PerlDir_mapW(wBuffer), mode);
3574 return chmod(PerlDir_mapA(path), mode);
3579 create_command_line(char *cname, STRLEN clen, const char * const *args)
3586 bool bat_file = FALSE;
3587 bool cmd_shell = FALSE;
3588 bool dumb_shell = FALSE;
3589 bool extra_quotes = FALSE;
3590 bool quote_next = FALSE;
3593 cname = (char*)args[0];
3595 /* The NT cmd.exe shell has the following peculiarity that needs to be
3596 * worked around. It strips a leading and trailing dquote when any
3597 * of the following is true:
3598 * 1. the /S switch was used
3599 * 2. there are more than two dquotes
3600 * 3. there is a special character from this set: &<>()@^|
3601 * 4. no whitespace characters within the two dquotes
3602 * 5. string between two dquotes isn't an executable file
3603 * To work around this, we always add a leading and trailing dquote
3604 * to the string, if the first argument is either "cmd.exe" or "cmd",
3605 * and there were at least two or more arguments passed to cmd.exe
3606 * (not including switches).
3607 * XXX the above rules (from "cmd /?") don't seem to be applied
3608 * always, making for the convolutions below :-(
3612 clen = strlen(cname);
3615 && (stricmp(&cname[clen-4], ".bat") == 0
3616 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3623 char *exe = strrchr(cname, '/');
3624 char *exe2 = strrchr(cname, '\\');
3631 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3635 else if (stricmp(exe, "command.com") == 0
3636 || stricmp(exe, "command") == 0)
3643 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3644 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3645 STRLEN curlen = strlen(arg);
3646 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3647 len += 2; /* assume quoting needed (worst case) */
3649 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3651 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3654 Newx(cmd, len, char);
3657 if (bat_file && !IsWin95()) {
3659 extra_quotes = TRUE;
3662 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3664 STRLEN curlen = strlen(arg);
3666 /* we want to protect empty arguments and ones with spaces with
3667 * dquotes, but only if they aren't already there */
3672 else if (quote_next) {
3673 /* see if it really is multiple arguments pretending to
3674 * be one and force a set of quotes around it */
3675 if (*find_next_space(arg))
3678 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3680 while (i < curlen) {
3681 if (isSPACE(arg[i])) {
3684 else if (arg[i] == '"') {
3708 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3709 && stricmp(arg+curlen-2, "/c") == 0)
3711 /* is there a next argument? */
3712 if (args[index+1]) {
3713 /* are there two or more next arguments? */
3714 if (args[index+2]) {
3716 extra_quotes = TRUE;
3719 /* single argument, force quoting if it has spaces */
3735 qualified_path(const char *cmd)
3739 char *fullcmd, *curfullcmd;
3745 fullcmd = (char*)cmd;
3747 if (*fullcmd == '/' || *fullcmd == '\\')
3754 pathstr = PerlEnv_getenv("PATH");
3756 /* worst case: PATH is a single directory; we need additional space
3757 * to append "/", ".exe" and trailing "\0" */
3758 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3759 curfullcmd = fullcmd;
3764 /* start by appending the name to the current prefix */
3765 strcpy(curfullcmd, cmd);
3766 curfullcmd += cmdlen;
3768 /* if it doesn't end with '.', or has no extension, try adding
3769 * a trailing .exe first */
3770 if (cmd[cmdlen-1] != '.'
3771 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3773 strcpy(curfullcmd, ".exe");
3774 res = GetFileAttributes(fullcmd);
3775 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3780 /* that failed, try the bare name */
3781 res = GetFileAttributes(fullcmd);
3782 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3785 /* quit if no other path exists, or if cmd already has path */
3786 if (!pathstr || !*pathstr || has_slash)
3789 /* skip leading semis */
3790 while (*pathstr == ';')
3793 /* build a new prefix from scratch */
3794 curfullcmd = fullcmd;
3795 while (*pathstr && *pathstr != ';') {
3796 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3797 pathstr++; /* skip initial '"' */
3798 while (*pathstr && *pathstr != '"') {
3799 *curfullcmd++ = *pathstr++;
3802 pathstr++; /* skip trailing '"' */
3805 *curfullcmd++ = *pathstr++;
3809 pathstr++; /* skip trailing semi */
3810 if (curfullcmd > fullcmd /* append a dir separator */
3811 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3813 *curfullcmd++ = '\\';
3821 /* The following are just place holders.
3822 * Some hosts may provide and environment that the OS is
3823 * not tracking, therefore, these host must provide that
3824 * environment and the current directory to CreateProcess
3828 win32_get_childenv(void)
3834 win32_free_childenv(void* d)
3839 win32_clearenv(void)
3841 char *envv = GetEnvironmentStrings();
3845 char *end = strchr(cur,'=');
3846 if (end && end != cur) {
3848 SetEnvironmentVariable(cur, NULL);
3850 cur = end + strlen(end+1)+2;
3852 else if ((len = strlen(cur)))
3855 FreeEnvironmentStrings(envv);
3859 win32_get_childdir(void)
3863 char szfilename[(MAX_PATH+1)*2];
3865 WCHAR wfilename[MAX_PATH+1];
3866 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3867 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3870 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3873 Newx(ptr, strlen(szfilename)+1, char);
3874 strcpy(ptr, szfilename);
3879 win32_free_childdir(char* d)
3886 /* XXX this needs to be made more compatible with the spawnvp()
3887 * provided by the various RTLs. In particular, searching for
3888 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3889 * This doesn't significantly affect perl itself, because we
3890 * always invoke things using PERL5SHELL if a direct attempt to
3891 * spawn the executable fails.
3893 * XXX splitting and rejoining the commandline between do_aspawn()
3894 * and win32_spawnvp() could also be avoided.
3898 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3900 #ifdef USE_RTL_SPAWNVP
3901 return spawnvp(mode, cmdname, (char * const *)argv);
3908 STARTUPINFO StartupInfo;
3909 PROCESS_INFORMATION ProcessInformation;
3912 char *fullcmd = Nullch;
3913 char *cname = (char *)cmdname;
3917 clen = strlen(cname);
3918 /* if command name contains dquotes, must remove them */
3919 if (strchr(cname, '"')) {
3921 Newx(cname,clen+1,char);
3934 cmd = create_command_line(cname, clen, argv);
3936 env = PerlEnv_get_childenv();
3937 dir = PerlEnv_get_childdir();
3940 case P_NOWAIT: /* asynch + remember result */
3941 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3946 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3949 create |= CREATE_NEW_PROCESS_GROUP;
3952 case P_WAIT: /* synchronous execution */
3954 default: /* invalid mode */
3959 memset(&StartupInfo,0,sizeof(StartupInfo));
3960 StartupInfo.cb = sizeof(StartupInfo);
3961 memset(&tbl,0,sizeof(tbl));
3962 PerlEnv_get_child_IO(&tbl);
3963 StartupInfo.dwFlags = tbl.dwFlags;
3964 StartupInfo.dwX = tbl.dwX;
3965 StartupInfo.dwY = tbl.dwY;
3966 StartupInfo.dwXSize = tbl.dwXSize;
3967 StartupInfo.dwYSize = tbl.dwYSize;
3968 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3969 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3970 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3971 StartupInfo.wShowWindow = tbl.wShowWindow;
3972 StartupInfo.hStdInput = tbl.childStdIn;
3973 StartupInfo.hStdOutput = tbl.childStdOut;
3974 StartupInfo.hStdError = tbl.childStdErr;
3975 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3976 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3977 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3979 create |= CREATE_NEW_CONSOLE;
3982 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3984 if (w32_use_showwindow) {
3985 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3986 StartupInfo.wShowWindow = w32_showwindow;
3989 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3992 if (!CreateProcess(cname, /* search PATH to find executable */
3993 cmd, /* executable, and its arguments */
3994 NULL, /* process attributes */
3995 NULL, /* thread attributes */
3996 TRUE, /* inherit handles */
3997 create, /* creation flags */
3998 (LPVOID)env, /* inherit environment */
3999 dir, /* inherit cwd */
4001 &ProcessInformation))
4003 /* initial NULL argument to CreateProcess() does a PATH
4004 * search, but it always first looks in the directory
4005 * where the current process was started, which behavior
4006 * is undesirable for backward compatibility. So we
4007 * jump through our own hoops by picking out the path
4008 * we really want it to use. */
4010 fullcmd = qualified_path(cname);
4012 if (cname != cmdname)
4015 DEBUG_p(PerlIO_printf(Perl_debug_log,
4016 "Retrying [%s] with same args\n",
4026 if (mode == P_NOWAIT) {
4027 /* asynchronous spawn -- store handle, return PID */
4028 ret = (int)ProcessInformation.dwProcessId;
4029 if (IsWin95() && ret < 0)
4032 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4033 w32_child_pids[w32_num_children] = (DWORD)ret;
4038 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4039 /* FIXME: if msgwait returned due to message perhaps forward the
4040 "signal" to the process
4042 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4044 CloseHandle(ProcessInformation.hProcess);
4047 CloseHandle(ProcessInformation.hThread);
4050 PerlEnv_free_childenv(env);
4051 PerlEnv_free_childdir(dir);
4053 if (cname != cmdname)
4060 win32_execv(const char *cmdname, const char *const *argv)
4064 /* if this is a pseudo-forked child, we just want to spawn
4065 * the new program, and return */
4067 # ifdef __BORLANDC__
4068 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4070 return spawnv(P_WAIT, cmdname, argv);
4074 return execv(cmdname, (char *const *)argv);
4076 return execv(cmdname, argv);
4081 win32_execvp(const char *cmdname, const char *const *argv)
4085 /* if this is a pseudo-forked child, we just want to spawn
4086 * the new program, and return */
4087 if (w32_pseudo_id) {
4088 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4098 return execvp(cmdname, (char *const *)argv);
4100 return execvp(cmdname, argv);
4105 win32_perror(const char *str)
4111 win32_setbuf(FILE *pf, char *buf)
4117 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4119 return setvbuf(pf, buf, type, size);
4123 win32_flushall(void)
4129 win32_fcloseall(void)
4135 win32_fgets(char *s, int n, FILE *pf)
4137 return fgets(s, n, pf);
4147 win32_fgetc(FILE *pf)
4153 win32_putc(int c, FILE *pf)
4159 win32_puts(const char *s)
4171 win32_putchar(int c)
4178 #ifndef USE_PERL_SBRK
4180 static char *committed = NULL; /* XXX threadead */
4181 static char *base = NULL; /* XXX threadead */
4182 static char *reserved = NULL; /* XXX threadead */
4183 static char *brk = NULL; /* XXX threadead */
4184 static DWORD pagesize = 0; /* XXX threadead */
4187 sbrk(ptrdiff_t need)
4192 GetSystemInfo(&info);
4193 /* Pretend page size is larger so we don't perpetually
4194 * call the OS to commit just one page ...
4196 pagesize = info.dwPageSize << 3;
4198 if (brk+need >= reserved)
4200 DWORD size = brk+need-reserved;
4202 char *prev_committed = NULL;
4203 if (committed && reserved && committed < reserved)
4205 /* Commit last of previous chunk cannot span allocations */
4206 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4209 /* Remember where we committed from in case we want to decommit later */
4210 prev_committed = committed;
4211 committed = reserved;
4214 /* Reserve some (more) space
4215 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4216 * this is only address space not memory...
4217 * Note this is a little sneaky, 1st call passes NULL as reserved
4218 * so lets system choose where we start, subsequent calls pass
4219 * the old end address so ask for a contiguous block
4222 if (size < 64*1024*1024)
4223 size = 64*1024*1024;
4224 size = ((size + pagesize - 1) / pagesize) * pagesize;
4225 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4228 reserved = addr+size;
4238 /* The existing block could not be extended far enough, so decommit
4239 * anything that was just committed above and start anew */
4242 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4245 reserved = base = committed = brk = NULL;
4256 if (brk > committed)
4258 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4260 if (committed+size > reserved)
4261 size = reserved-committed;
4262 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4275 win32_malloc(size_t size)
4277 return malloc(size);
4281 win32_calloc(size_t numitems, size_t size)
4283 return calloc(numitems,size);
4287 win32_realloc(void *block, size_t size)
4289 return realloc(block,size);
4293 win32_free(void *block)
4300 win32_open_osfhandle(intptr_t handle, int flags)
4302 #ifdef USE_FIXED_OSFHANDLE
4304 return my_open_osfhandle(handle, flags);
4306 return _open_osfhandle(handle, flags);
4310 win32_get_osfhandle(int fd)
4312 return (intptr_t)_get_osfhandle(fd);
4316 win32_fdupopen(FILE *pf)
4321 int fileno = win32_dup(win32_fileno(pf));
4323 /* open the file in the same mode */
4325 if((pf)->flags & _F_READ) {
4329 else if((pf)->flags & _F_WRIT) {
4333 else if((pf)->flags & _F_RDWR) {
4339 if((pf)->_flag & _IOREAD) {
4343 else if((pf)->_flag & _IOWRT) {
4347 else if((pf)->_flag & _IORW) {
4354 /* it appears that the binmode is attached to the
4355 * file descriptor so binmode files will be handled
4358 pfdup = win32_fdopen(fileno, mode);
4360 /* move the file pointer to the same position */
4361 if (!fgetpos(pf, &pos)) {
4362 fsetpos(pfdup, &pos);
4368 win32_dynaload(const char* filename)
4372 char buf[MAX_PATH+1];
4375 /* LoadLibrary() doesn't recognize forward slashes correctly,
4376 * so turn 'em back. */
4377 first = strchr(filename, '/');
4379 STRLEN len = strlen(filename);
4380 if (len <= MAX_PATH) {
4381 strcpy(buf, filename);
4382 filename = &buf[first - filename];
4384 if (*filename == '/')
4385 *(char*)filename = '\\';
4392 WCHAR wfilename[MAX_PATH+1];
4393 A2WHELPER(filename, wfilename, sizeof(wfilename));
4394 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4397 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4407 XS(w32_SetChildShowWindow)
4410 BOOL use_showwindow = w32_use_showwindow;
4411 /* use "unsigned short" because Perl has redefined "WORD" */
4412 unsigned short showwindow = w32_showwindow;
4415 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4417 if (items == 0 || !SvOK(ST(0)))
4418 w32_use_showwindow = FALSE;
4420 w32_use_showwindow = TRUE;
4421 w32_showwindow = (unsigned short)SvIV(ST(0));
4426 ST(0) = sv_2mortal(newSViv(showwindow));
4428 ST(0) = &PL_sv_undef;
4436 /* Make the host for current directory */
4437 char* ptr = PerlEnv_get_childdir();
4440 * then it worked, set PV valid,
4441 * else return 'undef'
4444 SV *sv = sv_newmortal();
4446 PerlEnv_free_childdir(ptr);
4448 #ifndef INCOMPLETE_TAINTS
4465 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4466 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4473 XS(w32_GetNextAvailDrive)
4477 char root[] = "_:\\";
4482 if (GetDriveType(root) == 1) {
4491 XS(w32_GetLastError)
4495 XSRETURN_IV(GetLastError());
4499 XS(w32_SetLastError)
4503 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4504 SetLastError(SvIV(ST(0)));
4512 char *name = w32_getlogin_buffer;
4513 DWORD size = sizeof(w32_getlogin_buffer);
4515 if (GetUserName(name,&size)) {
4516 /* size includes NULL */
4517 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4527 char name[MAX_COMPUTERNAME_LENGTH+1];
4528 DWORD size = sizeof(name);
4530 if (GetComputerName(name,&size)) {
4531 /* size does NOT include NULL :-( */
4532 ST(0) = sv_2mortal(newSVpvn(name,size));
4543 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4544 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4545 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4549 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4550 GetProcAddress(hNetApi32, "NetApiBufferFree");
4551 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4552 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4555 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4556 /* this way is more reliable, in case user has a local account. */
4558 DWORD dnamelen = sizeof(dname);
4560 DWORD wki100_platform_id;
4561 LPWSTR wki100_computername;
4562 LPWSTR wki100_langroup;
4563 DWORD wki100_ver_major;
4564 DWORD wki100_ver_minor;
4566 /* NERR_Success *is* 0*/
4567 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4568 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4569 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4570 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4573 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4574 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4576 pfnNetApiBufferFree(pwi);
4577 FreeLibrary(hNetApi32);
4580 FreeLibrary(hNetApi32);
4583 /* Win95 doesn't have NetWksta*(), so do it the old way */
4585 DWORD size = sizeof(name);
4587 FreeLibrary(hNetApi32);
4588 if (GetUserName(name,&size)) {
4589 char sid[ONE_K_BUFSIZE];
4590 DWORD sidlen = sizeof(sid);
4592 DWORD dnamelen = sizeof(dname);
4594 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4595 dname, &dnamelen, &snu)) {
4596 XSRETURN_PV(dname); /* all that for this */
4608 DWORD flags, filecomplen;
4609 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4610 &flags, fsname, sizeof(fsname))) {
4611 if (GIMME_V == G_ARRAY) {
4612 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4613 XPUSHs(sv_2mortal(newSViv(flags)));
4614 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4619 XSRETURN_PV(fsname);
4625 XS(w32_GetOSVersion)
4628 /* Use explicit struct definition because wSuiteMask and
4629 * wProductType are not defined in the VC++ 6.0 headers.
4630 * WORD type has been replaced by unsigned short because
4631 * WORD is already used by Perl itself.
4634 DWORD dwOSVersionInfoSize;
4635 DWORD dwMajorVersion;
4636 DWORD dwMinorVersion;
4637 DWORD dwBuildNumber;
4639 CHAR szCSDVersion[128];
4640 unsigned short wServicePackMajor;
4641 unsigned short wServicePackMinor;
4642 unsigned short wSuiteMask;
4650 DWORD dwOSVersionInfoSize;
4651 DWORD dwMajorVersion;
4652 DWORD dwMinorVersion;
4653 DWORD dwBuildNumber;
4655 WCHAR szCSDVersion[128];
4656 unsigned short wServicePackMajor;
4657 unsigned short wServicePackMinor;
4658 unsigned short wSuiteMask;
4662 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4663 osverw.dwOSVersionInfoSize = sizeof(osverw);
4664 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4666 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4667 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4671 if (GIMME_V == G_SCALAR) {
4672 XSRETURN_IV(osverw.dwPlatformId);
4674 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4675 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4676 osver.dwMajorVersion = osverw.dwMajorVersion;
4677 osver.dwMinorVersion = osverw.dwMinorVersion;
4678 osver.dwBuildNumber = osverw.dwBuildNumber;
4679 osver.dwPlatformId = osverw.dwPlatformId;
4680 osver.wServicePackMajor = osverw.wServicePackMajor;
4681 osver.wServicePackMinor = osverw.wServicePackMinor;
4682 osver.wSuiteMask = osverw.wSuiteMask;
4683 osver.wProductType = osverw.wProductType;
4686 osver.dwOSVersionInfoSize = sizeof(osver);
4687 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4689 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4690 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4694 if (GIMME_V == G_SCALAR) {
4695 XSRETURN_IV(osver.dwPlatformId);
4697 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4699 XPUSHs(newSViv(osver.dwMajorVersion));
4700 XPUSHs(newSViv(osver.dwMinorVersion));
4701 XPUSHs(newSViv(osver.dwBuildNumber));
4702 XPUSHs(newSViv(osver.dwPlatformId));
4704 XPUSHs(newSViv(osver.wServicePackMajor));
4705 XPUSHs(newSViv(osver.wServicePackMinor));
4706 XPUSHs(newSViv(osver.wSuiteMask));
4707 XPUSHs(newSViv(osver.wProductType));
4717 XSRETURN_IV(IsWinNT());
4725 XSRETURN_IV(IsWin95());
4729 XS(w32_FormatMessage)
4733 char msgbuf[ONE_K_BUFSIZE];
4736 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4739 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4740 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4741 &source, SvIV(ST(0)), 0,
4742 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4744 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4745 XSRETURN_PV(msgbuf);
4749 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4750 &source, SvIV(ST(0)), 0,
4751 msgbuf, sizeof(msgbuf)-1, NULL))
4752 XSRETURN_PV(msgbuf);
4765 PROCESS_INFORMATION stProcInfo;
4766 STARTUPINFO stStartInfo;
4767 BOOL bSuccess = FALSE;
4770 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4772 cmd = SvPV_nolen(ST(0));
4773 args = SvPV_nolen(ST(1));
4775 env = PerlEnv_get_childenv();
4776 dir = PerlEnv_get_childdir();
4778 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4779 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4780 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4781 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4784 cmd, /* Image path */
4785 args, /* Arguments for command line */
4786 NULL, /* Default process security */
4787 NULL, /* Default thread security */
4788 FALSE, /* Must be TRUE to use std handles */
4789 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4790 env, /* Inherit our environment block */
4791 dir, /* Inherit our currrent directory */
4792 &stStartInfo, /* -> Startup info */
4793 &stProcInfo)) /* <- Process info (if OK) */
4795 int pid = (int)stProcInfo.dwProcessId;
4796 if (IsWin95() && pid < 0)
4798 sv_setiv(ST(2), pid);
4799 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4802 PerlEnv_free_childenv(env);
4803 PerlEnv_free_childdir(dir);
4804 XSRETURN_IV(bSuccess);
4808 XS(w32_GetTickCount)
4811 DWORD msec = GetTickCount();
4819 XS(w32_GetShortPathName)
4826 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4828 shortpath = sv_mortalcopy(ST(0));
4829 SvUPGRADE(shortpath, SVt_PV);
4830 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4833 /* src == target is allowed */
4835 len = GetShortPathName(SvPVX(shortpath),
4838 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4840 SvCUR_set(shortpath,len);
4841 *SvEND(shortpath) = '\0';
4849 XS(w32_GetFullPathName)
4856 STRLEN filename_len;
4860 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4863 filename_p = SvPV(filename, filename_len);
4864 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4865 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4869 len = GetFullPathName(SvPVX(filename),
4873 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4875 if (GIMME_V == G_ARRAY) {
4878 XST_mPV(1,filepart);
4879 len = filepart - SvPVX(fullpath);
4886 SvCUR_set(fullpath,len);
4887 *SvEND(fullpath) = '\0';
4895 XS(w32_GetLongPathName)
4899 char tmpbuf[MAX_PATH+1];
4904 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4907 pathstr = SvPV(path,len);
4908 strcpy(tmpbuf, pathstr);
4909 pathstr = win32_longpath(tmpbuf);
4911 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4922 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4933 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4935 WCHAR wSourceFile[MAX_PATH+1];
4936 WCHAR wDestFile[MAX_PATH+1];
4937 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4938 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4939 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4940 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4943 char szSourceFile[MAX_PATH+1];
4944 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4945 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4954 Perl_init_os_extras(void)
4957 char *file = __FILE__;
4960 /* these names are Activeware compatible */
4961 newXS("Win32::GetCwd", w32_GetCwd, file);
4962 newXS("Win32::SetCwd", w32_SetCwd, file);
4963 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4964 newXS("Win32::GetLastError", w32_GetLastError, file);
4965 newXS("Win32::SetLastError", w32_SetLastError, file);
4966 newXS("Win32::LoginName", w32_LoginName, file);
4967 newXS("Win32::NodeName", w32_NodeName, file);
4968 newXS("Win32::DomainName", w32_DomainName, file);
4969 newXS("Win32::FsType", w32_FsType, file);
4970 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4971 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4972 newXS("Win32::IsWin95", w32_IsWin95, file);
4973 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4974 newXS("Win32::Spawn", w32_Spawn, file);
4975 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4976 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4977 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4978 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4979 newXS("Win32::CopyFile", w32_CopyFile, file);
4980 newXS("Win32::Sleep", w32_Sleep, file);
4981 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4983 /* XXX Bloat Alert! The following Activeware preloads really
4984 * ought to be part of Win32::Sys::*, so they're not included
4987 /* LookupAccountName
4989 * InitiateSystemShutdown
4990 * AbortSystemShutdown
4991 * ExpandEnvrironmentStrings
4996 win32_signal_context(void)
5001 my_perl = PL_curinterp;
5002 PERL_SET_THX(my_perl);
5006 return PL_curinterp;
5012 win32_ctrlhandler(DWORD dwCtrlType)
5015 dTHXa(PERL_GET_SIG_CONTEXT);
5021 switch(dwCtrlType) {
5022 case CTRL_CLOSE_EVENT:
5023 /* A signal that the system sends to all processes attached to a console when
5024 the user closes the console (either by choosing the Close command from the
5025 console window's System menu, or by choosing the End Task command from the
5028 if (do_raise(aTHX_ 1)) /* SIGHUP */
5029 sig_terminate(aTHX_ 1);
5033 /* A CTRL+c signal was received */
5034 if (do_raise(aTHX_ SIGINT))
5035 sig_terminate(aTHX_ SIGINT);
5038 case CTRL_BREAK_EVENT:
5039 /* A CTRL+BREAK signal was received */
5040 if (do_raise(aTHX_ SIGBREAK))
5041 sig_terminate(aTHX_ SIGBREAK);
5044 case CTRL_LOGOFF_EVENT:
5045 /* A signal that the system sends to all console processes when a user is logging
5046 off. This signal does not indicate which user is logging off, so no
5047 assumptions can be made.
5050 case CTRL_SHUTDOWN_EVENT:
5051 /* A signal that the system sends to all console processes when the system is
5054 if (do_raise(aTHX_ SIGTERM))
5055 sig_terminate(aTHX_ SIGTERM);
5065 Perl_win32_init(int *argcp, char ***argvp)
5067 /* Disable floating point errors, Perl will trap the ones we
5068 * care about. VC++ RTL defaults to switching these off
5069 * already, but the Borland RTL doesn't. Since we don't
5070 * want to be at the vendor's whim on the default, we set
5071 * it explicitly here.
5073 #if !defined(_ALPHA_) && !defined(__GNUC__)
5074 _control87(MCW_EM, MCW_EM);
5080 Perl_win32_term(void)
5087 win32_get_child_IO(child_IO_table* ptbl)
5089 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
5090 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
5091 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
5095 win32_signal(int sig, Sighandler_t subcode)
5098 if (sig < SIG_SIZE) {
5099 int save_errno = errno;
5100 Sighandler_t result = signal(sig, subcode);
5101 if (result == SIG_ERR) {
5102 result = w32_sighandler[sig];
5105 w32_sighandler[sig] = subcode;
5115 #ifdef HAVE_INTERP_INTERN
5119 win32_csighandler(int sig)
5122 dTHXa(PERL_GET_SIG_CONTEXT);
5123 Perl_warn(aTHX_ "Got signal %d",sig);
5129 Perl_sys_intern_init(pTHX)
5132 w32_perlshell_tokens = Nullch;
5133 w32_perlshell_vec = (char**)NULL;
5134 w32_perlshell_items = 0;
5135 w32_fdpid = newAV();
5136 Newx(w32_children, 1, child_tab);
5137 w32_num_children = 0;
5138 # ifdef USE_ITHREADS
5140 Newx(w32_pseudo_children, 1, child_tab);
5141 w32_num_pseudo_children = 0;
5145 for (i=0; i < SIG_SIZE; i++) {
5146 w32_sighandler[i] = SIG_DFL;
5149 if (my_perl == PL_curinterp) {
5153 /* Force C runtime signal stuff to set its console handler */
5154 signal(SIGINT,win32_csighandler);
5155 signal(SIGBREAK,win32_csighandler);
5156 /* Push our handler on top */
5157 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5162 Perl_sys_intern_clear(pTHX)
5164 Safefree(w32_perlshell_tokens);
5165 Safefree(w32_perlshell_vec);
5166 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5167 Safefree(w32_children);
5169 KillTimer(NULL,w32_timerid);
5172 # ifdef MULTIPLICITY
5173 if (my_perl == PL_curinterp) {
5177 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5179 # ifdef USE_ITHREADS
5180 Safefree(w32_pseudo_children);
5184 # ifdef USE_ITHREADS
5187 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5189 dst->perlshell_tokens = Nullch;
5190 dst->perlshell_vec = (char**)NULL;
5191 dst->perlshell_items = 0;
5192 dst->fdpid = newAV();
5193 Newxz(dst->children, 1, child_tab);
5195 Newxz(dst->pseudo_children, 1, child_tab);
5197 dst->poll_count = 0;
5198 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5200 # endif /* USE_ITHREADS */
5201 #endif /* HAVE_INTERP_INTERN */
5204 win32_free_argvw(pTHX_ void *ptr)
5206 char** argv = (char**)ptr;
5214 win32_argv2utf8(int argc, char** argv)
5219 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5220 if (lpwStr && argc) {
5222 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5223 Newxz(psz, length, char);
5224 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5227 call_atexit(win32_free_argvw, argv);
5229 GlobalFree((HGLOBAL)lpwStr);