3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
18 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20 # include <shellapi.h>
22 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
28 /* #include "config.h" */
30 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
39 #define PERL_NO_GET_CONTEXT
45 /* assert.h conflicts with #define of assert in perl.h */
52 #if defined(_MSC_VER) || defined(__MINGW32__)
53 #include <sys/utime.h>
58 /* Mingw32 defaults to globing command line
59 * So we turn it off like this:
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 /* Mingw32-1.1 is missing some prototypes */
66 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
73 #if defined(__BORLANDC__)
75 # define _utimbuf utimbuf
80 #define EXECF_SPAWN_NOWAIT 3
82 #if defined(PERL_IMPLICIT_SYS)
83 # undef win32_get_privlib
84 # define win32_get_privlib g_win32_get_privlib
85 # undef win32_get_sitelib
86 # define win32_get_sitelib g_win32_get_sitelib
87 # undef win32_get_vendorlib
88 # define win32_get_vendorlib g_win32_get_vendorlib
90 # define getlogin g_getlogin
93 static void get_shell(void);
94 static long tokenize(const char *str, char **dest, char ***destv);
95 static int do_spawn2(pTHX_ char *cmd, int exectype);
96 static BOOL has_shell_metachars(char *ptr);
97 static long filetime_to_clock(PFILETIME ft);
98 static BOOL filetime_from_time(PFILETIME ft, time_t t);
99 static char * get_emd_part(SV **leading, char *trailing, ...);
100 static void remove_dead_process(long deceased);
101 static long find_pid(int pid);
102 static char * qualified_path(const char *cmd);
103 static char * win32_get_xlib(const char *pl, const char *xlib,
104 const char *libname);
107 static void remove_dead_pseudo_process(long child);
108 static long find_pseudo_pid(int pid);
112 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113 char w32_module_name[MAX_PATH+1];
116 static DWORD w32_platform = (DWORD)-1;
118 #define ONE_K_BUFSIZE 1024
123 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
129 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
133 set_w32_module_name(void)
136 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
137 ? GetModuleHandle(NULL)
138 : w32_perldll_handle),
139 w32_module_name, sizeof(w32_module_name));
141 /* try to get full path to binary (which may be mangled when perl is
142 * run from a 16-bit app) */
143 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
144 (void)win32_longpath(w32_module_name);
145 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
147 /* normalize to forward slashes */
148 ptr = w32_module_name;
156 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
158 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
160 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
163 const char *subkey = "Software\\Perl";
167 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
168 if (retval == ERROR_SUCCESS) {
170 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
171 if (retval == ERROR_SUCCESS
172 && (type == REG_SZ || type == REG_EXPAND_SZ))
176 *svp = sv_2mortal(newSVpvn("",0));
177 SvGROW(*svp, datalen);
178 retval = RegQueryValueEx(handle, valuename, 0, NULL,
179 (PBYTE)SvPVX(*svp), &datalen);
180 if (retval == ERROR_SUCCESS) {
182 SvCUR_set(*svp,datalen-1);
190 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
192 get_regstr(const char *valuename, SV **svp)
194 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
196 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
200 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
202 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
206 char mod_name[MAX_PATH+1];
212 va_start(ap, trailing_path);
213 strip = va_arg(ap, char *);
215 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
216 baselen = strlen(base);
218 if (!*w32_module_name) {
219 set_w32_module_name();
221 strcpy(mod_name, w32_module_name);
222 ptr = strrchr(mod_name, '/');
223 while (ptr && strip) {
224 /* look for directories to skip back */
227 ptr = strrchr(mod_name, '/');
228 /* avoid stripping component if there is no slash,
229 * or it doesn't match ... */
230 if (!ptr || stricmp(ptr+1, strip) != 0) {
231 /* ... but not if component matches m|5\.$patchlevel.*| */
232 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
233 && strncmp(strip, base, baselen) == 0
234 && strncmp(ptr+1, base, baselen) == 0))
240 strip = va_arg(ap, char *);
248 strcpy(++ptr, trailing_path);
250 /* only add directory if it exists */
251 if (GetFileAttributes(mod_name) != (DWORD) -1) {
252 /* directory exists */
255 *prev_pathp = sv_2mortal(newSVpvn("",0));
256 sv_catpvn(*prev_pathp, ";", 1);
257 sv_catpv(*prev_pathp, mod_name);
258 return SvPVX(*prev_pathp);
265 win32_get_privlib(const char *pl)
268 char *stdlib = "lib";
269 char buffer[MAX_PATH+1];
272 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
273 sprintf(buffer, "%s-%s", stdlib, pl);
274 if (!get_regstr(buffer, &sv))
275 (void)get_regstr(stdlib, &sv);
277 /* $stdlib .= ";$EMD/../../lib" */
278 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
282 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
286 char pathstr[MAX_PATH+1];
290 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
291 sprintf(regstr, "%s-%s", xlib, pl);
292 (void)get_regstr(regstr, &sv1);
295 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
296 sprintf(pathstr, "%s/%s/lib", libname, pl);
297 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
299 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
300 (void)get_regstr(xlib, &sv2);
303 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
304 sprintf(pathstr, "%s/lib", libname);
305 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
314 sv_catpvn(sv1, ";", 1);
321 win32_get_sitelib(const char *pl)
323 return win32_get_xlib(pl, "sitelib", "site");
326 #ifndef PERL_VENDORLIB_NAME
327 # define PERL_VENDORLIB_NAME "vendor"
331 win32_get_vendorlib(const char *pl)
333 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
337 has_shell_metachars(char *ptr)
343 * Scan string looking for redirection (< or >) or pipe
344 * characters (|) that are not in a quoted string.
345 * Shell variable interpolation (%VAR%) can also happen inside strings.
377 #if !defined(PERL_IMPLICIT_SYS)
378 /* since the current process environment is being updated in util.c
379 * the library functions will get the correct environment
382 Perl_my_popen(pTHX_ char *cmd, char *mode)
385 #define fixcmd(x) { \
386 char *pspace = strchr((x),' '); \
389 while (p < pspace) { \
400 PERL_FLUSHALL_FOR_CHILD;
401 return win32_popen(cmd, mode);
405 Perl_my_pclose(pTHX_ PerlIO *fp)
407 return win32_pclose(fp);
411 DllExport unsigned long
414 static OSVERSIONINFO osver;
416 if (osver.dwPlatformId != w32_platform) {
417 memset(&osver, 0, sizeof(OSVERSIONINFO));
418 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
419 GetVersionEx(&osver);
420 w32_platform = osver.dwPlatformId;
422 return (unsigned long)w32_platform;
432 return -((int)w32_pseudo_id);
435 /* Windows 9x appears to always reports a pid for threads and processes
436 * that has the high bit set. So we treat the lower 31 bits as the
437 * "real" PID for Perl's purposes. */
438 if (IsWin95() && pid < 0)
443 /* Tokenize a string. Words are null-separated, and the list
444 * ends with a doubled null. Any character (except null and
445 * including backslash) may be escaped by preceding it with a
446 * backslash (the backslash will be stripped).
447 * Returns number of words in result buffer.
450 tokenize(const char *str, char **dest, char ***destv)
452 char *retstart = Nullch;
453 char **retvstart = 0;
457 int slen = strlen(str);
459 register char **retv;
460 New(1307, ret, slen+2, char);
461 New(1308, retv, (slen+3)/2, char*);
469 if (*ret == '\\' && *str)
471 else if (*ret == ' ') {
487 retvstart[items] = Nullch;
500 if (!w32_perlshell_tokens) {
501 /* we don't use COMSPEC here for two reasons:
502 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
503 * uncontrolled unportability of the ensuing scripts.
504 * 2. PERL5SHELL could be set to a shell that may not be fit for
505 * interactive use (which is what most programs look in COMSPEC
508 const char* defaultshell = (IsWinNT()
509 ? "cmd.exe /x/d/c" : "command.com /c");
510 const char *usershell = PerlEnv_getenv("PERL5SHELL");
511 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
512 &w32_perlshell_tokens,
518 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
530 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
532 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
537 while (++mark <= sp) {
538 if (*mark && (str = SvPV_nolen(*mark)))
545 status = win32_spawnvp(flag,
546 (const char*)(really ? SvPV_nolen(really) : argv[0]),
547 (const char* const*)argv);
549 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
550 /* possible shell-builtin, invoke with shell */
552 sh_items = w32_perlshell_items;
554 argv[index+sh_items] = argv[index];
555 while (--sh_items >= 0)
556 argv[sh_items] = w32_perlshell_vec[sh_items];
558 status = win32_spawnvp(flag,
559 (const char*)(really ? SvPV_nolen(really) : argv[0]),
560 (const char* const*)argv);
563 if (flag == P_NOWAIT) {
565 PL_statusvalue = -1; /* >16bits hint for pp_system() */
569 if (ckWARN(WARN_EXEC))
570 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
575 PL_statusvalue = status;
581 /* returns pointer to the next unquoted space or the end of the string */
583 find_next_space(const char *s)
585 bool in_quotes = FALSE;
587 /* ignore doubled backslashes, or backslash+quote */
588 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
591 /* keep track of when we're within quotes */
592 else if (*s == '"') {
594 in_quotes = !in_quotes;
596 /* break it up only at spaces that aren't in quotes */
597 else if (!in_quotes && isSPACE(*s))
606 do_spawn2(pTHX_ char *cmd, int exectype)
612 BOOL needToTry = TRUE;
615 /* Save an extra exec if possible. See if there are shell
616 * metacharacters in it */
617 if (!has_shell_metachars(cmd)) {
618 New(1301,argv, strlen(cmd) / 2 + 2, char*);
619 New(1302,cmd2, strlen(cmd) + 1, char);
622 for (s = cmd2; *s;) {
623 while (*s && isSPACE(*s))
627 s = find_next_space(s);
635 status = win32_spawnvp(P_WAIT, argv[0],
636 (const char* const*)argv);
638 case EXECF_SPAWN_NOWAIT:
639 status = win32_spawnvp(P_NOWAIT, argv[0],
640 (const char* const*)argv);
643 status = win32_execvp(argv[0], (const char* const*)argv);
646 if (status != -1 || errno == 0)
656 New(1306, argv, w32_perlshell_items + 2, char*);
657 while (++i < w32_perlshell_items)
658 argv[i] = w32_perlshell_vec[i];
663 status = win32_spawnvp(P_WAIT, argv[0],
664 (const char* const*)argv);
666 case EXECF_SPAWN_NOWAIT:
667 status = win32_spawnvp(P_NOWAIT, argv[0],
668 (const char* const*)argv);
671 status = win32_execvp(argv[0], (const char* const*)argv);
677 if (exectype == EXECF_SPAWN_NOWAIT) {
679 PL_statusvalue = -1; /* >16bits hint for pp_system() */
683 if (ckWARN(WARN_EXEC))
684 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
685 (exectype == EXECF_EXEC ? "exec" : "spawn"),
686 cmd, strerror(errno));
691 PL_statusvalue = status;
697 Perl_do_spawn(pTHX_ char *cmd)
699 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
703 Perl_do_spawn_nowait(pTHX_ char *cmd)
705 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
709 Perl_do_exec(pTHX_ char *cmd)
711 do_spawn2(aTHX_ cmd, EXECF_EXEC);
715 /* The idea here is to read all the directory names into a string table
716 * (separated by nulls) and when one of the other dir functions is called
717 * return the pointer to the current file name.
720 win32_opendir(char *filename)
726 char scanname[MAX_PATH+3];
728 WIN32_FIND_DATAA aFindData;
729 WIN32_FIND_DATAW wFindData;
731 char buffer[MAX_PATH*2];
732 WCHAR wbuffer[MAX_PATH+1];
735 len = strlen(filename);
739 /* check to see if filename is a directory */
740 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
743 /* Get us a DIR structure */
744 Newz(1303, dirp, 1, DIR);
746 /* Create the search pattern */
747 strcpy(scanname, filename);
749 /* bare drive name means look in cwd for drive */
750 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
751 scanname[len++] = '.';
752 scanname[len++] = '/';
754 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
755 scanname[len++] = '/';
757 scanname[len++] = '*';
758 scanname[len] = '\0';
760 /* do the FindFirstFile call */
762 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
763 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
766 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
769 if (fh == INVALID_HANDLE_VALUE) {
770 DWORD err = GetLastError();
771 /* FindFirstFile() fails on empty drives! */
773 case ERROR_FILE_NOT_FOUND:
775 case ERROR_NO_MORE_FILES:
776 case ERROR_PATH_NOT_FOUND:
779 case ERROR_NOT_ENOUGH_MEMORY:
790 /* now allocate the first part of the string table for
791 * the filenames that we find.
794 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
798 ptr = aFindData.cFileName;
805 New(1304, dirp->start, dirp->size, char);
806 strcpy(dirp->start, ptr);
808 dirp->end = dirp->curr = dirp->start;
814 /* Readdir just returns the current string pointer and bumps the
815 * string pointer to the nDllExport entry.
817 DllExport struct direct *
818 win32_readdir(DIR *dirp)
823 /* first set up the structure to return */
824 len = strlen(dirp->curr);
825 strcpy(dirp->dirstr.d_name, dirp->curr);
826 dirp->dirstr.d_namlen = len;
829 dirp->dirstr.d_ino = dirp->curr - dirp->start;
831 /* Now set up for the next call to readdir */
832 dirp->curr += len + 1;
833 if (dirp->curr >= dirp->end) {
837 WIN32_FIND_DATAW wFindData;
838 WIN32_FIND_DATAA aFindData;
839 char buffer[MAX_PATH*2];
841 /* finding the next file that matches the wildcard
842 * (which should be all of them in this directory!).
845 res = FindNextFileW(dirp->handle, &wFindData);
847 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
852 res = FindNextFileA(dirp->handle, &aFindData);
854 ptr = aFindData.cFileName;
857 long endpos = dirp->end - dirp->start;
858 long newsize = endpos + strlen(ptr) + 1;
859 /* bump the string table size by enough for the
860 * new name and its null terminator */
861 while (newsize > dirp->size) {
862 long curpos = dirp->curr - dirp->start;
864 Renew(dirp->start, dirp->size, char);
865 dirp->curr = dirp->start + curpos;
867 strcpy(dirp->start + endpos, ptr);
868 dirp->end = dirp->start + newsize;
874 return &(dirp->dirstr);
880 /* Telldir returns the current string pointer position */
882 win32_telldir(DIR *dirp)
884 return (dirp->curr - dirp->start);
888 /* Seekdir moves the string pointer to a previously saved position
889 * (returned by telldir).
892 win32_seekdir(DIR *dirp, long loc)
894 dirp->curr = dirp->start + loc;
897 /* Rewinddir resets the string pointer to the start */
899 win32_rewinddir(DIR *dirp)
901 dirp->curr = dirp->start;
904 /* free the memory allocated by opendir */
906 win32_closedir(DIR *dirp)
909 if (dirp->handle != INVALID_HANDLE_VALUE)
910 FindClose(dirp->handle);
911 Safefree(dirp->start);
924 * Just pretend that everyone is a superuser. NT will let us know if
925 * we don\'t really have permission to do something.
928 #define ROOT_UID ((uid_t)0)
929 #define ROOT_GID ((gid_t)0)
958 return (auid == ROOT_UID ? 0 : -1);
964 return (agid == ROOT_GID ? 0 : -1);
971 char *buf = w32_getlogin_buffer;
972 DWORD size = sizeof(w32_getlogin_buffer);
973 if (GetUserName(buf,&size))
979 chown(const char *path, uid_t owner, gid_t group)
986 * XXX this needs strengthening (for PerlIO)
989 int mkstemp(const char *path)
992 char buf[MAX_PATH+1];
996 if (i++ > 10) { /* give up */
1000 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1004 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1014 long child = w32_num_children;
1015 while (--child >= 0) {
1016 if ((int)w32_child_pids[child] == pid)
1023 remove_dead_process(long child)
1027 CloseHandle(w32_child_handles[child]);
1028 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1029 (w32_num_children-child-1), HANDLE);
1030 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1031 (w32_num_children-child-1), DWORD);
1038 find_pseudo_pid(int pid)
1041 long child = w32_num_pseudo_children;
1042 while (--child >= 0) {
1043 if ((int)w32_pseudo_child_pids[child] == pid)
1050 remove_dead_pseudo_process(long child)
1054 CloseHandle(w32_pseudo_child_handles[child]);
1055 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1056 (w32_num_pseudo_children-child-1), HANDLE);
1057 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1058 (w32_num_pseudo_children-child-1), DWORD);
1059 w32_num_pseudo_children--;
1065 win32_kill(int pid, int sig)
1073 /* it is a pseudo-forked child */
1074 child = find_pseudo_pid(-pid);
1076 hProcess = w32_pseudo_child_handles[child];
1079 /* "Does process exist?" use of kill */
1082 /* kill -9 style un-graceful exit */
1083 if (TerminateThread(hProcess, sig)) {
1084 remove_dead_pseudo_process(child);
1089 /* We fake signals to pseudo-processes using Win32
1090 * message queue. In Win9X the pids are negative already. */
1091 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1092 /* It might be us ... */
1099 else if (IsWin95()) {
1107 child = find_pid(pid);
1109 hProcess = w32_child_handles[child];
1112 /* "Does process exist?" use of kill */
1115 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1120 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1123 default: /* For now be backwards compatible with perl5.6 */
1125 if (TerminateProcess(hProcess, sig)) {
1126 remove_dead_process(child);
1135 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1136 (IsWin95() ? -pid : pid));
1140 /* "Does process exist?" use of kill */
1144 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1149 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1152 default: /* For now be backwards compatible with perl5.6 */
1154 if (TerminateProcess(hProcess, sig))
1159 CloseHandle(hProcess);
1169 win32_stat(const char *path, Stat_t *sbuf)
1172 char buffer[MAX_PATH+1];
1173 int l = strlen(path);
1175 WCHAR wbuffer[MAX_PATH+1];
1181 switch(path[l - 1]) {
1182 /* FindFirstFile() and stat() are buggy with a trailing
1183 * backslash, so change it to a forward slash :-( */
1185 strncpy(buffer, path, l-1);
1186 buffer[l - 1] = '/';
1190 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1192 if (l == 2 && isALPHA(path[0])) {
1193 buffer[0] = path[0];
1204 /* We *must* open & close the file once; otherwise file attribute changes */
1205 /* might not yet have propagated to "other" hard links of the same file. */
1206 /* This also gives us an opportunity to determine the number of links. */
1208 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1209 pwbuffer = PerlDir_mapW(wbuffer);
1210 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1213 path = PerlDir_mapA(path);
1215 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1217 if (handle != INVALID_HANDLE_VALUE) {
1218 BY_HANDLE_FILE_INFORMATION bhi;
1219 if (GetFileInformationByHandle(handle, &bhi))
1220 nlink = bhi.nNumberOfLinks;
1221 CloseHandle(handle);
1224 /* pwbuffer or path will be mapped correctly above */
1226 #if defined(WIN64) || defined(USE_LARGE_FILES)
1227 res = _wstati64(pwbuffer, sbuf);
1229 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1233 #if defined(WIN64) || defined(USE_LARGE_FILES)
1234 res = _stati64(path, sbuf);
1236 res = stat(path, sbuf);
1239 sbuf->st_nlink = nlink;
1242 /* CRT is buggy on sharenames, so make sure it really isn't.
1243 * XXX using GetFileAttributesEx() will enable us to set
1244 * sbuf->st_*time (but note that's not available on the
1245 * Windows of 1995) */
1248 r = GetFileAttributesW(pwbuffer);
1251 r = GetFileAttributesA(path);
1253 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1254 /* sbuf may still contain old garbage since stat() failed */
1255 Zero(sbuf, 1, Stat_t);
1256 sbuf->st_mode = S_IFDIR | S_IREAD;
1258 if (!(r & FILE_ATTRIBUTE_READONLY))
1259 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1264 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1265 && (path[2] == '\\' || path[2] == '/'))
1267 /* The drive can be inaccessible, some _stat()s are buggy */
1269 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1270 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1276 if (S_ISDIR(sbuf->st_mode))
1277 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1278 else if (S_ISREG(sbuf->st_mode)) {
1280 if (l >= 4 && path[l-4] == '.') {
1281 const char *e = path + l - 3;
1282 if (strnicmp(e,"exe",3)
1283 && strnicmp(e,"bat",3)
1284 && strnicmp(e,"com",3)
1285 && (IsWin95() || strnicmp(e,"cmd",3)))
1286 sbuf->st_mode &= ~S_IEXEC;
1288 sbuf->st_mode |= S_IEXEC;
1291 sbuf->st_mode &= ~S_IEXEC;
1292 /* Propagate permissions to _group_ and _others_ */
1293 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1294 sbuf->st_mode |= (perms>>3) | (perms>>6);
1301 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1302 #define SKIP_SLASHES(s) \
1304 while (*(s) && isSLASH(*(s))) \
1307 #define COPY_NONSLASHES(d,s) \
1309 while (*(s) && !isSLASH(*(s))) \
1313 /* Find the longname of a given path. path is destructively modified.
1314 * It should have space for at least MAX_PATH characters. */
1316 win32_longpath(char *path)
1318 WIN32_FIND_DATA fdata;
1320 char tmpbuf[MAX_PATH+1];
1321 char *tmpstart = tmpbuf;
1328 if (isALPHA(path[0]) && path[1] == ':') {
1330 *tmpstart++ = path[0];
1334 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1336 *tmpstart++ = path[0];
1337 *tmpstart++ = path[1];
1338 SKIP_SLASHES(start);
1339 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1341 *tmpstart++ = *start++;
1342 SKIP_SLASHES(start);
1343 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1348 /* copy initial slash, if any */
1349 if (isSLASH(*start)) {
1350 *tmpstart++ = *start++;
1352 SKIP_SLASHES(start);
1355 /* FindFirstFile() expands "." and "..", so we need to pass
1356 * those through unmolested */
1358 && (!start[1] || isSLASH(start[1])
1359 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1361 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1366 /* if this is the end, bust outta here */
1370 /* now we're at a non-slash; walk up to next slash */
1371 while (*start && !isSLASH(*start))
1374 /* stop and find full name of component */
1377 fhand = FindFirstFile(path,&fdata);
1379 if (fhand != INVALID_HANDLE_VALUE) {
1380 STRLEN len = strlen(fdata.cFileName);
1381 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1382 strcpy(tmpstart, fdata.cFileName);
1393 /* failed a step, just return without side effects */
1394 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1399 strcpy(path,tmpbuf);
1404 win32_getenv(const char *name)
1407 WCHAR wBuffer[MAX_PATH+1];
1409 SV *curitem = Nullsv;
1412 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1413 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1416 needlen = GetEnvironmentVariableA(name,NULL,0);
1418 curitem = sv_2mortal(newSVpvn("", 0));
1422 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1423 needlen = GetEnvironmentVariableW(wBuffer,
1424 (WCHAR*)SvPVX(curitem),
1426 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1427 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1428 acuritem = sv_2mortal(newSVsv(curitem));
1429 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1433 SvGROW(curitem, needlen+1);
1434 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1436 } while (needlen >= SvLEN(curitem));
1437 SvCUR_set(curitem, needlen);
1441 /* allow any environment variables that begin with 'PERL'
1442 to be stored in the registry */
1443 if (strncmp(name, "PERL", 4) == 0)
1444 (void)get_regstr(name, &curitem);
1446 if (curitem && SvCUR(curitem))
1447 return SvPVX(curitem);
1453 win32_putenv(const char *name)
1460 int length, relval = -1;
1464 length = strlen(name)+1;
1465 New(1309,wCuritem,length,WCHAR);
1466 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1467 wVal = wcschr(wCuritem, '=');
1470 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1476 New(1309,curitem,strlen(name)+1,char);
1477 strcpy(curitem, name);
1478 val = strchr(curitem, '=');
1480 /* The sane way to deal with the environment.
1481 * Has these advantages over putenv() & co.:
1482 * * enables us to store a truly empty value in the
1483 * environment (like in UNIX).
1484 * * we don't have to deal with RTL globals, bugs and leaks.
1486 * Why you may want to enable USE_WIN32_RTL_ENV:
1487 * * environ[] and RTL functions will not reflect changes,
1488 * which might be an issue if extensions want to access
1489 * the env. via RTL. This cuts both ways, since RTL will
1490 * not see changes made by extensions that call the Win32
1491 * functions directly, either.
1495 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1505 filetime_to_clock(PFILETIME ft)
1507 __int64 qw = ft->dwHighDateTime;
1509 qw |= ft->dwLowDateTime;
1510 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1515 win32_times(struct tms *timebuf)
1520 clock_t process_time_so_far = clock();
1521 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1523 timebuf->tms_utime = filetime_to_clock(&user);
1524 timebuf->tms_stime = filetime_to_clock(&kernel);
1525 timebuf->tms_cutime = 0;
1526 timebuf->tms_cstime = 0;
1528 /* That failed - e.g. Win95 fallback to clock() */
1529 timebuf->tms_utime = process_time_so_far;
1530 timebuf->tms_stime = 0;
1531 timebuf->tms_cutime = 0;
1532 timebuf->tms_cstime = 0;
1534 return process_time_so_far;
1537 /* fix utime() so it works on directories in NT */
1539 filetime_from_time(PFILETIME pFileTime, time_t Time)
1541 struct tm *pTM = localtime(&Time);
1542 SYSTEMTIME SystemTime;
1548 SystemTime.wYear = pTM->tm_year + 1900;
1549 SystemTime.wMonth = pTM->tm_mon + 1;
1550 SystemTime.wDay = pTM->tm_mday;
1551 SystemTime.wHour = pTM->tm_hour;
1552 SystemTime.wMinute = pTM->tm_min;
1553 SystemTime.wSecond = pTM->tm_sec;
1554 SystemTime.wMilliseconds = 0;
1556 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1557 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1561 win32_unlink(const char *filename)
1568 WCHAR wBuffer[MAX_PATH+1];
1571 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1572 pwBuffer = PerlDir_mapW(wBuffer);
1573 attrs = GetFileAttributesW(pwBuffer);
1574 if (attrs == 0xFFFFFFFF)
1576 if (attrs & FILE_ATTRIBUTE_READONLY) {
1577 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1578 ret = _wunlink(pwBuffer);
1580 (void)SetFileAttributesW(pwBuffer, attrs);
1583 ret = _wunlink(pwBuffer);
1586 filename = PerlDir_mapA(filename);
1587 attrs = GetFileAttributesA(filename);
1588 if (attrs == 0xFFFFFFFF)
1590 if (attrs & FILE_ATTRIBUTE_READONLY) {
1591 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1592 ret = unlink(filename);
1594 (void)SetFileAttributesA(filename, attrs);
1597 ret = unlink(filename);
1606 win32_utime(const char *filename, struct utimbuf *times)
1613 struct utimbuf TimeBuffer;
1614 WCHAR wbuffer[MAX_PATH+1];
1619 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1620 pwbuffer = PerlDir_mapW(wbuffer);
1621 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1624 filename = PerlDir_mapA(filename);
1625 rc = utime(filename, times);
1627 /* EACCES: path specifies directory or readonly file */
1628 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1631 if (times == NULL) {
1632 times = &TimeBuffer;
1633 time(×->actime);
1634 times->modtime = times->actime;
1637 /* This will (and should) still fail on readonly files */
1639 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1640 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1641 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1644 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1645 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1646 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1648 if (handle == INVALID_HANDLE_VALUE)
1651 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1652 filetime_from_time(&ftAccess, times->actime) &&
1653 filetime_from_time(&ftWrite, times->modtime) &&
1654 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1659 CloseHandle(handle);
1664 unsigned __int64 ft_i64;
1669 #define Const64(x) x##LL
1671 #define Const64(x) x##i64
1673 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1674 #define EPOCH_BIAS Const64(116444736000000000)
1676 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1677 * and appears to be unsupported even by glibc) */
1679 win32_gettimeofday(struct timeval *tp, void *not_used)
1683 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1684 GetSystemTimeAsFileTime(&ft.ft_val);
1686 /* seconds since epoch */
1687 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1689 /* microseconds remaining */
1690 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1696 win32_uname(struct utsname *name)
1698 struct hostent *hep;
1699 STRLEN nodemax = sizeof(name->nodename)-1;
1700 OSVERSIONINFO osver;
1702 memset(&osver, 0, sizeof(OSVERSIONINFO));
1703 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1704 if (GetVersionEx(&osver)) {
1706 switch (osver.dwPlatformId) {
1707 case VER_PLATFORM_WIN32_WINDOWS:
1708 strcpy(name->sysname, "Windows");
1710 case VER_PLATFORM_WIN32_NT:
1711 strcpy(name->sysname, "Windows NT");
1713 case VER_PLATFORM_WIN32s:
1714 strcpy(name->sysname, "Win32s");
1717 strcpy(name->sysname, "Win32 Unknown");
1722 sprintf(name->release, "%d.%d",
1723 osver.dwMajorVersion, osver.dwMinorVersion);
1726 sprintf(name->version, "Build %d",
1727 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1728 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1729 if (osver.szCSDVersion[0]) {
1730 char *buf = name->version + strlen(name->version);
1731 sprintf(buf, " (%s)", osver.szCSDVersion);
1735 *name->sysname = '\0';
1736 *name->version = '\0';
1737 *name->release = '\0';
1741 hep = win32_gethostbyname("localhost");
1743 STRLEN len = strlen(hep->h_name);
1744 if (len <= nodemax) {
1745 strcpy(name->nodename, hep->h_name);
1748 strncpy(name->nodename, hep->h_name, nodemax);
1749 name->nodename[nodemax] = '\0';
1754 if (!GetComputerName(name->nodename, &sz))
1755 *name->nodename = '\0';
1758 /* machine (architecture) */
1763 GetSystemInfo(&info);
1765 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1766 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1767 procarch = info.u.s.wProcessorArchitecture;
1769 procarch = info.wProcessorArchitecture;
1772 case PROCESSOR_ARCHITECTURE_INTEL:
1773 arch = "x86"; break;
1774 case PROCESSOR_ARCHITECTURE_MIPS:
1775 arch = "mips"; break;
1776 case PROCESSOR_ARCHITECTURE_ALPHA:
1777 arch = "alpha"; break;
1778 case PROCESSOR_ARCHITECTURE_PPC:
1779 arch = "ppc"; break;
1780 #ifdef PROCESSOR_ARCHITECTURE_SHX
1781 case PROCESSOR_ARCHITECTURE_SHX:
1782 arch = "shx"; break;
1784 #ifdef PROCESSOR_ARCHITECTURE_ARM
1785 case PROCESSOR_ARCHITECTURE_ARM:
1786 arch = "arm"; break;
1788 #ifdef PROCESSOR_ARCHITECTURE_IA64
1789 case PROCESSOR_ARCHITECTURE_IA64:
1790 arch = "ia64"; break;
1792 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1793 case PROCESSOR_ARCHITECTURE_ALPHA64:
1794 arch = "alpha64"; break;
1796 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1797 case PROCESSOR_ARCHITECTURE_MSIL:
1798 arch = "msil"; break;
1800 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1801 case PROCESSOR_ARCHITECTURE_AMD64:
1802 arch = "amd64"; break;
1804 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1805 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1806 arch = "ia32-64"; break;
1808 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1809 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1810 arch = "unknown"; break;
1813 sprintf(name->machine, "unknown(0x%x)", procarch);
1814 arch = name->machine;
1817 if (name->machine != arch)
1818 strcpy(name->machine, arch);
1823 /* Timing related stuff */
1826 do_raise(pTHX_ int sig)
1828 if (sig < SIG_SIZE) {
1829 Sighandler_t handler = w32_sighandler[sig];
1830 if (handler == SIG_IGN) {
1833 else if (handler != SIG_DFL) {
1838 /* Choose correct default behaviour */
1854 /* Tell caller to exit thread/process as approriate */
1859 sig_terminate(pTHX_ int sig)
1861 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1862 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1869 win32_async_check(pTHX)
1873 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1874 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1876 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1878 switch(msg.message) {
1881 /* Perhaps some other messages could map to signals ? ... */
1884 /* Treat WM_QUIT like SIGHUP? */
1890 /* We use WM_USER to fake kill() with other signals */
1894 if (do_raise(aTHX_ sig)) {
1895 sig_terminate(aTHX_ sig);
1901 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1902 if (w32_timerid && w32_timerid==msg.wParam) {
1903 KillTimer(NULL,w32_timerid);
1908 /* Now fake a call to signal handler */
1909 if (do_raise(aTHX_ 14)) {
1910 sig_terminate(aTHX_ 14);
1915 /* Otherwise do normal Win32 thing - in case it is useful */
1918 TranslateMessage(&msg);
1919 DispatchMessage(&msg);
1926 /* Above or other stuff may have set a signal flag */
1927 if (PL_sig_pending) {
1933 /* This function will not return until the timeout has elapsed, or until
1934 * one of the handles is ready. */
1936 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1938 /* We may need several goes at this - so compute when we stop */
1940 if (timeout != INFINITE) {
1941 ticks = GetTickCount();
1945 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1948 if (result == WAIT_TIMEOUT) {
1949 /* Ran out of time - explicit return of zero to avoid -ve if we
1950 have scheduling issues
1954 if (timeout != INFINITE) {
1955 ticks = GetTickCount();
1957 if (result == WAIT_OBJECT_0 + count) {
1958 /* Message has arrived - check it */
1959 (void)win32_async_check(aTHX);
1962 /* Not timeout or message - one of handles is ready */
1966 /* compute time left to wait */
1967 ticks = timeout - ticks;
1968 /* If we are past the end say zero */
1969 return (ticks > 0) ? ticks : 0;
1973 win32_internal_wait(int *status, DWORD timeout)
1975 /* XXX this wait emulation only knows about processes
1976 * spawned via win32_spawnvp(P_NOWAIT, ...).
1980 DWORD exitcode, waitcode;
1983 if (w32_num_pseudo_children) {
1984 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1985 timeout, &waitcode);
1986 /* Time out here if there are no other children to wait for. */
1987 if (waitcode == WAIT_TIMEOUT) {
1988 if (!w32_num_children) {
1992 else if (waitcode != WAIT_FAILED) {
1993 if (waitcode >= WAIT_ABANDONED_0
1994 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1995 i = waitcode - WAIT_ABANDONED_0;
1997 i = waitcode - WAIT_OBJECT_0;
1998 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1999 *status = (int)((exitcode & 0xff) << 8);
2000 retval = (int)w32_pseudo_child_pids[i];
2001 remove_dead_pseudo_process(i);
2008 if (!w32_num_children) {
2013 /* if a child exists, wait for it to die */
2014 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2015 if (waitcode == WAIT_TIMEOUT) {
2018 if (waitcode != WAIT_FAILED) {
2019 if (waitcode >= WAIT_ABANDONED_0
2020 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2021 i = waitcode - WAIT_ABANDONED_0;
2023 i = waitcode - WAIT_OBJECT_0;
2024 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2025 *status = (int)((exitcode & 0xff) << 8);
2026 retval = (int)w32_child_pids[i];
2027 remove_dead_process(i);
2032 errno = GetLastError();
2037 win32_waitpid(int pid, int *status, int flags)
2040 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2043 if (pid == -1) /* XXX threadid == 1 ? */
2044 return win32_internal_wait(status, timeout);
2047 child = find_pseudo_pid(-pid);
2049 HANDLE hThread = w32_pseudo_child_handles[child];
2051 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2052 if (waitcode == WAIT_TIMEOUT) {
2055 else if (waitcode == WAIT_OBJECT_0) {
2056 if (GetExitCodeThread(hThread, &waitcode)) {
2057 *status = (int)((waitcode & 0xff) << 8);
2058 retval = (int)w32_pseudo_child_pids[child];
2059 remove_dead_pseudo_process(child);
2066 else if (IsWin95()) {
2075 child = find_pid(pid);
2077 hProcess = w32_child_handles[child];
2078 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2079 if (waitcode == WAIT_TIMEOUT) {
2082 else if (waitcode == WAIT_OBJECT_0) {
2083 if (GetExitCodeProcess(hProcess, &waitcode)) {
2084 *status = (int)((waitcode & 0xff) << 8);
2085 retval = (int)w32_child_pids[child];
2086 remove_dead_process(child);
2095 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2096 (IsWin95() ? -pid : pid));
2098 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2099 if (waitcode == WAIT_TIMEOUT) {
2100 CloseHandle(hProcess);
2103 else if (waitcode == WAIT_OBJECT_0) {
2104 if (GetExitCodeProcess(hProcess, &waitcode)) {
2105 *status = (int)((waitcode & 0xff) << 8);
2106 CloseHandle(hProcess);
2110 CloseHandle(hProcess);
2116 return retval >= 0 ? pid : retval;
2120 win32_wait(int *status)
2122 return win32_internal_wait(status, INFINITE);
2125 DllExport unsigned int
2126 win32_sleep(unsigned int t)
2129 /* Win32 times are in ms so *1000 in and /1000 out */
2130 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2133 DllExport unsigned int
2134 win32_alarm(unsigned int sec)
2137 * the 'obvious' implentation is SetTimer() with a callback
2138 * which does whatever receiving SIGALRM would do
2139 * we cannot use SIGALRM even via raise() as it is not
2140 * one of the supported codes in <signal.h>
2144 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2148 KillTimer(NULL,w32_timerid);
2155 #ifdef HAVE_DES_FCRYPT
2156 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2160 win32_crypt(const char *txt, const char *salt)
2163 #ifdef HAVE_DES_FCRYPT
2164 return des_fcrypt(txt, salt, w32_crypt_buffer);
2166 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2171 #ifdef USE_FIXED_OSFHANDLE
2173 #define FOPEN 0x01 /* file handle open */
2174 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2175 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2176 #define FDEV 0x40 /* file handle refers to device */
2177 #define FTEXT 0x80 /* file handle is in text mode */
2180 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2183 * This function allocates a free C Runtime file handle and associates
2184 * it with the Win32 HANDLE specified by the first parameter. This is a
2185 * temperary fix for WIN95's brain damage GetFileType() error on socket
2186 * we just bypass that call for socket
2188 * This works with MSVC++ 4.0+ or GCC/Mingw32
2191 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2192 * int flags - flags to associate with C Runtime file handle.
2195 * returns index of entry in fh, if successful
2196 * return -1, if no free entry is found
2200 *******************************************************************************/
2203 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2204 * this lets sockets work on Win9X with GCC and should fix the problems
2209 /* create an ioinfo entry, kill its handle, and steal the entry */
2214 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2215 int fh = _open_osfhandle((intptr_t)hF, 0);
2219 EnterCriticalSection(&(_pioinfo(fh)->lock));
2224 my_open_osfhandle(intptr_t osfhandle, int flags)
2227 char fileflags; /* _osfile flags */
2229 /* copy relevant flags from second parameter */
2232 if (flags & O_APPEND)
2233 fileflags |= FAPPEND;
2238 if (flags & O_NOINHERIT)
2239 fileflags |= FNOINHERIT;
2241 /* attempt to allocate a C Runtime file handle */
2242 if ((fh = _alloc_osfhnd()) == -1) {
2243 errno = EMFILE; /* too many open files */
2244 _doserrno = 0L; /* not an OS error */
2245 return -1; /* return error to caller */
2248 /* the file is open. now, set the info in _osfhnd array */
2249 _set_osfhnd(fh, osfhandle);
2251 fileflags |= FOPEN; /* mark as open */
2253 _osfile(fh) = fileflags; /* set osfile entry */
2254 LeaveCriticalSection(&_pioinfo(fh)->lock);
2256 return fh; /* return handle */
2259 #endif /* USE_FIXED_OSFHANDLE */
2261 /* simulate flock by locking a range on the file */
2263 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2264 #define LK_LEN 0xffff0000
2267 win32_flock(int fd, int oper)
2275 Perl_croak_nocontext("flock() unimplemented on this platform");
2278 fh = (HANDLE)_get_osfhandle(fd);
2279 memset(&o, 0, sizeof(o));
2282 case LOCK_SH: /* shared lock */
2283 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2285 case LOCK_EX: /* exclusive lock */
2286 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2288 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2289 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2291 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2292 LK_ERR(LockFileEx(fh,
2293 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2294 0, LK_LEN, 0, &o),i);
2296 case LOCK_UN: /* unlock lock */
2297 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2299 default: /* unknown */
2310 * redirected io subsystem for all XS modules
2323 return (&(_environ));
2326 /* the rest are the remapped stdio routines */
2346 win32_ferror(FILE *fp)
2348 return (ferror(fp));
2353 win32_feof(FILE *fp)
2359 * Since the errors returned by the socket error function
2360 * WSAGetLastError() are not known by the library routine strerror
2361 * we have to roll our own.
2365 win32_strerror(int e)
2367 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2368 extern int sys_nerr;
2372 if (e < 0 || e > sys_nerr) {
2377 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2378 w32_strerror_buffer,
2379 sizeof(w32_strerror_buffer), NULL) == 0)
2380 strcpy(w32_strerror_buffer, "Unknown Error");
2382 return w32_strerror_buffer;
2388 win32_str_os_error(void *sv, DWORD dwErr)
2392 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2393 |FORMAT_MESSAGE_IGNORE_INSERTS
2394 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2395 dwErr, 0, (char *)&sMsg, 1, NULL);
2396 /* strip trailing whitespace and period */
2399 --dwLen; /* dwLen doesn't include trailing null */
2400 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2401 if ('.' != sMsg[dwLen])
2406 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2408 dwLen = sprintf(sMsg,
2409 "Unknown error #0x%lX (lookup 0x%lX)",
2410 dwErr, GetLastError());
2414 sv_setpvn((SV*)sv, sMsg, dwLen);
2420 win32_fprintf(FILE *fp, const char *format, ...)
2423 va_start(marker, format); /* Initialize variable arguments. */
2425 return (vfprintf(fp, format, marker));
2429 win32_printf(const char *format, ...)
2432 va_start(marker, format); /* Initialize variable arguments. */
2434 return (vprintf(format, marker));
2438 win32_vfprintf(FILE *fp, const char *format, va_list args)
2440 return (vfprintf(fp, format, args));
2444 win32_vprintf(const char *format, va_list args)
2446 return (vprintf(format, args));
2450 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2452 return fread(buf, size, count, fp);
2456 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2458 return fwrite(buf, size, count, fp);
2461 #define MODE_SIZE 10
2464 win32_fopen(const char *filename, const char *mode)
2467 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2473 if (stricmp(filename, "/dev/null")==0)
2477 A2WHELPER(mode, wMode, sizeof(wMode));
2478 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2479 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2482 f = fopen(PerlDir_mapA(filename), mode);
2483 /* avoid buffering headaches for child processes */
2484 if (f && *mode == 'a')
2485 win32_fseek(f, 0, SEEK_END);
2489 #ifndef USE_SOCKETS_AS_HANDLES
2491 #define fdopen my_fdopen
2495 win32_fdopen(int handle, const char *mode)
2498 WCHAR wMode[MODE_SIZE];
2501 A2WHELPER(mode, wMode, sizeof(wMode));
2502 f = _wfdopen(handle, wMode);
2505 f = fdopen(handle, (char *) mode);
2506 /* avoid buffering headaches for child processes */
2507 if (f && *mode == 'a')
2508 win32_fseek(f, 0, SEEK_END);
2513 win32_freopen(const char *path, const char *mode, FILE *stream)
2516 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2517 if (stricmp(path, "/dev/null")==0)
2521 A2WHELPER(mode, wMode, sizeof(wMode));
2522 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2523 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2525 return freopen(PerlDir_mapA(path), mode, stream);
2529 win32_fclose(FILE *pf)
2531 return my_fclose(pf); /* defined in win32sck.c */
2535 win32_fputs(const char *s,FILE *pf)
2537 return fputs(s, pf);
2541 win32_fputc(int c,FILE *pf)
2547 win32_ungetc(int c,FILE *pf)
2549 return ungetc(c,pf);
2553 win32_getc(FILE *pf)
2559 win32_fileno(FILE *pf)
2565 win32_clearerr(FILE *pf)
2572 win32_fflush(FILE *pf)
2578 win32_ftell(FILE *pf)
2580 #if defined(WIN64) || defined(USE_LARGE_FILES)
2581 #if defined(__BORLAND__) /* buk */
2582 return win32_tell( fileno( pf ) );
2585 if (fgetpos(pf, &pos))
2595 win32_fseek(FILE *pf, Off_t offset,int origin)
2597 #if defined(WIN64) || defined(USE_LARGE_FILES)
2598 #if defined(__BORLANDC__) /* buk */
2608 if (fgetpos(pf, &pos))
2613 fseek(pf, 0, SEEK_END);
2614 pos = _telli64(fileno(pf));
2623 return fsetpos(pf, &offset);
2626 return fseek(pf, offset, origin);
2631 win32_fgetpos(FILE *pf,fpos_t *p)
2633 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2634 if( win32_tell(fileno(pf)) == -1L ) {
2640 return fgetpos(pf, p);
2645 win32_fsetpos(FILE *pf,const fpos_t *p)
2647 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2648 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2650 return fsetpos(pf, p);
2655 win32_rewind(FILE *pf)
2665 char prefix[MAX_PATH+1];
2666 char filename[MAX_PATH+1];
2667 DWORD len = GetTempPath(MAX_PATH, prefix);
2668 if (len && len < MAX_PATH) {
2669 if (GetTempFileName(prefix, "plx", 0, filename)) {
2670 HANDLE fh = CreateFile(filename,
2671 DELETE | GENERIC_READ | GENERIC_WRITE,
2675 FILE_ATTRIBUTE_NORMAL
2676 | FILE_FLAG_DELETE_ON_CLOSE,
2678 if (fh != INVALID_HANDLE_VALUE) {
2679 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2681 #if defined(__BORLANDC__)
2682 setmode(fd,O_BINARY);
2684 DEBUG_p(PerlIO_printf(Perl_debug_log,
2685 "Created tmpfile=%s\n",filename));
2697 int fd = win32_tmpfd();
2699 return win32_fdopen(fd, "w+b");
2711 win32_fstat(int fd, Stat_t *sbufptr)
2714 /* A file designated by filehandle is not shown as accessible
2715 * for write operations, probably because it is opened for reading.
2718 int rc = fstat(fd,sbufptr);
2719 BY_HANDLE_FILE_INFORMATION bhfi;
2720 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2721 sbufptr->st_mode &= 0xFE00;
2722 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2723 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2725 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2726 + ((S_IREAD|S_IWRITE) >> 6));
2730 return my_fstat(fd,sbufptr);
2735 win32_pipe(int *pfd, unsigned int size, int mode)
2737 return _pipe(pfd, size, mode);
2741 win32_popenlist(const char *mode, IV narg, SV **args)
2744 Perl_croak(aTHX_ "List form of pipe open not implemented");
2749 * a popen() clone that respects PERL5SHELL
2751 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2755 win32_popen(const char *command, const char *mode)
2757 #ifdef USE_RTL_POPEN
2758 return _popen(command, mode);
2770 /* establish which ends read and write */
2771 if (strchr(mode,'w')) {
2772 stdfd = 0; /* stdin */
2775 nhandle = STD_INPUT_HANDLE;
2777 else if (strchr(mode,'r')) {
2778 stdfd = 1; /* stdout */
2781 nhandle = STD_OUTPUT_HANDLE;
2786 /* set the correct mode */
2787 if (strchr(mode,'b'))
2789 else if (strchr(mode,'t'))
2792 ourmode = _fmode & (O_TEXT | O_BINARY);
2794 /* the child doesn't inherit handles */
2795 ourmode |= O_NOINHERIT;
2797 if (win32_pipe(p, 512, ourmode) == -1)
2800 /* save current stdfd */
2801 if ((oldfd = win32_dup(stdfd)) == -1)
2804 /* save the old std handle (this needs to happen before the
2805 * dup2(), since that might call SetStdHandle() too) */
2808 old_h = GetStdHandle(nhandle);
2810 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2811 /* stdfd will be inherited by the child */
2812 if (win32_dup2(p[child], stdfd) == -1)
2815 /* close the child end in parent */
2816 win32_close(p[child]);
2818 /* set the new std handle (in case dup2() above didn't) */
2819 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2821 /* start the child */
2824 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2827 /* revert stdfd to whatever it was before */
2828 if (win32_dup2(oldfd, stdfd) == -1)
2831 /* restore the old std handle (this needs to happen after the
2832 * dup2(), since that might call SetStdHandle() too */
2834 SetStdHandle(nhandle, old_h);
2839 /* close saved handle */
2843 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2846 /* set process id so that it can be returned by perl's open() */
2847 PL_forkprocess = childpid;
2850 /* we have an fd, return a file stream */
2851 return (PerlIO_fdopen(p[parent], (char *)mode));
2854 /* we don't need to check for errors here */
2858 SetStdHandle(nhandle, old_h);
2863 win32_dup2(oldfd, stdfd);
2868 #endif /* USE_RTL_POPEN */
2876 win32_pclose(PerlIO *pf)
2878 #ifdef USE_RTL_POPEN
2882 int childpid, status;
2886 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2889 childpid = SvIVX(sv);
2906 if (win32_waitpid(childpid, &status, 0) == -1)
2911 #endif /* USE_RTL_POPEN */
2917 LPCWSTR lpExistingFileName,
2918 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2921 WCHAR wFullName[MAX_PATH+1];
2922 LPVOID lpContext = NULL;
2923 WIN32_STREAM_ID StreamId;
2924 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2929 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2930 BOOL, BOOL, LPVOID*) =
2931 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2932 BOOL, BOOL, LPVOID*))
2933 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2934 if (pfnBackupWrite == NULL)
2937 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2940 dwLen = (dwLen+1)*sizeof(WCHAR);
2942 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2943 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2944 NULL, OPEN_EXISTING, 0, NULL);
2945 if (handle == INVALID_HANDLE_VALUE)
2948 StreamId.dwStreamId = BACKUP_LINK;
2949 StreamId.dwStreamAttributes = 0;
2950 StreamId.dwStreamNameSize = 0;
2951 #if defined(__BORLANDC__) \
2952 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2953 StreamId.Size.u.HighPart = 0;
2954 StreamId.Size.u.LowPart = dwLen;
2956 StreamId.Size.HighPart = 0;
2957 StreamId.Size.LowPart = dwLen;
2960 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2961 FALSE, FALSE, &lpContext);
2963 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2964 FALSE, FALSE, &lpContext);
2965 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2968 CloseHandle(handle);
2973 win32_link(const char *oldname, const char *newname)
2976 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2977 WCHAR wOldName[MAX_PATH+1];
2978 WCHAR wNewName[MAX_PATH+1];
2981 Perl_croak(aTHX_ PL_no_func, "link");
2983 pfnCreateHardLinkW =
2984 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2985 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2986 if (pfnCreateHardLinkW == NULL)
2987 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2989 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2990 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2991 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2992 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2996 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3001 win32_rename(const char *oname, const char *newname)
3003 WCHAR wOldName[MAX_PATH+1];
3004 WCHAR wNewName[MAX_PATH+1];
3005 char szOldName[MAX_PATH+1];
3006 char szNewName[MAX_PATH+1];
3010 /* XXX despite what the documentation says about MoveFileEx(),
3011 * it doesn't work under Windows95!
3014 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3016 A2WHELPER(oname, wOldName, sizeof(wOldName));
3017 A2WHELPER(newname, wNewName, sizeof(wNewName));
3018 if (wcsicmp(wNewName, wOldName))
3019 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3020 wcscpy(wOldName, PerlDir_mapW(wOldName));
3021 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
3024 if (stricmp(newname, oname))
3025 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3026 strcpy(szOldName, PerlDir_mapA(oname));
3027 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3030 DWORD err = GetLastError();
3032 case ERROR_BAD_NET_NAME:
3033 case ERROR_BAD_NETPATH:
3034 case ERROR_BAD_PATHNAME:
3035 case ERROR_FILE_NOT_FOUND:
3036 case ERROR_FILENAME_EXCED_RANGE:
3037 case ERROR_INVALID_DRIVE:
3038 case ERROR_NO_MORE_FILES:
3039 case ERROR_PATH_NOT_FOUND:
3052 char szTmpName[MAX_PATH+1];
3053 char dname[MAX_PATH+1];
3054 char *endname = Nullch;
3056 DWORD from_attr, to_attr;
3058 strcpy(szOldName, PerlDir_mapA(oname));
3059 strcpy(szNewName, PerlDir_mapA(newname));
3061 /* if oname doesn't exist, do nothing */
3062 from_attr = GetFileAttributes(szOldName);
3063 if (from_attr == 0xFFFFFFFF) {
3068 /* if newname exists, rename it to a temporary name so that we
3069 * don't delete it in case oname happens to be the same file
3070 * (but perhaps accessed via a different path)
3072 to_attr = GetFileAttributes(szNewName);
3073 if (to_attr != 0xFFFFFFFF) {
3074 /* if newname is a directory, we fail
3075 * XXX could overcome this with yet more convoluted logic */
3076 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3080 tmplen = strlen(szNewName);
3081 strcpy(szTmpName,szNewName);
3082 endname = szTmpName+tmplen;
3083 for (; endname > szTmpName ; --endname) {
3084 if (*endname == '/' || *endname == '\\') {
3089 if (endname > szTmpName)
3090 endname = strcpy(dname,szTmpName);
3094 /* get a temporary filename in same directory
3095 * XXX is this really the best we can do? */
3096 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3100 DeleteFile(szTmpName);
3102 retval = rename(szNewName, szTmpName);
3109 /* rename oname to newname */
3110 retval = rename(szOldName, szNewName);
3112 /* if we created a temporary file before ... */
3113 if (endname != Nullch) {
3114 /* ...and rename succeeded, delete temporary file/directory */
3116 DeleteFile(szTmpName);
3117 /* else restore it to what it was */
3119 (void)rename(szTmpName, szNewName);
3126 win32_setmode(int fd, int mode)
3128 return setmode(fd, mode);
3132 win32_chsize(int fd, Off_t size)
3134 #if defined(WIN64) || defined(USE_LARGE_FILES)
3136 Off_t cur, end, extend;
3138 cur = win32_tell(fd);
3141 end = win32_lseek(fd, 0, SEEK_END);
3144 extend = size - end;
3148 else if (extend > 0) {
3149 /* must grow the file, padding with nulls */
3151 int oldmode = win32_setmode(fd, O_BINARY);
3153 memset(b, '\0', sizeof(b));
3155 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3156 count = win32_write(fd, b, count);
3157 if ((int)count < 0) {
3161 } while ((extend -= count) > 0);
3162 win32_setmode(fd, oldmode);
3165 /* shrink the file */
3166 win32_lseek(fd, size, SEEK_SET);
3167 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3173 win32_lseek(fd, cur, SEEK_SET);
3176 return chsize(fd, size);
3181 win32_lseek(int fd, Off_t offset, int origin)
3183 #if defined(WIN64) || defined(USE_LARGE_FILES)
3184 #if defined(__BORLANDC__) /* buk */
3186 pos.QuadPart = offset;
3187 pos.LowPart = SetFilePointer(
3188 (HANDLE)_get_osfhandle(fd),
3193 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3197 return pos.QuadPart;
3199 return _lseeki64(fd, offset, origin);
3202 return lseek(fd, offset, origin);
3209 #if defined(WIN64) || defined(USE_LARGE_FILES)
3210 #if defined(__BORLANDC__) /* buk */
3213 pos.LowPart = SetFilePointer(
3214 (HANDLE)_get_osfhandle(fd),
3219 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3223 return pos.QuadPart;
3224 /* return tell(fd); */
3226 return _telli64(fd);
3234 win32_open(const char *path, int flag, ...)
3239 WCHAR wBuffer[MAX_PATH+1];
3242 pmode = va_arg(ap, int);
3245 if (stricmp(path, "/dev/null")==0)
3249 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3250 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3252 return open(PerlDir_mapA(path), flag, pmode);
3255 /* close() that understands socket */
3256 extern int my_close(int); /* in win32sck.c */
3261 return my_close(fd);
3277 win32_dup2(int fd1,int fd2)
3279 return dup2(fd1,fd2);
3282 #ifdef PERL_MSVCRT_READFIX
3284 #define LF 10 /* line feed */
3285 #define CR 13 /* carriage return */
3286 #define CTRLZ 26 /* ctrl-z means eof for text */
3287 #define FOPEN 0x01 /* file handle open */
3288 #define FEOFLAG 0x02 /* end of file has been encountered */
3289 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3290 #define FPIPE 0x08 /* file handle refers to a pipe */
3291 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3292 #define FDEV 0x40 /* file handle refers to device */
3293 #define FTEXT 0x80 /* file handle is in text mode */
3294 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3297 _fixed_read(int fh, void *buf, unsigned cnt)
3299 int bytes_read; /* number of bytes read */
3300 char *buffer; /* buffer to read to */
3301 int os_read; /* bytes read on OS call */
3302 char *p, *q; /* pointers into buffer */
3303 char peekchr; /* peek-ahead character */
3304 ULONG filepos; /* file position after seek */
3305 ULONG dosretval; /* o.s. return value */
3307 /* validate handle */
3308 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3309 !(_osfile(fh) & FOPEN))
3311 /* out of range -- return error */
3313 _doserrno = 0; /* not o.s. error */
3318 * If lockinitflag is FALSE, assume fd is device
3319 * lockinitflag is set to TRUE by open.
3321 if (_pioinfo(fh)->lockinitflag)
3322 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3324 bytes_read = 0; /* nothing read yet */
3325 buffer = (char*)buf;
3327 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3328 /* nothing to read or at EOF, so return 0 read */
3332 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3333 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3335 *buffer++ = _pipech(fh);
3338 _pipech(fh) = LF; /* mark as empty */
3343 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3345 /* ReadFile has reported an error. recognize two special cases.
3347 * 1. map ERROR_ACCESS_DENIED to EBADF
3349 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3350 * means the handle is a read-handle on a pipe for which
3351 * all write-handles have been closed and all data has been
3354 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3355 /* wrong read/write mode should return EBADF, not EACCES */
3357 _doserrno = dosretval;
3361 else if (dosretval == ERROR_BROKEN_PIPE) {
3371 bytes_read += os_read; /* update bytes read */
3373 if (_osfile(fh) & FTEXT) {
3374 /* now must translate CR-LFs to LFs in the buffer */
3376 /* set CRLF flag to indicate LF at beginning of buffer */
3377 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3378 /* _osfile(fh) |= FCRLF; */
3380 /* _osfile(fh) &= ~FCRLF; */
3382 _osfile(fh) &= ~FCRLF;
3384 /* convert chars in the buffer: p is src, q is dest */
3386 while (p < (char *)buf + bytes_read) {
3388 /* if fh is not a device, set ctrl-z flag */
3389 if (!(_osfile(fh) & FDEV))
3390 _osfile(fh) |= FEOFLAG;
3391 break; /* stop translating */
3396 /* *p is CR, so must check next char for LF */
3397 if (p < (char *)buf + bytes_read - 1) {
3400 *q++ = LF; /* convert CR-LF to LF */
3403 *q++ = *p++; /* store char normally */
3406 /* This is the hard part. We found a CR at end of
3407 buffer. We must peek ahead to see if next char
3412 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3413 (LPDWORD)&os_read, NULL))
3414 dosretval = GetLastError();
3416 if (dosretval != 0 || os_read == 0) {
3417 /* couldn't read ahead, store CR */
3421 /* peekchr now has the extra character -- we now
3422 have several possibilities:
3423 1. disk file and char is not LF; just seek back
3425 2. disk file and char is LF; store LF, don't seek back
3426 3. pipe/device and char is LF; store LF.
3427 4. pipe/device and char isn't LF, store CR and
3428 put char in pipe lookahead buffer. */
3429 if (_osfile(fh) & (FDEV|FPIPE)) {
3430 /* non-seekable device */
3435 _pipech(fh) = peekchr;
3440 if (peekchr == LF) {
3441 /* nothing read yet; must make some
3444 /* turn on this flag for tell routine */
3445 _osfile(fh) |= FCRLF;
3448 HANDLE osHandle; /* o.s. handle value */
3450 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3452 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3453 dosretval = GetLastError();
3464 /* we now change bytes_read to reflect the true number of chars
3466 bytes_read = q - (char *)buf;
3470 if (_pioinfo(fh)->lockinitflag)
3471 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3476 #endif /* PERL_MSVCRT_READFIX */
3479 win32_read(int fd, void *buf, unsigned int cnt)
3481 #ifdef PERL_MSVCRT_READFIX
3482 return _fixed_read(fd, buf, cnt);
3484 return read(fd, buf, cnt);
3489 win32_write(int fd, const void *buf, unsigned int cnt)
3491 return write(fd, buf, cnt);
3495 win32_mkdir(const char *dir, int mode)
3499 WCHAR wBuffer[MAX_PATH+1];
3500 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3501 return _wmkdir(PerlDir_mapW(wBuffer));
3503 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3507 win32_rmdir(const char *dir)
3511 WCHAR wBuffer[MAX_PATH+1];
3512 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3513 return _wrmdir(PerlDir_mapW(wBuffer));
3515 return rmdir(PerlDir_mapA(dir));
3519 win32_chdir(const char *dir)
3527 WCHAR wBuffer[MAX_PATH+1];
3528 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3529 return _wchdir(wBuffer);
3535 win32_access(const char *path, int mode)
3539 WCHAR wBuffer[MAX_PATH+1];
3540 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3541 return _waccess(PerlDir_mapW(wBuffer), mode);
3543 return access(PerlDir_mapA(path), mode);
3547 win32_chmod(const char *path, int mode)
3551 WCHAR wBuffer[MAX_PATH+1];
3552 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3553 return _wchmod(PerlDir_mapW(wBuffer), mode);
3555 return chmod(PerlDir_mapA(path), mode);
3560 create_command_line(char *cname, STRLEN clen, const char * const *args)
3567 bool bat_file = FALSE;
3568 bool cmd_shell = FALSE;
3569 bool dumb_shell = FALSE;
3570 bool extra_quotes = FALSE;
3571 bool quote_next = FALSE;
3574 cname = (char*)args[0];
3576 /* The NT cmd.exe shell has the following peculiarity that needs to be
3577 * worked around. It strips a leading and trailing dquote when any
3578 * of the following is true:
3579 * 1. the /S switch was used
3580 * 2. there are more than two dquotes
3581 * 3. there is a special character from this set: &<>()@^|
3582 * 4. no whitespace characters within the two dquotes
3583 * 5. string between two dquotes isn't an executable file
3584 * To work around this, we always add a leading and trailing dquote
3585 * to the string, if the first argument is either "cmd.exe" or "cmd",
3586 * and there were at least two or more arguments passed to cmd.exe
3587 * (not including switches).
3588 * XXX the above rules (from "cmd /?") don't seem to be applied
3589 * always, making for the convolutions below :-(
3593 clen = strlen(cname);
3596 && (stricmp(&cname[clen-4], ".bat") == 0
3597 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3603 char *exe = strrchr(cname, '/');
3604 char *exe2 = strrchr(cname, '\\');
3611 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3615 else if (stricmp(exe, "command.com") == 0
3616 || stricmp(exe, "command") == 0)
3623 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3624 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3625 STRLEN curlen = strlen(arg);
3626 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3627 len += 2; /* assume quoting needed (worst case) */
3629 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3631 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3634 New(1310, cmd, len, char);
3639 extra_quotes = TRUE;
3642 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3644 STRLEN curlen = strlen(arg);
3646 /* we want to protect empty arguments and ones with spaces with
3647 * dquotes, but only if they aren't already there */
3652 else if (quote_next) {
3653 /* see if it really is multiple arguments pretending to
3654 * be one and force a set of quotes around it */
3655 if (*find_next_space(arg))
3658 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3660 while (i < curlen) {
3661 if (isSPACE(arg[i])) {
3664 else if (arg[i] == '"') {
3688 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3689 && stricmp(arg+curlen-2, "/c") == 0)
3691 /* is there a next argument? */
3692 if (args[index+1]) {
3693 /* are there two or more next arguments? */
3694 if (args[index+2]) {
3696 extra_quotes = TRUE;
3699 /* single argument, force quoting if it has spaces */
3715 qualified_path(const char *cmd)
3719 char *fullcmd, *curfullcmd;
3725 fullcmd = (char*)cmd;
3727 if (*fullcmd == '/' || *fullcmd == '\\')
3734 pathstr = PerlEnv_getenv("PATH");
3735 New(0, fullcmd, MAX_PATH+1, char);
3736 curfullcmd = fullcmd;
3741 /* start by appending the name to the current prefix */
3742 strcpy(curfullcmd, cmd);
3743 curfullcmd += cmdlen;
3745 /* if it doesn't end with '.', or has no extension, try adding
3746 * a trailing .exe first */
3747 if (cmd[cmdlen-1] != '.'
3748 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3750 strcpy(curfullcmd, ".exe");
3751 res = GetFileAttributes(fullcmd);
3752 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3757 /* that failed, try the bare name */
3758 res = GetFileAttributes(fullcmd);
3759 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3762 /* quit if no other path exists, or if cmd already has path */
3763 if (!pathstr || !*pathstr || has_slash)
3766 /* skip leading semis */
3767 while (*pathstr == ';')
3770 /* build a new prefix from scratch */
3771 curfullcmd = fullcmd;
3772 while (*pathstr && *pathstr != ';') {
3773 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3774 pathstr++; /* skip initial '"' */
3775 while (*pathstr && *pathstr != '"') {
3776 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3777 *curfullcmd++ = *pathstr;
3781 pathstr++; /* skip trailing '"' */
3784 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3785 *curfullcmd++ = *pathstr;
3790 pathstr++; /* skip trailing semi */
3791 if (curfullcmd > fullcmd /* append a dir separator */
3792 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3794 *curfullcmd++ = '\\';
3802 /* The following are just place holders.
3803 * Some hosts may provide and environment that the OS is
3804 * not tracking, therefore, these host must provide that
3805 * environment and the current directory to CreateProcess
3809 win32_get_childenv(void)
3815 win32_free_childenv(void* d)
3820 win32_clearenv(void)
3822 char *envv = GetEnvironmentStrings();
3826 char *end = strchr(cur,'=');
3827 if (end && end != cur) {
3829 SetEnvironmentVariable(cur, NULL);
3831 cur = end + strlen(end+1)+2;
3833 else if ((len = strlen(cur)))
3836 FreeEnvironmentStrings(envv);
3840 win32_get_childdir(void)
3844 char szfilename[(MAX_PATH+1)*2];
3846 WCHAR wfilename[MAX_PATH+1];
3847 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3848 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3851 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3854 New(0, ptr, strlen(szfilename)+1, char);
3855 strcpy(ptr, szfilename);
3860 win32_free_childdir(char* d)
3867 /* XXX this needs to be made more compatible with the spawnvp()
3868 * provided by the various RTLs. In particular, searching for
3869 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3870 * This doesn't significantly affect perl itself, because we
3871 * always invoke things using PERL5SHELL if a direct attempt to
3872 * spawn the executable fails.
3874 * XXX splitting and rejoining the commandline between do_aspawn()
3875 * and win32_spawnvp() could also be avoided.
3879 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3881 #ifdef USE_RTL_SPAWNVP
3882 return spawnvp(mode, cmdname, (char * const *)argv);
3889 STARTUPINFO StartupInfo;
3890 PROCESS_INFORMATION ProcessInformation;
3893 char *fullcmd = Nullch;
3894 char *cname = (char *)cmdname;
3898 clen = strlen(cname);
3899 /* if command name contains dquotes, must remove them */
3900 if (strchr(cname, '"')) {
3902 New(0,cname,clen+1,char);
3915 cmd = create_command_line(cname, clen, argv);
3917 env = PerlEnv_get_childenv();
3918 dir = PerlEnv_get_childdir();
3921 case P_NOWAIT: /* asynch + remember result */
3922 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3927 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3930 create |= CREATE_NEW_PROCESS_GROUP;
3933 case P_WAIT: /* synchronous execution */
3935 default: /* invalid mode */
3940 memset(&StartupInfo,0,sizeof(StartupInfo));
3941 StartupInfo.cb = sizeof(StartupInfo);
3942 memset(&tbl,0,sizeof(tbl));
3943 PerlEnv_get_child_IO(&tbl);
3944 StartupInfo.dwFlags = tbl.dwFlags;
3945 StartupInfo.dwX = tbl.dwX;
3946 StartupInfo.dwY = tbl.dwY;
3947 StartupInfo.dwXSize = tbl.dwXSize;
3948 StartupInfo.dwYSize = tbl.dwYSize;
3949 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3950 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3951 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3952 StartupInfo.wShowWindow = tbl.wShowWindow;
3953 StartupInfo.hStdInput = tbl.childStdIn;
3954 StartupInfo.hStdOutput = tbl.childStdOut;
3955 StartupInfo.hStdError = tbl.childStdErr;
3956 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3957 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3958 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3960 create |= CREATE_NEW_CONSOLE;
3963 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3965 if (w32_use_showwindow) {
3966 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3967 StartupInfo.wShowWindow = w32_showwindow;
3970 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3973 if (!CreateProcess(cname, /* search PATH to find executable */
3974 cmd, /* executable, and its arguments */
3975 NULL, /* process attributes */
3976 NULL, /* thread attributes */
3977 TRUE, /* inherit handles */
3978 create, /* creation flags */
3979 (LPVOID)env, /* inherit environment */
3980 dir, /* inherit cwd */
3982 &ProcessInformation))
3984 /* initial NULL argument to CreateProcess() does a PATH
3985 * search, but it always first looks in the directory
3986 * where the current process was started, which behavior
3987 * is undesirable for backward compatibility. So we
3988 * jump through our own hoops by picking out the path
3989 * we really want it to use. */
3991 fullcmd = qualified_path(cname);
3993 if (cname != cmdname)
3996 DEBUG_p(PerlIO_printf(Perl_debug_log,
3997 "Retrying [%s] with same args\n",
4007 if (mode == P_NOWAIT) {
4008 /* asynchronous spawn -- store handle, return PID */
4009 ret = (int)ProcessInformation.dwProcessId;
4010 if (IsWin95() && ret < 0)
4013 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4014 w32_child_pids[w32_num_children] = (DWORD)ret;
4019 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4020 /* FIXME: if msgwait returned due to message perhaps forward the
4021 "signal" to the process
4023 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4025 CloseHandle(ProcessInformation.hProcess);
4028 CloseHandle(ProcessInformation.hThread);
4031 PerlEnv_free_childenv(env);
4032 PerlEnv_free_childdir(dir);
4034 if (cname != cmdname)
4041 win32_execv(const char *cmdname, const char *const *argv)
4045 /* if this is a pseudo-forked child, we just want to spawn
4046 * the new program, and return */
4048 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4050 return execv(cmdname, (char *const *)argv);
4054 win32_execvp(const char *cmdname, const char *const *argv)
4058 /* if this is a pseudo-forked child, we just want to spawn
4059 * the new program, and return */
4060 if (w32_pseudo_id) {
4061 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4070 return execvp(cmdname, (char *const *)argv);
4074 win32_perror(const char *str)
4080 win32_setbuf(FILE *pf, char *buf)
4086 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4088 return setvbuf(pf, buf, type, size);
4092 win32_flushall(void)
4098 win32_fcloseall(void)
4104 win32_fgets(char *s, int n, FILE *pf)
4106 return fgets(s, n, pf);
4116 win32_fgetc(FILE *pf)
4122 win32_putc(int c, FILE *pf)
4128 win32_puts(const char *s)
4140 win32_putchar(int c)
4147 #ifndef USE_PERL_SBRK
4149 static char *committed = NULL; /* XXX threadead */
4150 static char *base = NULL; /* XXX threadead */
4151 static char *reserved = NULL; /* XXX threadead */
4152 static char *brk = NULL; /* XXX threadead */
4153 static DWORD pagesize = 0; /* XXX threadead */
4154 static DWORD allocsize = 0; /* XXX threadead */
4157 sbrk(ptrdiff_t need)
4162 GetSystemInfo(&info);
4163 /* Pretend page size is larger so we don't perpetually
4164 * call the OS to commit just one page ...
4166 pagesize = info.dwPageSize << 3;
4167 allocsize = info.dwAllocationGranularity;
4169 /* This scheme fails eventually if request for contiguous
4170 * block is denied so reserve big blocks - this is only
4171 * address space not memory ...
4173 if (brk+need >= reserved)
4175 DWORD size = 64*1024*1024;
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);
4182 committed = reserved;
4184 /* Reserve some (more) space
4185 * Note this is a little sneaky, 1st call passes NULL as reserved
4186 * so lets system choose where we start, subsequent calls pass
4187 * the old end address so ask for a contiguous block
4189 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4192 reserved = addr+size;
4207 if (brk > committed)
4209 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4210 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4225 win32_malloc(size_t size)
4227 return malloc(size);
4231 win32_calloc(size_t numitems, size_t size)
4233 return calloc(numitems,size);
4237 win32_realloc(void *block, size_t size)
4239 return realloc(block,size);
4243 win32_free(void *block)
4250 win32_open_osfhandle(intptr_t handle, int flags)
4252 #ifdef USE_FIXED_OSFHANDLE
4254 return my_open_osfhandle(handle, flags);
4256 return _open_osfhandle(handle, flags);
4260 win32_get_osfhandle(int fd)
4262 return (intptr_t)_get_osfhandle(fd);
4266 win32_fdupopen(FILE *pf)
4271 int fileno = win32_dup(win32_fileno(pf));
4273 /* open the file in the same mode */
4275 if((pf)->flags & _F_READ) {
4279 else if((pf)->flags & _F_WRIT) {
4283 else if((pf)->flags & _F_RDWR) {
4289 if((pf)->_flag & _IOREAD) {
4293 else if((pf)->_flag & _IOWRT) {
4297 else if((pf)->_flag & _IORW) {
4304 /* it appears that the binmode is attached to the
4305 * file descriptor so binmode files will be handled
4308 pfdup = win32_fdopen(fileno, mode);
4310 /* move the file pointer to the same position */
4311 if (!fgetpos(pf, &pos)) {
4312 fsetpos(pfdup, &pos);
4318 win32_dynaload(const char* filename)
4322 char buf[MAX_PATH+1];
4325 /* LoadLibrary() doesn't recognize forward slashes correctly,
4326 * so turn 'em back. */
4327 first = strchr(filename, '/');
4329 STRLEN len = strlen(filename);
4330 if (len <= MAX_PATH) {
4331 strcpy(buf, filename);
4332 filename = &buf[first - filename];
4334 if (*filename == '/')
4335 *(char*)filename = '\\';
4342 WCHAR wfilename[MAX_PATH+1];
4343 A2WHELPER(filename, wfilename, sizeof(wfilename));
4344 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4347 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4357 XS(w32_SetChildShowWindow)
4360 BOOL use_showwindow = w32_use_showwindow;
4361 /* use "unsigned short" because Perl has redefined "WORD" */
4362 unsigned short showwindow = w32_showwindow;
4365 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4367 if (items == 0 || !SvOK(ST(0)))
4368 w32_use_showwindow = FALSE;
4370 w32_use_showwindow = TRUE;
4371 w32_showwindow = (unsigned short)SvIV(ST(0));
4376 ST(0) = sv_2mortal(newSViv(showwindow));
4378 ST(0) = &PL_sv_undef;
4386 /* Make the host for current directory */
4387 char* ptr = PerlEnv_get_childdir();
4390 * then it worked, set PV valid,
4391 * else return 'undef'
4394 SV *sv = sv_newmortal();
4396 PerlEnv_free_childdir(ptr);
4398 #ifndef INCOMPLETE_TAINTS
4415 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4416 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4423 XS(w32_GetNextAvailDrive)
4427 char root[] = "_:\\";
4432 if (GetDriveType(root) == 1) {
4441 XS(w32_GetLastError)
4445 XSRETURN_IV(GetLastError());
4449 XS(w32_SetLastError)
4453 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4454 SetLastError(SvIV(ST(0)));
4462 char *name = w32_getlogin_buffer;
4463 DWORD size = sizeof(w32_getlogin_buffer);
4465 if (GetUserName(name,&size)) {
4466 /* size includes NULL */
4467 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4477 char name[MAX_COMPUTERNAME_LENGTH+1];
4478 DWORD size = sizeof(name);
4480 if (GetComputerName(name,&size)) {
4481 /* size does NOT include NULL :-( */
4482 ST(0) = sv_2mortal(newSVpvn(name,size));
4493 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4494 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4495 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4499 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4500 GetProcAddress(hNetApi32, "NetApiBufferFree");
4501 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4502 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4505 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4506 /* this way is more reliable, in case user has a local account. */
4508 DWORD dnamelen = sizeof(dname);
4510 DWORD wki100_platform_id;
4511 LPWSTR wki100_computername;
4512 LPWSTR wki100_langroup;
4513 DWORD wki100_ver_major;
4514 DWORD wki100_ver_minor;
4516 /* NERR_Success *is* 0*/
4517 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4518 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4519 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4520 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4523 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4524 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4526 pfnNetApiBufferFree(pwi);
4527 FreeLibrary(hNetApi32);
4530 FreeLibrary(hNetApi32);
4533 /* Win95 doesn't have NetWksta*(), so do it the old way */
4535 DWORD size = sizeof(name);
4537 FreeLibrary(hNetApi32);
4538 if (GetUserName(name,&size)) {
4539 char sid[ONE_K_BUFSIZE];
4540 DWORD sidlen = sizeof(sid);
4542 DWORD dnamelen = sizeof(dname);
4544 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4545 dname, &dnamelen, &snu)) {
4546 XSRETURN_PV(dname); /* all that for this */
4558 DWORD flags, filecomplen;
4559 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4560 &flags, fsname, sizeof(fsname))) {
4561 if (GIMME_V == G_ARRAY) {
4562 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4563 XPUSHs(sv_2mortal(newSViv(flags)));
4564 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4569 XSRETURN_PV(fsname);
4575 XS(w32_GetOSVersion)
4578 /* Use explicit struct definition because wSuiteMask and
4579 * wProductType are not defined in the VC++ 6.0 headers.
4580 * WORD type has been replaced by unsigned short because
4581 * WORD is already used by Perl itself.
4584 DWORD dwOSVersionInfoSize;
4585 DWORD dwMajorVersion;
4586 DWORD dwMinorVersion;
4587 DWORD dwBuildNumber;
4589 CHAR szCSDVersion[128];
4590 unsigned short wServicePackMajor;
4591 unsigned short wServicePackMinor;
4592 unsigned short wSuiteMask;
4600 DWORD dwOSVersionInfoSize;
4601 DWORD dwMajorVersion;
4602 DWORD dwMinorVersion;
4603 DWORD dwBuildNumber;
4605 WCHAR szCSDVersion[128];
4606 unsigned short wServicePackMajor;
4607 unsigned short wServicePackMinor;
4608 unsigned short wSuiteMask;
4612 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4613 osverw.dwOSVersionInfoSize = sizeof(osverw);
4614 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4616 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4617 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4621 if (GIMME_V == G_SCALAR) {
4622 XSRETURN_IV(osverw.dwPlatformId);
4624 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4625 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4626 osver.dwMajorVersion = osverw.dwMajorVersion;
4627 osver.dwMinorVersion = osverw.dwMinorVersion;
4628 osver.dwBuildNumber = osverw.dwBuildNumber;
4629 osver.dwPlatformId = osverw.dwPlatformId;
4630 osver.wServicePackMajor = osverw.wServicePackMajor;
4631 osver.wServicePackMinor = osverw.wServicePackMinor;
4632 osver.wSuiteMask = osverw.wSuiteMask;
4633 osver.wProductType = osverw.wProductType;
4636 osver.dwOSVersionInfoSize = sizeof(osver);
4637 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4639 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4640 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4644 if (GIMME_V == G_SCALAR) {
4645 XSRETURN_IV(osver.dwPlatformId);
4647 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4649 XPUSHs(newSViv(osver.dwMajorVersion));
4650 XPUSHs(newSViv(osver.dwMinorVersion));
4651 XPUSHs(newSViv(osver.dwBuildNumber));
4652 XPUSHs(newSViv(osver.dwPlatformId));
4654 XPUSHs(newSViv(osver.wServicePackMajor));
4655 XPUSHs(newSViv(osver.wServicePackMinor));
4656 XPUSHs(newSViv(osver.wSuiteMask));
4657 XPUSHs(newSViv(osver.wProductType));
4667 XSRETURN_IV(IsWinNT());
4675 XSRETURN_IV(IsWin95());
4679 XS(w32_FormatMessage)
4683 char msgbuf[ONE_K_BUFSIZE];
4686 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4689 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4690 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4691 &source, SvIV(ST(0)), 0,
4692 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4694 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4695 XSRETURN_PV(msgbuf);
4699 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4700 &source, SvIV(ST(0)), 0,
4701 msgbuf, sizeof(msgbuf)-1, NULL))
4702 XSRETURN_PV(msgbuf);
4715 PROCESS_INFORMATION stProcInfo;
4716 STARTUPINFO stStartInfo;
4717 BOOL bSuccess = FALSE;
4720 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4722 cmd = SvPV_nolen(ST(0));
4723 args = SvPV_nolen(ST(1));
4725 env = PerlEnv_get_childenv();
4726 dir = PerlEnv_get_childdir();
4728 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4729 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4730 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4731 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4734 cmd, /* Image path */
4735 args, /* Arguments for command line */
4736 NULL, /* Default process security */
4737 NULL, /* Default thread security */
4738 FALSE, /* Must be TRUE to use std handles */
4739 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4740 env, /* Inherit our environment block */
4741 dir, /* Inherit our currrent directory */
4742 &stStartInfo, /* -> Startup info */
4743 &stProcInfo)) /* <- Process info (if OK) */
4745 int pid = (int)stProcInfo.dwProcessId;
4746 if (IsWin95() && pid < 0)
4748 sv_setiv(ST(2), pid);
4749 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4752 PerlEnv_free_childenv(env);
4753 PerlEnv_free_childdir(dir);
4754 XSRETURN_IV(bSuccess);
4758 XS(w32_GetTickCount)
4761 DWORD msec = GetTickCount();
4769 XS(w32_GetShortPathName)
4776 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4778 shortpath = sv_mortalcopy(ST(0));
4779 SvUPGRADE(shortpath, SVt_PV);
4780 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4783 /* src == target is allowed */
4785 len = GetShortPathName(SvPVX(shortpath),
4788 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4790 SvCUR_set(shortpath,len);
4791 *SvEND(shortpath) = '\0';
4799 XS(w32_GetFullPathName)
4808 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4811 fullpath = sv_mortalcopy(filename);
4812 SvUPGRADE(fullpath, SVt_PV);
4813 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4817 len = GetFullPathName(SvPVX(filename),
4821 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4823 if (GIMME_V == G_ARRAY) {
4826 XST_mPV(1,filepart);
4827 len = filepart - SvPVX(fullpath);
4834 SvCUR_set(fullpath,len);
4835 *SvEND(fullpath) = '\0';
4843 XS(w32_GetLongPathName)
4847 char tmpbuf[MAX_PATH+1];
4852 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4855 pathstr = SvPV(path,len);
4856 strcpy(tmpbuf, pathstr);
4857 pathstr = win32_longpath(tmpbuf);
4859 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4870 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4881 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4883 WCHAR wSourceFile[MAX_PATH+1];
4884 WCHAR wDestFile[MAX_PATH+1];
4885 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4886 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4887 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4888 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4891 char szSourceFile[MAX_PATH+1];
4892 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4893 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4902 Perl_init_os_extras(void)
4905 char *file = __FILE__;
4908 /* these names are Activeware compatible */
4909 newXS("Win32::GetCwd", w32_GetCwd, file);
4910 newXS("Win32::SetCwd", w32_SetCwd, file);
4911 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4912 newXS("Win32::GetLastError", w32_GetLastError, file);
4913 newXS("Win32::SetLastError", w32_SetLastError, file);
4914 newXS("Win32::LoginName", w32_LoginName, file);
4915 newXS("Win32::NodeName", w32_NodeName, file);
4916 newXS("Win32::DomainName", w32_DomainName, file);
4917 newXS("Win32::FsType", w32_FsType, file);
4918 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4919 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4920 newXS("Win32::IsWin95", w32_IsWin95, file);
4921 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4922 newXS("Win32::Spawn", w32_Spawn, file);
4923 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4924 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4925 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4926 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4927 newXS("Win32::CopyFile", w32_CopyFile, file);
4928 newXS("Win32::Sleep", w32_Sleep, file);
4929 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4931 /* XXX Bloat Alert! The following Activeware preloads really
4932 * ought to be part of Win32::Sys::*, so they're not included
4935 /* LookupAccountName
4937 * InitiateSystemShutdown
4938 * AbortSystemShutdown
4939 * ExpandEnvrironmentStrings
4944 win32_signal_context(void)
4949 my_perl = PL_curinterp;
4950 PERL_SET_THX(my_perl);
4954 return PL_curinterp;
4960 win32_ctrlhandler(DWORD dwCtrlType)
4963 dTHXa(PERL_GET_SIG_CONTEXT);
4969 switch(dwCtrlType) {
4970 case CTRL_CLOSE_EVENT:
4971 /* A signal that the system sends to all processes attached to a console when
4972 the user closes the console (either by choosing the Close command from the
4973 console window's System menu, or by choosing the End Task command from the
4976 if (do_raise(aTHX_ 1)) /* SIGHUP */
4977 sig_terminate(aTHX_ 1);
4981 /* A CTRL+c signal was received */
4982 if (do_raise(aTHX_ SIGINT))
4983 sig_terminate(aTHX_ SIGINT);
4986 case CTRL_BREAK_EVENT:
4987 /* A CTRL+BREAK signal was received */
4988 if (do_raise(aTHX_ SIGBREAK))
4989 sig_terminate(aTHX_ SIGBREAK);
4992 case CTRL_LOGOFF_EVENT:
4993 /* A signal that the system sends to all console processes when a user is logging
4994 off. This signal does not indicate which user is logging off, so no
4995 assumptions can be made.
4998 case CTRL_SHUTDOWN_EVENT:
4999 /* A signal that the system sends to all console processes when the system is
5002 if (do_raise(aTHX_ SIGTERM))
5003 sig_terminate(aTHX_ SIGTERM);
5013 Perl_win32_init(int *argcp, char ***argvp)
5015 /* Disable floating point errors, Perl will trap the ones we
5016 * care about. VC++ RTL defaults to switching these off
5017 * already, but the Borland RTL doesn't. Since we don't
5018 * want to be at the vendor's whim on the default, we set
5019 * it explicitly here.
5021 #if !defined(_ALPHA_) && !defined(__GNUC__)
5022 _control87(MCW_EM, MCW_EM);
5028 Perl_win32_term(void)
5035 win32_get_child_IO(child_IO_table* ptbl)
5037 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
5038 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
5039 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
5043 win32_signal(int sig, Sighandler_t subcode)
5046 if (sig < SIG_SIZE) {
5047 int save_errno = errno;
5048 Sighandler_t result = signal(sig, subcode);
5049 if (result == SIG_ERR) {
5050 result = w32_sighandler[sig];
5053 w32_sighandler[sig] = subcode;
5063 #ifdef HAVE_INTERP_INTERN
5067 win32_csighandler(int sig)
5070 dTHXa(PERL_GET_SIG_CONTEXT);
5071 Perl_warn(aTHX_ "Got signal %d",sig);
5077 Perl_sys_intern_init(pTHX)
5080 w32_perlshell_tokens = Nullch;
5081 w32_perlshell_vec = (char**)NULL;
5082 w32_perlshell_items = 0;
5083 w32_fdpid = newAV();
5084 New(1313, w32_children, 1, child_tab);
5085 w32_num_children = 0;
5086 # ifdef USE_ITHREADS
5088 New(1313, w32_pseudo_children, 1, child_tab);
5089 w32_num_pseudo_children = 0;
5091 w32_init_socktype = 0;
5094 for (i=0; i < SIG_SIZE; i++) {
5095 w32_sighandler[i] = SIG_DFL;
5098 if (my_perl == PL_curinterp) {
5102 /* Force C runtime signal stuff to set its console handler */
5103 signal(SIGINT,&win32_csighandler);
5104 signal(SIGBREAK,&win32_csighandler);
5105 /* Push our handler on top */
5106 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5111 Perl_sys_intern_clear(pTHX)
5113 Safefree(w32_perlshell_tokens);
5114 Safefree(w32_perlshell_vec);
5115 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5116 Safefree(w32_children);
5118 KillTimer(NULL,w32_timerid);
5121 # ifdef MULTIPLICITY
5122 if (my_perl == PL_curinterp) {
5126 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5128 # ifdef USE_ITHREADS
5129 Safefree(w32_pseudo_children);
5133 # ifdef USE_ITHREADS
5136 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5138 dst->perlshell_tokens = Nullch;
5139 dst->perlshell_vec = (char**)NULL;
5140 dst->perlshell_items = 0;
5141 dst->fdpid = newAV();
5142 Newz(1313, dst->children, 1, child_tab);
5144 Newz(1313, dst->pseudo_children, 1, child_tab);
5145 dst->thr_intern.Winit_socktype = 0;
5147 dst->poll_count = 0;
5148 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5150 # endif /* USE_ITHREADS */
5151 #endif /* HAVE_INTERP_INTERN */
5154 win32_free_argvw(pTHX_ void *ptr)
5156 char** argv = (char**)ptr;
5164 win32_argv2utf8(int argc, char** argv)
5169 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5170 if (lpwStr && argc) {
5172 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5173 Newz(0, psz, length, char);
5174 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5177 call_atexit(win32_free_argvw, argv);
5179 GlobalFree((HGLOBAL)lpwStr);