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 #ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */
19 # include <shellapi.h>
21 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
27 /* #include "config.h" */
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
38 #define PERL_NO_GET_CONTEXT
44 /* assert.h conflicts with #define of assert in perl.h */
51 #if defined(_MSC_VER) || defined(__MINGW32__)
52 #include <sys/utime.h>
57 /* Mingw32 defaults to globing command line
58 * So we turn it off like this:
63 #if defined(__MINGW32__)
64 /* Mingw32 is missing some prototypes */
65 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
72 #if defined(__BORLANDC__)
74 # define _utimbuf utimbuf
79 #define EXECF_SPAWN_NOWAIT 3
81 #if defined(PERL_IMPLICIT_SYS)
82 # undef win32_get_privlib
83 # define win32_get_privlib g_win32_get_privlib
84 # undef win32_get_sitelib
85 # define win32_get_sitelib g_win32_get_sitelib
86 # undef win32_get_vendorlib
87 # define win32_get_vendorlib g_win32_get_vendorlib
89 # define do_spawn g_do_spawn
91 # define getlogin g_getlogin
94 static void get_shell(void);
95 static long tokenize(const char *str, char **dest, char ***destv);
96 int do_spawn2(char *cmd, int exectype);
97 static BOOL has_shell_metachars(char *ptr);
98 static long filetime_to_clock(PFILETIME ft);
99 static BOOL filetime_from_time(PFILETIME ft, time_t t);
100 static char * get_emd_part(SV **leading, char *trailing, ...);
101 static void remove_dead_process(long deceased);
102 static long find_pid(int pid);
103 static char * qualified_path(const char *cmd);
104 static char * win32_get_xlib(const char *pl, const char *xlib,
105 const char *libname);
108 static void remove_dead_pseudo_process(long child);
109 static long find_pseudo_pid(int pid);
113 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
114 char w32_module_name[MAX_PATH+1];
117 static DWORD w32_platform = (DWORD)-1;
119 #define ONE_K_BUFSIZE 1024
124 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
130 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
134 set_w32_module_name(void)
137 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
138 ? GetModuleHandle(NULL)
139 : w32_perldll_handle),
140 w32_module_name, sizeof(w32_module_name));
142 /* try to get full path to binary (which may be mangled when perl is
143 * run from a 16-bit app) */
144 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
145 (void)win32_longpath(w32_module_name);
146 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
148 /* normalize to forward slashes */
149 ptr = w32_module_name;
157 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
159 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
161 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
164 const char *subkey = "Software\\Perl";
168 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
169 if (retval == ERROR_SUCCESS) {
171 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
172 if (retval == ERROR_SUCCESS
173 && (type == REG_SZ || type == REG_EXPAND_SZ))
177 *svp = sv_2mortal(newSVpvn("",0));
178 SvGROW(*svp, datalen);
179 retval = RegQueryValueEx(handle, valuename, 0, NULL,
180 (PBYTE)SvPVX(*svp), &datalen);
181 if (retval == ERROR_SUCCESS) {
183 SvCUR_set(*svp,datalen-1);
191 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
193 get_regstr(const char *valuename, SV **svp)
195 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
197 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
201 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
203 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
207 char mod_name[MAX_PATH+1];
211 int oldsize, newsize;
214 va_start(ap, trailing_path);
215 strip = va_arg(ap, char *);
217 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
218 baselen = strlen(base);
220 if (!*w32_module_name) {
221 set_w32_module_name();
223 strcpy(mod_name, w32_module_name);
224 ptr = strrchr(mod_name, '/');
225 while (ptr && strip) {
226 /* look for directories to skip back */
229 ptr = strrchr(mod_name, '/');
230 /* avoid stripping component if there is no slash,
231 * or it doesn't match ... */
232 if (!ptr || stricmp(ptr+1, strip) != 0) {
233 /* ... but not if component matches m|5\.$patchlevel.*| */
234 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
235 && strncmp(strip, base, baselen) == 0
236 && strncmp(ptr+1, base, baselen) == 0))
242 strip = va_arg(ap, char *);
250 strcpy(++ptr, trailing_path);
252 /* only add directory if it exists */
253 if (GetFileAttributes(mod_name) != (DWORD) -1) {
254 /* directory exists */
257 *prev_pathp = sv_2mortal(newSVpvn("",0));
258 sv_catpvn(*prev_pathp, ";", 1);
259 sv_catpv(*prev_pathp, mod_name);
260 return SvPVX(*prev_pathp);
267 win32_get_privlib(const char *pl)
270 char *stdlib = "lib";
271 char buffer[MAX_PATH+1];
274 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
275 sprintf(buffer, "%s-%s", stdlib, pl);
276 if (!get_regstr(buffer, &sv))
277 (void)get_regstr(stdlib, &sv);
279 /* $stdlib .= ";$EMD/../../lib" */
280 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
284 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
288 char pathstr[MAX_PATH+1];
294 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
295 sprintf(regstr, "%s-%s", xlib, pl);
296 (void)get_regstr(regstr, &sv1);
299 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
300 sprintf(pathstr, "%s/%s/lib", libname, pl);
301 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
303 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
304 (void)get_regstr(xlib, &sv2);
307 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
308 sprintf(pathstr, "%s/lib", libname);
309 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
318 sv_catpvn(sv1, ";", 1);
325 win32_get_sitelib(const char *pl)
327 return win32_get_xlib(pl, "sitelib", "site");
330 #ifndef PERL_VENDORLIB_NAME
331 # define PERL_VENDORLIB_NAME "vendor"
335 win32_get_vendorlib(const char *pl)
337 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
341 has_shell_metachars(char *ptr)
347 * Scan string looking for redirection (< or >) or pipe
348 * characters (|) that are not in a quoted string.
349 * Shell variable interpolation (%VAR%) can also happen inside strings.
381 #if !defined(PERL_IMPLICIT_SYS)
382 /* since the current process environment is being updated in util.c
383 * the library functions will get the correct environment
386 Perl_my_popen(pTHX_ char *cmd, char *mode)
389 #define fixcmd(x) { \
390 char *pspace = strchr((x),' '); \
393 while (p < pspace) { \
404 PERL_FLUSHALL_FOR_CHILD;
405 return win32_popen(cmd, mode);
409 Perl_my_pclose(pTHX_ PerlIO *fp)
411 return win32_pclose(fp);
415 DllExport unsigned long
418 static OSVERSIONINFO osver;
420 if (osver.dwPlatformId != w32_platform) {
421 memset(&osver, 0, sizeof(OSVERSIONINFO));
422 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
423 GetVersionEx(&osver);
424 w32_platform = osver.dwPlatformId;
426 return (unsigned long)w32_platform;
436 return -((int)w32_pseudo_id);
439 /* Windows 9x appears to always reports a pid for threads and processes
440 * that has the high bit set. So we treat the lower 31 bits as the
441 * "real" PID for Perl's purposes. */
442 if (IsWin95() && pid < 0)
447 /* Tokenize a string. Words are null-separated, and the list
448 * ends with a doubled null. Any character (except null and
449 * including backslash) may be escaped by preceding it with a
450 * backslash (the backslash will be stripped).
451 * Returns number of words in result buffer.
454 tokenize(const char *str, char **dest, char ***destv)
456 char *retstart = Nullch;
457 char **retvstart = 0;
461 int slen = strlen(str);
463 register char **retv;
464 New(1307, ret, slen+2, char);
465 New(1308, retv, (slen+3)/2, char*);
473 if (*ret == '\\' && *str)
475 else if (*ret == ' ') {
491 retvstart[items] = Nullch;
504 if (!w32_perlshell_tokens) {
505 /* we don't use COMSPEC here for two reasons:
506 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
507 * uncontrolled unportability of the ensuing scripts.
508 * 2. PERL5SHELL could be set to a shell that may not be fit for
509 * interactive use (which is what most programs look in COMSPEC
512 const char* defaultshell = (IsWinNT()
513 ? "cmd.exe /x/c" : "command.com /c");
514 const char *usershell = PerlEnv_getenv("PERL5SHELL");
515 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
516 &w32_perlshell_tokens,
522 do_aspawn(void *vreally, void **vmark, void **vsp)
525 SV *really = (SV*)vreally;
526 SV **mark = (SV**)vmark;
538 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
540 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
545 while (++mark <= sp) {
546 if (*mark && (str = SvPV_nolen(*mark)))
553 status = win32_spawnvp(flag,
554 (const char*)(really ? SvPV_nolen(really) : argv[0]),
555 (const char* const*)argv);
557 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
558 /* possible shell-builtin, invoke with shell */
560 sh_items = w32_perlshell_items;
562 argv[index+sh_items] = argv[index];
563 while (--sh_items >= 0)
564 argv[sh_items] = w32_perlshell_vec[sh_items];
566 status = win32_spawnvp(flag,
567 (const char*)(really ? SvPV_nolen(really) : argv[0]),
568 (const char* const*)argv);
571 if (flag == P_NOWAIT) {
573 PL_statusvalue = -1; /* >16bits hint for pp_system() */
577 if (ckWARN(WARN_EXEC))
578 Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
583 PL_statusvalue = status;
589 /* returns pointer to the next unquoted space or the end of the string */
591 find_next_space(const char *s)
593 bool in_quotes = FALSE;
595 /* ignore doubled backslashes, or backslash+quote */
596 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
599 /* keep track of when we're within quotes */
600 else if (*s == '"') {
602 in_quotes = !in_quotes;
604 /* break it up only at spaces that aren't in quotes */
605 else if (!in_quotes && isSPACE(*s))
614 do_spawn2(char *cmd, int exectype)
621 BOOL needToTry = TRUE;
624 /* Save an extra exec if possible. See if there are shell
625 * metacharacters in it */
626 if (!has_shell_metachars(cmd)) {
627 New(1301,argv, strlen(cmd) / 2 + 2, char*);
628 New(1302,cmd2, strlen(cmd) + 1, char);
631 for (s = cmd2; *s;) {
632 while (*s && isSPACE(*s))
636 s = find_next_space(s);
644 status = win32_spawnvp(P_WAIT, argv[0],
645 (const char* const*)argv);
647 case EXECF_SPAWN_NOWAIT:
648 status = win32_spawnvp(P_NOWAIT, argv[0],
649 (const char* const*)argv);
652 status = win32_execvp(argv[0], (const char* const*)argv);
655 if (status != -1 || errno == 0)
665 New(1306, argv, w32_perlshell_items + 2, char*);
666 while (++i < w32_perlshell_items)
667 argv[i] = w32_perlshell_vec[i];
672 status = win32_spawnvp(P_WAIT, argv[0],
673 (const char* const*)argv);
675 case EXECF_SPAWN_NOWAIT:
676 status = win32_spawnvp(P_NOWAIT, argv[0],
677 (const char* const*)argv);
680 status = win32_execvp(argv[0], (const char* const*)argv);
686 if (exectype == EXECF_SPAWN_NOWAIT) {
688 PL_statusvalue = -1; /* >16bits hint for pp_system() */
692 if (ckWARN(WARN_EXEC))
693 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
694 (exectype == EXECF_EXEC ? "exec" : "spawn"),
695 cmd, strerror(errno));
700 PL_statusvalue = status;
708 return do_spawn2(cmd, EXECF_SPAWN);
712 do_spawn_nowait(char *cmd)
714 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
718 Perl_do_exec(pTHX_ char *cmd)
720 do_spawn2(cmd, EXECF_EXEC);
724 /* The idea here is to read all the directory names into a string table
725 * (separated by nulls) and when one of the other dir functions is called
726 * return the pointer to the current file name.
729 win32_opendir(char *filename)
735 char scanname[MAX_PATH+3];
737 WIN32_FIND_DATAA aFindData;
738 WIN32_FIND_DATAW wFindData;
740 char buffer[MAX_PATH*2];
741 WCHAR wbuffer[MAX_PATH+1];
744 len = strlen(filename);
748 /* check to see if filename is a directory */
749 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
752 /* Get us a DIR structure */
753 Newz(1303, dirp, 1, DIR);
755 /* Create the search pattern */
756 strcpy(scanname, filename);
758 /* bare drive name means look in cwd for drive */
759 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
760 scanname[len++] = '.';
761 scanname[len++] = '/';
763 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
764 scanname[len++] = '/';
766 scanname[len++] = '*';
767 scanname[len] = '\0';
769 /* do the FindFirstFile call */
771 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
772 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
775 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
778 if (fh == INVALID_HANDLE_VALUE) {
779 DWORD err = GetLastError();
780 /* FindFirstFile() fails on empty drives! */
782 case ERROR_FILE_NOT_FOUND:
784 case ERROR_NO_MORE_FILES:
785 case ERROR_PATH_NOT_FOUND:
788 case ERROR_NOT_ENOUGH_MEMORY:
799 /* now allocate the first part of the string table for
800 * the filenames that we find.
803 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
807 ptr = aFindData.cFileName;
814 New(1304, dirp->start, dirp->size, char);
815 strcpy(dirp->start, ptr);
817 dirp->end = dirp->curr = dirp->start;
823 /* Readdir just returns the current string pointer and bumps the
824 * string pointer to the nDllExport entry.
826 DllExport struct direct *
827 win32_readdir(DIR *dirp)
832 /* first set up the structure to return */
833 len = strlen(dirp->curr);
834 strcpy(dirp->dirstr.d_name, dirp->curr);
835 dirp->dirstr.d_namlen = len;
838 dirp->dirstr.d_ino = dirp->curr - dirp->start;
840 /* Now set up for the next call to readdir */
841 dirp->curr += len + 1;
842 if (dirp->curr >= dirp->end) {
846 WIN32_FIND_DATAW wFindData;
847 WIN32_FIND_DATAA aFindData;
848 char buffer[MAX_PATH*2];
850 /* finding the next file that matches the wildcard
851 * (which should be all of them in this directory!).
854 res = FindNextFileW(dirp->handle, &wFindData);
856 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
861 res = FindNextFileA(dirp->handle, &aFindData);
863 ptr = aFindData.cFileName;
866 long endpos = dirp->end - dirp->start;
867 long newsize = endpos + strlen(ptr) + 1;
868 /* bump the string table size by enough for the
869 * new name and its null terminator */
870 while (newsize > dirp->size) {
871 long curpos = dirp->curr - dirp->start;
873 Renew(dirp->start, dirp->size, char);
874 dirp->curr = dirp->start + curpos;
876 strcpy(dirp->start + endpos, ptr);
877 dirp->end = dirp->start + newsize;
883 return &(dirp->dirstr);
889 /* Telldir returns the current string pointer position */
891 win32_telldir(DIR *dirp)
893 return (dirp->curr - dirp->start);
897 /* Seekdir moves the string pointer to a previously saved position
898 * (returned by telldir).
901 win32_seekdir(DIR *dirp, long loc)
903 dirp->curr = dirp->start + loc;
906 /* Rewinddir resets the string pointer to the start */
908 win32_rewinddir(DIR *dirp)
910 dirp->curr = dirp->start;
913 /* free the memory allocated by opendir */
915 win32_closedir(DIR *dirp)
918 if (dirp->handle != INVALID_HANDLE_VALUE)
919 FindClose(dirp->handle);
920 Safefree(dirp->start);
933 * Just pretend that everyone is a superuser. NT will let us know if
934 * we don\'t really have permission to do something.
937 #define ROOT_UID ((uid_t)0)
938 #define ROOT_GID ((gid_t)0)
967 return (auid == ROOT_UID ? 0 : -1);
973 return (agid == ROOT_GID ? 0 : -1);
980 char *buf = w32_getlogin_buffer;
981 DWORD size = sizeof(w32_getlogin_buffer);
982 if (GetUserName(buf,&size))
988 chown(const char *path, uid_t owner, gid_t group)
995 * XXX this needs strengthening (for PerlIO)
998 int mkstemp(const char *path)
1001 char buf[MAX_PATH+1];
1005 if (i++ > 10) { /* give up */
1009 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1013 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1023 long child = w32_num_children;
1024 while (--child >= 0) {
1025 if (w32_child_pids[child] == pid)
1032 remove_dead_process(long child)
1036 CloseHandle(w32_child_handles[child]);
1037 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1038 (w32_num_children-child-1), HANDLE);
1039 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1040 (w32_num_children-child-1), DWORD);
1047 find_pseudo_pid(int pid)
1050 long child = w32_num_pseudo_children;
1051 while (--child >= 0) {
1052 if (w32_pseudo_child_pids[child] == pid)
1059 remove_dead_pseudo_process(long child)
1063 CloseHandle(w32_pseudo_child_handles[child]);
1064 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1065 (w32_num_pseudo_children-child-1), HANDLE);
1066 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1067 (w32_num_pseudo_children-child-1), DWORD);
1068 w32_num_pseudo_children--;
1074 win32_kill(int pid, int sig)
1081 /* it is a pseudo-forked child */
1082 child = find_pseudo_pid(-pid);
1084 hProcess = w32_pseudo_child_handles[child];
1087 /* "Does process exist?" use of kill */
1090 /* kill -9 style un-graceful exit */
1091 if (TerminateThread(hProcess, sig)) {
1092 remove_dead_pseudo_process(child);
1097 /* We fake signals to pseudo-processes using Win32 message queue */
1098 if (PostThreadMessage(-pid,WM_USER,sig,0)) {
1099 /* It might be us ... */
1106 else if (IsWin95()) {
1114 child = find_pid(pid);
1116 hProcess = w32_child_handles[child];
1119 /* "Does process exist?" use of kill */
1122 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1125 default: /* For now be backwards compatible with perl5.6 */
1127 if (TerminateProcess(hProcess, sig)) {
1128 remove_dead_process(child);
1136 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1137 (IsWin95() ? -pid : pid));
1141 /* "Does process exist?" use of kill */
1144 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1147 default: /* For now be backwards compatible with perl5.6 */
1149 if (TerminateProcess(hProcess, sig)) {
1150 CloseHandle(hProcess);
1162 win32_stat(const char *path, struct stat *sbuf)
1165 char buffer[MAX_PATH+1];
1166 int l = strlen(path);
1168 WCHAR wbuffer[MAX_PATH+1];
1174 switch(path[l - 1]) {
1175 /* FindFirstFile() and stat() are buggy with a trailing
1176 * backslash, so change it to a forward slash :-( */
1178 strncpy(buffer, path, l-1);
1179 buffer[l - 1] = '/';
1183 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1185 if (l == 2 && isALPHA(path[0])) {
1186 buffer[0] = path[0];
1197 /* We *must* open & close the file once; otherwise file attribute changes */
1198 /* might not yet have propagated to "other" hard links of the same file. */
1199 /* This also gives us an opportunity to determine the number of links. */
1201 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1202 pwbuffer = PerlDir_mapW(wbuffer);
1203 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1206 path = PerlDir_mapA(path);
1208 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1210 if (handle != INVALID_HANDLE_VALUE) {
1211 BY_HANDLE_FILE_INFORMATION bhi;
1212 if (GetFileInformationByHandle(handle, &bhi))
1213 nlink = bhi.nNumberOfLinks;
1214 CloseHandle(handle);
1217 /* pwbuffer or path will be mapped correctly above */
1219 res = _wstat(pwbuffer, (struct _stat *)sbuf);
1222 res = stat(path, sbuf);
1224 sbuf->st_nlink = nlink;
1227 /* CRT is buggy on sharenames, so make sure it really isn't.
1228 * XXX using GetFileAttributesEx() will enable us to set
1229 * sbuf->st_*time (but note that's not available on the
1230 * Windows of 1995) */
1233 r = GetFileAttributesW(pwbuffer);
1236 r = GetFileAttributesA(path);
1238 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1239 /* sbuf may still contain old garbage since stat() failed */
1240 Zero(sbuf, 1, struct stat);
1241 sbuf->st_mode = S_IFDIR | S_IREAD;
1243 if (!(r & FILE_ATTRIBUTE_READONLY))
1244 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1249 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1250 && (path[2] == '\\' || path[2] == '/'))
1252 /* The drive can be inaccessible, some _stat()s are buggy */
1254 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1255 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1261 if (S_ISDIR(sbuf->st_mode))
1262 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1263 else if (S_ISREG(sbuf->st_mode)) {
1265 if (l >= 4 && path[l-4] == '.') {
1266 const char *e = path + l - 3;
1267 if (strnicmp(e,"exe",3)
1268 && strnicmp(e,"bat",3)
1269 && strnicmp(e,"com",3)
1270 && (IsWin95() || strnicmp(e,"cmd",3)))
1271 sbuf->st_mode &= ~S_IEXEC;
1273 sbuf->st_mode |= S_IEXEC;
1276 sbuf->st_mode &= ~S_IEXEC;
1277 /* Propagate permissions to _group_ and _others_ */
1278 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1279 sbuf->st_mode |= (perms>>3) | (perms>>6);
1286 /* Find the longname of a given path. path is destructively modified.
1287 * It should have space for at least MAX_PATH characters. */
1289 win32_longpath(char *path)
1291 WIN32_FIND_DATA fdata;
1293 char tmpbuf[MAX_PATH+1];
1294 char *tmpstart = tmpbuf;
1301 if (isALPHA(path[0]) && path[1] == ':' &&
1302 (path[2] == '/' || path[2] == '\\'))
1305 *tmpstart++ = path[0];
1309 else if ((path[0] == '/' || path[0] == '\\') &&
1310 (path[1] == '/' || path[1] == '\\'))
1313 *tmpstart++ = path[0];
1314 *tmpstart++ = path[1];
1315 /* copy machine name */
1316 while (*start && *start != '/' && *start != '\\')
1317 *tmpstart++ = *start++;
1319 *tmpstart++ = *start;
1321 /* copy share name */
1322 while (*start && *start != '/' && *start != '\\')
1323 *tmpstart++ = *start++;
1327 if (sep == '/' || sep == '\\')
1331 /* walk up to slash */
1332 while (*start && *start != '/' && *start != '\\')
1335 /* discard doubled slashes */
1336 while (*start && (start[1] == '/' || start[1] == '\\'))
1340 /* stop and find full name of component */
1342 fhand = FindFirstFile(path,&fdata);
1343 if (fhand != INVALID_HANDLE_VALUE) {
1344 strcpy(tmpstart, fdata.cFileName);
1345 tmpstart += strlen(fdata.cFileName);
1353 /* failed a step, just return without side effects */
1354 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1359 strcpy(path,tmpbuf);
1364 win32_getenv(const char *name)
1367 WCHAR wBuffer[MAX_PATH+1];
1369 SV *curitem = Nullsv;
1372 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1373 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1376 needlen = GetEnvironmentVariableA(name,NULL,0);
1378 curitem = sv_2mortal(newSVpvn("", 0));
1382 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1383 needlen = GetEnvironmentVariableW(wBuffer,
1384 (WCHAR*)SvPVX(curitem),
1386 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1387 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1388 acuritem = sv_2mortal(newSVsv(curitem));
1389 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1393 SvGROW(curitem, needlen+1);
1394 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1396 } while (needlen >= SvLEN(curitem));
1397 SvCUR_set(curitem, needlen);
1401 /* allow any environment variables that begin with 'PERL'
1402 to be stored in the registry */
1403 if (strncmp(name, "PERL", 4) == 0)
1404 (void)get_regstr(name, &curitem);
1406 if (curitem && SvCUR(curitem))
1407 return SvPVX(curitem);
1413 win32_putenv(const char *name)
1420 int length, relval = -1;
1424 length = strlen(name)+1;
1425 New(1309,wCuritem,length,WCHAR);
1426 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1427 wVal = wcschr(wCuritem, '=');
1430 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1436 New(1309,curitem,strlen(name)+1,char);
1437 strcpy(curitem, name);
1438 val = strchr(curitem, '=');
1440 /* The sane way to deal with the environment.
1441 * Has these advantages over putenv() & co.:
1442 * * enables us to store a truly empty value in the
1443 * environment (like in UNIX).
1444 * * we don't have to deal with RTL globals, bugs and leaks.
1446 * Why you may want to enable USE_WIN32_RTL_ENV:
1447 * * environ[] and RTL functions will not reflect changes,
1448 * which might be an issue if extensions want to access
1449 * the env. via RTL. This cuts both ways, since RTL will
1450 * not see changes made by extensions that call the Win32
1451 * functions directly, either.
1455 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1465 filetime_to_clock(PFILETIME ft)
1467 __int64 qw = ft->dwHighDateTime;
1469 qw |= ft->dwLowDateTime;
1470 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1475 win32_times(struct tms *timebuf)
1480 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1482 timebuf->tms_utime = filetime_to_clock(&user);
1483 timebuf->tms_stime = filetime_to_clock(&kernel);
1484 timebuf->tms_cutime = 0;
1485 timebuf->tms_cstime = 0;
1488 /* That failed - e.g. Win95 fallback to clock() */
1489 clock_t t = clock();
1490 timebuf->tms_utime = t;
1491 timebuf->tms_stime = 0;
1492 timebuf->tms_cutime = 0;
1493 timebuf->tms_cstime = 0;
1498 /* fix utime() so it works on directories in NT */
1500 filetime_from_time(PFILETIME pFileTime, time_t Time)
1502 struct tm *pTM = localtime(&Time);
1503 SYSTEMTIME SystemTime;
1509 SystemTime.wYear = pTM->tm_year + 1900;
1510 SystemTime.wMonth = pTM->tm_mon + 1;
1511 SystemTime.wDay = pTM->tm_mday;
1512 SystemTime.wHour = pTM->tm_hour;
1513 SystemTime.wMinute = pTM->tm_min;
1514 SystemTime.wSecond = pTM->tm_sec;
1515 SystemTime.wMilliseconds = 0;
1517 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1518 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1522 win32_unlink(const char *filename)
1529 WCHAR wBuffer[MAX_PATH+1];
1532 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1533 pwBuffer = PerlDir_mapW(wBuffer);
1534 attrs = GetFileAttributesW(pwBuffer);
1535 if (attrs == 0xFFFFFFFF)
1537 if (attrs & FILE_ATTRIBUTE_READONLY) {
1538 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1539 ret = _wunlink(pwBuffer);
1541 (void)SetFileAttributesW(pwBuffer, attrs);
1544 ret = _wunlink(pwBuffer);
1547 filename = PerlDir_mapA(filename);
1548 attrs = GetFileAttributesA(filename);
1549 if (attrs == 0xFFFFFFFF)
1551 if (attrs & FILE_ATTRIBUTE_READONLY) {
1552 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1553 ret = unlink(filename);
1555 (void)SetFileAttributesA(filename, attrs);
1558 ret = unlink(filename);
1567 win32_utime(const char *filename, struct utimbuf *times)
1574 struct utimbuf TimeBuffer;
1575 WCHAR wbuffer[MAX_PATH+1];
1580 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1581 pwbuffer = PerlDir_mapW(wbuffer);
1582 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1585 filename = PerlDir_mapA(filename);
1586 rc = utime(filename, times);
1588 /* EACCES: path specifies directory or readonly file */
1589 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1592 if (times == NULL) {
1593 times = &TimeBuffer;
1594 time(×->actime);
1595 times->modtime = times->actime;
1598 /* This will (and should) still fail on readonly files */
1600 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1601 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1602 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1605 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1606 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1607 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1609 if (handle == INVALID_HANDLE_VALUE)
1612 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1613 filetime_from_time(&ftAccess, times->actime) &&
1614 filetime_from_time(&ftWrite, times->modtime) &&
1615 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1620 CloseHandle(handle);
1625 win32_uname(struct utsname *name)
1627 struct hostent *hep;
1628 STRLEN nodemax = sizeof(name->nodename)-1;
1629 OSVERSIONINFO osver;
1631 memset(&osver, 0, sizeof(OSVERSIONINFO));
1632 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1633 if (GetVersionEx(&osver)) {
1635 switch (osver.dwPlatformId) {
1636 case VER_PLATFORM_WIN32_WINDOWS:
1637 strcpy(name->sysname, "Windows");
1639 case VER_PLATFORM_WIN32_NT:
1640 strcpy(name->sysname, "Windows NT");
1642 case VER_PLATFORM_WIN32s:
1643 strcpy(name->sysname, "Win32s");
1646 strcpy(name->sysname, "Win32 Unknown");
1651 sprintf(name->release, "%d.%d",
1652 osver.dwMajorVersion, osver.dwMinorVersion);
1655 sprintf(name->version, "Build %d",
1656 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1657 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1658 if (osver.szCSDVersion[0]) {
1659 char *buf = name->version + strlen(name->version);
1660 sprintf(buf, " (%s)", osver.szCSDVersion);
1664 *name->sysname = '\0';
1665 *name->version = '\0';
1666 *name->release = '\0';
1670 hep = win32_gethostbyname("localhost");
1672 STRLEN len = strlen(hep->h_name);
1673 if (len <= nodemax) {
1674 strcpy(name->nodename, hep->h_name);
1677 strncpy(name->nodename, hep->h_name, nodemax);
1678 name->nodename[nodemax] = '\0';
1683 if (!GetComputerName(name->nodename, &sz))
1684 *name->nodename = '\0';
1687 /* machine (architecture) */
1691 GetSystemInfo(&info);
1693 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1694 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1695 switch (info.u.s.wProcessorArchitecture) {
1697 switch (info.wProcessorArchitecture) {
1699 case PROCESSOR_ARCHITECTURE_INTEL:
1700 arch = "x86"; break;
1701 case PROCESSOR_ARCHITECTURE_MIPS:
1702 arch = "mips"; break;
1703 case PROCESSOR_ARCHITECTURE_ALPHA:
1704 arch = "alpha"; break;
1705 case PROCESSOR_ARCHITECTURE_PPC:
1706 arch = "ppc"; break;
1708 arch = "unknown"; break;
1710 strcpy(name->machine, arch);
1715 /* Timing related stuff */
1718 do_raise(pTHX_ int sig)
1720 if (sig < SIG_SIZE) {
1721 Sighandler_t handler = w32_sighandler[sig];
1722 if (handler == SIG_IGN) {
1725 else if (handler != SIG_DFL) {
1730 /* Choose correct default behaviour */
1746 /* Tell caller to exit thread/process as approriate */
1751 sig_terminate(pTHX_ int sig)
1753 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1754 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1761 win32_async_check(pTHX)
1765 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1766 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1768 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1770 switch(msg.message) {
1773 /* Perhaps some other messages could map to signals ? ... */
1776 /* Treat WM_QUIT like SIGHUP? */
1782 /* We use WM_USER to fake kill() with other signals */
1786 if (do_raise(aTHX_ sig)) {
1787 sig_terminate(aTHX_ sig);
1793 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1795 KillTimer(NULL,w32_timerid);
1798 /* Now fake a call to signal handler */
1799 if (do_raise(aTHX_ 14)) {
1800 sig_terminate(aTHX_ 14);
1805 /* Otherwise do normal Win32 thing - in case it is useful */
1807 TranslateMessage(&msg);
1808 DispatchMessage(&msg);
1815 /* Above or other stuff may have set a signal flag */
1816 if (PL_sig_pending) {
1823 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1825 /* We may need several goes at this - so compute when we stop */
1827 if (timeout != INFINITE) {
1828 ticks = GetTickCount();
1832 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1835 if (result == WAIT_TIMEOUT) {
1836 /* Ran out of time - explicit return of zero to avoid -ve if we
1837 have scheduling issues
1841 if (timeout != INFINITE) {
1842 ticks = GetTickCount();
1844 if (result == WAIT_OBJECT_0 + count) {
1845 /* Message has arrived - check it */
1846 if (win32_async_check(aTHX)) {
1847 /* was one of ours */
1852 /* Not timeout or message - one of handles is ready */
1856 /* compute time left to wait */
1857 ticks = timeout - ticks;
1858 /* If we are past the end say zero */
1859 return (ticks > 0) ? ticks : 0;
1863 win32_internal_wait(int *status, DWORD timeout)
1865 /* XXX this wait emulation only knows about processes
1866 * spawned via win32_spawnvp(P_NOWAIT, ...).
1870 DWORD exitcode, waitcode;
1873 if (w32_num_pseudo_children) {
1874 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1875 timeout, &waitcode);
1876 /* Time out here if there are no other children to wait for. */
1877 if (waitcode == WAIT_TIMEOUT) {
1878 if (!w32_num_children) {
1882 else if (waitcode != WAIT_FAILED) {
1883 if (waitcode >= WAIT_ABANDONED_0
1884 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1885 i = waitcode - WAIT_ABANDONED_0;
1887 i = waitcode - WAIT_OBJECT_0;
1888 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1889 *status = (int)((exitcode & 0xff) << 8);
1890 retval = (int)w32_pseudo_child_pids[i];
1891 remove_dead_pseudo_process(i);
1898 if (!w32_num_children) {
1903 /* if a child exists, wait for it to die */
1904 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1905 if (waitcode == WAIT_TIMEOUT) {
1908 if (waitcode != WAIT_FAILED) {
1909 if (waitcode >= WAIT_ABANDONED_0
1910 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1911 i = waitcode - WAIT_ABANDONED_0;
1913 i = waitcode - WAIT_OBJECT_0;
1914 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1915 *status = (int)((exitcode & 0xff) << 8);
1916 retval = (int)w32_child_pids[i];
1917 remove_dead_process(i);
1923 errno = GetLastError();
1928 win32_waitpid(int pid, int *status, int flags)
1931 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1934 if (pid == -1) /* XXX threadid == 1 ? */
1935 return win32_internal_wait(status, timeout);
1938 child = find_pseudo_pid(-pid);
1940 HANDLE hThread = w32_pseudo_child_handles[child];
1942 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1943 if (waitcode == WAIT_TIMEOUT) {
1946 else if (waitcode == WAIT_OBJECT_0) {
1947 if (GetExitCodeThread(hThread, &waitcode)) {
1948 *status = (int)((waitcode & 0xff) << 8);
1949 retval = (int)w32_pseudo_child_pids[child];
1950 remove_dead_pseudo_process(child);
1957 else if (IsWin95()) {
1966 child = find_pid(pid);
1968 hProcess = w32_child_handles[child];
1969 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1970 if (waitcode == WAIT_TIMEOUT) {
1973 else if (waitcode == WAIT_OBJECT_0) {
1974 if (GetExitCodeProcess(hProcess, &waitcode)) {
1975 *status = (int)((waitcode & 0xff) << 8);
1976 retval = (int)w32_child_pids[child];
1977 remove_dead_process(child);
1986 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1987 (IsWin95() ? -pid : pid));
1989 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1990 if (waitcode == WAIT_TIMEOUT) {
1993 else if (waitcode == WAIT_OBJECT_0) {
1994 if (GetExitCodeProcess(hProcess, &waitcode)) {
1995 *status = (int)((waitcode & 0xff) << 8);
1996 CloseHandle(hProcess);
2000 CloseHandle(hProcess);
2006 return retval >= 0 ? pid : retval;
2010 win32_wait(int *status)
2012 return win32_internal_wait(status, INFINITE);
2015 DllExport unsigned int
2016 win32_sleep(unsigned int t)
2019 /* Win32 times are in ms so *1000 in and /1000 out */
2020 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2023 DllExport unsigned int
2024 win32_alarm(unsigned int sec)
2027 * the 'obvious' implentation is SetTimer() with a callback
2028 * which does whatever receiving SIGALRM would do
2029 * we cannot use SIGALRM even via raise() as it is not
2030 * one of the supported codes in <signal.h>
2034 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2038 KillTimer(NULL,w32_timerid);
2045 #ifdef HAVE_DES_FCRYPT
2046 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2050 win32_crypt(const char *txt, const char *salt)
2053 #ifdef HAVE_DES_FCRYPT
2054 return des_fcrypt(txt, salt, w32_crypt_buffer);
2056 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2061 #ifdef USE_FIXED_OSFHANDLE
2063 #define FOPEN 0x01 /* file handle open */
2064 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2065 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2066 #define FDEV 0x40 /* file handle refers to device */
2067 #define FTEXT 0x80 /* file handle is in text mode */
2070 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2073 * This function allocates a free C Runtime file handle and associates
2074 * it with the Win32 HANDLE specified by the first parameter. This is a
2075 * temperary fix for WIN95's brain damage GetFileType() error on socket
2076 * we just bypass that call for socket
2078 * This works with MSVC++ 4.0+ or GCC/Mingw32
2081 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2082 * int flags - flags to associate with C Runtime file handle.
2085 * returns index of entry in fh, if successful
2086 * return -1, if no free entry is found
2090 *******************************************************************************/
2093 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2094 * this lets sockets work on Win9X with GCC and should fix the problems
2099 /* create an ioinfo entry, kill its handle, and steal the entry */
2104 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2105 int fh = _open_osfhandle((long)hF, 0);
2109 EnterCriticalSection(&(_pioinfo(fh)->lock));
2114 my_open_osfhandle(long osfhandle, int flags)
2117 char fileflags; /* _osfile flags */
2119 /* copy relevant flags from second parameter */
2122 if (flags & O_APPEND)
2123 fileflags |= FAPPEND;
2128 if (flags & O_NOINHERIT)
2129 fileflags |= FNOINHERIT;
2131 /* attempt to allocate a C Runtime file handle */
2132 if ((fh = _alloc_osfhnd()) == -1) {
2133 errno = EMFILE; /* too many open files */
2134 _doserrno = 0L; /* not an OS error */
2135 return -1; /* return error to caller */
2138 /* the file is open. now, set the info in _osfhnd array */
2139 _set_osfhnd(fh, osfhandle);
2141 fileflags |= FOPEN; /* mark as open */
2143 _osfile(fh) = fileflags; /* set osfile entry */
2144 LeaveCriticalSection(&_pioinfo(fh)->lock);
2146 return fh; /* return handle */
2149 #endif /* USE_FIXED_OSFHANDLE */
2151 /* simulate flock by locking a range on the file */
2153 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2154 #define LK_LEN 0xffff0000
2157 win32_flock(int fd, int oper)
2165 Perl_croak_nocontext("flock() unimplemented on this platform");
2168 fh = (HANDLE)_get_osfhandle(fd);
2169 memset(&o, 0, sizeof(o));
2172 case LOCK_SH: /* shared lock */
2173 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2175 case LOCK_EX: /* exclusive lock */
2176 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2178 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2179 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2181 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2182 LK_ERR(LockFileEx(fh,
2183 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2184 0, LK_LEN, 0, &o),i);
2186 case LOCK_UN: /* unlock lock */
2187 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2189 default: /* unknown */
2200 * redirected io subsystem for all XS modules
2213 return (&(_environ));
2216 /* the rest are the remapped stdio routines */
2236 win32_ferror(FILE *fp)
2238 return (ferror(fp));
2243 win32_feof(FILE *fp)
2249 * Since the errors returned by the socket error function
2250 * WSAGetLastError() are not known by the library routine strerror
2251 * we have to roll our own.
2255 win32_strerror(int e)
2257 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2258 extern int sys_nerr;
2262 if (e < 0 || e > sys_nerr) {
2267 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2268 w32_strerror_buffer,
2269 sizeof(w32_strerror_buffer), NULL) == 0)
2270 strcpy(w32_strerror_buffer, "Unknown Error");
2272 return w32_strerror_buffer;
2278 win32_str_os_error(void *sv, DWORD dwErr)
2282 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2283 |FORMAT_MESSAGE_IGNORE_INSERTS
2284 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2285 dwErr, 0, (char *)&sMsg, 1, NULL);
2286 /* strip trailing whitespace and period */
2289 --dwLen; /* dwLen doesn't include trailing null */
2290 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2291 if ('.' != sMsg[dwLen])
2296 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2298 dwLen = sprintf(sMsg,
2299 "Unknown error #0x%lX (lookup 0x%lX)",
2300 dwErr, GetLastError());
2304 sv_setpvn((SV*)sv, sMsg, dwLen);
2310 win32_fprintf(FILE *fp, const char *format, ...)
2313 va_start(marker, format); /* Initialize variable arguments. */
2315 return (vfprintf(fp, format, marker));
2319 win32_printf(const char *format, ...)
2322 va_start(marker, format); /* Initialize variable arguments. */
2324 return (vprintf(format, marker));
2328 win32_vfprintf(FILE *fp, const char *format, va_list args)
2330 return (vfprintf(fp, format, args));
2334 win32_vprintf(const char *format, va_list args)
2336 return (vprintf(format, args));
2340 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2342 return fread(buf, size, count, fp);
2346 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2348 return fwrite(buf, size, count, fp);
2351 #define MODE_SIZE 10
2354 win32_fopen(const char *filename, const char *mode)
2357 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2363 if (stricmp(filename, "/dev/null")==0)
2367 A2WHELPER(mode, wMode, sizeof(wMode));
2368 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2369 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2372 f = fopen(PerlDir_mapA(filename), mode);
2373 /* avoid buffering headaches for child processes */
2374 if (f && *mode == 'a')
2375 win32_fseek(f, 0, SEEK_END);
2379 #ifndef USE_SOCKETS_AS_HANDLES
2381 #define fdopen my_fdopen
2385 win32_fdopen(int handle, const char *mode)
2388 WCHAR wMode[MODE_SIZE];
2391 A2WHELPER(mode, wMode, sizeof(wMode));
2392 f = _wfdopen(handle, wMode);
2395 f = fdopen(handle, (char *) mode);
2396 /* avoid buffering headaches for child processes */
2397 if (f && *mode == 'a')
2398 win32_fseek(f, 0, SEEK_END);
2403 win32_freopen(const char *path, const char *mode, FILE *stream)
2406 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2407 if (stricmp(path, "/dev/null")==0)
2411 A2WHELPER(mode, wMode, sizeof(wMode));
2412 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2413 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2415 return freopen(PerlDir_mapA(path), mode, stream);
2419 win32_fclose(FILE *pf)
2421 return my_fclose(pf); /* defined in win32sck.c */
2425 win32_fputs(const char *s,FILE *pf)
2427 return fputs(s, pf);
2431 win32_fputc(int c,FILE *pf)
2437 win32_ungetc(int c,FILE *pf)
2439 return ungetc(c,pf);
2443 win32_getc(FILE *pf)
2449 win32_fileno(FILE *pf)
2455 win32_clearerr(FILE *pf)
2462 win32_fflush(FILE *pf)
2468 win32_ftell(FILE *pf)
2474 win32_fseek(FILE *pf,long offset,int origin)
2476 return fseek(pf, offset, origin);
2480 win32_fgetpos(FILE *pf,fpos_t *p)
2482 return fgetpos(pf, p);
2486 win32_fsetpos(FILE *pf,const fpos_t *p)
2488 return fsetpos(pf, p);
2492 win32_rewind(FILE *pf)
2502 char prefix[MAX_PATH+1];
2503 char filename[MAX_PATH+1];
2504 DWORD len = GetTempPath(MAX_PATH, prefix);
2505 if (len && len < MAX_PATH) {
2506 if (GetTempFileName(prefix, "plx", 0, filename)) {
2507 HANDLE fh = CreateFile(filename,
2508 DELETE | GENERIC_READ | GENERIC_WRITE,
2512 FILE_ATTRIBUTE_NORMAL
2513 | FILE_FLAG_DELETE_ON_CLOSE,
2515 if (fh != INVALID_HANDLE_VALUE) {
2516 int fd = win32_open_osfhandle((long)fh, 0);
2518 DEBUG_p(PerlIO_printf(Perl_debug_log,
2519 "Created tmpfile=%s\n",filename));
2520 return fdopen(fd, "w+b");
2536 win32_fstat(int fd,struct stat *sbufptr)
2539 /* A file designated by filehandle is not shown as accessible
2540 * for write operations, probably because it is opened for reading.
2543 int rc = fstat(fd,sbufptr);
2544 BY_HANDLE_FILE_INFORMATION bhfi;
2545 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2546 sbufptr->st_mode &= 0xFE00;
2547 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2548 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2550 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2551 + ((S_IREAD|S_IWRITE) >> 6));
2555 return my_fstat(fd,sbufptr);
2560 win32_pipe(int *pfd, unsigned int size, int mode)
2562 return _pipe(pfd, size, mode);
2566 win32_popenlist(const char *mode, IV narg, SV **args)
2569 Perl_croak(aTHX_ "List form of pipe open not implemented");
2574 * a popen() clone that respects PERL5SHELL
2576 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2580 win32_popen(const char *command, const char *mode)
2582 #ifdef USE_RTL_POPEN
2583 return _popen(command, mode);
2591 /* establish which ends read and write */
2592 if (strchr(mode,'w')) {
2593 stdfd = 0; /* stdin */
2597 else if (strchr(mode,'r')) {
2598 stdfd = 1; /* stdout */
2605 /* set the correct mode */
2606 if (strchr(mode,'b'))
2608 else if (strchr(mode,'t'))
2611 ourmode = _fmode & (O_TEXT | O_BINARY);
2613 /* the child doesn't inherit handles */
2614 ourmode |= O_NOINHERIT;
2616 if (win32_pipe( p, 512, ourmode) == -1)
2619 /* save current stdfd */
2620 if ((oldfd = win32_dup(stdfd)) == -1)
2623 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2624 /* stdfd will be inherited by the child */
2625 if (win32_dup2(p[child], stdfd) == -1)
2628 /* close the child end in parent */
2629 win32_close(p[child]);
2631 /* start the child */
2634 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2637 /* revert stdfd to whatever it was before */
2638 if (win32_dup2(oldfd, stdfd) == -1)
2641 /* close saved handle */
2645 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2648 /* set process id so that it can be returned by perl's open() */
2649 PL_forkprocess = childpid;
2652 /* we have an fd, return a file stream */
2653 return (PerlIO_fdopen(p[parent], (char *)mode));
2656 /* we don't need to check for errors here */
2660 win32_dup2(oldfd, stdfd);
2665 #endif /* USE_RTL_POPEN */
2673 win32_pclose(PerlIO *pf)
2675 #ifdef USE_RTL_POPEN
2679 int childpid, status;
2683 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2686 childpid = SvIVX(sv);
2703 if (win32_waitpid(childpid, &status, 0) == -1)
2708 #endif /* USE_RTL_POPEN */
2714 LPCWSTR lpExistingFileName,
2715 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2718 WCHAR wFullName[MAX_PATH+1];
2719 LPVOID lpContext = NULL;
2720 WIN32_STREAM_ID StreamId;
2721 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2726 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2727 BOOL, BOOL, LPVOID*) =
2728 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2729 BOOL, BOOL, LPVOID*))
2730 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2731 if (pfnBackupWrite == NULL)
2734 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2737 dwLen = (dwLen+1)*sizeof(WCHAR);
2739 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2740 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2741 NULL, OPEN_EXISTING, 0, NULL);
2742 if (handle == INVALID_HANDLE_VALUE)
2745 StreamId.dwStreamId = BACKUP_LINK;
2746 StreamId.dwStreamAttributes = 0;
2747 StreamId.dwStreamNameSize = 0;
2748 #if defined(__BORLANDC__) \
2749 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2750 StreamId.Size.u.HighPart = 0;
2751 StreamId.Size.u.LowPart = dwLen;
2753 StreamId.Size.HighPart = 0;
2754 StreamId.Size.LowPart = dwLen;
2757 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2758 FALSE, FALSE, &lpContext);
2760 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2761 FALSE, FALSE, &lpContext);
2762 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2765 CloseHandle(handle);
2770 win32_link(const char *oldname, const char *newname)
2773 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2774 WCHAR wOldName[MAX_PATH+1];
2775 WCHAR wNewName[MAX_PATH+1];
2778 Perl_croak(aTHX_ PL_no_func, "link");
2780 pfnCreateHardLinkW =
2781 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2782 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2783 if (pfnCreateHardLinkW == NULL)
2784 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2786 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2787 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2788 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2789 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2793 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2798 win32_rename(const char *oname, const char *newname)
2800 WCHAR wOldName[MAX_PATH+1];
2801 WCHAR wNewName[MAX_PATH+1];
2802 char szOldName[MAX_PATH+1];
2803 char szNewName[MAX_PATH+1];
2807 /* XXX despite what the documentation says about MoveFileEx(),
2808 * it doesn't work under Windows95!
2811 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2813 A2WHELPER(oname, wOldName, sizeof(wOldName));
2814 A2WHELPER(newname, wNewName, sizeof(wNewName));
2815 if (wcsicmp(wNewName, wOldName))
2816 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2817 wcscpy(wOldName, PerlDir_mapW(wOldName));
2818 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2821 if (stricmp(newname, oname))
2822 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2823 strcpy(szOldName, PerlDir_mapA(oname));
2824 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2827 DWORD err = GetLastError();
2829 case ERROR_BAD_NET_NAME:
2830 case ERROR_BAD_NETPATH:
2831 case ERROR_BAD_PATHNAME:
2832 case ERROR_FILE_NOT_FOUND:
2833 case ERROR_FILENAME_EXCED_RANGE:
2834 case ERROR_INVALID_DRIVE:
2835 case ERROR_NO_MORE_FILES:
2836 case ERROR_PATH_NOT_FOUND:
2849 char szTmpName[MAX_PATH+1];
2850 char dname[MAX_PATH+1];
2851 char *endname = Nullch;
2853 DWORD from_attr, to_attr;
2855 strcpy(szOldName, PerlDir_mapA(oname));
2856 strcpy(szNewName, PerlDir_mapA(newname));
2858 /* if oname doesn't exist, do nothing */
2859 from_attr = GetFileAttributes(szOldName);
2860 if (from_attr == 0xFFFFFFFF) {
2865 /* if newname exists, rename it to a temporary name so that we
2866 * don't delete it in case oname happens to be the same file
2867 * (but perhaps accessed via a different path)
2869 to_attr = GetFileAttributes(szNewName);
2870 if (to_attr != 0xFFFFFFFF) {
2871 /* if newname is a directory, we fail
2872 * XXX could overcome this with yet more convoluted logic */
2873 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2877 tmplen = strlen(szNewName);
2878 strcpy(szTmpName,szNewName);
2879 endname = szTmpName+tmplen;
2880 for (; endname > szTmpName ; --endname) {
2881 if (*endname == '/' || *endname == '\\') {
2886 if (endname > szTmpName)
2887 endname = strcpy(dname,szTmpName);
2891 /* get a temporary filename in same directory
2892 * XXX is this really the best we can do? */
2893 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2897 DeleteFile(szTmpName);
2899 retval = rename(szNewName, szTmpName);
2906 /* rename oname to newname */
2907 retval = rename(szOldName, szNewName);
2909 /* if we created a temporary file before ... */
2910 if (endname != Nullch) {
2911 /* ...and rename succeeded, delete temporary file/directory */
2913 DeleteFile(szTmpName);
2914 /* else restore it to what it was */
2916 (void)rename(szTmpName, szNewName);
2923 win32_setmode(int fd, int mode)
2925 return setmode(fd, mode);
2929 win32_lseek(int fd, long offset, int origin)
2931 return lseek(fd, offset, origin);
2941 win32_open(const char *path, int flag, ...)
2946 WCHAR wBuffer[MAX_PATH+1];
2949 pmode = va_arg(ap, int);
2952 if (stricmp(path, "/dev/null")==0)
2956 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2957 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2959 return open(PerlDir_mapA(path), flag, pmode);
2962 /* close() that understands socket */
2963 extern int my_close(int); /* in win32sck.c */
2968 return my_close(fd);
2984 win32_dup2(int fd1,int fd2)
2986 return dup2(fd1,fd2);
2989 #ifdef PERL_MSVCRT_READFIX
2991 #define LF 10 /* line feed */
2992 #define CR 13 /* carriage return */
2993 #define CTRLZ 26 /* ctrl-z means eof for text */
2994 #define FOPEN 0x01 /* file handle open */
2995 #define FEOFLAG 0x02 /* end of file has been encountered */
2996 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2997 #define FPIPE 0x08 /* file handle refers to a pipe */
2998 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2999 #define FDEV 0x40 /* file handle refers to device */
3000 #define FTEXT 0x80 /* file handle is in text mode */
3001 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3004 _fixed_read(int fh, void *buf, unsigned cnt)
3006 int bytes_read; /* number of bytes read */
3007 char *buffer; /* buffer to read to */
3008 int os_read; /* bytes read on OS call */
3009 char *p, *q; /* pointers into buffer */
3010 char peekchr; /* peek-ahead character */
3011 ULONG filepos; /* file position after seek */
3012 ULONG dosretval; /* o.s. return value */
3014 /* validate handle */
3015 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3016 !(_osfile(fh) & FOPEN))
3018 /* out of range -- return error */
3020 _doserrno = 0; /* not o.s. error */
3025 * If lockinitflag is FALSE, assume fd is device
3026 * lockinitflag is set to TRUE by open.
3028 if (_pioinfo(fh)->lockinitflag)
3029 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3031 bytes_read = 0; /* nothing read yet */
3032 buffer = (char*)buf;
3034 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3035 /* nothing to read or at EOF, so return 0 read */
3039 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3040 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3042 *buffer++ = _pipech(fh);
3045 _pipech(fh) = LF; /* mark as empty */
3050 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3052 /* ReadFile has reported an error. recognize two special cases.
3054 * 1. map ERROR_ACCESS_DENIED to EBADF
3056 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3057 * means the handle is a read-handle on a pipe for which
3058 * all write-handles have been closed and all data has been
3061 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3062 /* wrong read/write mode should return EBADF, not EACCES */
3064 _doserrno = dosretval;
3068 else if (dosretval == ERROR_BROKEN_PIPE) {
3078 bytes_read += os_read; /* update bytes read */
3080 if (_osfile(fh) & FTEXT) {
3081 /* now must translate CR-LFs to LFs in the buffer */
3083 /* set CRLF flag to indicate LF at beginning of buffer */
3084 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3085 /* _osfile(fh) |= FCRLF; */
3087 /* _osfile(fh) &= ~FCRLF; */
3089 _osfile(fh) &= ~FCRLF;
3091 /* convert chars in the buffer: p is src, q is dest */
3093 while (p < (char *)buf + bytes_read) {
3095 /* if fh is not a device, set ctrl-z flag */
3096 if (!(_osfile(fh) & FDEV))
3097 _osfile(fh) |= FEOFLAG;
3098 break; /* stop translating */
3103 /* *p is CR, so must check next char for LF */
3104 if (p < (char *)buf + bytes_read - 1) {
3107 *q++ = LF; /* convert CR-LF to LF */
3110 *q++ = *p++; /* store char normally */
3113 /* This is the hard part. We found a CR at end of
3114 buffer. We must peek ahead to see if next char
3119 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3120 (LPDWORD)&os_read, NULL))
3121 dosretval = GetLastError();
3123 if (dosretval != 0 || os_read == 0) {
3124 /* couldn't read ahead, store CR */
3128 /* peekchr now has the extra character -- we now
3129 have several possibilities:
3130 1. disk file and char is not LF; just seek back
3132 2. disk file and char is LF; store LF, don't seek back
3133 3. pipe/device and char is LF; store LF.
3134 4. pipe/device and char isn't LF, store CR and
3135 put char in pipe lookahead buffer. */
3136 if (_osfile(fh) & (FDEV|FPIPE)) {
3137 /* non-seekable device */
3142 _pipech(fh) = peekchr;
3147 if (peekchr == LF) {
3148 /* nothing read yet; must make some
3151 /* turn on this flag for tell routine */
3152 _osfile(fh) |= FCRLF;
3155 HANDLE osHandle; /* o.s. handle value */
3157 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3159 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3160 dosretval = GetLastError();
3171 /* we now change bytes_read to reflect the true number of chars
3173 bytes_read = q - (char *)buf;
3177 if (_pioinfo(fh)->lockinitflag)
3178 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3183 #endif /* PERL_MSVCRT_READFIX */
3186 win32_read(int fd, void *buf, unsigned int cnt)
3188 #ifdef PERL_MSVCRT_READFIX
3189 return _fixed_read(fd, buf, cnt);
3191 return read(fd, buf, cnt);
3196 win32_write(int fd, const void *buf, unsigned int cnt)
3198 return write(fd, buf, cnt);
3202 win32_mkdir(const char *dir, int mode)
3206 WCHAR wBuffer[MAX_PATH+1];
3207 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3208 return _wmkdir(PerlDir_mapW(wBuffer));
3210 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3214 win32_rmdir(const char *dir)
3218 WCHAR wBuffer[MAX_PATH+1];
3219 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3220 return _wrmdir(PerlDir_mapW(wBuffer));
3222 return rmdir(PerlDir_mapA(dir));
3226 win32_chdir(const char *dir)
3234 WCHAR wBuffer[MAX_PATH+1];
3235 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3236 return _wchdir(wBuffer);
3242 win32_access(const char *path, int mode)
3246 WCHAR wBuffer[MAX_PATH+1];
3247 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3248 return _waccess(PerlDir_mapW(wBuffer), mode);
3250 return access(PerlDir_mapA(path), mode);
3254 win32_chmod(const char *path, int mode)
3258 WCHAR wBuffer[MAX_PATH+1];
3259 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3260 return _wchmod(PerlDir_mapW(wBuffer), mode);
3262 return chmod(PerlDir_mapA(path), mode);
3267 create_command_line(char *cname, STRLEN clen, const char * const *args)
3274 bool bat_file = FALSE;
3275 bool cmd_shell = FALSE;
3276 bool dumb_shell = FALSE;
3277 bool extra_quotes = FALSE;
3278 bool quote_next = FALSE;
3281 cname = (char*)args[0];
3283 /* The NT cmd.exe shell has the following peculiarity that needs to be
3284 * worked around. It strips a leading and trailing dquote when any
3285 * of the following is true:
3286 * 1. the /S switch was used
3287 * 2. there are more than two dquotes
3288 * 3. there is a special character from this set: &<>()@^|
3289 * 4. no whitespace characters within the two dquotes
3290 * 5. string between two dquotes isn't an executable file
3291 * To work around this, we always add a leading and trailing dquote
3292 * to the string, if the first argument is either "cmd.exe" or "cmd",
3293 * and there were at least two or more arguments passed to cmd.exe
3294 * (not including switches).
3295 * XXX the above rules (from "cmd /?") don't seem to be applied
3296 * always, making for the convolutions below :-(
3300 clen = strlen(cname);
3303 && (stricmp(&cname[clen-4], ".bat") == 0
3304 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3310 char *exe = strrchr(cname, '/');
3311 char *exe2 = strrchr(cname, '\\');
3318 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3322 else if (stricmp(exe, "command.com") == 0
3323 || stricmp(exe, "command") == 0)
3330 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3331 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3332 STRLEN curlen = strlen(arg);
3333 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3334 len += 2; /* assume quoting needed (worst case) */
3336 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3338 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3341 New(1310, cmd, len, char);
3346 extra_quotes = TRUE;
3349 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3351 STRLEN curlen = strlen(arg);
3353 /* we want to protect empty arguments and ones with spaces with
3354 * dquotes, but only if they aren't already there */
3359 else if (quote_next) {
3360 /* see if it really is multiple arguments pretending to
3361 * be one and force a set of quotes around it */
3362 if (*find_next_space(arg))
3365 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3367 while (i < curlen) {
3368 if (isSPACE(arg[i])) {
3371 else if (arg[i] == '"') {
3394 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3396 /* is there a next argument? */
3397 if (args[index+1]) {
3398 /* are there two or more next arguments? */
3399 if (args[index+2]) {
3401 extra_quotes = TRUE;
3404 /* single argument, force quoting if it has spaces */
3420 qualified_path(const char *cmd)
3424 char *fullcmd, *curfullcmd;
3430 fullcmd = (char*)cmd;
3432 if (*fullcmd == '/' || *fullcmd == '\\')
3439 pathstr = PerlEnv_getenv("PATH");
3440 New(0, fullcmd, MAX_PATH+1, char);
3441 curfullcmd = fullcmd;
3446 /* start by appending the name to the current prefix */
3447 strcpy(curfullcmd, cmd);
3448 curfullcmd += cmdlen;
3450 /* if it doesn't end with '.', or has no extension, try adding
3451 * a trailing .exe first */
3452 if (cmd[cmdlen-1] != '.'
3453 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3455 strcpy(curfullcmd, ".exe");
3456 res = GetFileAttributes(fullcmd);
3457 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3462 /* that failed, try the bare name */
3463 res = GetFileAttributes(fullcmd);
3464 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3467 /* quit if no other path exists, or if cmd already has path */
3468 if (!pathstr || !*pathstr || has_slash)
3471 /* skip leading semis */
3472 while (*pathstr == ';')
3475 /* build a new prefix from scratch */
3476 curfullcmd = fullcmd;
3477 while (*pathstr && *pathstr != ';') {
3478 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3479 pathstr++; /* skip initial '"' */
3480 while (*pathstr && *pathstr != '"') {
3481 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3482 *curfullcmd++ = *pathstr;
3486 pathstr++; /* skip trailing '"' */
3489 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3490 *curfullcmd++ = *pathstr;
3495 pathstr++; /* skip trailing semi */
3496 if (curfullcmd > fullcmd /* append a dir separator */
3497 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3499 *curfullcmd++ = '\\';
3507 /* The following are just place holders.
3508 * Some hosts may provide and environment that the OS is
3509 * not tracking, therefore, these host must provide that
3510 * environment and the current directory to CreateProcess
3514 win32_get_childenv(void)
3520 win32_free_childenv(void* d)
3525 win32_clearenv(void)
3527 char *envv = GetEnvironmentStrings();
3531 char *end = strchr(cur,'=');
3532 if (end && end != cur) {
3534 SetEnvironmentVariable(cur, NULL);
3536 cur = end + strlen(end+1)+2;
3538 else if ((len = strlen(cur)))
3541 FreeEnvironmentStrings(envv);
3545 win32_get_childdir(void)
3549 char szfilename[(MAX_PATH+1)*2];
3551 WCHAR wfilename[MAX_PATH+1];
3552 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3553 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3556 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3559 New(0, ptr, strlen(szfilename)+1, char);
3560 strcpy(ptr, szfilename);
3565 win32_free_childdir(char* d)
3572 /* XXX this needs to be made more compatible with the spawnvp()
3573 * provided by the various RTLs. In particular, searching for
3574 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3575 * This doesn't significantly affect perl itself, because we
3576 * always invoke things using PERL5SHELL if a direct attempt to
3577 * spawn the executable fails.
3579 * XXX splitting and rejoining the commandline between do_aspawn()
3580 * and win32_spawnvp() could also be avoided.
3584 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3586 #ifdef USE_RTL_SPAWNVP
3587 return spawnvp(mode, cmdname, (char * const *)argv);
3594 STARTUPINFO StartupInfo;
3595 PROCESS_INFORMATION ProcessInformation;
3598 char *fullcmd = Nullch;
3599 char *cname = (char *)cmdname;
3603 clen = strlen(cname);
3604 /* if command name contains dquotes, must remove them */
3605 if (strchr(cname, '"')) {
3607 New(0,cname,clen+1,char);
3620 cmd = create_command_line(cname, clen, argv);
3622 env = PerlEnv_get_childenv();
3623 dir = PerlEnv_get_childdir();
3626 case P_NOWAIT: /* asynch + remember result */
3627 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3632 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3635 create |= CREATE_NEW_PROCESS_GROUP;
3638 case P_WAIT: /* synchronous execution */
3640 default: /* invalid mode */
3645 memset(&StartupInfo,0,sizeof(StartupInfo));
3646 StartupInfo.cb = sizeof(StartupInfo);
3647 memset(&tbl,0,sizeof(tbl));
3648 PerlEnv_get_child_IO(&tbl);
3649 StartupInfo.dwFlags = tbl.dwFlags;
3650 StartupInfo.dwX = tbl.dwX;
3651 StartupInfo.dwY = tbl.dwY;
3652 StartupInfo.dwXSize = tbl.dwXSize;
3653 StartupInfo.dwYSize = tbl.dwYSize;
3654 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3655 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3656 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3657 StartupInfo.wShowWindow = tbl.wShowWindow;
3658 StartupInfo.hStdInput = tbl.childStdIn;
3659 StartupInfo.hStdOutput = tbl.childStdOut;
3660 StartupInfo.hStdError = tbl.childStdErr;
3661 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3662 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3663 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3665 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3668 create |= CREATE_NEW_CONSOLE;
3671 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3674 if (!CreateProcess(cname, /* search PATH to find executable */
3675 cmd, /* executable, and its arguments */
3676 NULL, /* process attributes */
3677 NULL, /* thread attributes */
3678 TRUE, /* inherit handles */
3679 create, /* creation flags */
3680 (LPVOID)env, /* inherit environment */
3681 dir, /* inherit cwd */
3683 &ProcessInformation))
3685 /* initial NULL argument to CreateProcess() does a PATH
3686 * search, but it always first looks in the directory
3687 * where the current process was started, which behavior
3688 * is undesirable for backward compatibility. So we
3689 * jump through our own hoops by picking out the path
3690 * we really want it to use. */
3692 fullcmd = qualified_path(cname);
3694 if (cname != cmdname)
3697 DEBUG_p(PerlIO_printf(Perl_debug_log,
3698 "Retrying [%s] with same args\n",
3708 if (mode == P_NOWAIT) {
3709 /* asynchronous spawn -- store handle, return PID */
3710 ret = (int)ProcessInformation.dwProcessId;
3711 if (IsWin95() && ret < 0)
3714 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3715 w32_child_pids[w32_num_children] = (DWORD)ret;
3720 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3721 /* FIXME: if msgwait returned due to message perhaps forward the
3722 "signal" to the process
3724 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3726 CloseHandle(ProcessInformation.hProcess);
3729 CloseHandle(ProcessInformation.hThread);
3732 PerlEnv_free_childenv(env);
3733 PerlEnv_free_childdir(dir);
3735 if (cname != cmdname)
3742 win32_execv(const char *cmdname, const char *const *argv)
3746 /* if this is a pseudo-forked child, we just want to spawn
3747 * the new program, and return */
3749 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3751 return execv(cmdname, (char *const *)argv);
3755 win32_execvp(const char *cmdname, const char *const *argv)
3759 /* if this is a pseudo-forked child, we just want to spawn
3760 * the new program, and return */
3761 if (w32_pseudo_id) {
3762 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3771 return execvp(cmdname, (char *const *)argv);
3775 win32_perror(const char *str)
3781 win32_setbuf(FILE *pf, char *buf)
3787 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3789 return setvbuf(pf, buf, type, size);
3793 win32_flushall(void)
3799 win32_fcloseall(void)
3805 win32_fgets(char *s, int n, FILE *pf)
3807 return fgets(s, n, pf);
3817 win32_fgetc(FILE *pf)
3823 win32_putc(int c, FILE *pf)
3829 win32_puts(const char *s)
3841 win32_putchar(int c)
3848 #ifndef USE_PERL_SBRK
3850 static char *committed = NULL; /* XXX threadead */
3851 static char *base = NULL; /* XXX threadead */
3852 static char *reserved = NULL; /* XXX threadead */
3853 static char *brk = NULL; /* XXX threadead */
3854 static DWORD pagesize = 0; /* XXX threadead */
3855 static DWORD allocsize = 0; /* XXX threadead */
3863 GetSystemInfo(&info);
3864 /* Pretend page size is larger so we don't perpetually
3865 * call the OS to commit just one page ...
3867 pagesize = info.dwPageSize << 3;
3868 allocsize = info.dwAllocationGranularity;
3870 /* This scheme fails eventually if request for contiguous
3871 * block is denied so reserve big blocks - this is only
3872 * address space not memory ...
3874 if (brk+need >= reserved)
3876 DWORD size = 64*1024*1024;
3878 if (committed && reserved && committed < reserved)
3880 /* Commit last of previous chunk cannot span allocations */
3881 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3883 committed = reserved;
3885 /* Reserve some (more) space
3886 * Note this is a little sneaky, 1st call passes NULL as reserved
3887 * so lets system choose where we start, subsequent calls pass
3888 * the old end address so ask for a contiguous block
3890 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3893 reserved = addr+size;
3908 if (brk > committed)
3910 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3911 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3926 win32_malloc(size_t size)
3928 return malloc(size);
3932 win32_calloc(size_t numitems, size_t size)
3934 return calloc(numitems,size);
3938 win32_realloc(void *block, size_t size)
3940 return realloc(block,size);
3944 win32_free(void *block)
3951 win32_open_osfhandle(long handle, int flags)
3953 #ifdef USE_FIXED_OSFHANDLE
3955 return my_open_osfhandle(handle, flags);
3957 return _open_osfhandle(handle, flags);
3961 win32_get_osfhandle(int fd)
3963 return _get_osfhandle(fd);
3967 win32_dynaload(const char* filename)
3971 char buf[MAX_PATH+1];
3974 /* LoadLibrary() doesn't recognize forward slashes correctly,
3975 * so turn 'em back. */
3976 first = strchr(filename, '/');
3978 STRLEN len = strlen(filename);
3979 if (len <= MAX_PATH) {
3980 strcpy(buf, filename);
3981 filename = &buf[first - filename];
3983 if (*filename == '/')
3984 *(char*)filename = '\\';
3991 WCHAR wfilename[MAX_PATH+1];
3992 A2WHELPER(filename, wfilename, sizeof(wfilename));
3993 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3996 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4009 /* Make the host for current directory */
4010 char* ptr = PerlEnv_get_childdir();
4013 * then it worked, set PV valid,
4014 * else return 'undef'
4017 SV *sv = sv_newmortal();
4019 PerlEnv_free_childdir(ptr);
4021 #ifndef INCOMPLETE_TAINTS
4038 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4039 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4046 XS(w32_GetNextAvailDrive)
4050 char root[] = "_:\\";
4055 if (GetDriveType(root) == 1) {
4064 XS(w32_GetLastError)
4068 XSRETURN_IV(GetLastError());
4072 XS(w32_SetLastError)
4076 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4077 SetLastError(SvIV(ST(0)));
4085 char *name = w32_getlogin_buffer;
4086 DWORD size = sizeof(w32_getlogin_buffer);
4088 if (GetUserName(name,&size)) {
4089 /* size includes NULL */
4090 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4100 char name[MAX_COMPUTERNAME_LENGTH+1];
4101 DWORD size = sizeof(name);
4103 if (GetComputerName(name,&size)) {
4104 /* size does NOT include NULL :-( */
4105 ST(0) = sv_2mortal(newSVpvn(name,size));
4116 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4117 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4118 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4122 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4123 GetProcAddress(hNetApi32, "NetApiBufferFree");
4124 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4125 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4128 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4129 /* this way is more reliable, in case user has a local account. */
4131 DWORD dnamelen = sizeof(dname);
4133 DWORD wki100_platform_id;
4134 LPWSTR wki100_computername;
4135 LPWSTR wki100_langroup;
4136 DWORD wki100_ver_major;
4137 DWORD wki100_ver_minor;
4139 /* NERR_Success *is* 0*/
4140 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4141 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4142 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4143 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4146 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4147 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4149 pfnNetApiBufferFree(pwi);
4150 FreeLibrary(hNetApi32);
4153 FreeLibrary(hNetApi32);
4156 /* Win95 doesn't have NetWksta*(), so do it the old way */
4158 DWORD size = sizeof(name);
4160 FreeLibrary(hNetApi32);
4161 if (GetUserName(name,&size)) {
4162 char sid[ONE_K_BUFSIZE];
4163 DWORD sidlen = sizeof(sid);
4165 DWORD dnamelen = sizeof(dname);
4167 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4168 dname, &dnamelen, &snu)) {
4169 XSRETURN_PV(dname); /* all that for this */
4181 DWORD flags, filecomplen;
4182 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4183 &flags, fsname, sizeof(fsname))) {
4184 if (GIMME_V == G_ARRAY) {
4185 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4186 XPUSHs(sv_2mortal(newSViv(flags)));
4187 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4192 XSRETURN_PV(fsname);
4198 XS(w32_GetOSVersion)
4201 OSVERSIONINFOA osver;
4204 OSVERSIONINFOW osverw;
4205 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4206 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4207 if (!GetVersionExW(&osverw)) {
4210 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4211 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4212 osver.dwMajorVersion = osverw.dwMajorVersion;
4213 osver.dwMinorVersion = osverw.dwMinorVersion;
4214 osver.dwBuildNumber = osverw.dwBuildNumber;
4215 osver.dwPlatformId = osverw.dwPlatformId;
4218 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4219 if (!GetVersionExA(&osver)) {
4222 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4224 XPUSHs(newSViv(osver.dwMajorVersion));
4225 XPUSHs(newSViv(osver.dwMinorVersion));
4226 XPUSHs(newSViv(osver.dwBuildNumber));
4227 XPUSHs(newSViv(osver.dwPlatformId));
4236 XSRETURN_IV(IsWinNT());
4244 XSRETURN_IV(IsWin95());
4248 XS(w32_FormatMessage)
4252 char msgbuf[ONE_K_BUFSIZE];
4255 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4258 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4259 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4260 &source, SvIV(ST(0)), 0,
4261 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4263 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4264 XSRETURN_PV(msgbuf);
4268 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4269 &source, SvIV(ST(0)), 0,
4270 msgbuf, sizeof(msgbuf)-1, NULL))
4271 XSRETURN_PV(msgbuf);
4284 PROCESS_INFORMATION stProcInfo;
4285 STARTUPINFO stStartInfo;
4286 BOOL bSuccess = FALSE;
4289 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4291 cmd = SvPV_nolen(ST(0));
4292 args = SvPV_nolen(ST(1));
4294 env = PerlEnv_get_childenv();
4295 dir = PerlEnv_get_childdir();
4297 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4298 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4299 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4300 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4303 cmd, /* Image path */
4304 args, /* Arguments for command line */
4305 NULL, /* Default process security */
4306 NULL, /* Default thread security */
4307 FALSE, /* Must be TRUE to use std handles */
4308 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4309 env, /* Inherit our environment block */
4310 dir, /* Inherit our currrent directory */
4311 &stStartInfo, /* -> Startup info */
4312 &stProcInfo)) /* <- Process info (if OK) */
4314 int pid = (int)stProcInfo.dwProcessId;
4315 if (IsWin95() && pid < 0)
4317 sv_setiv(ST(2), pid);
4318 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4321 PerlEnv_free_childenv(env);
4322 PerlEnv_free_childdir(dir);
4323 XSRETURN_IV(bSuccess);
4327 XS(w32_GetTickCount)
4330 DWORD msec = GetTickCount();
4338 XS(w32_GetShortPathName)
4345 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4347 shortpath = sv_mortalcopy(ST(0));
4348 SvUPGRADE(shortpath, SVt_PV);
4349 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4352 /* src == target is allowed */
4354 len = GetShortPathName(SvPVX(shortpath),
4357 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4359 SvCUR_set(shortpath,len);
4367 XS(w32_GetFullPathName)
4376 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4379 fullpath = sv_mortalcopy(filename);
4380 SvUPGRADE(fullpath, SVt_PV);
4381 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4385 len = GetFullPathName(SvPVX(filename),
4389 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4391 if (GIMME_V == G_ARRAY) {
4393 XST_mPV(1,filepart);
4394 len = filepart - SvPVX(fullpath);
4397 SvCUR_set(fullpath,len);
4405 XS(w32_GetLongPathName)
4409 char tmpbuf[MAX_PATH+1];
4414 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4417 pathstr = SvPV(path,len);
4418 strcpy(tmpbuf, pathstr);
4419 pathstr = win32_longpath(tmpbuf);
4421 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4432 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4443 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4445 WCHAR wSourceFile[MAX_PATH+1];
4446 WCHAR wDestFile[MAX_PATH+1];
4447 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4448 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4449 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4450 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4453 char szSourceFile[MAX_PATH+1];
4454 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4455 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4464 Perl_init_os_extras(void)
4467 char *file = __FILE__;
4470 /* these names are Activeware compatible */
4471 newXS("Win32::GetCwd", w32_GetCwd, file);
4472 newXS("Win32::SetCwd", w32_SetCwd, file);
4473 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4474 newXS("Win32::GetLastError", w32_GetLastError, file);
4475 newXS("Win32::SetLastError", w32_SetLastError, file);
4476 newXS("Win32::LoginName", w32_LoginName, file);
4477 newXS("Win32::NodeName", w32_NodeName, file);
4478 newXS("Win32::DomainName", w32_DomainName, file);
4479 newXS("Win32::FsType", w32_FsType, file);
4480 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4481 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4482 newXS("Win32::IsWin95", w32_IsWin95, file);
4483 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4484 newXS("Win32::Spawn", w32_Spawn, file);
4485 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4486 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4487 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4488 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4489 newXS("Win32::CopyFile", w32_CopyFile, file);
4490 newXS("Win32::Sleep", w32_Sleep, file);
4492 /* XXX Bloat Alert! The following Activeware preloads really
4493 * ought to be part of Win32::Sys::*, so they're not included
4496 /* LookupAccountName
4498 * InitiateSystemShutdown
4499 * AbortSystemShutdown
4500 * ExpandEnvrironmentStrings
4505 win32_signal_context(void)
4509 my_perl = PL_curinterp;
4510 PERL_SET_THX(my_perl);
4516 win32_ctrlhandler(DWORD dwCtrlType)
4518 dTHXa(PERL_GET_SIG_CONTEXT);
4523 switch(dwCtrlType) {
4524 case CTRL_CLOSE_EVENT:
4525 /* A signal that the system sends to all processes attached to a console when
4526 the user closes the console (either by choosing the Close command from the
4527 console window's System menu, or by choosing the End Task command from the
4530 if (do_raise(aTHX_ 1)) /* SIGHUP */
4531 sig_terminate(aTHX_ 1);
4535 /* A CTRL+c signal was received */
4536 if (do_raise(aTHX_ SIGINT))
4537 sig_terminate(aTHX_ SIGINT);
4540 case CTRL_BREAK_EVENT:
4541 /* A CTRL+BREAK signal was received */
4542 if (do_raise(aTHX_ SIGBREAK))
4543 sig_terminate(aTHX_ SIGBREAK);
4546 case CTRL_LOGOFF_EVENT:
4547 /* A signal that the system sends to all console processes when a user is logging
4548 off. This signal does not indicate which user is logging off, so no
4549 assumptions can be made.
4552 case CTRL_SHUTDOWN_EVENT:
4553 /* A signal that the system sends to all console processes when the system is
4556 if (do_raise(aTHX_ SIGTERM))
4557 sig_terminate(aTHX_ SIGTERM);
4567 Perl_win32_init(int *argcp, char ***argvp)
4569 /* Disable floating point errors, Perl will trap the ones we
4570 * care about. VC++ RTL defaults to switching these off
4571 * already, but the Borland RTL doesn't. Since we don't
4572 * want to be at the vendor's whim on the default, we set
4573 * it explicitly here.
4575 #if !defined(_ALPHA_) && !defined(__GNUC__)
4576 _control87(MCW_EM, MCW_EM);
4582 win32_get_child_IO(child_IO_table* ptbl)
4584 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4585 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4586 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4590 win32_signal(int sig, Sighandler_t subcode)
4593 if (sig < SIG_SIZE) {
4594 int save_errno = errno;
4595 Sighandler_t result = signal(sig, subcode);
4596 if (result == SIG_ERR) {
4597 result = w32_sighandler[sig];
4600 w32_sighandler[sig] = subcode;
4610 #ifdef HAVE_INTERP_INTERN
4614 win32_csighandler(int sig)
4617 dTHXa(PERL_GET_SIG_CONTEXT);
4618 Perl_warn(aTHX_ "Got signal %d",sig);
4624 Perl_sys_intern_init(pTHX)
4627 w32_perlshell_tokens = Nullch;
4628 w32_perlshell_vec = (char**)NULL;
4629 w32_perlshell_items = 0;
4630 w32_fdpid = newAV();
4631 New(1313, w32_children, 1, child_tab);
4632 w32_num_children = 0;
4633 # ifdef USE_ITHREADS
4635 New(1313, w32_pseudo_children, 1, child_tab);
4636 w32_num_pseudo_children = 0;
4638 w32_init_socktype = 0;
4641 for (i=0; i < SIG_SIZE; i++) {
4642 w32_sighandler[i] = SIG_DFL;
4644 if (my_perl == PL_curinterp) {
4645 /* Force C runtime signal stuff to set its console handler */
4646 signal(SIGINT,&win32_csighandler);
4647 signal(SIGBREAK,&win32_csighandler);
4648 /* Push our handler on top */
4649 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4654 Perl_sys_intern_clear(pTHX)
4656 Safefree(w32_perlshell_tokens);
4657 Safefree(w32_perlshell_vec);
4658 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4659 Safefree(w32_children);
4661 KillTimer(NULL,w32_timerid);
4664 if (my_perl == PL_curinterp) {
4665 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4667 # ifdef USE_ITHREADS
4668 Safefree(w32_pseudo_children);
4672 # ifdef USE_ITHREADS
4675 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4677 dst->perlshell_tokens = Nullch;
4678 dst->perlshell_vec = (char**)NULL;
4679 dst->perlshell_items = 0;
4680 dst->fdpid = newAV();
4681 Newz(1313, dst->children, 1, child_tab);
4683 Newz(1313, dst->pseudo_children, 1, child_tab);
4684 dst->thr_intern.Winit_socktype = 0;
4686 dst->poll_count = 0;
4687 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4689 # endif /* USE_ITHREADS */
4690 #endif /* HAVE_INTERP_INTERN */
4693 win32_free_argvw(pTHX_ void *ptr)
4695 char** argv = (char**)ptr;
4703 win32_argv2utf8(int argc, char** argv)
4708 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4709 if (lpwStr && argc) {
4711 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4712 Newz(0, psz, length, char);
4713 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4716 call_atexit(win32_free_argvw, argv);
4718 GlobalFree((HGLOBAL)lpwStr);