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_ packWARN(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_ packWARN(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
1098 * message queue. In Win9X the pids are negative already. */
1099 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1100 /* It might be us ... */
1107 else if (IsWin95()) {
1115 child = find_pid(pid);
1117 hProcess = w32_child_handles[child];
1120 /* "Does process exist?" use of kill */
1123 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1126 default: /* For now be backwards compatible with perl5.6 */
1128 if (TerminateProcess(hProcess, sig)) {
1129 remove_dead_process(child);
1137 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1138 (IsWin95() ? -pid : pid));
1142 /* "Does process exist?" use of kill */
1145 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1148 default: /* For now be backwards compatible with perl5.6 */
1150 if (TerminateProcess(hProcess, sig)) {
1151 CloseHandle(hProcess);
1163 win32_stat(const char *path, struct stat *sbuf)
1166 char buffer[MAX_PATH+1];
1167 int l = strlen(path);
1169 WCHAR wbuffer[MAX_PATH+1];
1175 switch(path[l - 1]) {
1176 /* FindFirstFile() and stat() are buggy with a trailing
1177 * backslash, so change it to a forward slash :-( */
1179 strncpy(buffer, path, l-1);
1180 buffer[l - 1] = '/';
1184 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1186 if (l == 2 && isALPHA(path[0])) {
1187 buffer[0] = path[0];
1198 /* We *must* open & close the file once; otherwise file attribute changes */
1199 /* might not yet have propagated to "other" hard links of the same file. */
1200 /* This also gives us an opportunity to determine the number of links. */
1202 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1203 pwbuffer = PerlDir_mapW(wbuffer);
1204 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1207 path = PerlDir_mapA(path);
1209 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1211 if (handle != INVALID_HANDLE_VALUE) {
1212 BY_HANDLE_FILE_INFORMATION bhi;
1213 if (GetFileInformationByHandle(handle, &bhi))
1214 nlink = bhi.nNumberOfLinks;
1215 CloseHandle(handle);
1218 /* pwbuffer or path will be mapped correctly above */
1220 res = _wstat(pwbuffer, (struct _stat *)sbuf);
1223 res = stat(path, sbuf);
1225 sbuf->st_nlink = nlink;
1228 /* CRT is buggy on sharenames, so make sure it really isn't.
1229 * XXX using GetFileAttributesEx() will enable us to set
1230 * sbuf->st_*time (but note that's not available on the
1231 * Windows of 1995) */
1234 r = GetFileAttributesW(pwbuffer);
1237 r = GetFileAttributesA(path);
1239 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1240 /* sbuf may still contain old garbage since stat() failed */
1241 Zero(sbuf, 1, struct stat);
1242 sbuf->st_mode = S_IFDIR | S_IREAD;
1244 if (!(r & FILE_ATTRIBUTE_READONLY))
1245 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1250 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1251 && (path[2] == '\\' || path[2] == '/'))
1253 /* The drive can be inaccessible, some _stat()s are buggy */
1255 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1256 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1262 if (S_ISDIR(sbuf->st_mode))
1263 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1264 else if (S_ISREG(sbuf->st_mode)) {
1266 if (l >= 4 && path[l-4] == '.') {
1267 const char *e = path + l - 3;
1268 if (strnicmp(e,"exe",3)
1269 && strnicmp(e,"bat",3)
1270 && strnicmp(e,"com",3)
1271 && (IsWin95() || strnicmp(e,"cmd",3)))
1272 sbuf->st_mode &= ~S_IEXEC;
1274 sbuf->st_mode |= S_IEXEC;
1277 sbuf->st_mode &= ~S_IEXEC;
1278 /* Propagate permissions to _group_ and _others_ */
1279 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1280 sbuf->st_mode |= (perms>>3) | (perms>>6);
1287 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1288 #define SKIP_SLASHES(s) \
1290 while (*(s) && isSLASH(*(s))) \
1293 #define COPY_NONSLASHES(d,s) \
1295 while (*(s) && !isSLASH(*(s))) \
1299 /* Find the longname of a given path. path is destructively modified.
1300 * It should have space for at least MAX_PATH characters. */
1302 win32_longpath(char *path)
1304 WIN32_FIND_DATA fdata;
1306 char tmpbuf[MAX_PATH+1];
1307 char *tmpstart = tmpbuf;
1314 if (isALPHA(path[0]) && path[1] == ':') {
1316 *tmpstart++ = path[0];
1320 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1322 *tmpstart++ = path[0];
1323 *tmpstart++ = path[1];
1324 SKIP_SLASHES(start);
1325 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1327 *tmpstart++ = *start++;
1328 SKIP_SLASHES(start);
1329 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1334 /* copy initial slash, if any */
1335 if (isSLASH(*start)) {
1336 *tmpstart++ = *start++;
1338 SKIP_SLASHES(start);
1341 /* FindFirstFile() expands "." and "..", so we need to pass
1342 * those through unmolested */
1344 && (!start[1] || isSLASH(start[1])
1345 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1347 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1352 /* if this is the end, bust outta here */
1356 /* now we're at a non-slash; walk up to next slash */
1357 while (*start && !isSLASH(*start))
1360 /* stop and find full name of component */
1363 fhand = FindFirstFile(path,&fdata);
1365 if (fhand != INVALID_HANDLE_VALUE) {
1366 STRLEN len = strlen(fdata.cFileName);
1367 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1368 strcpy(tmpstart, fdata.cFileName);
1379 /* failed a step, just return without side effects */
1380 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1385 strcpy(path,tmpbuf);
1390 win32_getenv(const char *name)
1393 WCHAR wBuffer[MAX_PATH+1];
1395 SV *curitem = Nullsv;
1398 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1399 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1402 needlen = GetEnvironmentVariableA(name,NULL,0);
1404 curitem = sv_2mortal(newSVpvn("", 0));
1408 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1409 needlen = GetEnvironmentVariableW(wBuffer,
1410 (WCHAR*)SvPVX(curitem),
1412 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1413 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1414 acuritem = sv_2mortal(newSVsv(curitem));
1415 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1419 SvGROW(curitem, needlen+1);
1420 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1422 } while (needlen >= SvLEN(curitem));
1423 SvCUR_set(curitem, needlen);
1427 /* allow any environment variables that begin with 'PERL'
1428 to be stored in the registry */
1429 if (strncmp(name, "PERL", 4) == 0)
1430 (void)get_regstr(name, &curitem);
1432 if (curitem && SvCUR(curitem))
1433 return SvPVX(curitem);
1439 win32_putenv(const char *name)
1446 int length, relval = -1;
1450 length = strlen(name)+1;
1451 New(1309,wCuritem,length,WCHAR);
1452 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1453 wVal = wcschr(wCuritem, '=');
1456 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1462 New(1309,curitem,strlen(name)+1,char);
1463 strcpy(curitem, name);
1464 val = strchr(curitem, '=');
1466 /* The sane way to deal with the environment.
1467 * Has these advantages over putenv() & co.:
1468 * * enables us to store a truly empty value in the
1469 * environment (like in UNIX).
1470 * * we don't have to deal with RTL globals, bugs and leaks.
1472 * Why you may want to enable USE_WIN32_RTL_ENV:
1473 * * environ[] and RTL functions will not reflect changes,
1474 * which might be an issue if extensions want to access
1475 * the env. via RTL. This cuts both ways, since RTL will
1476 * not see changes made by extensions that call the Win32
1477 * functions directly, either.
1481 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1491 filetime_to_clock(PFILETIME ft)
1493 __int64 qw = ft->dwHighDateTime;
1495 qw |= ft->dwLowDateTime;
1496 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1501 win32_times(struct tms *timebuf)
1506 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1508 timebuf->tms_utime = filetime_to_clock(&user);
1509 timebuf->tms_stime = filetime_to_clock(&kernel);
1510 timebuf->tms_cutime = 0;
1511 timebuf->tms_cstime = 0;
1514 /* That failed - e.g. Win95 fallback to clock() */
1515 clock_t t = clock();
1516 timebuf->tms_utime = t;
1517 timebuf->tms_stime = 0;
1518 timebuf->tms_cutime = 0;
1519 timebuf->tms_cstime = 0;
1524 /* fix utime() so it works on directories in NT */
1526 filetime_from_time(PFILETIME pFileTime, time_t Time)
1528 struct tm *pTM = localtime(&Time);
1529 SYSTEMTIME SystemTime;
1535 SystemTime.wYear = pTM->tm_year + 1900;
1536 SystemTime.wMonth = pTM->tm_mon + 1;
1537 SystemTime.wDay = pTM->tm_mday;
1538 SystemTime.wHour = pTM->tm_hour;
1539 SystemTime.wMinute = pTM->tm_min;
1540 SystemTime.wSecond = pTM->tm_sec;
1541 SystemTime.wMilliseconds = 0;
1543 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1544 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1548 win32_unlink(const char *filename)
1555 WCHAR wBuffer[MAX_PATH+1];
1558 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1559 pwBuffer = PerlDir_mapW(wBuffer);
1560 attrs = GetFileAttributesW(pwBuffer);
1561 if (attrs == 0xFFFFFFFF)
1563 if (attrs & FILE_ATTRIBUTE_READONLY) {
1564 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1565 ret = _wunlink(pwBuffer);
1567 (void)SetFileAttributesW(pwBuffer, attrs);
1570 ret = _wunlink(pwBuffer);
1573 filename = PerlDir_mapA(filename);
1574 attrs = GetFileAttributesA(filename);
1575 if (attrs == 0xFFFFFFFF)
1577 if (attrs & FILE_ATTRIBUTE_READONLY) {
1578 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1579 ret = unlink(filename);
1581 (void)SetFileAttributesA(filename, attrs);
1584 ret = unlink(filename);
1593 win32_utime(const char *filename, struct utimbuf *times)
1600 struct utimbuf TimeBuffer;
1601 WCHAR wbuffer[MAX_PATH+1];
1606 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1607 pwbuffer = PerlDir_mapW(wbuffer);
1608 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1611 filename = PerlDir_mapA(filename);
1612 rc = utime(filename, times);
1614 /* EACCES: path specifies directory or readonly file */
1615 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1618 if (times == NULL) {
1619 times = &TimeBuffer;
1620 time(×->actime);
1621 times->modtime = times->actime;
1624 /* This will (and should) still fail on readonly files */
1626 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1627 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1628 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1631 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1632 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1633 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1635 if (handle == INVALID_HANDLE_VALUE)
1638 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1639 filetime_from_time(&ftAccess, times->actime) &&
1640 filetime_from_time(&ftWrite, times->modtime) &&
1641 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1646 CloseHandle(handle);
1651 win32_uname(struct utsname *name)
1653 struct hostent *hep;
1654 STRLEN nodemax = sizeof(name->nodename)-1;
1655 OSVERSIONINFO osver;
1657 memset(&osver, 0, sizeof(OSVERSIONINFO));
1658 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1659 if (GetVersionEx(&osver)) {
1661 switch (osver.dwPlatformId) {
1662 case VER_PLATFORM_WIN32_WINDOWS:
1663 strcpy(name->sysname, "Windows");
1665 case VER_PLATFORM_WIN32_NT:
1666 strcpy(name->sysname, "Windows NT");
1668 case VER_PLATFORM_WIN32s:
1669 strcpy(name->sysname, "Win32s");
1672 strcpy(name->sysname, "Win32 Unknown");
1677 sprintf(name->release, "%d.%d",
1678 osver.dwMajorVersion, osver.dwMinorVersion);
1681 sprintf(name->version, "Build %d",
1682 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1683 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1684 if (osver.szCSDVersion[0]) {
1685 char *buf = name->version + strlen(name->version);
1686 sprintf(buf, " (%s)", osver.szCSDVersion);
1690 *name->sysname = '\0';
1691 *name->version = '\0';
1692 *name->release = '\0';
1696 hep = win32_gethostbyname("localhost");
1698 STRLEN len = strlen(hep->h_name);
1699 if (len <= nodemax) {
1700 strcpy(name->nodename, hep->h_name);
1703 strncpy(name->nodename, hep->h_name, nodemax);
1704 name->nodename[nodemax] = '\0';
1709 if (!GetComputerName(name->nodename, &sz))
1710 *name->nodename = '\0';
1713 /* machine (architecture) */
1717 GetSystemInfo(&info);
1719 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1720 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1721 switch (info.u.s.wProcessorArchitecture) {
1723 switch (info.wProcessorArchitecture) {
1725 case PROCESSOR_ARCHITECTURE_INTEL:
1726 arch = "x86"; break;
1727 case PROCESSOR_ARCHITECTURE_MIPS:
1728 arch = "mips"; break;
1729 case PROCESSOR_ARCHITECTURE_ALPHA:
1730 arch = "alpha"; break;
1731 case PROCESSOR_ARCHITECTURE_PPC:
1732 arch = "ppc"; break;
1734 arch = "unknown"; break;
1736 strcpy(name->machine, arch);
1741 /* Timing related stuff */
1744 do_raise(pTHX_ int sig)
1746 if (sig < SIG_SIZE) {
1747 Sighandler_t handler = w32_sighandler[sig];
1748 if (handler == SIG_IGN) {
1751 else if (handler != SIG_DFL) {
1756 /* Choose correct default behaviour */
1772 /* Tell caller to exit thread/process as approriate */
1777 sig_terminate(pTHX_ int sig)
1779 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1780 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1787 win32_async_check(pTHX)
1791 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1792 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1794 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1796 switch(msg.message) {
1799 /* Perhaps some other messages could map to signals ? ... */
1802 /* Treat WM_QUIT like SIGHUP? */
1808 /* We use WM_USER to fake kill() with other signals */
1812 if (do_raise(aTHX_ sig)) {
1813 sig_terminate(aTHX_ sig);
1819 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1821 KillTimer(NULL,w32_timerid);
1824 /* Now fake a call to signal handler */
1825 if (do_raise(aTHX_ 14)) {
1826 sig_terminate(aTHX_ 14);
1831 /* Otherwise do normal Win32 thing - in case it is useful */
1833 TranslateMessage(&msg);
1834 DispatchMessage(&msg);
1841 /* Above or other stuff may have set a signal flag */
1842 if (PL_sig_pending) {
1849 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1851 /* We may need several goes at this - so compute when we stop */
1853 if (timeout != INFINITE) {
1854 ticks = GetTickCount();
1858 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1861 if (result == WAIT_TIMEOUT) {
1862 /* Ran out of time - explicit return of zero to avoid -ve if we
1863 have scheduling issues
1867 if (timeout != INFINITE) {
1868 ticks = GetTickCount();
1870 if (result == WAIT_OBJECT_0 + count) {
1871 /* Message has arrived - check it */
1872 if (win32_async_check(aTHX)) {
1873 /* was one of ours */
1878 /* Not timeout or message - one of handles is ready */
1882 /* compute time left to wait */
1883 ticks = timeout - ticks;
1884 /* If we are past the end say zero */
1885 return (ticks > 0) ? ticks : 0;
1889 win32_internal_wait(int *status, DWORD timeout)
1891 /* XXX this wait emulation only knows about processes
1892 * spawned via win32_spawnvp(P_NOWAIT, ...).
1896 DWORD exitcode, waitcode;
1899 if (w32_num_pseudo_children) {
1900 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1901 timeout, &waitcode);
1902 /* Time out here if there are no other children to wait for. */
1903 if (waitcode == WAIT_TIMEOUT) {
1904 if (!w32_num_children) {
1908 else if (waitcode != WAIT_FAILED) {
1909 if (waitcode >= WAIT_ABANDONED_0
1910 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1911 i = waitcode - WAIT_ABANDONED_0;
1913 i = waitcode - WAIT_OBJECT_0;
1914 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1915 *status = (int)((exitcode & 0xff) << 8);
1916 retval = (int)w32_pseudo_child_pids[i];
1917 remove_dead_pseudo_process(i);
1924 if (!w32_num_children) {
1929 /* if a child exists, wait for it to die */
1930 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1931 if (waitcode == WAIT_TIMEOUT) {
1934 if (waitcode != WAIT_FAILED) {
1935 if (waitcode >= WAIT_ABANDONED_0
1936 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1937 i = waitcode - WAIT_ABANDONED_0;
1939 i = waitcode - WAIT_OBJECT_0;
1940 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1941 *status = (int)((exitcode & 0xff) << 8);
1942 retval = (int)w32_child_pids[i];
1943 remove_dead_process(i);
1949 errno = GetLastError();
1954 win32_waitpid(int pid, int *status, int flags)
1957 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1960 if (pid == -1) /* XXX threadid == 1 ? */
1961 return win32_internal_wait(status, timeout);
1964 child = find_pseudo_pid(-pid);
1966 HANDLE hThread = w32_pseudo_child_handles[child];
1968 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1969 if (waitcode == WAIT_TIMEOUT) {
1972 else if (waitcode == WAIT_OBJECT_0) {
1973 if (GetExitCodeThread(hThread, &waitcode)) {
1974 *status = (int)((waitcode & 0xff) << 8);
1975 retval = (int)w32_pseudo_child_pids[child];
1976 remove_dead_pseudo_process(child);
1983 else if (IsWin95()) {
1992 child = find_pid(pid);
1994 hProcess = w32_child_handles[child];
1995 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1996 if (waitcode == WAIT_TIMEOUT) {
1999 else if (waitcode == WAIT_OBJECT_0) {
2000 if (GetExitCodeProcess(hProcess, &waitcode)) {
2001 *status = (int)((waitcode & 0xff) << 8);
2002 retval = (int)w32_child_pids[child];
2003 remove_dead_process(child);
2012 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2013 (IsWin95() ? -pid : pid));
2015 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2016 if (waitcode == WAIT_TIMEOUT) {
2019 else if (waitcode == WAIT_OBJECT_0) {
2020 if (GetExitCodeProcess(hProcess, &waitcode)) {
2021 *status = (int)((waitcode & 0xff) << 8);
2022 CloseHandle(hProcess);
2026 CloseHandle(hProcess);
2032 return retval >= 0 ? pid : retval;
2036 win32_wait(int *status)
2038 return win32_internal_wait(status, INFINITE);
2041 DllExport unsigned int
2042 win32_sleep(unsigned int t)
2045 /* Win32 times are in ms so *1000 in and /1000 out */
2046 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2049 DllExport unsigned int
2050 win32_alarm(unsigned int sec)
2053 * the 'obvious' implentation is SetTimer() with a callback
2054 * which does whatever receiving SIGALRM would do
2055 * we cannot use SIGALRM even via raise() as it is not
2056 * one of the supported codes in <signal.h>
2060 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2064 KillTimer(NULL,w32_timerid);
2071 #ifdef HAVE_DES_FCRYPT
2072 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2076 win32_crypt(const char *txt, const char *salt)
2079 #ifdef HAVE_DES_FCRYPT
2080 return des_fcrypt(txt, salt, w32_crypt_buffer);
2082 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2087 #ifdef USE_FIXED_OSFHANDLE
2089 #define FOPEN 0x01 /* file handle open */
2090 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2091 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2092 #define FDEV 0x40 /* file handle refers to device */
2093 #define FTEXT 0x80 /* file handle is in text mode */
2096 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2099 * This function allocates a free C Runtime file handle and associates
2100 * it with the Win32 HANDLE specified by the first parameter. This is a
2101 * temperary fix for WIN95's brain damage GetFileType() error on socket
2102 * we just bypass that call for socket
2104 * This works with MSVC++ 4.0+ or GCC/Mingw32
2107 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2108 * int flags - flags to associate with C Runtime file handle.
2111 * returns index of entry in fh, if successful
2112 * return -1, if no free entry is found
2116 *******************************************************************************/
2119 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2120 * this lets sockets work on Win9X with GCC and should fix the problems
2125 /* create an ioinfo entry, kill its handle, and steal the entry */
2130 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2131 int fh = _open_osfhandle((long)hF, 0);
2135 EnterCriticalSection(&(_pioinfo(fh)->lock));
2140 my_open_osfhandle(long osfhandle, int flags)
2143 char fileflags; /* _osfile flags */
2145 /* copy relevant flags from second parameter */
2148 if (flags & O_APPEND)
2149 fileflags |= FAPPEND;
2154 if (flags & O_NOINHERIT)
2155 fileflags |= FNOINHERIT;
2157 /* attempt to allocate a C Runtime file handle */
2158 if ((fh = _alloc_osfhnd()) == -1) {
2159 errno = EMFILE; /* too many open files */
2160 _doserrno = 0L; /* not an OS error */
2161 return -1; /* return error to caller */
2164 /* the file is open. now, set the info in _osfhnd array */
2165 _set_osfhnd(fh, osfhandle);
2167 fileflags |= FOPEN; /* mark as open */
2169 _osfile(fh) = fileflags; /* set osfile entry */
2170 LeaveCriticalSection(&_pioinfo(fh)->lock);
2172 return fh; /* return handle */
2175 #endif /* USE_FIXED_OSFHANDLE */
2177 /* simulate flock by locking a range on the file */
2179 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2180 #define LK_LEN 0xffff0000
2183 win32_flock(int fd, int oper)
2191 Perl_croak_nocontext("flock() unimplemented on this platform");
2194 fh = (HANDLE)_get_osfhandle(fd);
2195 memset(&o, 0, sizeof(o));
2198 case LOCK_SH: /* shared lock */
2199 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2201 case LOCK_EX: /* exclusive lock */
2202 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2204 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2205 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2207 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2208 LK_ERR(LockFileEx(fh,
2209 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2210 0, LK_LEN, 0, &o),i);
2212 case LOCK_UN: /* unlock lock */
2213 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2215 default: /* unknown */
2226 * redirected io subsystem for all XS modules
2239 return (&(_environ));
2242 /* the rest are the remapped stdio routines */
2262 win32_ferror(FILE *fp)
2264 return (ferror(fp));
2269 win32_feof(FILE *fp)
2275 * Since the errors returned by the socket error function
2276 * WSAGetLastError() are not known by the library routine strerror
2277 * we have to roll our own.
2281 win32_strerror(int e)
2283 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2284 extern int sys_nerr;
2288 if (e < 0 || e > sys_nerr) {
2293 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2294 w32_strerror_buffer,
2295 sizeof(w32_strerror_buffer), NULL) == 0)
2296 strcpy(w32_strerror_buffer, "Unknown Error");
2298 return w32_strerror_buffer;
2304 win32_str_os_error(void *sv, DWORD dwErr)
2308 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2309 |FORMAT_MESSAGE_IGNORE_INSERTS
2310 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2311 dwErr, 0, (char *)&sMsg, 1, NULL);
2312 /* strip trailing whitespace and period */
2315 --dwLen; /* dwLen doesn't include trailing null */
2316 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2317 if ('.' != sMsg[dwLen])
2322 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2324 dwLen = sprintf(sMsg,
2325 "Unknown error #0x%lX (lookup 0x%lX)",
2326 dwErr, GetLastError());
2330 sv_setpvn((SV*)sv, sMsg, dwLen);
2336 win32_fprintf(FILE *fp, const char *format, ...)
2339 va_start(marker, format); /* Initialize variable arguments. */
2341 return (vfprintf(fp, format, marker));
2345 win32_printf(const char *format, ...)
2348 va_start(marker, format); /* Initialize variable arguments. */
2350 return (vprintf(format, marker));
2354 win32_vfprintf(FILE *fp, const char *format, va_list args)
2356 return (vfprintf(fp, format, args));
2360 win32_vprintf(const char *format, va_list args)
2362 return (vprintf(format, args));
2366 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2368 return fread(buf, size, count, fp);
2372 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2374 return fwrite(buf, size, count, fp);
2377 #define MODE_SIZE 10
2380 win32_fopen(const char *filename, const char *mode)
2383 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2389 if (stricmp(filename, "/dev/null")==0)
2393 A2WHELPER(mode, wMode, sizeof(wMode));
2394 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2395 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2398 f = fopen(PerlDir_mapA(filename), mode);
2399 /* avoid buffering headaches for child processes */
2400 if (f && *mode == 'a')
2401 win32_fseek(f, 0, SEEK_END);
2405 #ifndef USE_SOCKETS_AS_HANDLES
2407 #define fdopen my_fdopen
2411 win32_fdopen(int handle, const char *mode)
2414 WCHAR wMode[MODE_SIZE];
2417 A2WHELPER(mode, wMode, sizeof(wMode));
2418 f = _wfdopen(handle, wMode);
2421 f = fdopen(handle, (char *) mode);
2422 /* avoid buffering headaches for child processes */
2423 if (f && *mode == 'a')
2424 win32_fseek(f, 0, SEEK_END);
2429 win32_freopen(const char *path, const char *mode, FILE *stream)
2432 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2433 if (stricmp(path, "/dev/null")==0)
2437 A2WHELPER(mode, wMode, sizeof(wMode));
2438 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2439 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2441 return freopen(PerlDir_mapA(path), mode, stream);
2445 win32_fclose(FILE *pf)
2447 return my_fclose(pf); /* defined in win32sck.c */
2451 win32_fputs(const char *s,FILE *pf)
2453 return fputs(s, pf);
2457 win32_fputc(int c,FILE *pf)
2463 win32_ungetc(int c,FILE *pf)
2465 return ungetc(c,pf);
2469 win32_getc(FILE *pf)
2475 win32_fileno(FILE *pf)
2481 win32_clearerr(FILE *pf)
2488 win32_fflush(FILE *pf)
2494 win32_ftell(FILE *pf)
2500 win32_fseek(FILE *pf,long offset,int origin)
2502 return fseek(pf, offset, origin);
2506 win32_fgetpos(FILE *pf,fpos_t *p)
2508 return fgetpos(pf, p);
2512 win32_fsetpos(FILE *pf,const fpos_t *p)
2514 return fsetpos(pf, p);
2518 win32_rewind(FILE *pf)
2528 char prefix[MAX_PATH+1];
2529 char filename[MAX_PATH+1];
2530 DWORD len = GetTempPath(MAX_PATH, prefix);
2531 if (len && len < MAX_PATH) {
2532 if (GetTempFileName(prefix, "plx", 0, filename)) {
2533 HANDLE fh = CreateFile(filename,
2534 DELETE | GENERIC_READ | GENERIC_WRITE,
2538 FILE_ATTRIBUTE_NORMAL
2539 | FILE_FLAG_DELETE_ON_CLOSE,
2541 if (fh != INVALID_HANDLE_VALUE) {
2542 int fd = win32_open_osfhandle((long)fh, 0);
2544 #if defined(__BORLANDC__)
2545 setmode(fd,O_BINARY);
2547 DEBUG_p(PerlIO_printf(Perl_debug_log,
2548 "Created tmpfile=%s\n",filename));
2549 return fdopen(fd, "w+b");
2565 win32_fstat(int fd,struct stat *sbufptr)
2568 /* A file designated by filehandle is not shown as accessible
2569 * for write operations, probably because it is opened for reading.
2572 int rc = fstat(fd,sbufptr);
2573 BY_HANDLE_FILE_INFORMATION bhfi;
2574 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2575 sbufptr->st_mode &= 0xFE00;
2576 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2577 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2579 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2580 + ((S_IREAD|S_IWRITE) >> 6));
2584 return my_fstat(fd,sbufptr);
2589 win32_pipe(int *pfd, unsigned int size, int mode)
2591 return _pipe(pfd, size, mode);
2595 win32_popenlist(const char *mode, IV narg, SV **args)
2598 Perl_croak(aTHX_ "List form of pipe open not implemented");
2603 * a popen() clone that respects PERL5SHELL
2605 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2609 win32_popen(const char *command, const char *mode)
2611 #ifdef USE_RTL_POPEN
2612 return _popen(command, mode);
2620 /* establish which ends read and write */
2621 if (strchr(mode,'w')) {
2622 stdfd = 0; /* stdin */
2626 else if (strchr(mode,'r')) {
2627 stdfd = 1; /* stdout */
2634 /* set the correct mode */
2635 if (strchr(mode,'b'))
2637 else if (strchr(mode,'t'))
2640 ourmode = _fmode & (O_TEXT | O_BINARY);
2642 /* the child doesn't inherit handles */
2643 ourmode |= O_NOINHERIT;
2645 if (win32_pipe( p, 512, ourmode) == -1)
2648 /* save current stdfd */
2649 if ((oldfd = win32_dup(stdfd)) == -1)
2652 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2653 /* stdfd will be inherited by the child */
2654 if (win32_dup2(p[child], stdfd) == -1)
2657 /* close the child end in parent */
2658 win32_close(p[child]);
2660 /* start the child */
2663 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2666 /* revert stdfd to whatever it was before */
2667 if (win32_dup2(oldfd, stdfd) == -1)
2670 /* close saved handle */
2674 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2677 /* set process id so that it can be returned by perl's open() */
2678 PL_forkprocess = childpid;
2681 /* we have an fd, return a file stream */
2682 return (PerlIO_fdopen(p[parent], (char *)mode));
2685 /* we don't need to check for errors here */
2689 win32_dup2(oldfd, stdfd);
2694 #endif /* USE_RTL_POPEN */
2702 win32_pclose(PerlIO *pf)
2704 #ifdef USE_RTL_POPEN
2708 int childpid, status;
2712 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2715 childpid = SvIVX(sv);
2732 if (win32_waitpid(childpid, &status, 0) == -1)
2737 #endif /* USE_RTL_POPEN */
2743 LPCWSTR lpExistingFileName,
2744 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2747 WCHAR wFullName[MAX_PATH+1];
2748 LPVOID lpContext = NULL;
2749 WIN32_STREAM_ID StreamId;
2750 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2755 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2756 BOOL, BOOL, LPVOID*) =
2757 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2758 BOOL, BOOL, LPVOID*))
2759 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2760 if (pfnBackupWrite == NULL)
2763 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2766 dwLen = (dwLen+1)*sizeof(WCHAR);
2768 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2769 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2770 NULL, OPEN_EXISTING, 0, NULL);
2771 if (handle == INVALID_HANDLE_VALUE)
2774 StreamId.dwStreamId = BACKUP_LINK;
2775 StreamId.dwStreamAttributes = 0;
2776 StreamId.dwStreamNameSize = 0;
2777 #if defined(__BORLANDC__) \
2778 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2779 StreamId.Size.u.HighPart = 0;
2780 StreamId.Size.u.LowPart = dwLen;
2782 StreamId.Size.HighPart = 0;
2783 StreamId.Size.LowPart = dwLen;
2786 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2787 FALSE, FALSE, &lpContext);
2789 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2790 FALSE, FALSE, &lpContext);
2791 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2794 CloseHandle(handle);
2799 win32_link(const char *oldname, const char *newname)
2802 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2803 WCHAR wOldName[MAX_PATH+1];
2804 WCHAR wNewName[MAX_PATH+1];
2807 Perl_croak(aTHX_ PL_no_func, "link");
2809 pfnCreateHardLinkW =
2810 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2811 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2812 if (pfnCreateHardLinkW == NULL)
2813 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2815 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2816 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2817 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2818 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2822 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2827 win32_rename(const char *oname, const char *newname)
2829 WCHAR wOldName[MAX_PATH+1];
2830 WCHAR wNewName[MAX_PATH+1];
2831 char szOldName[MAX_PATH+1];
2832 char szNewName[MAX_PATH+1];
2836 /* XXX despite what the documentation says about MoveFileEx(),
2837 * it doesn't work under Windows95!
2840 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2842 A2WHELPER(oname, wOldName, sizeof(wOldName));
2843 A2WHELPER(newname, wNewName, sizeof(wNewName));
2844 if (wcsicmp(wNewName, wOldName))
2845 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2846 wcscpy(wOldName, PerlDir_mapW(wOldName));
2847 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2850 if (stricmp(newname, oname))
2851 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2852 strcpy(szOldName, PerlDir_mapA(oname));
2853 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2856 DWORD err = GetLastError();
2858 case ERROR_BAD_NET_NAME:
2859 case ERROR_BAD_NETPATH:
2860 case ERROR_BAD_PATHNAME:
2861 case ERROR_FILE_NOT_FOUND:
2862 case ERROR_FILENAME_EXCED_RANGE:
2863 case ERROR_INVALID_DRIVE:
2864 case ERROR_NO_MORE_FILES:
2865 case ERROR_PATH_NOT_FOUND:
2878 char szTmpName[MAX_PATH+1];
2879 char dname[MAX_PATH+1];
2880 char *endname = Nullch;
2882 DWORD from_attr, to_attr;
2884 strcpy(szOldName, PerlDir_mapA(oname));
2885 strcpy(szNewName, PerlDir_mapA(newname));
2887 /* if oname doesn't exist, do nothing */
2888 from_attr = GetFileAttributes(szOldName);
2889 if (from_attr == 0xFFFFFFFF) {
2894 /* if newname exists, rename it to a temporary name so that we
2895 * don't delete it in case oname happens to be the same file
2896 * (but perhaps accessed via a different path)
2898 to_attr = GetFileAttributes(szNewName);
2899 if (to_attr != 0xFFFFFFFF) {
2900 /* if newname is a directory, we fail
2901 * XXX could overcome this with yet more convoluted logic */
2902 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2906 tmplen = strlen(szNewName);
2907 strcpy(szTmpName,szNewName);
2908 endname = szTmpName+tmplen;
2909 for (; endname > szTmpName ; --endname) {
2910 if (*endname == '/' || *endname == '\\') {
2915 if (endname > szTmpName)
2916 endname = strcpy(dname,szTmpName);
2920 /* get a temporary filename in same directory
2921 * XXX is this really the best we can do? */
2922 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2926 DeleteFile(szTmpName);
2928 retval = rename(szNewName, szTmpName);
2935 /* rename oname to newname */
2936 retval = rename(szOldName, szNewName);
2938 /* if we created a temporary file before ... */
2939 if (endname != Nullch) {
2940 /* ...and rename succeeded, delete temporary file/directory */
2942 DeleteFile(szTmpName);
2943 /* else restore it to what it was */
2945 (void)rename(szTmpName, szNewName);
2952 win32_setmode(int fd, int mode)
2954 return setmode(fd, mode);
2958 win32_lseek(int fd, long offset, int origin)
2960 return lseek(fd, offset, origin);
2970 win32_open(const char *path, int flag, ...)
2975 WCHAR wBuffer[MAX_PATH+1];
2978 pmode = va_arg(ap, int);
2981 if (stricmp(path, "/dev/null")==0)
2985 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2986 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2988 return open(PerlDir_mapA(path), flag, pmode);
2991 /* close() that understands socket */
2992 extern int my_close(int); /* in win32sck.c */
2997 return my_close(fd);
3013 win32_dup2(int fd1,int fd2)
3015 return dup2(fd1,fd2);
3018 #ifdef PERL_MSVCRT_READFIX
3020 #define LF 10 /* line feed */
3021 #define CR 13 /* carriage return */
3022 #define CTRLZ 26 /* ctrl-z means eof for text */
3023 #define FOPEN 0x01 /* file handle open */
3024 #define FEOFLAG 0x02 /* end of file has been encountered */
3025 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3026 #define FPIPE 0x08 /* file handle refers to a pipe */
3027 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3028 #define FDEV 0x40 /* file handle refers to device */
3029 #define FTEXT 0x80 /* file handle is in text mode */
3030 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3033 _fixed_read(int fh, void *buf, unsigned cnt)
3035 int bytes_read; /* number of bytes read */
3036 char *buffer; /* buffer to read to */
3037 int os_read; /* bytes read on OS call */
3038 char *p, *q; /* pointers into buffer */
3039 char peekchr; /* peek-ahead character */
3040 ULONG filepos; /* file position after seek */
3041 ULONG dosretval; /* o.s. return value */
3043 /* validate handle */
3044 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3045 !(_osfile(fh) & FOPEN))
3047 /* out of range -- return error */
3049 _doserrno = 0; /* not o.s. error */
3054 * If lockinitflag is FALSE, assume fd is device
3055 * lockinitflag is set to TRUE by open.
3057 if (_pioinfo(fh)->lockinitflag)
3058 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3060 bytes_read = 0; /* nothing read yet */
3061 buffer = (char*)buf;
3063 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3064 /* nothing to read or at EOF, so return 0 read */
3068 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3069 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3071 *buffer++ = _pipech(fh);
3074 _pipech(fh) = LF; /* mark as empty */
3079 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3081 /* ReadFile has reported an error. recognize two special cases.
3083 * 1. map ERROR_ACCESS_DENIED to EBADF
3085 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3086 * means the handle is a read-handle on a pipe for which
3087 * all write-handles have been closed and all data has been
3090 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3091 /* wrong read/write mode should return EBADF, not EACCES */
3093 _doserrno = dosretval;
3097 else if (dosretval == ERROR_BROKEN_PIPE) {
3107 bytes_read += os_read; /* update bytes read */
3109 if (_osfile(fh) & FTEXT) {
3110 /* now must translate CR-LFs to LFs in the buffer */
3112 /* set CRLF flag to indicate LF at beginning of buffer */
3113 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3114 /* _osfile(fh) |= FCRLF; */
3116 /* _osfile(fh) &= ~FCRLF; */
3118 _osfile(fh) &= ~FCRLF;
3120 /* convert chars in the buffer: p is src, q is dest */
3122 while (p < (char *)buf + bytes_read) {
3124 /* if fh is not a device, set ctrl-z flag */
3125 if (!(_osfile(fh) & FDEV))
3126 _osfile(fh) |= FEOFLAG;
3127 break; /* stop translating */
3132 /* *p is CR, so must check next char for LF */
3133 if (p < (char *)buf + bytes_read - 1) {
3136 *q++ = LF; /* convert CR-LF to LF */
3139 *q++ = *p++; /* store char normally */
3142 /* This is the hard part. We found a CR at end of
3143 buffer. We must peek ahead to see if next char
3148 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3149 (LPDWORD)&os_read, NULL))
3150 dosretval = GetLastError();
3152 if (dosretval != 0 || os_read == 0) {
3153 /* couldn't read ahead, store CR */
3157 /* peekchr now has the extra character -- we now
3158 have several possibilities:
3159 1. disk file and char is not LF; just seek back
3161 2. disk file and char is LF; store LF, don't seek back
3162 3. pipe/device and char is LF; store LF.
3163 4. pipe/device and char isn't LF, store CR and
3164 put char in pipe lookahead buffer. */
3165 if (_osfile(fh) & (FDEV|FPIPE)) {
3166 /* non-seekable device */
3171 _pipech(fh) = peekchr;
3176 if (peekchr == LF) {
3177 /* nothing read yet; must make some
3180 /* turn on this flag for tell routine */
3181 _osfile(fh) |= FCRLF;
3184 HANDLE osHandle; /* o.s. handle value */
3186 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3188 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3189 dosretval = GetLastError();
3200 /* we now change bytes_read to reflect the true number of chars
3202 bytes_read = q - (char *)buf;
3206 if (_pioinfo(fh)->lockinitflag)
3207 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3212 #endif /* PERL_MSVCRT_READFIX */
3215 win32_read(int fd, void *buf, unsigned int cnt)
3217 #ifdef PERL_MSVCRT_READFIX
3218 return _fixed_read(fd, buf, cnt);
3220 return read(fd, buf, cnt);
3225 win32_write(int fd, const void *buf, unsigned int cnt)
3227 return write(fd, buf, cnt);
3231 win32_mkdir(const char *dir, int mode)
3235 WCHAR wBuffer[MAX_PATH+1];
3236 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3237 return _wmkdir(PerlDir_mapW(wBuffer));
3239 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3243 win32_rmdir(const char *dir)
3247 WCHAR wBuffer[MAX_PATH+1];
3248 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3249 return _wrmdir(PerlDir_mapW(wBuffer));
3251 return rmdir(PerlDir_mapA(dir));
3255 win32_chdir(const char *dir)
3263 WCHAR wBuffer[MAX_PATH+1];
3264 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3265 return _wchdir(wBuffer);
3271 win32_access(const char *path, int mode)
3275 WCHAR wBuffer[MAX_PATH+1];
3276 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3277 return _waccess(PerlDir_mapW(wBuffer), mode);
3279 return access(PerlDir_mapA(path), mode);
3283 win32_chmod(const char *path, int mode)
3287 WCHAR wBuffer[MAX_PATH+1];
3288 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3289 return _wchmod(PerlDir_mapW(wBuffer), mode);
3291 return chmod(PerlDir_mapA(path), mode);
3296 create_command_line(char *cname, STRLEN clen, const char * const *args)
3303 bool bat_file = FALSE;
3304 bool cmd_shell = FALSE;
3305 bool dumb_shell = FALSE;
3306 bool extra_quotes = FALSE;
3307 bool quote_next = FALSE;
3310 cname = (char*)args[0];
3312 /* The NT cmd.exe shell has the following peculiarity that needs to be
3313 * worked around. It strips a leading and trailing dquote when any
3314 * of the following is true:
3315 * 1. the /S switch was used
3316 * 2. there are more than two dquotes
3317 * 3. there is a special character from this set: &<>()@^|
3318 * 4. no whitespace characters within the two dquotes
3319 * 5. string between two dquotes isn't an executable file
3320 * To work around this, we always add a leading and trailing dquote
3321 * to the string, if the first argument is either "cmd.exe" or "cmd",
3322 * and there were at least two or more arguments passed to cmd.exe
3323 * (not including switches).
3324 * XXX the above rules (from "cmd /?") don't seem to be applied
3325 * always, making for the convolutions below :-(
3329 clen = strlen(cname);
3332 && (stricmp(&cname[clen-4], ".bat") == 0
3333 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3339 char *exe = strrchr(cname, '/');
3340 char *exe2 = strrchr(cname, '\\');
3347 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3351 else if (stricmp(exe, "command.com") == 0
3352 || stricmp(exe, "command") == 0)
3359 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3360 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3361 STRLEN curlen = strlen(arg);
3362 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3363 len += 2; /* assume quoting needed (worst case) */
3365 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3367 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3370 New(1310, cmd, len, char);
3375 extra_quotes = TRUE;
3378 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3380 STRLEN curlen = strlen(arg);
3382 /* we want to protect empty arguments and ones with spaces with
3383 * dquotes, but only if they aren't already there */
3388 else if (quote_next) {
3389 /* see if it really is multiple arguments pretending to
3390 * be one and force a set of quotes around it */
3391 if (*find_next_space(arg))
3394 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3396 while (i < curlen) {
3397 if (isSPACE(arg[i])) {
3400 else if (arg[i] == '"') {
3423 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3425 /* is there a next argument? */
3426 if (args[index+1]) {
3427 /* are there two or more next arguments? */
3428 if (args[index+2]) {
3430 extra_quotes = TRUE;
3433 /* single argument, force quoting if it has spaces */
3449 qualified_path(const char *cmd)
3453 char *fullcmd, *curfullcmd;
3459 fullcmd = (char*)cmd;
3461 if (*fullcmd == '/' || *fullcmd == '\\')
3468 pathstr = PerlEnv_getenv("PATH");
3469 New(0, fullcmd, MAX_PATH+1, char);
3470 curfullcmd = fullcmd;
3475 /* start by appending the name to the current prefix */
3476 strcpy(curfullcmd, cmd);
3477 curfullcmd += cmdlen;
3479 /* if it doesn't end with '.', or has no extension, try adding
3480 * a trailing .exe first */
3481 if (cmd[cmdlen-1] != '.'
3482 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3484 strcpy(curfullcmd, ".exe");
3485 res = GetFileAttributes(fullcmd);
3486 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3491 /* that failed, try the bare name */
3492 res = GetFileAttributes(fullcmd);
3493 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3496 /* quit if no other path exists, or if cmd already has path */
3497 if (!pathstr || !*pathstr || has_slash)
3500 /* skip leading semis */
3501 while (*pathstr == ';')
3504 /* build a new prefix from scratch */
3505 curfullcmd = fullcmd;
3506 while (*pathstr && *pathstr != ';') {
3507 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3508 pathstr++; /* skip initial '"' */
3509 while (*pathstr && *pathstr != '"') {
3510 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3511 *curfullcmd++ = *pathstr;
3515 pathstr++; /* skip trailing '"' */
3518 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3519 *curfullcmd++ = *pathstr;
3524 pathstr++; /* skip trailing semi */
3525 if (curfullcmd > fullcmd /* append a dir separator */
3526 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3528 *curfullcmd++ = '\\';
3536 /* The following are just place holders.
3537 * Some hosts may provide and environment that the OS is
3538 * not tracking, therefore, these host must provide that
3539 * environment and the current directory to CreateProcess
3543 win32_get_childenv(void)
3549 win32_free_childenv(void* d)
3554 win32_clearenv(void)
3556 char *envv = GetEnvironmentStrings();
3560 char *end = strchr(cur,'=');
3561 if (end && end != cur) {
3563 SetEnvironmentVariable(cur, NULL);
3565 cur = end + strlen(end+1)+2;
3567 else if ((len = strlen(cur)))
3570 FreeEnvironmentStrings(envv);
3574 win32_get_childdir(void)
3578 char szfilename[(MAX_PATH+1)*2];
3580 WCHAR wfilename[MAX_PATH+1];
3581 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3582 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3585 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3588 New(0, ptr, strlen(szfilename)+1, char);
3589 strcpy(ptr, szfilename);
3594 win32_free_childdir(char* d)
3601 /* XXX this needs to be made more compatible with the spawnvp()
3602 * provided by the various RTLs. In particular, searching for
3603 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3604 * This doesn't significantly affect perl itself, because we
3605 * always invoke things using PERL5SHELL if a direct attempt to
3606 * spawn the executable fails.
3608 * XXX splitting and rejoining the commandline between do_aspawn()
3609 * and win32_spawnvp() could also be avoided.
3613 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3615 #ifdef USE_RTL_SPAWNVP
3616 return spawnvp(mode, cmdname, (char * const *)argv);
3623 STARTUPINFO StartupInfo;
3624 PROCESS_INFORMATION ProcessInformation;
3627 char *fullcmd = Nullch;
3628 char *cname = (char *)cmdname;
3632 clen = strlen(cname);
3633 /* if command name contains dquotes, must remove them */
3634 if (strchr(cname, '"')) {
3636 New(0,cname,clen+1,char);
3649 cmd = create_command_line(cname, clen, argv);
3651 env = PerlEnv_get_childenv();
3652 dir = PerlEnv_get_childdir();
3655 case P_NOWAIT: /* asynch + remember result */
3656 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3661 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3664 create |= CREATE_NEW_PROCESS_GROUP;
3667 case P_WAIT: /* synchronous execution */
3669 default: /* invalid mode */
3674 memset(&StartupInfo,0,sizeof(StartupInfo));
3675 StartupInfo.cb = sizeof(StartupInfo);
3676 memset(&tbl,0,sizeof(tbl));
3677 PerlEnv_get_child_IO(&tbl);
3678 StartupInfo.dwFlags = tbl.dwFlags;
3679 StartupInfo.dwX = tbl.dwX;
3680 StartupInfo.dwY = tbl.dwY;
3681 StartupInfo.dwXSize = tbl.dwXSize;
3682 StartupInfo.dwYSize = tbl.dwYSize;
3683 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3684 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3685 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3686 StartupInfo.wShowWindow = tbl.wShowWindow;
3687 StartupInfo.hStdInput = tbl.childStdIn;
3688 StartupInfo.hStdOutput = tbl.childStdOut;
3689 StartupInfo.hStdError = tbl.childStdErr;
3690 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3691 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3692 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3694 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3697 create |= CREATE_NEW_CONSOLE;
3699 if (w32_use_showwindow) {
3700 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3701 StartupInfo.wShowWindow = w32_showwindow;
3704 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3707 if (!CreateProcess(cname, /* search PATH to find executable */
3708 cmd, /* executable, and its arguments */
3709 NULL, /* process attributes */
3710 NULL, /* thread attributes */
3711 TRUE, /* inherit handles */
3712 create, /* creation flags */
3713 (LPVOID)env, /* inherit environment */
3714 dir, /* inherit cwd */
3716 &ProcessInformation))
3718 /* initial NULL argument to CreateProcess() does a PATH
3719 * search, but it always first looks in the directory
3720 * where the current process was started, which behavior
3721 * is undesirable for backward compatibility. So we
3722 * jump through our own hoops by picking out the path
3723 * we really want it to use. */
3725 fullcmd = qualified_path(cname);
3727 if (cname != cmdname)
3730 DEBUG_p(PerlIO_printf(Perl_debug_log,
3731 "Retrying [%s] with same args\n",
3741 if (mode == P_NOWAIT) {
3742 /* asynchronous spawn -- store handle, return PID */
3743 ret = (int)ProcessInformation.dwProcessId;
3744 if (IsWin95() && ret < 0)
3747 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3748 w32_child_pids[w32_num_children] = (DWORD)ret;
3753 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3754 /* FIXME: if msgwait returned due to message perhaps forward the
3755 "signal" to the process
3757 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3759 CloseHandle(ProcessInformation.hProcess);
3762 CloseHandle(ProcessInformation.hThread);
3765 PerlEnv_free_childenv(env);
3766 PerlEnv_free_childdir(dir);
3768 if (cname != cmdname)
3775 win32_execv(const char *cmdname, const char *const *argv)
3779 /* if this is a pseudo-forked child, we just want to spawn
3780 * the new program, and return */
3782 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3784 return execv(cmdname, (char *const *)argv);
3788 win32_execvp(const char *cmdname, const char *const *argv)
3792 /* if this is a pseudo-forked child, we just want to spawn
3793 * the new program, and return */
3794 if (w32_pseudo_id) {
3795 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3804 return execvp(cmdname, (char *const *)argv);
3808 win32_perror(const char *str)
3814 win32_setbuf(FILE *pf, char *buf)
3820 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3822 return setvbuf(pf, buf, type, size);
3826 win32_flushall(void)
3832 win32_fcloseall(void)
3838 win32_fgets(char *s, int n, FILE *pf)
3840 return fgets(s, n, pf);
3850 win32_fgetc(FILE *pf)
3856 win32_putc(int c, FILE *pf)
3862 win32_puts(const char *s)
3874 win32_putchar(int c)
3881 #ifndef USE_PERL_SBRK
3883 static char *committed = NULL; /* XXX threadead */
3884 static char *base = NULL; /* XXX threadead */
3885 static char *reserved = NULL; /* XXX threadead */
3886 static char *brk = NULL; /* XXX threadead */
3887 static DWORD pagesize = 0; /* XXX threadead */
3888 static DWORD allocsize = 0; /* XXX threadead */
3896 GetSystemInfo(&info);
3897 /* Pretend page size is larger so we don't perpetually
3898 * call the OS to commit just one page ...
3900 pagesize = info.dwPageSize << 3;
3901 allocsize = info.dwAllocationGranularity;
3903 /* This scheme fails eventually if request for contiguous
3904 * block is denied so reserve big blocks - this is only
3905 * address space not memory ...
3907 if (brk+need >= reserved)
3909 DWORD size = 64*1024*1024;
3911 if (committed && reserved && committed < reserved)
3913 /* Commit last of previous chunk cannot span allocations */
3914 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3916 committed = reserved;
3918 /* Reserve some (more) space
3919 * Note this is a little sneaky, 1st call passes NULL as reserved
3920 * so lets system choose where we start, subsequent calls pass
3921 * the old end address so ask for a contiguous block
3923 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3926 reserved = addr+size;
3941 if (brk > committed)
3943 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3944 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3959 win32_malloc(size_t size)
3961 return malloc(size);
3965 win32_calloc(size_t numitems, size_t size)
3967 return calloc(numitems,size);
3971 win32_realloc(void *block, size_t size)
3973 return realloc(block,size);
3977 win32_free(void *block)
3984 win32_open_osfhandle(long handle, int flags)
3986 #ifdef USE_FIXED_OSFHANDLE
3988 return my_open_osfhandle(handle, flags);
3990 return _open_osfhandle(handle, flags);
3994 win32_get_osfhandle(int fd)
3996 return _get_osfhandle(fd);
4000 win32_dynaload(const char* filename)
4004 char buf[MAX_PATH+1];
4007 /* LoadLibrary() doesn't recognize forward slashes correctly,
4008 * so turn 'em back. */
4009 first = strchr(filename, '/');
4011 STRLEN len = strlen(filename);
4012 if (len <= MAX_PATH) {
4013 strcpy(buf, filename);
4014 filename = &buf[first - filename];
4016 if (*filename == '/')
4017 *(char*)filename = '\\';
4024 WCHAR wfilename[MAX_PATH+1];
4025 A2WHELPER(filename, wfilename, sizeof(wfilename));
4026 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4029 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4039 XS(w32_SetChildShowWindow)
4042 BOOL use_showwindow = w32_use_showwindow;
4043 /* use "unsigned short" because Perl has redefined "WORD" */
4044 unsigned short showwindow = w32_showwindow;
4047 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4049 if (items == 0 || !SvOK(ST(0)))
4050 w32_use_showwindow = FALSE;
4052 w32_use_showwindow = TRUE;
4053 w32_showwindow = (unsigned short)SvIV(ST(0));
4058 ST(0) = sv_2mortal(newSViv(showwindow));
4060 ST(0) = &PL_sv_undef;
4068 /* Make the host for current directory */
4069 char* ptr = PerlEnv_get_childdir();
4072 * then it worked, set PV valid,
4073 * else return 'undef'
4076 SV *sv = sv_newmortal();
4078 PerlEnv_free_childdir(ptr);
4080 #ifndef INCOMPLETE_TAINTS
4097 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4098 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4105 XS(w32_GetNextAvailDrive)
4109 char root[] = "_:\\";
4114 if (GetDriveType(root) == 1) {
4123 XS(w32_GetLastError)
4127 XSRETURN_IV(GetLastError());
4131 XS(w32_SetLastError)
4135 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4136 SetLastError(SvIV(ST(0)));
4144 char *name = w32_getlogin_buffer;
4145 DWORD size = sizeof(w32_getlogin_buffer);
4147 if (GetUserName(name,&size)) {
4148 /* size includes NULL */
4149 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4159 char name[MAX_COMPUTERNAME_LENGTH+1];
4160 DWORD size = sizeof(name);
4162 if (GetComputerName(name,&size)) {
4163 /* size does NOT include NULL :-( */
4164 ST(0) = sv_2mortal(newSVpvn(name,size));
4175 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4176 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4177 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4181 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4182 GetProcAddress(hNetApi32, "NetApiBufferFree");
4183 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4184 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4187 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4188 /* this way is more reliable, in case user has a local account. */
4190 DWORD dnamelen = sizeof(dname);
4192 DWORD wki100_platform_id;
4193 LPWSTR wki100_computername;
4194 LPWSTR wki100_langroup;
4195 DWORD wki100_ver_major;
4196 DWORD wki100_ver_minor;
4198 /* NERR_Success *is* 0*/
4199 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4200 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4201 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4202 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4205 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4206 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4208 pfnNetApiBufferFree(pwi);
4209 FreeLibrary(hNetApi32);
4212 FreeLibrary(hNetApi32);
4215 /* Win95 doesn't have NetWksta*(), so do it the old way */
4217 DWORD size = sizeof(name);
4219 FreeLibrary(hNetApi32);
4220 if (GetUserName(name,&size)) {
4221 char sid[ONE_K_BUFSIZE];
4222 DWORD sidlen = sizeof(sid);
4224 DWORD dnamelen = sizeof(dname);
4226 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4227 dname, &dnamelen, &snu)) {
4228 XSRETURN_PV(dname); /* all that for this */
4240 DWORD flags, filecomplen;
4241 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4242 &flags, fsname, sizeof(fsname))) {
4243 if (GIMME_V == G_ARRAY) {
4244 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4245 XPUSHs(sv_2mortal(newSViv(flags)));
4246 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4251 XSRETURN_PV(fsname);
4257 XS(w32_GetOSVersion)
4260 OSVERSIONINFOA osver;
4263 OSVERSIONINFOW osverw;
4264 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4265 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4266 if (!GetVersionExW(&osverw)) {
4269 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4270 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4271 osver.dwMajorVersion = osverw.dwMajorVersion;
4272 osver.dwMinorVersion = osverw.dwMinorVersion;
4273 osver.dwBuildNumber = osverw.dwBuildNumber;
4274 osver.dwPlatformId = osverw.dwPlatformId;
4277 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4278 if (!GetVersionExA(&osver)) {
4281 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4283 XPUSHs(newSViv(osver.dwMajorVersion));
4284 XPUSHs(newSViv(osver.dwMinorVersion));
4285 XPUSHs(newSViv(osver.dwBuildNumber));
4286 XPUSHs(newSViv(osver.dwPlatformId));
4295 XSRETURN_IV(IsWinNT());
4303 XSRETURN_IV(IsWin95());
4307 XS(w32_FormatMessage)
4311 char msgbuf[ONE_K_BUFSIZE];
4314 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4317 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4318 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4319 &source, SvIV(ST(0)), 0,
4320 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4322 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4323 XSRETURN_PV(msgbuf);
4327 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4328 &source, SvIV(ST(0)), 0,
4329 msgbuf, sizeof(msgbuf)-1, NULL))
4330 XSRETURN_PV(msgbuf);
4343 PROCESS_INFORMATION stProcInfo;
4344 STARTUPINFO stStartInfo;
4345 BOOL bSuccess = FALSE;
4348 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4350 cmd = SvPV_nolen(ST(0));
4351 args = SvPV_nolen(ST(1));
4353 env = PerlEnv_get_childenv();
4354 dir = PerlEnv_get_childdir();
4356 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4357 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4358 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4359 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4362 cmd, /* Image path */
4363 args, /* Arguments for command line */
4364 NULL, /* Default process security */
4365 NULL, /* Default thread security */
4366 FALSE, /* Must be TRUE to use std handles */
4367 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4368 env, /* Inherit our environment block */
4369 dir, /* Inherit our currrent directory */
4370 &stStartInfo, /* -> Startup info */
4371 &stProcInfo)) /* <- Process info (if OK) */
4373 int pid = (int)stProcInfo.dwProcessId;
4374 if (IsWin95() && pid < 0)
4376 sv_setiv(ST(2), pid);
4377 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4380 PerlEnv_free_childenv(env);
4381 PerlEnv_free_childdir(dir);
4382 XSRETURN_IV(bSuccess);
4386 XS(w32_GetTickCount)
4389 DWORD msec = GetTickCount();
4397 XS(w32_GetShortPathName)
4404 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4406 shortpath = sv_mortalcopy(ST(0));
4407 SvUPGRADE(shortpath, SVt_PV);
4408 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4411 /* src == target is allowed */
4413 len = GetShortPathName(SvPVX(shortpath),
4416 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4418 SvCUR_set(shortpath,len);
4426 XS(w32_GetFullPathName)
4435 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4438 fullpath = sv_mortalcopy(filename);
4439 SvUPGRADE(fullpath, SVt_PV);
4440 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4444 len = GetFullPathName(SvPVX(filename),
4448 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4450 if (GIMME_V == G_ARRAY) {
4452 XST_mPV(1,filepart);
4453 len = filepart - SvPVX(fullpath);
4456 SvCUR_set(fullpath,len);
4464 XS(w32_GetLongPathName)
4468 char tmpbuf[MAX_PATH+1];
4473 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4476 pathstr = SvPV(path,len);
4477 strcpy(tmpbuf, pathstr);
4478 pathstr = win32_longpath(tmpbuf);
4480 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4491 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4502 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4504 WCHAR wSourceFile[MAX_PATH+1];
4505 WCHAR wDestFile[MAX_PATH+1];
4506 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4507 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4508 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4509 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4512 char szSourceFile[MAX_PATH+1];
4513 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4514 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4523 Perl_init_os_extras(void)
4526 char *file = __FILE__;
4529 /* these names are Activeware compatible */
4530 newXS("Win32::GetCwd", w32_GetCwd, file);
4531 newXS("Win32::SetCwd", w32_SetCwd, file);
4532 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4533 newXS("Win32::GetLastError", w32_GetLastError, file);
4534 newXS("Win32::SetLastError", w32_SetLastError, file);
4535 newXS("Win32::LoginName", w32_LoginName, file);
4536 newXS("Win32::NodeName", w32_NodeName, file);
4537 newXS("Win32::DomainName", w32_DomainName, file);
4538 newXS("Win32::FsType", w32_FsType, file);
4539 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4540 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4541 newXS("Win32::IsWin95", w32_IsWin95, file);
4542 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4543 newXS("Win32::Spawn", w32_Spawn, file);
4544 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4545 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4546 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4547 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4548 newXS("Win32::CopyFile", w32_CopyFile, file);
4549 newXS("Win32::Sleep", w32_Sleep, file);
4550 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4552 /* XXX Bloat Alert! The following Activeware preloads really
4553 * ought to be part of Win32::Sys::*, so they're not included
4556 /* LookupAccountName
4558 * InitiateSystemShutdown
4559 * AbortSystemShutdown
4560 * ExpandEnvrironmentStrings
4567 win32_signal_context(void)
4571 my_perl = PL_curinterp;
4572 PERL_SET_THX(my_perl);
4580 win32_ctrlhandler(DWORD dwCtrlType)
4583 dTHXa(PERL_GET_SIG_CONTEXT);
4589 switch(dwCtrlType) {
4590 case CTRL_CLOSE_EVENT:
4591 /* A signal that the system sends to all processes attached to a console when
4592 the user closes the console (either by choosing the Close command from the
4593 console window's System menu, or by choosing the End Task command from the
4596 if (do_raise(aTHX_ 1)) /* SIGHUP */
4597 sig_terminate(aTHX_ 1);
4601 /* A CTRL+c signal was received */
4602 if (do_raise(aTHX_ SIGINT))
4603 sig_terminate(aTHX_ SIGINT);
4606 case CTRL_BREAK_EVENT:
4607 /* A CTRL+BREAK signal was received */
4608 if (do_raise(aTHX_ SIGBREAK))
4609 sig_terminate(aTHX_ SIGBREAK);
4612 case CTRL_LOGOFF_EVENT:
4613 /* A signal that the system sends to all console processes when a user is logging
4614 off. This signal does not indicate which user is logging off, so no
4615 assumptions can be made.
4618 case CTRL_SHUTDOWN_EVENT:
4619 /* A signal that the system sends to all console processes when the system is
4622 if (do_raise(aTHX_ SIGTERM))
4623 sig_terminate(aTHX_ SIGTERM);
4633 Perl_win32_init(int *argcp, char ***argvp)
4635 /* Disable floating point errors, Perl will trap the ones we
4636 * care about. VC++ RTL defaults to switching these off
4637 * already, but the Borland RTL doesn't. Since we don't
4638 * want to be at the vendor's whim on the default, we set
4639 * it explicitly here.
4641 #if !defined(_ALPHA_) && !defined(__GNUC__)
4642 _control87(MCW_EM, MCW_EM);
4648 win32_get_child_IO(child_IO_table* ptbl)
4650 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4651 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4652 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4656 win32_signal(int sig, Sighandler_t subcode)
4659 if (sig < SIG_SIZE) {
4660 int save_errno = errno;
4661 Sighandler_t result = signal(sig, subcode);
4662 if (result == SIG_ERR) {
4663 result = w32_sighandler[sig];
4666 w32_sighandler[sig] = subcode;
4676 #ifdef HAVE_INTERP_INTERN
4680 win32_csighandler(int sig)
4683 dTHXa(PERL_GET_SIG_CONTEXT);
4684 Perl_warn(aTHX_ "Got signal %d",sig);
4690 Perl_sys_intern_init(pTHX)
4693 w32_perlshell_tokens = Nullch;
4694 w32_perlshell_vec = (char**)NULL;
4695 w32_perlshell_items = 0;
4696 w32_fdpid = newAV();
4697 New(1313, w32_children, 1, child_tab);
4698 w32_num_children = 0;
4699 # ifdef USE_ITHREADS
4701 New(1313, w32_pseudo_children, 1, child_tab);
4702 w32_num_pseudo_children = 0;
4704 w32_init_socktype = 0;
4707 for (i=0; i < SIG_SIZE; i++) {
4708 w32_sighandler[i] = SIG_DFL;
4711 if (my_perl == PL_curinterp) {
4715 /* Force C runtime signal stuff to set its console handler */
4716 signal(SIGINT,&win32_csighandler);
4717 signal(SIGBREAK,&win32_csighandler);
4718 /* Push our handler on top */
4719 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4724 Perl_sys_intern_clear(pTHX)
4726 Safefree(w32_perlshell_tokens);
4727 Safefree(w32_perlshell_vec);
4728 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4729 Safefree(w32_children);
4731 KillTimer(NULL,w32_timerid);
4734 # ifdef MULTIPLICITY
4735 if (my_perl == PL_curinterp) {
4739 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4741 # ifdef USE_ITHREADS
4742 Safefree(w32_pseudo_children);
4746 # ifdef USE_ITHREADS
4749 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4751 dst->perlshell_tokens = Nullch;
4752 dst->perlshell_vec = (char**)NULL;
4753 dst->perlshell_items = 0;
4754 dst->fdpid = newAV();
4755 Newz(1313, dst->children, 1, child_tab);
4757 Newz(1313, dst->pseudo_children, 1, child_tab);
4758 dst->thr_intern.Winit_socktype = 0;
4760 dst->poll_count = 0;
4761 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4763 # endif /* USE_ITHREADS */
4764 #endif /* HAVE_INTERP_INTERN */
4767 win32_free_argvw(pTHX_ void *ptr)
4769 char** argv = (char**)ptr;
4777 win32_argv2utf8(int argc, char** argv)
4782 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4783 if (lpwStr && argc) {
4785 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4786 Newz(0, psz, length, char);
4787 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4790 call_atexit(win32_free_argvw, argv);
4792 GlobalFree((HGLOBAL)lpwStr);