3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
18 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20 # include <shellapi.h>
22 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
28 /* #include "config.h" */
30 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
39 #define PERL_NO_GET_CONTEXT
45 /* assert.h conflicts with #define of assert in perl.h */
52 #if defined(_MSC_VER) || defined(__MINGW32__)
53 #include <sys/utime.h>
58 /* Mingw32 defaults to globing command line
59 * So we turn it off like this:
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 /* Mingw32-1.1 is missing some prototypes */
66 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
73 #if defined(__BORLANDC__)
75 # define _utimbuf utimbuf
80 #define EXECF_SPAWN_NOWAIT 3
82 #if defined(PERL_IMPLICIT_SYS)
83 # undef win32_get_privlib
84 # define win32_get_privlib g_win32_get_privlib
85 # undef win32_get_sitelib
86 # define win32_get_sitelib g_win32_get_sitelib
87 # undef win32_get_vendorlib
88 # define win32_get_vendorlib g_win32_get_vendorlib
90 # define getlogin g_getlogin
93 static void get_shell(void);
94 static long tokenize(const char *str, char **dest, char ***destv);
95 static int do_spawn2(pTHX_ char *cmd, int exectype);
96 static BOOL has_shell_metachars(char *ptr);
97 static long filetime_to_clock(PFILETIME ft);
98 static BOOL filetime_from_time(PFILETIME ft, time_t t);
99 static char * get_emd_part(SV **leading, char *trailing, ...);
100 static void remove_dead_process(long deceased);
101 static long find_pid(int pid);
102 static char * qualified_path(const char *cmd);
103 static char * win32_get_xlib(const char *pl, const char *xlib,
104 const char *libname);
107 static void remove_dead_pseudo_process(long child);
108 static long find_pseudo_pid(int pid);
112 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113 char w32_module_name[MAX_PATH+1];
116 static DWORD w32_platform = (DWORD)-1;
118 #define ONE_K_BUFSIZE 1024
123 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
129 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
133 set_w32_module_name(void)
136 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
137 ? GetModuleHandle(NULL)
138 : w32_perldll_handle),
139 w32_module_name, sizeof(w32_module_name));
141 /* try to get full path to binary (which may be mangled when perl is
142 * run from a 16-bit app) */
143 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
144 (void)win32_longpath(w32_module_name);
145 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
147 /* normalize to forward slashes */
148 ptr = w32_module_name;
156 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
158 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
160 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
163 const char *subkey = "Software\\Perl";
167 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
168 if (retval == ERROR_SUCCESS) {
170 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
171 if (retval == ERROR_SUCCESS
172 && (type == REG_SZ || type == REG_EXPAND_SZ))
176 *svp = sv_2mortal(newSVpvn("",0));
177 SvGROW(*svp, datalen);
178 retval = RegQueryValueEx(handle, valuename, 0, NULL,
179 (PBYTE)SvPVX(*svp), &datalen);
180 if (retval == ERROR_SUCCESS) {
182 SvCUR_set(*svp,datalen-1);
190 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
192 get_regstr(const char *valuename, SV **svp)
194 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
196 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
200 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
202 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
206 char mod_name[MAX_PATH+1];
212 va_start(ap, trailing_path);
213 strip = va_arg(ap, char *);
215 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
216 baselen = strlen(base);
218 if (!*w32_module_name) {
219 set_w32_module_name();
221 strcpy(mod_name, w32_module_name);
222 ptr = strrchr(mod_name, '/');
223 while (ptr && strip) {
224 /* look for directories to skip back */
227 ptr = strrchr(mod_name, '/');
228 /* avoid stripping component if there is no slash,
229 * or it doesn't match ... */
230 if (!ptr || stricmp(ptr+1, strip) != 0) {
231 /* ... but not if component matches m|5\.$patchlevel.*| */
232 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
233 && strncmp(strip, base, baselen) == 0
234 && strncmp(ptr+1, base, baselen) == 0))
240 strip = va_arg(ap, char *);
248 strcpy(++ptr, trailing_path);
250 /* only add directory if it exists */
251 if (GetFileAttributes(mod_name) != (DWORD) -1) {
252 /* directory exists */
255 *prev_pathp = sv_2mortal(newSVpvn("",0));
256 else if (SvPVX(*prev_pathp))
257 sv_catpvn(*prev_pathp, ";", 1);
258 sv_catpv(*prev_pathp, mod_name);
259 return SvPVX(*prev_pathp);
266 win32_get_privlib(const char *pl)
269 char *stdlib = "lib";
270 char buffer[MAX_PATH+1];
273 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
274 sprintf(buffer, "%s-%s", stdlib, pl);
275 if (!get_regstr(buffer, &sv))
276 (void)get_regstr(stdlib, &sv);
278 /* $stdlib .= ";$EMD/../../lib" */
279 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
283 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
287 char pathstr[MAX_PATH+1];
291 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
292 sprintf(regstr, "%s-%s", xlib, pl);
293 (void)get_regstr(regstr, &sv1);
296 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
297 sprintf(pathstr, "%s/%s/lib", libname, pl);
298 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
300 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
301 (void)get_regstr(xlib, &sv2);
304 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
305 sprintf(pathstr, "%s/lib", libname);
306 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
315 sv_catpvn(sv1, ";", 1);
322 win32_get_sitelib(const char *pl)
324 return win32_get_xlib(pl, "sitelib", "site");
327 #ifndef PERL_VENDORLIB_NAME
328 # define PERL_VENDORLIB_NAME "vendor"
332 win32_get_vendorlib(const char *pl)
334 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
338 has_shell_metachars(char *ptr)
344 * Scan string looking for redirection (< or >) or pipe
345 * characters (|) that are not in a quoted string.
346 * Shell variable interpolation (%VAR%) can also happen inside strings.
378 #if !defined(PERL_IMPLICIT_SYS)
379 /* since the current process environment is being updated in util.c
380 * the library functions will get the correct environment
383 Perl_my_popen(pTHX_ char *cmd, char *mode)
386 #define fixcmd(x) { \
387 char *pspace = strchr((x),' '); \
390 while (p < pspace) { \
401 PERL_FLUSHALL_FOR_CHILD;
402 return win32_popen(cmd, mode);
406 Perl_my_pclose(pTHX_ PerlIO *fp)
408 return win32_pclose(fp);
412 DllExport unsigned long
415 static OSVERSIONINFO osver;
417 if (osver.dwPlatformId != w32_platform) {
418 memset(&osver, 0, sizeof(OSVERSIONINFO));
419 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
420 GetVersionEx(&osver);
421 w32_platform = osver.dwPlatformId;
423 return (unsigned long)w32_platform;
433 return -((int)w32_pseudo_id);
436 /* Windows 9x appears to always reports a pid for threads and processes
437 * that has the high bit set. So we treat the lower 31 bits as the
438 * "real" PID for Perl's purposes. */
439 if (IsWin95() && pid < 0)
444 /* Tokenize a string. Words are null-separated, and the list
445 * ends with a doubled null. Any character (except null and
446 * including backslash) may be escaped by preceding it with a
447 * backslash (the backslash will be stripped).
448 * Returns number of words in result buffer.
451 tokenize(const char *str, char **dest, char ***destv)
453 char *retstart = Nullch;
454 char **retvstart = 0;
458 int slen = strlen(str);
460 register char **retv;
461 New(1307, ret, slen+2, char);
462 New(1308, retv, (slen+3)/2, char*);
470 if (*ret == '\\' && *str)
472 else if (*ret == ' ') {
488 retvstart[items] = Nullch;
501 if (!w32_perlshell_tokens) {
502 /* we don't use COMSPEC here for two reasons:
503 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
504 * uncontrolled unportability of the ensuing scripts.
505 * 2. PERL5SHELL could be set to a shell that may not be fit for
506 * interactive use (which is what most programs look in COMSPEC
509 const char* defaultshell = (IsWinNT()
510 ? "cmd.exe /x/d/c" : "command.com /c");
511 const char *usershell = PerlEnv_getenv("PERL5SHELL");
512 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
513 &w32_perlshell_tokens,
519 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
531 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
533 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
538 while (++mark <= sp) {
539 if (*mark && (str = SvPV_nolen(*mark)))
546 status = win32_spawnvp(flag,
547 (const char*)(really ? SvPV_nolen(really) : argv[0]),
548 (const char* const*)argv);
550 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
551 /* possible shell-builtin, invoke with shell */
553 sh_items = w32_perlshell_items;
555 argv[index+sh_items] = argv[index];
556 while (--sh_items >= 0)
557 argv[sh_items] = w32_perlshell_vec[sh_items];
559 status = win32_spawnvp(flag,
560 (const char*)(really ? SvPV_nolen(really) : argv[0]),
561 (const char* const*)argv);
564 if (flag == P_NOWAIT) {
566 PL_statusvalue = -1; /* >16bits hint for pp_system() */
570 if (ckWARN(WARN_EXEC))
571 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
576 PL_statusvalue = status;
582 /* returns pointer to the next unquoted space or the end of the string */
584 find_next_space(const char *s)
586 bool in_quotes = FALSE;
588 /* ignore doubled backslashes, or backslash+quote */
589 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
592 /* keep track of when we're within quotes */
593 else if (*s == '"') {
595 in_quotes = !in_quotes;
597 /* break it up only at spaces that aren't in quotes */
598 else if (!in_quotes && isSPACE(*s))
607 do_spawn2(pTHX_ char *cmd, int exectype)
613 BOOL needToTry = TRUE;
616 /* Save an extra exec if possible. See if there are shell
617 * metacharacters in it */
618 if (!has_shell_metachars(cmd)) {
619 New(1301,argv, strlen(cmd) / 2 + 2, char*);
620 New(1302,cmd2, strlen(cmd) + 1, char);
623 for (s = cmd2; *s;) {
624 while (*s && isSPACE(*s))
628 s = find_next_space(s);
636 status = win32_spawnvp(P_WAIT, argv[0],
637 (const char* const*)argv);
639 case EXECF_SPAWN_NOWAIT:
640 status = win32_spawnvp(P_NOWAIT, argv[0],
641 (const char* const*)argv);
644 status = win32_execvp(argv[0], (const char* const*)argv);
647 if (status != -1 || errno == 0)
657 New(1306, argv, w32_perlshell_items + 2, char*);
658 while (++i < w32_perlshell_items)
659 argv[i] = w32_perlshell_vec[i];
664 status = win32_spawnvp(P_WAIT, argv[0],
665 (const char* const*)argv);
667 case EXECF_SPAWN_NOWAIT:
668 status = win32_spawnvp(P_NOWAIT, argv[0],
669 (const char* const*)argv);
672 status = win32_execvp(argv[0], (const char* const*)argv);
678 if (exectype == EXECF_SPAWN_NOWAIT) {
680 PL_statusvalue = -1; /* >16bits hint for pp_system() */
684 if (ckWARN(WARN_EXEC))
685 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
686 (exectype == EXECF_EXEC ? "exec" : "spawn"),
687 cmd, strerror(errno));
692 PL_statusvalue = status;
698 Perl_do_spawn(pTHX_ char *cmd)
700 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
704 Perl_do_spawn_nowait(pTHX_ char *cmd)
706 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
710 Perl_do_exec(pTHX_ char *cmd)
712 do_spawn2(aTHX_ cmd, EXECF_EXEC);
716 /* The idea here is to read all the directory names into a string table
717 * (separated by nulls) and when one of the other dir functions is called
718 * return the pointer to the current file name.
721 win32_opendir(char *filename)
727 char scanname[MAX_PATH+3];
729 WIN32_FIND_DATAA aFindData;
730 WIN32_FIND_DATAW wFindData;
732 char buffer[MAX_PATH*2];
733 WCHAR wbuffer[MAX_PATH+1];
736 len = strlen(filename);
740 /* check to see if filename is a directory */
741 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
744 /* Get us a DIR structure */
745 Newz(1303, dirp, 1, DIR);
747 /* Create the search pattern */
748 strcpy(scanname, filename);
750 /* bare drive name means look in cwd for drive */
751 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
752 scanname[len++] = '.';
753 scanname[len++] = '/';
755 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
756 scanname[len++] = '/';
758 scanname[len++] = '*';
759 scanname[len] = '\0';
761 /* do the FindFirstFile call */
763 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
764 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
767 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
770 if (fh == INVALID_HANDLE_VALUE) {
771 DWORD err = GetLastError();
772 /* FindFirstFile() fails on empty drives! */
774 case ERROR_FILE_NOT_FOUND:
776 case ERROR_NO_MORE_FILES:
777 case ERROR_PATH_NOT_FOUND:
780 case ERROR_NOT_ENOUGH_MEMORY:
791 /* now allocate the first part of the string table for
792 * the filenames that we find.
795 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
799 ptr = aFindData.cFileName;
806 New(1304, dirp->start, dirp->size, char);
807 strcpy(dirp->start, ptr);
809 dirp->end = dirp->curr = dirp->start;
815 /* Readdir just returns the current string pointer and bumps the
816 * string pointer to the nDllExport entry.
818 DllExport struct direct *
819 win32_readdir(DIR *dirp)
824 /* first set up the structure to return */
825 len = strlen(dirp->curr);
826 strcpy(dirp->dirstr.d_name, dirp->curr);
827 dirp->dirstr.d_namlen = len;
830 dirp->dirstr.d_ino = dirp->curr - dirp->start;
832 /* Now set up for the next call to readdir */
833 dirp->curr += len + 1;
834 if (dirp->curr >= dirp->end) {
838 WIN32_FIND_DATAW wFindData;
839 WIN32_FIND_DATAA aFindData;
840 char buffer[MAX_PATH*2];
842 /* finding the next file that matches the wildcard
843 * (which should be all of them in this directory!).
846 res = FindNextFileW(dirp->handle, &wFindData);
848 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
853 res = FindNextFileA(dirp->handle, &aFindData);
855 ptr = aFindData.cFileName;
858 long endpos = dirp->end - dirp->start;
859 long newsize = endpos + strlen(ptr) + 1;
860 /* bump the string table size by enough for the
861 * new name and its null terminator */
862 while (newsize > dirp->size) {
863 long curpos = dirp->curr - dirp->start;
865 Renew(dirp->start, dirp->size, char);
866 dirp->curr = dirp->start + curpos;
868 strcpy(dirp->start + endpos, ptr);
869 dirp->end = dirp->start + newsize;
875 return &(dirp->dirstr);
881 /* Telldir returns the current string pointer position */
883 win32_telldir(DIR *dirp)
885 return (dirp->curr - dirp->start);
889 /* Seekdir moves the string pointer to a previously saved position
890 * (returned by telldir).
893 win32_seekdir(DIR *dirp, long loc)
895 dirp->curr = dirp->start + loc;
898 /* Rewinddir resets the string pointer to the start */
900 win32_rewinddir(DIR *dirp)
902 dirp->curr = dirp->start;
905 /* free the memory allocated by opendir */
907 win32_closedir(DIR *dirp)
910 if (dirp->handle != INVALID_HANDLE_VALUE)
911 FindClose(dirp->handle);
912 Safefree(dirp->start);
925 * Just pretend that everyone is a superuser. NT will let us know if
926 * we don\'t really have permission to do something.
929 #define ROOT_UID ((uid_t)0)
930 #define ROOT_GID ((gid_t)0)
959 return (auid == ROOT_UID ? 0 : -1);
965 return (agid == ROOT_GID ? 0 : -1);
972 char *buf = w32_getlogin_buffer;
973 DWORD size = sizeof(w32_getlogin_buffer);
974 if (GetUserName(buf,&size))
980 chown(const char *path, uid_t owner, gid_t group)
987 * XXX this needs strengthening (for PerlIO)
990 int mkstemp(const char *path)
993 char buf[MAX_PATH+1];
997 if (i++ > 10) { /* give up */
1001 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1005 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1015 long child = w32_num_children;
1016 while (--child >= 0) {
1017 if ((int)w32_child_pids[child] == pid)
1024 remove_dead_process(long child)
1028 CloseHandle(w32_child_handles[child]);
1029 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1030 (w32_num_children-child-1), HANDLE);
1031 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1032 (w32_num_children-child-1), DWORD);
1039 find_pseudo_pid(int pid)
1042 long child = w32_num_pseudo_children;
1043 while (--child >= 0) {
1044 if ((int)w32_pseudo_child_pids[child] == pid)
1051 remove_dead_pseudo_process(long child)
1055 CloseHandle(w32_pseudo_child_handles[child]);
1056 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1057 (w32_num_pseudo_children-child-1), HANDLE);
1058 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1059 (w32_num_pseudo_children-child-1), DWORD);
1060 w32_num_pseudo_children--;
1066 win32_kill(int pid, int sig)
1074 /* it is a pseudo-forked child */
1075 child = find_pseudo_pid(-pid);
1077 hProcess = w32_pseudo_child_handles[child];
1080 /* "Does process exist?" use of kill */
1083 /* kill -9 style un-graceful exit */
1084 if (TerminateThread(hProcess, sig)) {
1085 remove_dead_pseudo_process(child);
1090 /* We fake signals to pseudo-processes using Win32
1091 * message queue. In Win9X the pids are negative already. */
1092 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1093 /* It might be us ... */
1100 else if (IsWin95()) {
1108 child = find_pid(pid);
1110 hProcess = w32_child_handles[child];
1113 /* "Does process exist?" use of kill */
1116 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1121 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1124 default: /* For now be backwards compatible with perl5.6 */
1126 if (TerminateProcess(hProcess, sig)) {
1127 remove_dead_process(child);
1136 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1137 (IsWin95() ? -pid : pid));
1141 /* "Does process exist?" use of kill */
1145 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1150 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1153 default: /* For now be backwards compatible with perl5.6 */
1155 if (TerminateProcess(hProcess, sig))
1160 CloseHandle(hProcess);
1170 win32_stat(const char *path, Stat_t *sbuf)
1173 char buffer[MAX_PATH+1];
1174 int l = strlen(path);
1176 WCHAR wbuffer[MAX_PATH+1];
1182 switch(path[l - 1]) {
1183 /* FindFirstFile() and stat() are buggy with a trailing
1184 * backslash, so change it to a forward slash :-( */
1186 if (l >= sizeof(buffer)) {
1187 errno = ENAMETOOLONG;
1190 strncpy(buffer, path, l-1);
1191 buffer[l - 1] = '/';
1195 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1197 if (l == 2 && isALPHA(path[0])) {
1198 buffer[0] = path[0];
1209 /* We *must* open & close the file once; otherwise file attribute changes */
1210 /* might not yet have propagated to "other" hard links of the same file. */
1211 /* This also gives us an opportunity to determine the number of links. */
1213 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1214 pwbuffer = PerlDir_mapW(wbuffer);
1215 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1218 path = PerlDir_mapA(path);
1220 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1222 if (handle != INVALID_HANDLE_VALUE) {
1223 BY_HANDLE_FILE_INFORMATION bhi;
1224 if (GetFileInformationByHandle(handle, &bhi))
1225 nlink = bhi.nNumberOfLinks;
1226 CloseHandle(handle);
1229 /* pwbuffer or path will be mapped correctly above */
1231 #if defined(WIN64) || defined(USE_LARGE_FILES)
1232 res = _wstati64(pwbuffer, sbuf);
1234 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1238 #if defined(WIN64) || defined(USE_LARGE_FILES)
1239 res = _stati64(path, sbuf);
1241 res = stat(path, sbuf);
1244 sbuf->st_nlink = nlink;
1247 /* CRT is buggy on sharenames, so make sure it really isn't.
1248 * XXX using GetFileAttributesEx() will enable us to set
1249 * sbuf->st_*time (but note that's not available on the
1250 * Windows of 1995) */
1253 r = GetFileAttributesW(pwbuffer);
1256 r = GetFileAttributesA(path);
1258 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1259 /* sbuf may still contain old garbage since stat() failed */
1260 Zero(sbuf, 1, Stat_t);
1261 sbuf->st_mode = S_IFDIR | S_IREAD;
1263 if (!(r & FILE_ATTRIBUTE_READONLY))
1264 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1269 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1270 && (path[2] == '\\' || path[2] == '/'))
1272 /* The drive can be inaccessible, some _stat()s are buggy */
1274 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1275 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1281 if (S_ISDIR(sbuf->st_mode))
1282 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1283 else if (S_ISREG(sbuf->st_mode)) {
1285 if (l >= 4 && path[l-4] == '.') {
1286 const char *e = path + l - 3;
1287 if (strnicmp(e,"exe",3)
1288 && strnicmp(e,"bat",3)
1289 && strnicmp(e,"com",3)
1290 && (IsWin95() || strnicmp(e,"cmd",3)))
1291 sbuf->st_mode &= ~S_IEXEC;
1293 sbuf->st_mode |= S_IEXEC;
1296 sbuf->st_mode &= ~S_IEXEC;
1297 /* Propagate permissions to _group_ and _others_ */
1298 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1299 sbuf->st_mode |= (perms>>3) | (perms>>6);
1306 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1307 #define SKIP_SLASHES(s) \
1309 while (*(s) && isSLASH(*(s))) \
1312 #define COPY_NONSLASHES(d,s) \
1314 while (*(s) && !isSLASH(*(s))) \
1318 /* Find the longname of a given path. path is destructively modified.
1319 * It should have space for at least MAX_PATH characters. */
1321 win32_longpath(char *path)
1323 WIN32_FIND_DATA fdata;
1325 char tmpbuf[MAX_PATH+1];
1326 char *tmpstart = tmpbuf;
1333 if (isALPHA(path[0]) && path[1] == ':') {
1335 *tmpstart++ = path[0];
1339 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1341 *tmpstart++ = path[0];
1342 *tmpstart++ = path[1];
1343 SKIP_SLASHES(start);
1344 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1346 *tmpstart++ = *start++;
1347 SKIP_SLASHES(start);
1348 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1353 /* copy initial slash, if any */
1354 if (isSLASH(*start)) {
1355 *tmpstart++ = *start++;
1357 SKIP_SLASHES(start);
1360 /* FindFirstFile() expands "." and "..", so we need to pass
1361 * those through unmolested */
1363 && (!start[1] || isSLASH(start[1])
1364 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1366 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1371 /* if this is the end, bust outta here */
1375 /* now we're at a non-slash; walk up to next slash */
1376 while (*start && !isSLASH(*start))
1379 /* stop and find full name of component */
1382 fhand = FindFirstFile(path,&fdata);
1384 if (fhand != INVALID_HANDLE_VALUE) {
1385 STRLEN len = strlen(fdata.cFileName);
1386 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1387 strcpy(tmpstart, fdata.cFileName);
1398 /* failed a step, just return without side effects */
1399 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1404 strcpy(path,tmpbuf);
1409 win32_getenv(const char *name)
1412 WCHAR wBuffer[MAX_PATH+1];
1414 SV *curitem = Nullsv;
1417 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1418 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1421 needlen = GetEnvironmentVariableA(name,NULL,0);
1423 curitem = sv_2mortal(newSVpvn("", 0));
1427 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1428 needlen = GetEnvironmentVariableW(wBuffer,
1429 (WCHAR*)SvPVX(curitem),
1431 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1432 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1433 acuritem = sv_2mortal(newSVsv(curitem));
1434 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1438 SvGROW(curitem, needlen+1);
1439 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1441 } while (needlen >= SvLEN(curitem));
1442 SvCUR_set(curitem, needlen);
1446 /* allow any environment variables that begin with 'PERL'
1447 to be stored in the registry */
1448 if (strncmp(name, "PERL", 4) == 0)
1449 (void)get_regstr(name, &curitem);
1451 if (curitem && SvCUR(curitem))
1452 return SvPVX(curitem);
1458 win32_putenv(const char *name)
1465 int length, relval = -1;
1469 length = strlen(name)+1;
1470 New(1309,wCuritem,length,WCHAR);
1471 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1472 wVal = wcschr(wCuritem, '=');
1475 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1481 New(1309,curitem,strlen(name)+1,char);
1482 strcpy(curitem, name);
1483 val = strchr(curitem, '=');
1485 /* The sane way to deal with the environment.
1486 * Has these advantages over putenv() & co.:
1487 * * enables us to store a truly empty value in the
1488 * environment (like in UNIX).
1489 * * we don't have to deal with RTL globals, bugs and leaks.
1491 * Why you may want to enable USE_WIN32_RTL_ENV:
1492 * * environ[] and RTL functions will not reflect changes,
1493 * which might be an issue if extensions want to access
1494 * the env. via RTL. This cuts both ways, since RTL will
1495 * not see changes made by extensions that call the Win32
1496 * functions directly, either.
1500 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1510 filetime_to_clock(PFILETIME ft)
1512 __int64 qw = ft->dwHighDateTime;
1514 qw |= ft->dwLowDateTime;
1515 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1520 win32_times(struct tms *timebuf)
1525 clock_t process_time_so_far = clock();
1526 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1528 timebuf->tms_utime = filetime_to_clock(&user);
1529 timebuf->tms_stime = filetime_to_clock(&kernel);
1530 timebuf->tms_cutime = 0;
1531 timebuf->tms_cstime = 0;
1533 /* That failed - e.g. Win95 fallback to clock() */
1534 timebuf->tms_utime = process_time_so_far;
1535 timebuf->tms_stime = 0;
1536 timebuf->tms_cutime = 0;
1537 timebuf->tms_cstime = 0;
1539 return process_time_so_far;
1542 /* fix utime() so it works on directories in NT */
1544 filetime_from_time(PFILETIME pFileTime, time_t Time)
1546 struct tm *pTM = localtime(&Time);
1547 SYSTEMTIME SystemTime;
1553 SystemTime.wYear = pTM->tm_year + 1900;
1554 SystemTime.wMonth = pTM->tm_mon + 1;
1555 SystemTime.wDay = pTM->tm_mday;
1556 SystemTime.wHour = pTM->tm_hour;
1557 SystemTime.wMinute = pTM->tm_min;
1558 SystemTime.wSecond = pTM->tm_sec;
1559 SystemTime.wMilliseconds = 0;
1561 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1562 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1566 win32_unlink(const char *filename)
1573 WCHAR wBuffer[MAX_PATH+1];
1576 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1577 pwBuffer = PerlDir_mapW(wBuffer);
1578 attrs = GetFileAttributesW(pwBuffer);
1579 if (attrs == 0xFFFFFFFF)
1581 if (attrs & FILE_ATTRIBUTE_READONLY) {
1582 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1583 ret = _wunlink(pwBuffer);
1585 (void)SetFileAttributesW(pwBuffer, attrs);
1588 ret = _wunlink(pwBuffer);
1591 filename = PerlDir_mapA(filename);
1592 attrs = GetFileAttributesA(filename);
1593 if (attrs == 0xFFFFFFFF)
1595 if (attrs & FILE_ATTRIBUTE_READONLY) {
1596 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1597 ret = unlink(filename);
1599 (void)SetFileAttributesA(filename, attrs);
1602 ret = unlink(filename);
1611 win32_utime(const char *filename, struct utimbuf *times)
1618 struct utimbuf TimeBuffer;
1619 WCHAR wbuffer[MAX_PATH+1];
1624 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1625 pwbuffer = PerlDir_mapW(wbuffer);
1626 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1629 filename = PerlDir_mapA(filename);
1630 rc = utime(filename, times);
1632 /* EACCES: path specifies directory or readonly file */
1633 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1636 if (times == NULL) {
1637 times = &TimeBuffer;
1638 time(×->actime);
1639 times->modtime = times->actime;
1642 /* This will (and should) still fail on readonly files */
1644 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1645 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1646 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1649 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1650 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1651 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1653 if (handle == INVALID_HANDLE_VALUE)
1656 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1657 filetime_from_time(&ftAccess, times->actime) &&
1658 filetime_from_time(&ftWrite, times->modtime) &&
1659 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1664 CloseHandle(handle);
1669 unsigned __int64 ft_i64;
1674 #define Const64(x) x##LL
1676 #define Const64(x) x##i64
1678 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1679 #define EPOCH_BIAS Const64(116444736000000000)
1681 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1682 * and appears to be unsupported even by glibc) */
1684 win32_gettimeofday(struct timeval *tp, void *not_used)
1688 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1689 GetSystemTimeAsFileTime(&ft.ft_val);
1691 /* seconds since epoch */
1692 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1694 /* microseconds remaining */
1695 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1701 win32_uname(struct utsname *name)
1703 struct hostent *hep;
1704 STRLEN nodemax = sizeof(name->nodename)-1;
1705 OSVERSIONINFO osver;
1707 memset(&osver, 0, sizeof(OSVERSIONINFO));
1708 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1709 if (GetVersionEx(&osver)) {
1711 switch (osver.dwPlatformId) {
1712 case VER_PLATFORM_WIN32_WINDOWS:
1713 strcpy(name->sysname, "Windows");
1715 case VER_PLATFORM_WIN32_NT:
1716 strcpy(name->sysname, "Windows NT");
1718 case VER_PLATFORM_WIN32s:
1719 strcpy(name->sysname, "Win32s");
1722 strcpy(name->sysname, "Win32 Unknown");
1727 sprintf(name->release, "%d.%d",
1728 osver.dwMajorVersion, osver.dwMinorVersion);
1731 sprintf(name->version, "Build %d",
1732 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1733 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1734 if (osver.szCSDVersion[0]) {
1735 char *buf = name->version + strlen(name->version);
1736 sprintf(buf, " (%s)", osver.szCSDVersion);
1740 *name->sysname = '\0';
1741 *name->version = '\0';
1742 *name->release = '\0';
1746 hep = win32_gethostbyname("localhost");
1748 STRLEN len = strlen(hep->h_name);
1749 if (len <= nodemax) {
1750 strcpy(name->nodename, hep->h_name);
1753 strncpy(name->nodename, hep->h_name, nodemax);
1754 name->nodename[nodemax] = '\0';
1759 if (!GetComputerName(name->nodename, &sz))
1760 *name->nodename = '\0';
1763 /* machine (architecture) */
1768 GetSystemInfo(&info);
1770 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1771 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1772 procarch = info.u.s.wProcessorArchitecture;
1774 procarch = info.wProcessorArchitecture;
1777 case PROCESSOR_ARCHITECTURE_INTEL:
1778 arch = "x86"; break;
1779 case PROCESSOR_ARCHITECTURE_MIPS:
1780 arch = "mips"; break;
1781 case PROCESSOR_ARCHITECTURE_ALPHA:
1782 arch = "alpha"; break;
1783 case PROCESSOR_ARCHITECTURE_PPC:
1784 arch = "ppc"; break;
1785 #ifdef PROCESSOR_ARCHITECTURE_SHX
1786 case PROCESSOR_ARCHITECTURE_SHX:
1787 arch = "shx"; break;
1789 #ifdef PROCESSOR_ARCHITECTURE_ARM
1790 case PROCESSOR_ARCHITECTURE_ARM:
1791 arch = "arm"; break;
1793 #ifdef PROCESSOR_ARCHITECTURE_IA64
1794 case PROCESSOR_ARCHITECTURE_IA64:
1795 arch = "ia64"; break;
1797 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1798 case PROCESSOR_ARCHITECTURE_ALPHA64:
1799 arch = "alpha64"; break;
1801 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1802 case PROCESSOR_ARCHITECTURE_MSIL:
1803 arch = "msil"; break;
1805 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1806 case PROCESSOR_ARCHITECTURE_AMD64:
1807 arch = "amd64"; break;
1809 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1810 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1811 arch = "ia32-64"; break;
1813 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1814 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1815 arch = "unknown"; break;
1818 sprintf(name->machine, "unknown(0x%x)", procarch);
1819 arch = name->machine;
1822 if (name->machine != arch)
1823 strcpy(name->machine, arch);
1828 /* Timing related stuff */
1831 do_raise(pTHX_ int sig)
1833 if (sig < SIG_SIZE) {
1834 Sighandler_t handler = w32_sighandler[sig];
1835 if (handler == SIG_IGN) {
1838 else if (handler != SIG_DFL) {
1843 /* Choose correct default behaviour */
1859 /* Tell caller to exit thread/process as approriate */
1864 sig_terminate(pTHX_ int sig)
1866 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1867 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1874 win32_async_check(pTHX)
1878 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1879 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1881 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1883 switch(msg.message) {
1886 /* Perhaps some other messages could map to signals ? ... */
1889 /* Treat WM_QUIT like SIGHUP? */
1895 /* We use WM_USER to fake kill() with other signals */
1899 if (do_raise(aTHX_ sig)) {
1900 sig_terminate(aTHX_ sig);
1906 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1907 if (w32_timerid && w32_timerid==msg.wParam) {
1908 KillTimer(NULL,w32_timerid);
1913 /* Now fake a call to signal handler */
1914 if (do_raise(aTHX_ 14)) {
1915 sig_terminate(aTHX_ 14);
1920 /* Otherwise do normal Win32 thing - in case it is useful */
1923 TranslateMessage(&msg);
1924 DispatchMessage(&msg);
1931 /* Above or other stuff may have set a signal flag */
1932 if (PL_sig_pending) {
1938 /* This function will not return until the timeout has elapsed, or until
1939 * one of the handles is ready. */
1941 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1943 /* We may need several goes at this - so compute when we stop */
1945 if (timeout != INFINITE) {
1946 ticks = GetTickCount();
1950 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1953 if (result == WAIT_TIMEOUT) {
1954 /* Ran out of time - explicit return of zero to avoid -ve if we
1955 have scheduling issues
1959 if (timeout != INFINITE) {
1960 ticks = GetTickCount();
1962 if (result == WAIT_OBJECT_0 + count) {
1963 /* Message has arrived - check it */
1964 (void)win32_async_check(aTHX);
1967 /* Not timeout or message - one of handles is ready */
1971 /* compute time left to wait */
1972 ticks = timeout - ticks;
1973 /* If we are past the end say zero */
1974 return (ticks > 0) ? ticks : 0;
1978 win32_internal_wait(int *status, DWORD timeout)
1980 /* XXX this wait emulation only knows about processes
1981 * spawned via win32_spawnvp(P_NOWAIT, ...).
1985 DWORD exitcode, waitcode;
1988 if (w32_num_pseudo_children) {
1989 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1990 timeout, &waitcode);
1991 /* Time out here if there are no other children to wait for. */
1992 if (waitcode == WAIT_TIMEOUT) {
1993 if (!w32_num_children) {
1997 else if (waitcode != WAIT_FAILED) {
1998 if (waitcode >= WAIT_ABANDONED_0
1999 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2000 i = waitcode - WAIT_ABANDONED_0;
2002 i = waitcode - WAIT_OBJECT_0;
2003 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2004 *status = (int)((exitcode & 0xff) << 8);
2005 retval = (int)w32_pseudo_child_pids[i];
2006 remove_dead_pseudo_process(i);
2013 if (!w32_num_children) {
2018 /* if a child exists, wait for it to die */
2019 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2020 if (waitcode == WAIT_TIMEOUT) {
2023 if (waitcode != WAIT_FAILED) {
2024 if (waitcode >= WAIT_ABANDONED_0
2025 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2026 i = waitcode - WAIT_ABANDONED_0;
2028 i = waitcode - WAIT_OBJECT_0;
2029 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2030 *status = (int)((exitcode & 0xff) << 8);
2031 retval = (int)w32_child_pids[i];
2032 remove_dead_process(i);
2037 errno = GetLastError();
2042 win32_waitpid(int pid, int *status, int flags)
2045 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2048 if (pid == -1) /* XXX threadid == 1 ? */
2049 return win32_internal_wait(status, timeout);
2052 child = find_pseudo_pid(-pid);
2054 HANDLE hThread = w32_pseudo_child_handles[child];
2056 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2057 if (waitcode == WAIT_TIMEOUT) {
2060 else if (waitcode == WAIT_OBJECT_0) {
2061 if (GetExitCodeThread(hThread, &waitcode)) {
2062 *status = (int)((waitcode & 0xff) << 8);
2063 retval = (int)w32_pseudo_child_pids[child];
2064 remove_dead_pseudo_process(child);
2071 else if (IsWin95()) {
2080 child = find_pid(pid);
2082 hProcess = w32_child_handles[child];
2083 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2084 if (waitcode == WAIT_TIMEOUT) {
2087 else if (waitcode == WAIT_OBJECT_0) {
2088 if (GetExitCodeProcess(hProcess, &waitcode)) {
2089 *status = (int)((waitcode & 0xff) << 8);
2090 retval = (int)w32_child_pids[child];
2091 remove_dead_process(child);
2100 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2101 (IsWin95() ? -pid : pid));
2103 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2104 if (waitcode == WAIT_TIMEOUT) {
2105 CloseHandle(hProcess);
2108 else if (waitcode == WAIT_OBJECT_0) {
2109 if (GetExitCodeProcess(hProcess, &waitcode)) {
2110 *status = (int)((waitcode & 0xff) << 8);
2111 CloseHandle(hProcess);
2115 CloseHandle(hProcess);
2121 return retval >= 0 ? pid : retval;
2125 win32_wait(int *status)
2127 return win32_internal_wait(status, INFINITE);
2130 DllExport unsigned int
2131 win32_sleep(unsigned int t)
2134 /* Win32 times are in ms so *1000 in and /1000 out */
2135 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2138 DllExport unsigned int
2139 win32_alarm(unsigned int sec)
2142 * the 'obvious' implentation is SetTimer() with a callback
2143 * which does whatever receiving SIGALRM would do
2144 * we cannot use SIGALRM even via raise() as it is not
2145 * one of the supported codes in <signal.h>
2149 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2153 KillTimer(NULL,w32_timerid);
2160 #ifdef HAVE_DES_FCRYPT
2161 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2165 win32_crypt(const char *txt, const char *salt)
2168 #ifdef HAVE_DES_FCRYPT
2169 return des_fcrypt(txt, salt, w32_crypt_buffer);
2171 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2176 #ifdef USE_FIXED_OSFHANDLE
2178 #define FOPEN 0x01 /* file handle open */
2179 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2180 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2181 #define FDEV 0x40 /* file handle refers to device */
2182 #define FTEXT 0x80 /* file handle is in text mode */
2185 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2188 * This function allocates a free C Runtime file handle and associates
2189 * it with the Win32 HANDLE specified by the first parameter. This is a
2190 * temperary fix for WIN95's brain damage GetFileType() error on socket
2191 * we just bypass that call for socket
2193 * This works with MSVC++ 4.0+ or GCC/Mingw32
2196 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2197 * int flags - flags to associate with C Runtime file handle.
2200 * returns index of entry in fh, if successful
2201 * return -1, if no free entry is found
2205 *******************************************************************************/
2208 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2209 * this lets sockets work on Win9X with GCC and should fix the problems
2214 /* create an ioinfo entry, kill its handle, and steal the entry */
2219 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2220 int fh = _open_osfhandle((intptr_t)hF, 0);
2224 EnterCriticalSection(&(_pioinfo(fh)->lock));
2229 my_open_osfhandle(intptr_t osfhandle, int flags)
2232 char fileflags; /* _osfile flags */
2234 /* copy relevant flags from second parameter */
2237 if (flags & O_APPEND)
2238 fileflags |= FAPPEND;
2243 if (flags & O_NOINHERIT)
2244 fileflags |= FNOINHERIT;
2246 /* attempt to allocate a C Runtime file handle */
2247 if ((fh = _alloc_osfhnd()) == -1) {
2248 errno = EMFILE; /* too many open files */
2249 _doserrno = 0L; /* not an OS error */
2250 return -1; /* return error to caller */
2253 /* the file is open. now, set the info in _osfhnd array */
2254 _set_osfhnd(fh, osfhandle);
2256 fileflags |= FOPEN; /* mark as open */
2258 _osfile(fh) = fileflags; /* set osfile entry */
2259 LeaveCriticalSection(&_pioinfo(fh)->lock);
2261 return fh; /* return handle */
2264 #endif /* USE_FIXED_OSFHANDLE */
2266 /* simulate flock by locking a range on the file */
2268 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2269 #define LK_LEN 0xffff0000
2272 win32_flock(int fd, int oper)
2280 Perl_croak_nocontext("flock() unimplemented on this platform");
2283 fh = (HANDLE)_get_osfhandle(fd);
2284 memset(&o, 0, sizeof(o));
2287 case LOCK_SH: /* shared lock */
2288 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2290 case LOCK_EX: /* exclusive lock */
2291 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2293 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2294 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2296 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2297 LK_ERR(LockFileEx(fh,
2298 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2299 0, LK_LEN, 0, &o),i);
2301 case LOCK_UN: /* unlock lock */
2302 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2304 default: /* unknown */
2315 * redirected io subsystem for all XS modules
2328 return (&(_environ));
2331 /* the rest are the remapped stdio routines */
2351 win32_ferror(FILE *fp)
2353 return (ferror(fp));
2358 win32_feof(FILE *fp)
2364 * Since the errors returned by the socket error function
2365 * WSAGetLastError() are not known by the library routine strerror
2366 * we have to roll our own.
2370 win32_strerror(int e)
2372 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2373 extern int sys_nerr;
2377 if (e < 0 || e > sys_nerr) {
2382 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2383 w32_strerror_buffer,
2384 sizeof(w32_strerror_buffer), NULL) == 0)
2385 strcpy(w32_strerror_buffer, "Unknown Error");
2387 return w32_strerror_buffer;
2393 win32_str_os_error(void *sv, DWORD dwErr)
2397 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2398 |FORMAT_MESSAGE_IGNORE_INSERTS
2399 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2400 dwErr, 0, (char *)&sMsg, 1, NULL);
2401 /* strip trailing whitespace and period */
2404 --dwLen; /* dwLen doesn't include trailing null */
2405 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2406 if ('.' != sMsg[dwLen])
2411 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2413 dwLen = sprintf(sMsg,
2414 "Unknown error #0x%lX (lookup 0x%lX)",
2415 dwErr, GetLastError());
2419 sv_setpvn((SV*)sv, sMsg, dwLen);
2425 win32_fprintf(FILE *fp, const char *format, ...)
2428 va_start(marker, format); /* Initialize variable arguments. */
2430 return (vfprintf(fp, format, marker));
2434 win32_printf(const char *format, ...)
2437 va_start(marker, format); /* Initialize variable arguments. */
2439 return (vprintf(format, marker));
2443 win32_vfprintf(FILE *fp, const char *format, va_list args)
2445 return (vfprintf(fp, format, args));
2449 win32_vprintf(const char *format, va_list args)
2451 return (vprintf(format, args));
2455 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2457 return fread(buf, size, count, fp);
2461 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2463 return fwrite(buf, size, count, fp);
2466 #define MODE_SIZE 10
2469 win32_fopen(const char *filename, const char *mode)
2472 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2478 if (stricmp(filename, "/dev/null")==0)
2482 A2WHELPER(mode, wMode, sizeof(wMode));
2483 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2484 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2487 f = fopen(PerlDir_mapA(filename), mode);
2488 /* avoid buffering headaches for child processes */
2489 if (f && *mode == 'a')
2490 win32_fseek(f, 0, SEEK_END);
2494 #ifndef USE_SOCKETS_AS_HANDLES
2496 #define fdopen my_fdopen
2500 win32_fdopen(int handle, const char *mode)
2503 WCHAR wMode[MODE_SIZE];
2506 A2WHELPER(mode, wMode, sizeof(wMode));
2507 f = _wfdopen(handle, wMode);
2510 f = fdopen(handle, (char *) mode);
2511 /* avoid buffering headaches for child processes */
2512 if (f && *mode == 'a')
2513 win32_fseek(f, 0, SEEK_END);
2518 win32_freopen(const char *path, const char *mode, FILE *stream)
2521 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2522 if (stricmp(path, "/dev/null")==0)
2526 A2WHELPER(mode, wMode, sizeof(wMode));
2527 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2528 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2530 return freopen(PerlDir_mapA(path), mode, stream);
2534 win32_fclose(FILE *pf)
2536 return my_fclose(pf); /* defined in win32sck.c */
2540 win32_fputs(const char *s,FILE *pf)
2542 return fputs(s, pf);
2546 win32_fputc(int c,FILE *pf)
2552 win32_ungetc(int c,FILE *pf)
2554 return ungetc(c,pf);
2558 win32_getc(FILE *pf)
2564 win32_fileno(FILE *pf)
2570 win32_clearerr(FILE *pf)
2577 win32_fflush(FILE *pf)
2583 win32_ftell(FILE *pf)
2585 #if defined(WIN64) || defined(USE_LARGE_FILES)
2586 #if defined(__BORLAND__) /* buk */
2587 return win32_tell( fileno( pf ) );
2590 if (fgetpos(pf, &pos))
2600 win32_fseek(FILE *pf, Off_t offset,int origin)
2602 #if defined(WIN64) || defined(USE_LARGE_FILES)
2603 #if defined(__BORLANDC__) /* buk */
2613 if (fgetpos(pf, &pos))
2618 fseek(pf, 0, SEEK_END);
2619 pos = _telli64(fileno(pf));
2628 return fsetpos(pf, &offset);
2631 return fseek(pf, offset, origin);
2636 win32_fgetpos(FILE *pf,fpos_t *p)
2638 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2639 if( win32_tell(fileno(pf)) == -1L ) {
2645 return fgetpos(pf, p);
2650 win32_fsetpos(FILE *pf,const fpos_t *p)
2652 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2653 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2655 return fsetpos(pf, p);
2660 win32_rewind(FILE *pf)
2670 char prefix[MAX_PATH+1];
2671 char filename[MAX_PATH+1];
2672 DWORD len = GetTempPath(MAX_PATH, prefix);
2673 if (len && len < MAX_PATH) {
2674 if (GetTempFileName(prefix, "plx", 0, filename)) {
2675 HANDLE fh = CreateFile(filename,
2676 DELETE | GENERIC_READ | GENERIC_WRITE,
2680 FILE_ATTRIBUTE_NORMAL
2681 | FILE_FLAG_DELETE_ON_CLOSE,
2683 if (fh != INVALID_HANDLE_VALUE) {
2684 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2686 #if defined(__BORLANDC__)
2687 setmode(fd,O_BINARY);
2689 DEBUG_p(PerlIO_printf(Perl_debug_log,
2690 "Created tmpfile=%s\n",filename));
2702 int fd = win32_tmpfd();
2704 return win32_fdopen(fd, "w+b");
2716 win32_fstat(int fd, Stat_t *sbufptr)
2719 /* A file designated by filehandle is not shown as accessible
2720 * for write operations, probably because it is opened for reading.
2723 int rc = fstat(fd,sbufptr);
2724 BY_HANDLE_FILE_INFORMATION bhfi;
2725 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2726 sbufptr->st_mode &= 0xFE00;
2727 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2728 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2730 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2731 + ((S_IREAD|S_IWRITE) >> 6));
2735 return my_fstat(fd,sbufptr);
2740 win32_pipe(int *pfd, unsigned int size, int mode)
2742 return _pipe(pfd, size, mode);
2746 win32_popenlist(const char *mode, IV narg, SV **args)
2749 Perl_croak(aTHX_ "List form of pipe open not implemented");
2754 * a popen() clone that respects PERL5SHELL
2756 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2760 win32_popen(const char *command, const char *mode)
2762 #ifdef USE_RTL_POPEN
2763 return _popen(command, mode);
2775 /* establish which ends read and write */
2776 if (strchr(mode,'w')) {
2777 stdfd = 0; /* stdin */
2780 nhandle = STD_INPUT_HANDLE;
2782 else if (strchr(mode,'r')) {
2783 stdfd = 1; /* stdout */
2786 nhandle = STD_OUTPUT_HANDLE;
2791 /* set the correct mode */
2792 if (strchr(mode,'b'))
2794 else if (strchr(mode,'t'))
2797 ourmode = _fmode & (O_TEXT | O_BINARY);
2799 /* the child doesn't inherit handles */
2800 ourmode |= O_NOINHERIT;
2802 if (win32_pipe(p, 512, ourmode) == -1)
2805 /* save current stdfd */
2806 if ((oldfd = win32_dup(stdfd)) == -1)
2809 /* save the old std handle (this needs to happen before the
2810 * dup2(), since that might call SetStdHandle() too) */
2813 old_h = GetStdHandle(nhandle);
2815 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2816 /* stdfd will be inherited by the child */
2817 if (win32_dup2(p[child], stdfd) == -1)
2820 /* close the child end in parent */
2821 win32_close(p[child]);
2823 /* set the new std handle (in case dup2() above didn't) */
2824 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2826 /* start the child */
2829 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2832 /* revert stdfd to whatever it was before */
2833 if (win32_dup2(oldfd, stdfd) == -1)
2836 /* restore the old std handle (this needs to happen after the
2837 * dup2(), since that might call SetStdHandle() too */
2839 SetStdHandle(nhandle, old_h);
2844 /* close saved handle */
2848 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2851 /* set process id so that it can be returned by perl's open() */
2852 PL_forkprocess = childpid;
2855 /* we have an fd, return a file stream */
2856 return (PerlIO_fdopen(p[parent], (char *)mode));
2859 /* we don't need to check for errors here */
2863 SetStdHandle(nhandle, old_h);
2868 win32_dup2(oldfd, stdfd);
2873 #endif /* USE_RTL_POPEN */
2881 win32_pclose(PerlIO *pf)
2883 #ifdef USE_RTL_POPEN
2887 int childpid, status;
2891 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2894 childpid = SvIVX(sv);
2911 if (win32_waitpid(childpid, &status, 0) == -1)
2916 #endif /* USE_RTL_POPEN */
2922 LPCWSTR lpExistingFileName,
2923 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2926 WCHAR wFullName[MAX_PATH+1];
2927 LPVOID lpContext = NULL;
2928 WIN32_STREAM_ID StreamId;
2929 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2934 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2935 BOOL, BOOL, LPVOID*) =
2936 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2937 BOOL, BOOL, LPVOID*))
2938 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2939 if (pfnBackupWrite == NULL)
2942 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2945 dwLen = (dwLen+1)*sizeof(WCHAR);
2947 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2948 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2949 NULL, OPEN_EXISTING, 0, NULL);
2950 if (handle == INVALID_HANDLE_VALUE)
2953 StreamId.dwStreamId = BACKUP_LINK;
2954 StreamId.dwStreamAttributes = 0;
2955 StreamId.dwStreamNameSize = 0;
2956 #if defined(__BORLANDC__) \
2957 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2958 StreamId.Size.u.HighPart = 0;
2959 StreamId.Size.u.LowPart = dwLen;
2961 StreamId.Size.HighPart = 0;
2962 StreamId.Size.LowPart = dwLen;
2965 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2966 FALSE, FALSE, &lpContext);
2968 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2969 FALSE, FALSE, &lpContext);
2970 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2973 CloseHandle(handle);
2978 win32_link(const char *oldname, const char *newname)
2981 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2982 WCHAR wOldName[MAX_PATH+1];
2983 WCHAR wNewName[MAX_PATH+1];
2986 Perl_croak(aTHX_ PL_no_func, "link");
2988 pfnCreateHardLinkW =
2989 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2990 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2991 if (pfnCreateHardLinkW == NULL)
2992 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2994 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2995 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2996 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2997 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3001 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3006 win32_rename(const char *oname, const char *newname)
3008 WCHAR wOldName[MAX_PATH+1];
3009 WCHAR wNewName[MAX_PATH+1];
3010 char szOldName[MAX_PATH+1];
3011 char szNewName[MAX_PATH+1];
3015 /* XXX despite what the documentation says about MoveFileEx(),
3016 * it doesn't work under Windows95!
3019 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3021 A2WHELPER(oname, wOldName, sizeof(wOldName));
3022 A2WHELPER(newname, wNewName, sizeof(wNewName));
3023 if (wcsicmp(wNewName, wOldName))
3024 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3025 wcscpy(wOldName, PerlDir_mapW(wOldName));
3026 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
3029 if (stricmp(newname, oname))
3030 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3031 strcpy(szOldName, PerlDir_mapA(oname));
3032 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3035 DWORD err = GetLastError();
3037 case ERROR_BAD_NET_NAME:
3038 case ERROR_BAD_NETPATH:
3039 case ERROR_BAD_PATHNAME:
3040 case ERROR_FILE_NOT_FOUND:
3041 case ERROR_FILENAME_EXCED_RANGE:
3042 case ERROR_INVALID_DRIVE:
3043 case ERROR_NO_MORE_FILES:
3044 case ERROR_PATH_NOT_FOUND:
3057 char szTmpName[MAX_PATH+1];
3058 char dname[MAX_PATH+1];
3059 char *endname = Nullch;
3061 DWORD from_attr, to_attr;
3063 strcpy(szOldName, PerlDir_mapA(oname));
3064 strcpy(szNewName, PerlDir_mapA(newname));
3066 /* if oname doesn't exist, do nothing */
3067 from_attr = GetFileAttributes(szOldName);
3068 if (from_attr == 0xFFFFFFFF) {
3073 /* if newname exists, rename it to a temporary name so that we
3074 * don't delete it in case oname happens to be the same file
3075 * (but perhaps accessed via a different path)
3077 to_attr = GetFileAttributes(szNewName);
3078 if (to_attr != 0xFFFFFFFF) {
3079 /* if newname is a directory, we fail
3080 * XXX could overcome this with yet more convoluted logic */
3081 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3085 tmplen = strlen(szNewName);
3086 strcpy(szTmpName,szNewName);
3087 endname = szTmpName+tmplen;
3088 for (; endname > szTmpName ; --endname) {
3089 if (*endname == '/' || *endname == '\\') {
3094 if (endname > szTmpName)
3095 endname = strcpy(dname,szTmpName);
3099 /* get a temporary filename in same directory
3100 * XXX is this really the best we can do? */
3101 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3105 DeleteFile(szTmpName);
3107 retval = rename(szNewName, szTmpName);
3114 /* rename oname to newname */
3115 retval = rename(szOldName, szNewName);
3117 /* if we created a temporary file before ... */
3118 if (endname != Nullch) {
3119 /* ...and rename succeeded, delete temporary file/directory */
3121 DeleteFile(szTmpName);
3122 /* else restore it to what it was */
3124 (void)rename(szTmpName, szNewName);
3131 win32_setmode(int fd, int mode)
3133 return setmode(fd, mode);
3137 win32_chsize(int fd, Off_t size)
3139 #if defined(WIN64) || defined(USE_LARGE_FILES)
3141 Off_t cur, end, extend;
3143 cur = win32_tell(fd);
3146 end = win32_lseek(fd, 0, SEEK_END);
3149 extend = size - end;
3153 else if (extend > 0) {
3154 /* must grow the file, padding with nulls */
3156 int oldmode = win32_setmode(fd, O_BINARY);
3158 memset(b, '\0', sizeof(b));
3160 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3161 count = win32_write(fd, b, count);
3162 if ((int)count < 0) {
3166 } while ((extend -= count) > 0);
3167 win32_setmode(fd, oldmode);
3170 /* shrink the file */
3171 win32_lseek(fd, size, SEEK_SET);
3172 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3178 win32_lseek(fd, cur, SEEK_SET);
3181 return chsize(fd, size);
3186 win32_lseek(int fd, Off_t offset, int origin)
3188 #if defined(WIN64) || defined(USE_LARGE_FILES)
3189 #if defined(__BORLANDC__) /* buk */
3191 pos.QuadPart = offset;
3192 pos.LowPart = SetFilePointer(
3193 (HANDLE)_get_osfhandle(fd),
3198 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3202 return pos.QuadPart;
3204 return _lseeki64(fd, offset, origin);
3207 return lseek(fd, offset, origin);
3214 #if defined(WIN64) || defined(USE_LARGE_FILES)
3215 #if defined(__BORLANDC__) /* buk */
3218 pos.LowPart = SetFilePointer(
3219 (HANDLE)_get_osfhandle(fd),
3224 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3228 return pos.QuadPart;
3229 /* return tell(fd); */
3231 return _telli64(fd);
3239 win32_open(const char *path, int flag, ...)
3244 WCHAR wBuffer[MAX_PATH+1];
3247 pmode = va_arg(ap, int);
3250 if (stricmp(path, "/dev/null")==0)
3254 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3255 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3257 return open(PerlDir_mapA(path), flag, pmode);
3260 /* close() that understands socket */
3261 extern int my_close(int); /* in win32sck.c */
3266 return my_close(fd);
3282 win32_dup2(int fd1,int fd2)
3284 return dup2(fd1,fd2);
3287 #ifdef PERL_MSVCRT_READFIX
3289 #define LF 10 /* line feed */
3290 #define CR 13 /* carriage return */
3291 #define CTRLZ 26 /* ctrl-z means eof for text */
3292 #define FOPEN 0x01 /* file handle open */
3293 #define FEOFLAG 0x02 /* end of file has been encountered */
3294 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3295 #define FPIPE 0x08 /* file handle refers to a pipe */
3296 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3297 #define FDEV 0x40 /* file handle refers to device */
3298 #define FTEXT 0x80 /* file handle is in text mode */
3299 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3302 _fixed_read(int fh, void *buf, unsigned cnt)
3304 int bytes_read; /* number of bytes read */
3305 char *buffer; /* buffer to read to */
3306 int os_read; /* bytes read on OS call */
3307 char *p, *q; /* pointers into buffer */
3308 char peekchr; /* peek-ahead character */
3309 ULONG filepos; /* file position after seek */
3310 ULONG dosretval; /* o.s. return value */
3312 /* validate handle */
3313 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3314 !(_osfile(fh) & FOPEN))
3316 /* out of range -- return error */
3318 _doserrno = 0; /* not o.s. error */
3323 * If lockinitflag is FALSE, assume fd is device
3324 * lockinitflag is set to TRUE by open.
3326 if (_pioinfo(fh)->lockinitflag)
3327 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3329 bytes_read = 0; /* nothing read yet */
3330 buffer = (char*)buf;
3332 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3333 /* nothing to read or at EOF, so return 0 read */
3337 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3338 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3340 *buffer++ = _pipech(fh);
3343 _pipech(fh) = LF; /* mark as empty */
3348 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3350 /* ReadFile has reported an error. recognize two special cases.
3352 * 1. map ERROR_ACCESS_DENIED to EBADF
3354 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3355 * means the handle is a read-handle on a pipe for which
3356 * all write-handles have been closed and all data has been
3359 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3360 /* wrong read/write mode should return EBADF, not EACCES */
3362 _doserrno = dosretval;
3366 else if (dosretval == ERROR_BROKEN_PIPE) {
3376 bytes_read += os_read; /* update bytes read */
3378 if (_osfile(fh) & FTEXT) {
3379 /* now must translate CR-LFs to LFs in the buffer */
3381 /* set CRLF flag to indicate LF at beginning of buffer */
3382 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3383 /* _osfile(fh) |= FCRLF; */
3385 /* _osfile(fh) &= ~FCRLF; */
3387 _osfile(fh) &= ~FCRLF;
3389 /* convert chars in the buffer: p is src, q is dest */
3391 while (p < (char *)buf + bytes_read) {
3393 /* if fh is not a device, set ctrl-z flag */
3394 if (!(_osfile(fh) & FDEV))
3395 _osfile(fh) |= FEOFLAG;
3396 break; /* stop translating */
3401 /* *p is CR, so must check next char for LF */
3402 if (p < (char *)buf + bytes_read - 1) {
3405 *q++ = LF; /* convert CR-LF to LF */
3408 *q++ = *p++; /* store char normally */
3411 /* This is the hard part. We found a CR at end of
3412 buffer. We must peek ahead to see if next char
3417 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3418 (LPDWORD)&os_read, NULL))
3419 dosretval = GetLastError();
3421 if (dosretval != 0 || os_read == 0) {
3422 /* couldn't read ahead, store CR */
3426 /* peekchr now has the extra character -- we now
3427 have several possibilities:
3428 1. disk file and char is not LF; just seek back
3430 2. disk file and char is LF; store LF, don't seek back
3431 3. pipe/device and char is LF; store LF.
3432 4. pipe/device and char isn't LF, store CR and
3433 put char in pipe lookahead buffer. */
3434 if (_osfile(fh) & (FDEV|FPIPE)) {
3435 /* non-seekable device */
3440 _pipech(fh) = peekchr;
3445 if (peekchr == LF) {
3446 /* nothing read yet; must make some
3449 /* turn on this flag for tell routine */
3450 _osfile(fh) |= FCRLF;
3453 HANDLE osHandle; /* o.s. handle value */
3455 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3457 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3458 dosretval = GetLastError();
3469 /* we now change bytes_read to reflect the true number of chars
3471 bytes_read = q - (char *)buf;
3475 if (_pioinfo(fh)->lockinitflag)
3476 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3481 #endif /* PERL_MSVCRT_READFIX */
3484 win32_read(int fd, void *buf, unsigned int cnt)
3486 #ifdef PERL_MSVCRT_READFIX
3487 return _fixed_read(fd, buf, cnt);
3489 return read(fd, buf, cnt);
3494 win32_write(int fd, const void *buf, unsigned int cnt)
3496 return write(fd, buf, cnt);
3500 win32_mkdir(const char *dir, int mode)
3504 WCHAR wBuffer[MAX_PATH+1];
3505 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3506 return _wmkdir(PerlDir_mapW(wBuffer));
3508 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3512 win32_rmdir(const char *dir)
3516 WCHAR wBuffer[MAX_PATH+1];
3517 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3518 return _wrmdir(PerlDir_mapW(wBuffer));
3520 return rmdir(PerlDir_mapA(dir));
3524 win32_chdir(const char *dir)
3532 WCHAR wBuffer[MAX_PATH+1];
3533 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3534 return _wchdir(wBuffer);
3540 win32_access(const char *path, int mode)
3544 WCHAR wBuffer[MAX_PATH+1];
3545 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3546 return _waccess(PerlDir_mapW(wBuffer), mode);
3548 return access(PerlDir_mapA(path), mode);
3552 win32_chmod(const char *path, int mode)
3556 WCHAR wBuffer[MAX_PATH+1];
3557 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3558 return _wchmod(PerlDir_mapW(wBuffer), mode);
3560 return chmod(PerlDir_mapA(path), mode);
3565 create_command_line(char *cname, STRLEN clen, const char * const *args)
3572 bool bat_file = FALSE;
3573 bool cmd_shell = FALSE;
3574 bool dumb_shell = FALSE;
3575 bool extra_quotes = FALSE;
3576 bool quote_next = FALSE;
3579 cname = (char*)args[0];
3581 /* The NT cmd.exe shell has the following peculiarity that needs to be
3582 * worked around. It strips a leading and trailing dquote when any
3583 * of the following is true:
3584 * 1. the /S switch was used
3585 * 2. there are more than two dquotes
3586 * 3. there is a special character from this set: &<>()@^|
3587 * 4. no whitespace characters within the two dquotes
3588 * 5. string between two dquotes isn't an executable file
3589 * To work around this, we always add a leading and trailing dquote
3590 * to the string, if the first argument is either "cmd.exe" or "cmd",
3591 * and there were at least two or more arguments passed to cmd.exe
3592 * (not including switches).
3593 * XXX the above rules (from "cmd /?") don't seem to be applied
3594 * always, making for the convolutions below :-(
3598 clen = strlen(cname);
3601 && (stricmp(&cname[clen-4], ".bat") == 0
3602 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3609 char *exe = strrchr(cname, '/');
3610 char *exe2 = strrchr(cname, '\\');
3617 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3621 else if (stricmp(exe, "command.com") == 0
3622 || stricmp(exe, "command") == 0)
3629 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3630 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3631 STRLEN curlen = strlen(arg);
3632 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3633 len += 2; /* assume quoting needed (worst case) */
3635 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3637 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3640 New(1310, cmd, len, char);
3643 if (bat_file && !IsWin95()) {
3645 extra_quotes = TRUE;
3648 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3650 STRLEN curlen = strlen(arg);
3652 /* we want to protect empty arguments and ones with spaces with
3653 * dquotes, but only if they aren't already there */
3658 else if (quote_next) {
3659 /* see if it really is multiple arguments pretending to
3660 * be one and force a set of quotes around it */
3661 if (*find_next_space(arg))
3664 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3666 while (i < curlen) {
3667 if (isSPACE(arg[i])) {
3670 else if (arg[i] == '"') {
3694 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3695 && stricmp(arg+curlen-2, "/c") == 0)
3697 /* is there a next argument? */
3698 if (args[index+1]) {
3699 /* are there two or more next arguments? */
3700 if (args[index+2]) {
3702 extra_quotes = TRUE;
3705 /* single argument, force quoting if it has spaces */
3721 qualified_path(const char *cmd)
3725 char *fullcmd, *curfullcmd;
3731 fullcmd = (char*)cmd;
3733 if (*fullcmd == '/' || *fullcmd == '\\')
3740 pathstr = PerlEnv_getenv("PATH");
3742 /* worst case: PATH is a single directory; we need additional space
3743 * to append "/", ".exe" and trailing "\0" */
3744 New(0, fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3745 curfullcmd = fullcmd;
3750 /* start by appending the name to the current prefix */
3751 strcpy(curfullcmd, cmd);
3752 curfullcmd += cmdlen;
3754 /* if it doesn't end with '.', or has no extension, try adding
3755 * a trailing .exe first */
3756 if (cmd[cmdlen-1] != '.'
3757 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3759 strcpy(curfullcmd, ".exe");
3760 res = GetFileAttributes(fullcmd);
3761 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3766 /* that failed, try the bare name */
3767 res = GetFileAttributes(fullcmd);
3768 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3771 /* quit if no other path exists, or if cmd already has path */
3772 if (!pathstr || !*pathstr || has_slash)
3775 /* skip leading semis */
3776 while (*pathstr == ';')
3779 /* build a new prefix from scratch */
3780 curfullcmd = fullcmd;
3781 while (*pathstr && *pathstr != ';') {
3782 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3783 pathstr++; /* skip initial '"' */
3784 while (*pathstr && *pathstr != '"') {
3785 *curfullcmd++ = *pathstr++;
3788 pathstr++; /* skip trailing '"' */
3791 *curfullcmd++ = *pathstr++;
3795 pathstr++; /* skip trailing semi */
3796 if (curfullcmd > fullcmd /* append a dir separator */
3797 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3799 *curfullcmd++ = '\\';
3807 /* The following are just place holders.
3808 * Some hosts may provide and environment that the OS is
3809 * not tracking, therefore, these host must provide that
3810 * environment and the current directory to CreateProcess
3814 win32_get_childenv(void)
3820 win32_free_childenv(void* d)
3825 win32_clearenv(void)
3827 char *envv = GetEnvironmentStrings();
3831 char *end = strchr(cur,'=');
3832 if (end && end != cur) {
3834 SetEnvironmentVariable(cur, NULL);
3836 cur = end + strlen(end+1)+2;
3838 else if ((len = strlen(cur)))
3841 FreeEnvironmentStrings(envv);
3845 win32_get_childdir(void)
3849 char szfilename[(MAX_PATH+1)*2];
3851 WCHAR wfilename[MAX_PATH+1];
3852 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3853 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3856 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3859 New(0, ptr, strlen(szfilename)+1, char);
3860 strcpy(ptr, szfilename);
3865 win32_free_childdir(char* d)
3872 /* XXX this needs to be made more compatible with the spawnvp()
3873 * provided by the various RTLs. In particular, searching for
3874 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3875 * This doesn't significantly affect perl itself, because we
3876 * always invoke things using PERL5SHELL if a direct attempt to
3877 * spawn the executable fails.
3879 * XXX splitting and rejoining the commandline between do_aspawn()
3880 * and win32_spawnvp() could also be avoided.
3884 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3886 #ifdef USE_RTL_SPAWNVP
3887 return spawnvp(mode, cmdname, (char * const *)argv);
3894 STARTUPINFO StartupInfo;
3895 PROCESS_INFORMATION ProcessInformation;
3898 char *fullcmd = Nullch;
3899 char *cname = (char *)cmdname;
3903 clen = strlen(cname);
3904 /* if command name contains dquotes, must remove them */
3905 if (strchr(cname, '"')) {
3907 New(0,cname,clen+1,char);
3920 cmd = create_command_line(cname, clen, argv);
3922 env = PerlEnv_get_childenv();
3923 dir = PerlEnv_get_childdir();
3926 case P_NOWAIT: /* asynch + remember result */
3927 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3932 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3935 create |= CREATE_NEW_PROCESS_GROUP;
3938 case P_WAIT: /* synchronous execution */
3940 default: /* invalid mode */
3945 memset(&StartupInfo,0,sizeof(StartupInfo));
3946 StartupInfo.cb = sizeof(StartupInfo);
3947 memset(&tbl,0,sizeof(tbl));
3948 PerlEnv_get_child_IO(&tbl);
3949 StartupInfo.dwFlags = tbl.dwFlags;
3950 StartupInfo.dwX = tbl.dwX;
3951 StartupInfo.dwY = tbl.dwY;
3952 StartupInfo.dwXSize = tbl.dwXSize;
3953 StartupInfo.dwYSize = tbl.dwYSize;
3954 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3955 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3956 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3957 StartupInfo.wShowWindow = tbl.wShowWindow;
3958 StartupInfo.hStdInput = tbl.childStdIn;
3959 StartupInfo.hStdOutput = tbl.childStdOut;
3960 StartupInfo.hStdError = tbl.childStdErr;
3961 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3962 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3963 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3965 create |= CREATE_NEW_CONSOLE;
3968 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3970 if (w32_use_showwindow) {
3971 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3972 StartupInfo.wShowWindow = w32_showwindow;
3975 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3978 if (!CreateProcess(cname, /* search PATH to find executable */
3979 cmd, /* executable, and its arguments */
3980 NULL, /* process attributes */
3981 NULL, /* thread attributes */
3982 TRUE, /* inherit handles */
3983 create, /* creation flags */
3984 (LPVOID)env, /* inherit environment */
3985 dir, /* inherit cwd */
3987 &ProcessInformation))
3989 /* initial NULL argument to CreateProcess() does a PATH
3990 * search, but it always first looks in the directory
3991 * where the current process was started, which behavior
3992 * is undesirable for backward compatibility. So we
3993 * jump through our own hoops by picking out the path
3994 * we really want it to use. */
3996 fullcmd = qualified_path(cname);
3998 if (cname != cmdname)
4001 DEBUG_p(PerlIO_printf(Perl_debug_log,
4002 "Retrying [%s] with same args\n",
4012 if (mode == P_NOWAIT) {
4013 /* asynchronous spawn -- store handle, return PID */
4014 ret = (int)ProcessInformation.dwProcessId;
4015 if (IsWin95() && ret < 0)
4018 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4019 w32_child_pids[w32_num_children] = (DWORD)ret;
4024 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4025 /* FIXME: if msgwait returned due to message perhaps forward the
4026 "signal" to the process
4028 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4030 CloseHandle(ProcessInformation.hProcess);
4033 CloseHandle(ProcessInformation.hThread);
4036 PerlEnv_free_childenv(env);
4037 PerlEnv_free_childdir(dir);
4039 if (cname != cmdname)
4046 win32_execv(const char *cmdname, const char *const *argv)
4050 /* if this is a pseudo-forked child, we just want to spawn
4051 * the new program, and return */
4053 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4055 return execv(cmdname, (char *const *)argv);
4059 win32_execvp(const char *cmdname, const char *const *argv)
4063 /* if this is a pseudo-forked child, we just want to spawn
4064 * the new program, and return */
4065 if (w32_pseudo_id) {
4066 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4075 return execvp(cmdname, (char *const *)argv);
4079 win32_perror(const char *str)
4085 win32_setbuf(FILE *pf, char *buf)
4091 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4093 return setvbuf(pf, buf, type, size);
4097 win32_flushall(void)
4103 win32_fcloseall(void)
4109 win32_fgets(char *s, int n, FILE *pf)
4111 return fgets(s, n, pf);
4121 win32_fgetc(FILE *pf)
4127 win32_putc(int c, FILE *pf)
4133 win32_puts(const char *s)
4145 win32_putchar(int c)
4152 #ifndef USE_PERL_SBRK
4154 static char *committed = NULL; /* XXX threadead */
4155 static char *base = NULL; /* XXX threadead */
4156 static char *reserved = NULL; /* XXX threadead */
4157 static char *brk = NULL; /* XXX threadead */
4158 static DWORD pagesize = 0; /* XXX threadead */
4161 sbrk(ptrdiff_t need)
4166 GetSystemInfo(&info);
4167 /* Pretend page size is larger so we don't perpetually
4168 * call the OS to commit just one page ...
4170 pagesize = info.dwPageSize << 3;
4172 if (brk+need >= reserved)
4174 DWORD size = brk+need-reserved;
4176 char *prev_committed = NULL;
4177 if (committed && reserved && committed < reserved)
4179 /* Commit last of previous chunk cannot span allocations */
4180 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4183 /* Remember where we committed from in case we want to decommit later */
4184 prev_committed = committed;
4185 committed = reserved;
4188 /* Reserve some (more) space
4189 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4190 * this is only address space not memory...
4191 * Note this is a little sneaky, 1st call passes NULL as reserved
4192 * so lets system choose where we start, subsequent calls pass
4193 * the old end address so ask for a contiguous block
4196 if (size < 64*1024*1024)
4197 size = 64*1024*1024;
4198 size = ((size + pagesize - 1) / pagesize) * pagesize;
4199 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4202 reserved = addr+size;
4212 /* The existing block could not be extended far enough, so decommit
4213 * anything that was just committed above and start anew */
4216 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4219 reserved = base = committed = brk = NULL;
4230 if (brk > committed)
4232 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4234 if (committed+size > reserved)
4235 size = reserved-committed;
4236 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4249 win32_malloc(size_t size)
4251 return malloc(size);
4255 win32_calloc(size_t numitems, size_t size)
4257 return calloc(numitems,size);
4261 win32_realloc(void *block, size_t size)
4263 return realloc(block,size);
4267 win32_free(void *block)
4274 win32_open_osfhandle(intptr_t handle, int flags)
4276 #ifdef USE_FIXED_OSFHANDLE
4278 return my_open_osfhandle(handle, flags);
4280 return _open_osfhandle(handle, flags);
4284 win32_get_osfhandle(int fd)
4286 return (intptr_t)_get_osfhandle(fd);
4290 win32_fdupopen(FILE *pf)
4295 int fileno = win32_dup(win32_fileno(pf));
4297 /* open the file in the same mode */
4299 if((pf)->flags & _F_READ) {
4303 else if((pf)->flags & _F_WRIT) {
4307 else if((pf)->flags & _F_RDWR) {
4313 if((pf)->_flag & _IOREAD) {
4317 else if((pf)->_flag & _IOWRT) {
4321 else if((pf)->_flag & _IORW) {
4328 /* it appears that the binmode is attached to the
4329 * file descriptor so binmode files will be handled
4332 pfdup = win32_fdopen(fileno, mode);
4334 /* move the file pointer to the same position */
4335 if (!fgetpos(pf, &pos)) {
4336 fsetpos(pfdup, &pos);
4342 win32_dynaload(const char* filename)
4346 char buf[MAX_PATH+1];
4349 /* LoadLibrary() doesn't recognize forward slashes correctly,
4350 * so turn 'em back. */
4351 first = strchr(filename, '/');
4353 STRLEN len = strlen(filename);
4354 if (len <= MAX_PATH) {
4355 strcpy(buf, filename);
4356 filename = &buf[first - filename];
4358 if (*filename == '/')
4359 *(char*)filename = '\\';
4366 WCHAR wfilename[MAX_PATH+1];
4367 A2WHELPER(filename, wfilename, sizeof(wfilename));
4368 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4371 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4381 XS(w32_SetChildShowWindow)
4384 BOOL use_showwindow = w32_use_showwindow;
4385 /* use "unsigned short" because Perl has redefined "WORD" */
4386 unsigned short showwindow = w32_showwindow;
4389 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4391 if (items == 0 || !SvOK(ST(0)))
4392 w32_use_showwindow = FALSE;
4394 w32_use_showwindow = TRUE;
4395 w32_showwindow = (unsigned short)SvIV(ST(0));
4400 ST(0) = sv_2mortal(newSViv(showwindow));
4402 ST(0) = &PL_sv_undef;
4410 /* Make the host for current directory */
4411 char* ptr = PerlEnv_get_childdir();
4414 * then it worked, set PV valid,
4415 * else return 'undef'
4418 SV *sv = sv_newmortal();
4420 PerlEnv_free_childdir(ptr);
4422 #ifndef INCOMPLETE_TAINTS
4439 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4440 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4447 XS(w32_GetNextAvailDrive)
4451 char root[] = "_:\\";
4456 if (GetDriveType(root) == 1) {
4465 XS(w32_GetLastError)
4469 XSRETURN_IV(GetLastError());
4473 XS(w32_SetLastError)
4477 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4478 SetLastError(SvIV(ST(0)));
4486 char *name = w32_getlogin_buffer;
4487 DWORD size = sizeof(w32_getlogin_buffer);
4489 if (GetUserName(name,&size)) {
4490 /* size includes NULL */
4491 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4501 char name[MAX_COMPUTERNAME_LENGTH+1];
4502 DWORD size = sizeof(name);
4504 if (GetComputerName(name,&size)) {
4505 /* size does NOT include NULL :-( */
4506 ST(0) = sv_2mortal(newSVpvn(name,size));
4517 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4518 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4519 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4523 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4524 GetProcAddress(hNetApi32, "NetApiBufferFree");
4525 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4526 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4529 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4530 /* this way is more reliable, in case user has a local account. */
4532 DWORD dnamelen = sizeof(dname);
4534 DWORD wki100_platform_id;
4535 LPWSTR wki100_computername;
4536 LPWSTR wki100_langroup;
4537 DWORD wki100_ver_major;
4538 DWORD wki100_ver_minor;
4540 /* NERR_Success *is* 0*/
4541 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4542 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4543 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4544 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4547 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4548 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4550 pfnNetApiBufferFree(pwi);
4551 FreeLibrary(hNetApi32);
4554 FreeLibrary(hNetApi32);
4557 /* Win95 doesn't have NetWksta*(), so do it the old way */
4559 DWORD size = sizeof(name);
4561 FreeLibrary(hNetApi32);
4562 if (GetUserName(name,&size)) {
4563 char sid[ONE_K_BUFSIZE];
4564 DWORD sidlen = sizeof(sid);
4566 DWORD dnamelen = sizeof(dname);
4568 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4569 dname, &dnamelen, &snu)) {
4570 XSRETURN_PV(dname); /* all that for this */
4582 DWORD flags, filecomplen;
4583 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4584 &flags, fsname, sizeof(fsname))) {
4585 if (GIMME_V == G_ARRAY) {
4586 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4587 XPUSHs(sv_2mortal(newSViv(flags)));
4588 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4593 XSRETURN_PV(fsname);
4599 XS(w32_GetOSVersion)
4602 /* Use explicit struct definition because wSuiteMask and
4603 * wProductType are not defined in the VC++ 6.0 headers.
4604 * WORD type has been replaced by unsigned short because
4605 * WORD is already used by Perl itself.
4608 DWORD dwOSVersionInfoSize;
4609 DWORD dwMajorVersion;
4610 DWORD dwMinorVersion;
4611 DWORD dwBuildNumber;
4613 CHAR szCSDVersion[128];
4614 unsigned short wServicePackMajor;
4615 unsigned short wServicePackMinor;
4616 unsigned short wSuiteMask;
4624 DWORD dwOSVersionInfoSize;
4625 DWORD dwMajorVersion;
4626 DWORD dwMinorVersion;
4627 DWORD dwBuildNumber;
4629 WCHAR szCSDVersion[128];
4630 unsigned short wServicePackMajor;
4631 unsigned short wServicePackMinor;
4632 unsigned short wSuiteMask;
4636 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4637 osverw.dwOSVersionInfoSize = sizeof(osverw);
4638 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4640 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4641 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4645 if (GIMME_V == G_SCALAR) {
4646 XSRETURN_IV(osverw.dwPlatformId);
4648 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4649 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4650 osver.dwMajorVersion = osverw.dwMajorVersion;
4651 osver.dwMinorVersion = osverw.dwMinorVersion;
4652 osver.dwBuildNumber = osverw.dwBuildNumber;
4653 osver.dwPlatformId = osverw.dwPlatformId;
4654 osver.wServicePackMajor = osverw.wServicePackMajor;
4655 osver.wServicePackMinor = osverw.wServicePackMinor;
4656 osver.wSuiteMask = osverw.wSuiteMask;
4657 osver.wProductType = osverw.wProductType;
4660 osver.dwOSVersionInfoSize = sizeof(osver);
4661 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4663 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4664 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4668 if (GIMME_V == G_SCALAR) {
4669 XSRETURN_IV(osver.dwPlatformId);
4671 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4673 XPUSHs(newSViv(osver.dwMajorVersion));
4674 XPUSHs(newSViv(osver.dwMinorVersion));
4675 XPUSHs(newSViv(osver.dwBuildNumber));
4676 XPUSHs(newSViv(osver.dwPlatformId));
4678 XPUSHs(newSViv(osver.wServicePackMajor));
4679 XPUSHs(newSViv(osver.wServicePackMinor));
4680 XPUSHs(newSViv(osver.wSuiteMask));
4681 XPUSHs(newSViv(osver.wProductType));
4691 XSRETURN_IV(IsWinNT());
4699 XSRETURN_IV(IsWin95());
4703 XS(w32_FormatMessage)
4707 char msgbuf[ONE_K_BUFSIZE];
4710 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4713 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4714 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4715 &source, SvIV(ST(0)), 0,
4716 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4718 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4719 XSRETURN_PV(msgbuf);
4723 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4724 &source, SvIV(ST(0)), 0,
4725 msgbuf, sizeof(msgbuf)-1, NULL))
4726 XSRETURN_PV(msgbuf);
4739 PROCESS_INFORMATION stProcInfo;
4740 STARTUPINFO stStartInfo;
4741 BOOL bSuccess = FALSE;
4744 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4746 cmd = SvPV_nolen(ST(0));
4747 args = SvPV_nolen(ST(1));
4749 env = PerlEnv_get_childenv();
4750 dir = PerlEnv_get_childdir();
4752 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4753 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4754 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4755 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4758 cmd, /* Image path */
4759 args, /* Arguments for command line */
4760 NULL, /* Default process security */
4761 NULL, /* Default thread security */
4762 FALSE, /* Must be TRUE to use std handles */
4763 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4764 env, /* Inherit our environment block */
4765 dir, /* Inherit our currrent directory */
4766 &stStartInfo, /* -> Startup info */
4767 &stProcInfo)) /* <- Process info (if OK) */
4769 int pid = (int)stProcInfo.dwProcessId;
4770 if (IsWin95() && pid < 0)
4772 sv_setiv(ST(2), pid);
4773 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4776 PerlEnv_free_childenv(env);
4777 PerlEnv_free_childdir(dir);
4778 XSRETURN_IV(bSuccess);
4782 XS(w32_GetTickCount)
4785 DWORD msec = GetTickCount();
4793 XS(w32_GetShortPathName)
4800 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4802 shortpath = sv_mortalcopy(ST(0));
4803 SvUPGRADE(shortpath, SVt_PV);
4804 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4807 /* src == target is allowed */
4809 len = GetShortPathName(SvPVX(shortpath),
4812 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4814 SvCUR_set(shortpath,len);
4815 *SvEND(shortpath) = '\0';
4823 XS(w32_GetFullPathName)
4830 STRLEN filename_len;
4834 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4837 filename_p = SvPV(filename, filename_len);
4838 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4839 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4843 len = GetFullPathName(SvPVX(filename),
4847 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4849 if (GIMME_V == G_ARRAY) {
4852 XST_mPV(1,filepart);
4853 len = filepart - SvPVX(fullpath);
4860 SvCUR_set(fullpath,len);
4861 *SvEND(fullpath) = '\0';
4869 XS(w32_GetLongPathName)
4873 char tmpbuf[MAX_PATH+1];
4878 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4881 pathstr = SvPV(path,len);
4882 strcpy(tmpbuf, pathstr);
4883 pathstr = win32_longpath(tmpbuf);
4885 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4896 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4907 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4909 WCHAR wSourceFile[MAX_PATH+1];
4910 WCHAR wDestFile[MAX_PATH+1];
4911 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4912 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4913 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4914 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4917 char szSourceFile[MAX_PATH+1];
4918 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4919 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4928 Perl_init_os_extras(void)
4931 char *file = __FILE__;
4934 /* these names are Activeware compatible */
4935 newXS("Win32::GetCwd", w32_GetCwd, file);
4936 newXS("Win32::SetCwd", w32_SetCwd, file);
4937 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4938 newXS("Win32::GetLastError", w32_GetLastError, file);
4939 newXS("Win32::SetLastError", w32_SetLastError, file);
4940 newXS("Win32::LoginName", w32_LoginName, file);
4941 newXS("Win32::NodeName", w32_NodeName, file);
4942 newXS("Win32::DomainName", w32_DomainName, file);
4943 newXS("Win32::FsType", w32_FsType, file);
4944 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4945 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4946 newXS("Win32::IsWin95", w32_IsWin95, file);
4947 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4948 newXS("Win32::Spawn", w32_Spawn, file);
4949 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4950 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4951 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4952 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4953 newXS("Win32::CopyFile", w32_CopyFile, file);
4954 newXS("Win32::Sleep", w32_Sleep, file);
4955 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4957 /* XXX Bloat Alert! The following Activeware preloads really
4958 * ought to be part of Win32::Sys::*, so they're not included
4961 /* LookupAccountName
4963 * InitiateSystemShutdown
4964 * AbortSystemShutdown
4965 * ExpandEnvrironmentStrings
4970 win32_signal_context(void)
4975 my_perl = PL_curinterp;
4976 PERL_SET_THX(my_perl);
4980 return PL_curinterp;
4986 win32_ctrlhandler(DWORD dwCtrlType)
4989 dTHXa(PERL_GET_SIG_CONTEXT);
4995 switch(dwCtrlType) {
4996 case CTRL_CLOSE_EVENT:
4997 /* A signal that the system sends to all processes attached to a console when
4998 the user closes the console (either by choosing the Close command from the
4999 console window's System menu, or by choosing the End Task command from the
5002 if (do_raise(aTHX_ 1)) /* SIGHUP */
5003 sig_terminate(aTHX_ 1);
5007 /* A CTRL+c signal was received */
5008 if (do_raise(aTHX_ SIGINT))
5009 sig_terminate(aTHX_ SIGINT);
5012 case CTRL_BREAK_EVENT:
5013 /* A CTRL+BREAK signal was received */
5014 if (do_raise(aTHX_ SIGBREAK))
5015 sig_terminate(aTHX_ SIGBREAK);
5018 case CTRL_LOGOFF_EVENT:
5019 /* A signal that the system sends to all console processes when a user is logging
5020 off. This signal does not indicate which user is logging off, so no
5021 assumptions can be made.
5024 case CTRL_SHUTDOWN_EVENT:
5025 /* A signal that the system sends to all console processes when the system is
5028 if (do_raise(aTHX_ SIGTERM))
5029 sig_terminate(aTHX_ SIGTERM);
5039 Perl_win32_init(int *argcp, char ***argvp)
5041 /* Disable floating point errors, Perl will trap the ones we
5042 * care about. VC++ RTL defaults to switching these off
5043 * already, but the Borland RTL doesn't. Since we don't
5044 * want to be at the vendor's whim on the default, we set
5045 * it explicitly here.
5047 #if !defined(_ALPHA_) && !defined(__GNUC__)
5048 _control87(MCW_EM, MCW_EM);
5054 Perl_win32_term(void)
5061 win32_get_child_IO(child_IO_table* ptbl)
5063 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
5064 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
5065 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
5069 win32_signal(int sig, Sighandler_t subcode)
5072 if (sig < SIG_SIZE) {
5073 int save_errno = errno;
5074 Sighandler_t result = signal(sig, subcode);
5075 if (result == SIG_ERR) {
5076 result = w32_sighandler[sig];
5079 w32_sighandler[sig] = subcode;
5089 #ifdef HAVE_INTERP_INTERN
5093 win32_csighandler(int sig)
5096 dTHXa(PERL_GET_SIG_CONTEXT);
5097 Perl_warn(aTHX_ "Got signal %d",sig);
5103 Perl_sys_intern_init(pTHX)
5106 w32_perlshell_tokens = Nullch;
5107 w32_perlshell_vec = (char**)NULL;
5108 w32_perlshell_items = 0;
5109 w32_fdpid = newAV();
5110 New(1313, w32_children, 1, child_tab);
5111 w32_num_children = 0;
5112 # ifdef USE_ITHREADS
5114 New(1313, w32_pseudo_children, 1, child_tab);
5115 w32_num_pseudo_children = 0;
5119 for (i=0; i < SIG_SIZE; i++) {
5120 w32_sighandler[i] = SIG_DFL;
5123 if (my_perl == PL_curinterp) {
5127 /* Force C runtime signal stuff to set its console handler */
5128 signal(SIGINT,&win32_csighandler);
5129 signal(SIGBREAK,&win32_csighandler);
5130 /* Push our handler on top */
5131 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5136 Perl_sys_intern_clear(pTHX)
5138 Safefree(w32_perlshell_tokens);
5139 Safefree(w32_perlshell_vec);
5140 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5141 Safefree(w32_children);
5143 KillTimer(NULL,w32_timerid);
5146 # ifdef MULTIPLICITY
5147 if (my_perl == PL_curinterp) {
5151 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5153 # ifdef USE_ITHREADS
5154 Safefree(w32_pseudo_children);
5158 # ifdef USE_ITHREADS
5161 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5163 dst->perlshell_tokens = Nullch;
5164 dst->perlshell_vec = (char**)NULL;
5165 dst->perlshell_items = 0;
5166 dst->fdpid = newAV();
5167 Newz(1313, dst->children, 1, child_tab);
5169 Newz(1313, dst->pseudo_children, 1, child_tab);
5171 dst->poll_count = 0;
5172 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5174 # endif /* USE_ITHREADS */
5175 #endif /* HAVE_INTERP_INTERN */
5178 win32_free_argvw(pTHX_ void *ptr)
5180 char** argv = (char**)ptr;
5188 win32_argv2utf8(int argc, char** argv)
5193 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5194 if (lpwStr && argc) {
5196 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5197 Newz(0, psz, length, char);
5198 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5201 call_atexit(win32_free_argvw, argv);
5203 GlobalFree((HGLOBAL)lpwStr);