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
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 /* Find the longname of a given path. path is destructively modified.
1288 * It should have space for at least MAX_PATH characters. */
1290 win32_longpath(char *path)
1292 WIN32_FIND_DATA fdata;
1294 char tmpbuf[MAX_PATH+1];
1295 char *tmpstart = tmpbuf;
1302 if (isALPHA(path[0]) && path[1] == ':' &&
1303 (path[2] == '/' || path[2] == '\\'))
1306 *tmpstart++ = path[0];
1310 else if ((path[0] == '/' || path[0] == '\\') &&
1311 (path[1] == '/' || path[1] == '\\'))
1314 *tmpstart++ = path[0];
1315 *tmpstart++ = path[1];
1316 /* copy machine name */
1317 while (*start && *start != '/' && *start != '\\')
1318 *tmpstart++ = *start++;
1320 *tmpstart++ = *start;
1322 /* copy share name */
1323 while (*start && *start != '/' && *start != '\\')
1324 *tmpstart++ = *start++;
1328 if (sep == '/' || sep == '\\')
1332 /* walk up to slash */
1333 while (*start && *start != '/' && *start != '\\')
1336 /* discard doubled slashes */
1337 while (*start && (start[1] == '/' || start[1] == '\\'))
1341 /* stop and find full name of component */
1343 fhand = FindFirstFile(path,&fdata);
1344 if (fhand != INVALID_HANDLE_VALUE) {
1345 strcpy(tmpstart, fdata.cFileName);
1346 tmpstart += strlen(fdata.cFileName);
1354 /* failed a step, just return without side effects */
1355 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1360 strcpy(path,tmpbuf);
1365 win32_getenv(const char *name)
1368 WCHAR wBuffer[MAX_PATH+1];
1370 SV *curitem = Nullsv;
1373 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1374 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1377 needlen = GetEnvironmentVariableA(name,NULL,0);
1379 curitem = sv_2mortal(newSVpvn("", 0));
1383 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1384 needlen = GetEnvironmentVariableW(wBuffer,
1385 (WCHAR*)SvPVX(curitem),
1387 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1388 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1389 acuritem = sv_2mortal(newSVsv(curitem));
1390 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1394 SvGROW(curitem, needlen+1);
1395 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1397 } while (needlen >= SvLEN(curitem));
1398 SvCUR_set(curitem, needlen);
1402 /* allow any environment variables that begin with 'PERL'
1403 to be stored in the registry */
1404 if (strncmp(name, "PERL", 4) == 0)
1405 (void)get_regstr(name, &curitem);
1407 if (curitem && SvCUR(curitem))
1408 return SvPVX(curitem);
1414 win32_putenv(const char *name)
1421 int length, relval = -1;
1425 length = strlen(name)+1;
1426 New(1309,wCuritem,length,WCHAR);
1427 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1428 wVal = wcschr(wCuritem, '=');
1431 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1437 New(1309,curitem,strlen(name)+1,char);
1438 strcpy(curitem, name);
1439 val = strchr(curitem, '=');
1441 /* The sane way to deal with the environment.
1442 * Has these advantages over putenv() & co.:
1443 * * enables us to store a truly empty value in the
1444 * environment (like in UNIX).
1445 * * we don't have to deal with RTL globals, bugs and leaks.
1447 * Why you may want to enable USE_WIN32_RTL_ENV:
1448 * * environ[] and RTL functions will not reflect changes,
1449 * which might be an issue if extensions want to access
1450 * the env. via RTL. This cuts both ways, since RTL will
1451 * not see changes made by extensions that call the Win32
1452 * functions directly, either.
1456 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1466 filetime_to_clock(PFILETIME ft)
1468 __int64 qw = ft->dwHighDateTime;
1470 qw |= ft->dwLowDateTime;
1471 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1476 win32_times(struct tms *timebuf)
1481 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1483 timebuf->tms_utime = filetime_to_clock(&user);
1484 timebuf->tms_stime = filetime_to_clock(&kernel);
1485 timebuf->tms_cutime = 0;
1486 timebuf->tms_cstime = 0;
1489 /* That failed - e.g. Win95 fallback to clock() */
1490 clock_t t = clock();
1491 timebuf->tms_utime = t;
1492 timebuf->tms_stime = 0;
1493 timebuf->tms_cutime = 0;
1494 timebuf->tms_cstime = 0;
1499 /* fix utime() so it works on directories in NT */
1501 filetime_from_time(PFILETIME pFileTime, time_t Time)
1503 struct tm *pTM = localtime(&Time);
1504 SYSTEMTIME SystemTime;
1510 SystemTime.wYear = pTM->tm_year + 1900;
1511 SystemTime.wMonth = pTM->tm_mon + 1;
1512 SystemTime.wDay = pTM->tm_mday;
1513 SystemTime.wHour = pTM->tm_hour;
1514 SystemTime.wMinute = pTM->tm_min;
1515 SystemTime.wSecond = pTM->tm_sec;
1516 SystemTime.wMilliseconds = 0;
1518 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1519 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1523 win32_unlink(const char *filename)
1530 WCHAR wBuffer[MAX_PATH+1];
1533 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1534 pwBuffer = PerlDir_mapW(wBuffer);
1535 attrs = GetFileAttributesW(pwBuffer);
1536 if (attrs == 0xFFFFFFFF)
1538 if (attrs & FILE_ATTRIBUTE_READONLY) {
1539 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1540 ret = _wunlink(pwBuffer);
1542 (void)SetFileAttributesW(pwBuffer, attrs);
1545 ret = _wunlink(pwBuffer);
1548 filename = PerlDir_mapA(filename);
1549 attrs = GetFileAttributesA(filename);
1550 if (attrs == 0xFFFFFFFF)
1552 if (attrs & FILE_ATTRIBUTE_READONLY) {
1553 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1554 ret = unlink(filename);
1556 (void)SetFileAttributesA(filename, attrs);
1559 ret = unlink(filename);
1568 win32_utime(const char *filename, struct utimbuf *times)
1575 struct utimbuf TimeBuffer;
1576 WCHAR wbuffer[MAX_PATH+1];
1581 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1582 pwbuffer = PerlDir_mapW(wbuffer);
1583 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1586 filename = PerlDir_mapA(filename);
1587 rc = utime(filename, times);
1589 /* EACCES: path specifies directory or readonly file */
1590 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1593 if (times == NULL) {
1594 times = &TimeBuffer;
1595 time(×->actime);
1596 times->modtime = times->actime;
1599 /* This will (and should) still fail on readonly files */
1601 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1602 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1603 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1606 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1607 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1608 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1610 if (handle == INVALID_HANDLE_VALUE)
1613 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1614 filetime_from_time(&ftAccess, times->actime) &&
1615 filetime_from_time(&ftWrite, times->modtime) &&
1616 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1621 CloseHandle(handle);
1626 win32_uname(struct utsname *name)
1628 struct hostent *hep;
1629 STRLEN nodemax = sizeof(name->nodename)-1;
1630 OSVERSIONINFO osver;
1632 memset(&osver, 0, sizeof(OSVERSIONINFO));
1633 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1634 if (GetVersionEx(&osver)) {
1636 switch (osver.dwPlatformId) {
1637 case VER_PLATFORM_WIN32_WINDOWS:
1638 strcpy(name->sysname, "Windows");
1640 case VER_PLATFORM_WIN32_NT:
1641 strcpy(name->sysname, "Windows NT");
1643 case VER_PLATFORM_WIN32s:
1644 strcpy(name->sysname, "Win32s");
1647 strcpy(name->sysname, "Win32 Unknown");
1652 sprintf(name->release, "%d.%d",
1653 osver.dwMajorVersion, osver.dwMinorVersion);
1656 sprintf(name->version, "Build %d",
1657 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1658 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1659 if (osver.szCSDVersion[0]) {
1660 char *buf = name->version + strlen(name->version);
1661 sprintf(buf, " (%s)", osver.szCSDVersion);
1665 *name->sysname = '\0';
1666 *name->version = '\0';
1667 *name->release = '\0';
1671 hep = win32_gethostbyname("localhost");
1673 STRLEN len = strlen(hep->h_name);
1674 if (len <= nodemax) {
1675 strcpy(name->nodename, hep->h_name);
1678 strncpy(name->nodename, hep->h_name, nodemax);
1679 name->nodename[nodemax] = '\0';
1684 if (!GetComputerName(name->nodename, &sz))
1685 *name->nodename = '\0';
1688 /* machine (architecture) */
1692 GetSystemInfo(&info);
1694 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1695 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1696 switch (info.u.s.wProcessorArchitecture) {
1698 switch (info.wProcessorArchitecture) {
1700 case PROCESSOR_ARCHITECTURE_INTEL:
1701 arch = "x86"; break;
1702 case PROCESSOR_ARCHITECTURE_MIPS:
1703 arch = "mips"; break;
1704 case PROCESSOR_ARCHITECTURE_ALPHA:
1705 arch = "alpha"; break;
1706 case PROCESSOR_ARCHITECTURE_PPC:
1707 arch = "ppc"; break;
1709 arch = "unknown"; break;
1711 strcpy(name->machine, arch);
1716 /* Timing related stuff */
1719 do_raise(pTHX_ int sig)
1721 if (sig < SIG_SIZE) {
1722 Sighandler_t handler = w32_sighandler[sig];
1723 if (handler == SIG_IGN) {
1726 else if (handler != SIG_DFL) {
1731 /* Choose correct default behaviour */
1747 /* Tell caller to exit thread/process as approriate */
1752 sig_terminate(pTHX_ int sig)
1754 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1755 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1762 win32_async_check(pTHX)
1766 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1767 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1769 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1771 switch(msg.message) {
1774 /* Perhaps some other messages could map to signals ? ... */
1777 /* Treat WM_QUIT like SIGHUP? */
1783 /* We use WM_USER to fake kill() with other signals */
1787 if (do_raise(aTHX_ sig)) {
1788 sig_terminate(aTHX_ sig);
1794 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1796 KillTimer(NULL,w32_timerid);
1799 /* Now fake a call to signal handler */
1800 if (do_raise(aTHX_ 14)) {
1801 sig_terminate(aTHX_ 14);
1806 /* Otherwise do normal Win32 thing - in case it is useful */
1808 TranslateMessage(&msg);
1809 DispatchMessage(&msg);
1816 /* Above or other stuff may have set a signal flag */
1817 if (PL_sig_pending) {
1824 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1826 /* We may need several goes at this - so compute when we stop */
1828 if (timeout != INFINITE) {
1829 ticks = GetTickCount();
1833 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1836 if (result == WAIT_TIMEOUT) {
1837 /* Ran out of time - explicit return of zero to avoid -ve if we
1838 have scheduling issues
1842 if (timeout != INFINITE) {
1843 ticks = GetTickCount();
1845 if (result == WAIT_OBJECT_0 + count) {
1846 /* Message has arrived - check it */
1847 if (win32_async_check(aTHX)) {
1848 /* was one of ours */
1853 /* Not timeout or message - one of handles is ready */
1857 /* compute time left to wait */
1858 ticks = timeout - ticks;
1859 /* If we are past the end say zero */
1860 return (ticks > 0) ? ticks : 0;
1864 win32_internal_wait(int *status, DWORD timeout)
1866 /* XXX this wait emulation only knows about processes
1867 * spawned via win32_spawnvp(P_NOWAIT, ...).
1871 DWORD exitcode, waitcode;
1874 if (w32_num_pseudo_children) {
1875 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1876 timeout, &waitcode);
1877 /* Time out here if there are no other children to wait for. */
1878 if (waitcode == WAIT_TIMEOUT) {
1879 if (!w32_num_children) {
1883 else if (waitcode != WAIT_FAILED) {
1884 if (waitcode >= WAIT_ABANDONED_0
1885 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1886 i = waitcode - WAIT_ABANDONED_0;
1888 i = waitcode - WAIT_OBJECT_0;
1889 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1890 *status = (int)((exitcode & 0xff) << 8);
1891 retval = (int)w32_pseudo_child_pids[i];
1892 remove_dead_pseudo_process(i);
1899 if (!w32_num_children) {
1904 /* if a child exists, wait for it to die */
1905 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1906 if (waitcode == WAIT_TIMEOUT) {
1909 if (waitcode != WAIT_FAILED) {
1910 if (waitcode >= WAIT_ABANDONED_0
1911 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1912 i = waitcode - WAIT_ABANDONED_0;
1914 i = waitcode - WAIT_OBJECT_0;
1915 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1916 *status = (int)((exitcode & 0xff) << 8);
1917 retval = (int)w32_child_pids[i];
1918 remove_dead_process(i);
1924 errno = GetLastError();
1929 win32_waitpid(int pid, int *status, int flags)
1932 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1935 if (pid == -1) /* XXX threadid == 1 ? */
1936 return win32_internal_wait(status, timeout);
1939 child = find_pseudo_pid(-pid);
1941 HANDLE hThread = w32_pseudo_child_handles[child];
1943 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1944 if (waitcode == WAIT_TIMEOUT) {
1947 else if (waitcode == WAIT_OBJECT_0) {
1948 if (GetExitCodeThread(hThread, &waitcode)) {
1949 *status = (int)((waitcode & 0xff) << 8);
1950 retval = (int)w32_pseudo_child_pids[child];
1951 remove_dead_pseudo_process(child);
1958 else if (IsWin95()) {
1967 child = find_pid(pid);
1969 hProcess = w32_child_handles[child];
1970 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1971 if (waitcode == WAIT_TIMEOUT) {
1974 else if (waitcode == WAIT_OBJECT_0) {
1975 if (GetExitCodeProcess(hProcess, &waitcode)) {
1976 *status = (int)((waitcode & 0xff) << 8);
1977 retval = (int)w32_child_pids[child];
1978 remove_dead_process(child);
1987 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1988 (IsWin95() ? -pid : pid));
1990 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1991 if (waitcode == WAIT_TIMEOUT) {
1994 else if (waitcode == WAIT_OBJECT_0) {
1995 if (GetExitCodeProcess(hProcess, &waitcode)) {
1996 *status = (int)((waitcode & 0xff) << 8);
1997 CloseHandle(hProcess);
2001 CloseHandle(hProcess);
2007 return retval >= 0 ? pid : retval;
2011 win32_wait(int *status)
2013 return win32_internal_wait(status, INFINITE);
2016 DllExport unsigned int
2017 win32_sleep(unsigned int t)
2020 /* Win32 times are in ms so *1000 in and /1000 out */
2021 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2024 DllExport unsigned int
2025 win32_alarm(unsigned int sec)
2028 * the 'obvious' implentation is SetTimer() with a callback
2029 * which does whatever receiving SIGALRM would do
2030 * we cannot use SIGALRM even via raise() as it is not
2031 * one of the supported codes in <signal.h>
2035 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2039 KillTimer(NULL,w32_timerid);
2046 #ifdef HAVE_DES_FCRYPT
2047 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2051 win32_crypt(const char *txt, const char *salt)
2054 #ifdef HAVE_DES_FCRYPT
2055 return des_fcrypt(txt, salt, w32_crypt_buffer);
2057 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2062 #ifdef USE_FIXED_OSFHANDLE
2064 #define FOPEN 0x01 /* file handle open */
2065 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2066 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2067 #define FDEV 0x40 /* file handle refers to device */
2068 #define FTEXT 0x80 /* file handle is in text mode */
2071 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2074 * This function allocates a free C Runtime file handle and associates
2075 * it with the Win32 HANDLE specified by the first parameter. This is a
2076 * temperary fix for WIN95's brain damage GetFileType() error on socket
2077 * we just bypass that call for socket
2079 * This works with MSVC++ 4.0+ or GCC/Mingw32
2082 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2083 * int flags - flags to associate with C Runtime file handle.
2086 * returns index of entry in fh, if successful
2087 * return -1, if no free entry is found
2091 *******************************************************************************/
2094 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2095 * this lets sockets work on Win9X with GCC and should fix the problems
2100 /* create an ioinfo entry, kill its handle, and steal the entry */
2105 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2106 int fh = _open_osfhandle((long)hF, 0);
2110 EnterCriticalSection(&(_pioinfo(fh)->lock));
2115 my_open_osfhandle(long osfhandle, int flags)
2118 char fileflags; /* _osfile flags */
2120 /* copy relevant flags from second parameter */
2123 if (flags & O_APPEND)
2124 fileflags |= FAPPEND;
2129 if (flags & O_NOINHERIT)
2130 fileflags |= FNOINHERIT;
2132 /* attempt to allocate a C Runtime file handle */
2133 if ((fh = _alloc_osfhnd()) == -1) {
2134 errno = EMFILE; /* too many open files */
2135 _doserrno = 0L; /* not an OS error */
2136 return -1; /* return error to caller */
2139 /* the file is open. now, set the info in _osfhnd array */
2140 _set_osfhnd(fh, osfhandle);
2142 fileflags |= FOPEN; /* mark as open */
2144 _osfile(fh) = fileflags; /* set osfile entry */
2145 LeaveCriticalSection(&_pioinfo(fh)->lock);
2147 return fh; /* return handle */
2150 #endif /* USE_FIXED_OSFHANDLE */
2152 /* simulate flock by locking a range on the file */
2154 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2155 #define LK_LEN 0xffff0000
2158 win32_flock(int fd, int oper)
2166 Perl_croak_nocontext("flock() unimplemented on this platform");
2169 fh = (HANDLE)_get_osfhandle(fd);
2170 memset(&o, 0, sizeof(o));
2173 case LOCK_SH: /* shared lock */
2174 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2176 case LOCK_EX: /* exclusive lock */
2177 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2179 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2180 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2182 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2183 LK_ERR(LockFileEx(fh,
2184 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2185 0, LK_LEN, 0, &o),i);
2187 case LOCK_UN: /* unlock lock */
2188 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2190 default: /* unknown */
2201 * redirected io subsystem for all XS modules
2214 return (&(_environ));
2217 /* the rest are the remapped stdio routines */
2237 win32_ferror(FILE *fp)
2239 return (ferror(fp));
2244 win32_feof(FILE *fp)
2250 * Since the errors returned by the socket error function
2251 * WSAGetLastError() are not known by the library routine strerror
2252 * we have to roll our own.
2256 win32_strerror(int e)
2258 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2259 extern int sys_nerr;
2263 if (e < 0 || e > sys_nerr) {
2268 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2269 w32_strerror_buffer,
2270 sizeof(w32_strerror_buffer), NULL) == 0)
2271 strcpy(w32_strerror_buffer, "Unknown Error");
2273 return w32_strerror_buffer;
2279 win32_str_os_error(void *sv, DWORD dwErr)
2283 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2284 |FORMAT_MESSAGE_IGNORE_INSERTS
2285 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2286 dwErr, 0, (char *)&sMsg, 1, NULL);
2287 /* strip trailing whitespace and period */
2290 --dwLen; /* dwLen doesn't include trailing null */
2291 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2292 if ('.' != sMsg[dwLen])
2297 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2299 dwLen = sprintf(sMsg,
2300 "Unknown error #0x%lX (lookup 0x%lX)",
2301 dwErr, GetLastError());
2305 sv_setpvn((SV*)sv, sMsg, dwLen);
2311 win32_fprintf(FILE *fp, const char *format, ...)
2314 va_start(marker, format); /* Initialize variable arguments. */
2316 return (vfprintf(fp, format, marker));
2320 win32_printf(const char *format, ...)
2323 va_start(marker, format); /* Initialize variable arguments. */
2325 return (vprintf(format, marker));
2329 win32_vfprintf(FILE *fp, const char *format, va_list args)
2331 return (vfprintf(fp, format, args));
2335 win32_vprintf(const char *format, va_list args)
2337 return (vprintf(format, args));
2341 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2343 return fread(buf, size, count, fp);
2347 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2349 return fwrite(buf, size, count, fp);
2352 #define MODE_SIZE 10
2355 win32_fopen(const char *filename, const char *mode)
2358 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2364 if (stricmp(filename, "/dev/null")==0)
2368 A2WHELPER(mode, wMode, sizeof(wMode));
2369 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2370 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2373 f = fopen(PerlDir_mapA(filename), mode);
2374 /* avoid buffering headaches for child processes */
2375 if (f && *mode == 'a')
2376 win32_fseek(f, 0, SEEK_END);
2380 #ifndef USE_SOCKETS_AS_HANDLES
2382 #define fdopen my_fdopen
2386 win32_fdopen(int handle, const char *mode)
2389 WCHAR wMode[MODE_SIZE];
2392 A2WHELPER(mode, wMode, sizeof(wMode));
2393 f = _wfdopen(handle, wMode);
2396 f = fdopen(handle, (char *) mode);
2397 /* avoid buffering headaches for child processes */
2398 if (f && *mode == 'a')
2399 win32_fseek(f, 0, SEEK_END);
2404 win32_freopen(const char *path, const char *mode, FILE *stream)
2407 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2408 if (stricmp(path, "/dev/null")==0)
2412 A2WHELPER(mode, wMode, sizeof(wMode));
2413 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2414 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2416 return freopen(PerlDir_mapA(path), mode, stream);
2420 win32_fclose(FILE *pf)
2422 return my_fclose(pf); /* defined in win32sck.c */
2426 win32_fputs(const char *s,FILE *pf)
2428 return fputs(s, pf);
2432 win32_fputc(int c,FILE *pf)
2438 win32_ungetc(int c,FILE *pf)
2440 return ungetc(c,pf);
2444 win32_getc(FILE *pf)
2450 win32_fileno(FILE *pf)
2456 win32_clearerr(FILE *pf)
2463 win32_fflush(FILE *pf)
2469 win32_ftell(FILE *pf)
2475 win32_fseek(FILE *pf,long offset,int origin)
2477 return fseek(pf, offset, origin);
2481 win32_fgetpos(FILE *pf,fpos_t *p)
2483 return fgetpos(pf, p);
2487 win32_fsetpos(FILE *pf,const fpos_t *p)
2489 return fsetpos(pf, p);
2493 win32_rewind(FILE *pf)
2503 char prefix[MAX_PATH+1];
2504 char filename[MAX_PATH+1];
2505 DWORD len = GetTempPath(MAX_PATH, prefix);
2506 if (len && len < MAX_PATH) {
2507 if (GetTempFileName(prefix, "plx", 0, filename)) {
2508 HANDLE fh = CreateFile(filename,
2509 DELETE | GENERIC_READ | GENERIC_WRITE,
2513 FILE_ATTRIBUTE_NORMAL
2514 | FILE_FLAG_DELETE_ON_CLOSE,
2516 if (fh != INVALID_HANDLE_VALUE) {
2517 int fd = win32_open_osfhandle((long)fh, 0);
2519 DEBUG_p(PerlIO_printf(Perl_debug_log,
2520 "Created tmpfile=%s\n",filename));
2521 return fdopen(fd, "w+b");
2537 win32_fstat(int fd,struct stat *sbufptr)
2540 /* A file designated by filehandle is not shown as accessible
2541 * for write operations, probably because it is opened for reading.
2544 int rc = fstat(fd,sbufptr);
2545 BY_HANDLE_FILE_INFORMATION bhfi;
2546 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2547 sbufptr->st_mode &= 0xFE00;
2548 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2549 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2551 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2552 + ((S_IREAD|S_IWRITE) >> 6));
2556 return my_fstat(fd,sbufptr);
2561 win32_pipe(int *pfd, unsigned int size, int mode)
2563 return _pipe(pfd, size, mode);
2567 win32_popenlist(const char *mode, IV narg, SV **args)
2570 Perl_croak(aTHX_ "List form of pipe open not implemented");
2575 * a popen() clone that respects PERL5SHELL
2577 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2581 win32_popen(const char *command, const char *mode)
2583 #ifdef USE_RTL_POPEN
2584 return _popen(command, mode);
2592 /* establish which ends read and write */
2593 if (strchr(mode,'w')) {
2594 stdfd = 0; /* stdin */
2598 else if (strchr(mode,'r')) {
2599 stdfd = 1; /* stdout */
2606 /* set the correct mode */
2607 if (strchr(mode,'b'))
2609 else if (strchr(mode,'t'))
2612 ourmode = _fmode & (O_TEXT | O_BINARY);
2614 /* the child doesn't inherit handles */
2615 ourmode |= O_NOINHERIT;
2617 if (win32_pipe( p, 512, ourmode) == -1)
2620 /* save current stdfd */
2621 if ((oldfd = win32_dup(stdfd)) == -1)
2624 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2625 /* stdfd will be inherited by the child */
2626 if (win32_dup2(p[child], stdfd) == -1)
2629 /* close the child end in parent */
2630 win32_close(p[child]);
2632 /* start the child */
2635 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2638 /* revert stdfd to whatever it was before */
2639 if (win32_dup2(oldfd, stdfd) == -1)
2642 /* close saved handle */
2646 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2649 /* set process id so that it can be returned by perl's open() */
2650 PL_forkprocess = childpid;
2653 /* we have an fd, return a file stream */
2654 return (PerlIO_fdopen(p[parent], (char *)mode));
2657 /* we don't need to check for errors here */
2661 win32_dup2(oldfd, stdfd);
2666 #endif /* USE_RTL_POPEN */
2674 win32_pclose(PerlIO *pf)
2676 #ifdef USE_RTL_POPEN
2680 int childpid, status;
2684 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2687 childpid = SvIVX(sv);
2704 if (win32_waitpid(childpid, &status, 0) == -1)
2709 #endif /* USE_RTL_POPEN */
2715 LPCWSTR lpExistingFileName,
2716 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2719 WCHAR wFullName[MAX_PATH+1];
2720 LPVOID lpContext = NULL;
2721 WIN32_STREAM_ID StreamId;
2722 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2727 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2728 BOOL, BOOL, LPVOID*) =
2729 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2730 BOOL, BOOL, LPVOID*))
2731 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2732 if (pfnBackupWrite == NULL)
2735 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2738 dwLen = (dwLen+1)*sizeof(WCHAR);
2740 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2741 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2742 NULL, OPEN_EXISTING, 0, NULL);
2743 if (handle == INVALID_HANDLE_VALUE)
2746 StreamId.dwStreamId = BACKUP_LINK;
2747 StreamId.dwStreamAttributes = 0;
2748 StreamId.dwStreamNameSize = 0;
2749 #if defined(__BORLANDC__) \
2750 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2751 StreamId.Size.u.HighPart = 0;
2752 StreamId.Size.u.LowPart = dwLen;
2754 StreamId.Size.HighPart = 0;
2755 StreamId.Size.LowPart = dwLen;
2758 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2759 FALSE, FALSE, &lpContext);
2761 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2762 FALSE, FALSE, &lpContext);
2763 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2766 CloseHandle(handle);
2771 win32_link(const char *oldname, const char *newname)
2774 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2775 WCHAR wOldName[MAX_PATH+1];
2776 WCHAR wNewName[MAX_PATH+1];
2779 Perl_croak(aTHX_ PL_no_func, "link");
2781 pfnCreateHardLinkW =
2782 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2783 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2784 if (pfnCreateHardLinkW == NULL)
2785 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2787 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2788 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2789 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2790 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2794 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2799 win32_rename(const char *oname, const char *newname)
2801 WCHAR wOldName[MAX_PATH+1];
2802 WCHAR wNewName[MAX_PATH+1];
2803 char szOldName[MAX_PATH+1];
2804 char szNewName[MAX_PATH+1];
2808 /* XXX despite what the documentation says about MoveFileEx(),
2809 * it doesn't work under Windows95!
2812 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2814 A2WHELPER(oname, wOldName, sizeof(wOldName));
2815 A2WHELPER(newname, wNewName, sizeof(wNewName));
2816 if (wcsicmp(wNewName, wOldName))
2817 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2818 wcscpy(wOldName, PerlDir_mapW(wOldName));
2819 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2822 if (stricmp(newname, oname))
2823 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2824 strcpy(szOldName, PerlDir_mapA(oname));
2825 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2828 DWORD err = GetLastError();
2830 case ERROR_BAD_NET_NAME:
2831 case ERROR_BAD_NETPATH:
2832 case ERROR_BAD_PATHNAME:
2833 case ERROR_FILE_NOT_FOUND:
2834 case ERROR_FILENAME_EXCED_RANGE:
2835 case ERROR_INVALID_DRIVE:
2836 case ERROR_NO_MORE_FILES:
2837 case ERROR_PATH_NOT_FOUND:
2850 char szTmpName[MAX_PATH+1];
2851 char dname[MAX_PATH+1];
2852 char *endname = Nullch;
2854 DWORD from_attr, to_attr;
2856 strcpy(szOldName, PerlDir_mapA(oname));
2857 strcpy(szNewName, PerlDir_mapA(newname));
2859 /* if oname doesn't exist, do nothing */
2860 from_attr = GetFileAttributes(szOldName);
2861 if (from_attr == 0xFFFFFFFF) {
2866 /* if newname exists, rename it to a temporary name so that we
2867 * don't delete it in case oname happens to be the same file
2868 * (but perhaps accessed via a different path)
2870 to_attr = GetFileAttributes(szNewName);
2871 if (to_attr != 0xFFFFFFFF) {
2872 /* if newname is a directory, we fail
2873 * XXX could overcome this with yet more convoluted logic */
2874 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2878 tmplen = strlen(szNewName);
2879 strcpy(szTmpName,szNewName);
2880 endname = szTmpName+tmplen;
2881 for (; endname > szTmpName ; --endname) {
2882 if (*endname == '/' || *endname == '\\') {
2887 if (endname > szTmpName)
2888 endname = strcpy(dname,szTmpName);
2892 /* get a temporary filename in same directory
2893 * XXX is this really the best we can do? */
2894 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2898 DeleteFile(szTmpName);
2900 retval = rename(szNewName, szTmpName);
2907 /* rename oname to newname */
2908 retval = rename(szOldName, szNewName);
2910 /* if we created a temporary file before ... */
2911 if (endname != Nullch) {
2912 /* ...and rename succeeded, delete temporary file/directory */
2914 DeleteFile(szTmpName);
2915 /* else restore it to what it was */
2917 (void)rename(szTmpName, szNewName);
2924 win32_setmode(int fd, int mode)
2926 return setmode(fd, mode);
2930 win32_lseek(int fd, long offset, int origin)
2932 return lseek(fd, offset, origin);
2942 win32_open(const char *path, int flag, ...)
2947 WCHAR wBuffer[MAX_PATH+1];
2950 pmode = va_arg(ap, int);
2953 if (stricmp(path, "/dev/null")==0)
2957 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2958 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2960 return open(PerlDir_mapA(path), flag, pmode);
2963 /* close() that understands socket */
2964 extern int my_close(int); /* in win32sck.c */
2969 return my_close(fd);
2985 win32_dup2(int fd1,int fd2)
2987 return dup2(fd1,fd2);
2990 #ifdef PERL_MSVCRT_READFIX
2992 #define LF 10 /* line feed */
2993 #define CR 13 /* carriage return */
2994 #define CTRLZ 26 /* ctrl-z means eof for text */
2995 #define FOPEN 0x01 /* file handle open */
2996 #define FEOFLAG 0x02 /* end of file has been encountered */
2997 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2998 #define FPIPE 0x08 /* file handle refers to a pipe */
2999 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3000 #define FDEV 0x40 /* file handle refers to device */
3001 #define FTEXT 0x80 /* file handle is in text mode */
3002 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3005 _fixed_read(int fh, void *buf, unsigned cnt)
3007 int bytes_read; /* number of bytes read */
3008 char *buffer; /* buffer to read to */
3009 int os_read; /* bytes read on OS call */
3010 char *p, *q; /* pointers into buffer */
3011 char peekchr; /* peek-ahead character */
3012 ULONG filepos; /* file position after seek */
3013 ULONG dosretval; /* o.s. return value */
3015 /* validate handle */
3016 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3017 !(_osfile(fh) & FOPEN))
3019 /* out of range -- return error */
3021 _doserrno = 0; /* not o.s. error */
3026 * If lockinitflag is FALSE, assume fd is device
3027 * lockinitflag is set to TRUE by open.
3029 if (_pioinfo(fh)->lockinitflag)
3030 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3032 bytes_read = 0; /* nothing read yet */
3033 buffer = (char*)buf;
3035 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3036 /* nothing to read or at EOF, so return 0 read */
3040 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3041 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3043 *buffer++ = _pipech(fh);
3046 _pipech(fh) = LF; /* mark as empty */
3051 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3053 /* ReadFile has reported an error. recognize two special cases.
3055 * 1. map ERROR_ACCESS_DENIED to EBADF
3057 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3058 * means the handle is a read-handle on a pipe for which
3059 * all write-handles have been closed and all data has been
3062 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3063 /* wrong read/write mode should return EBADF, not EACCES */
3065 _doserrno = dosretval;
3069 else if (dosretval == ERROR_BROKEN_PIPE) {
3079 bytes_read += os_read; /* update bytes read */
3081 if (_osfile(fh) & FTEXT) {
3082 /* now must translate CR-LFs to LFs in the buffer */
3084 /* set CRLF flag to indicate LF at beginning of buffer */
3085 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3086 /* _osfile(fh) |= FCRLF; */
3088 /* _osfile(fh) &= ~FCRLF; */
3090 _osfile(fh) &= ~FCRLF;
3092 /* convert chars in the buffer: p is src, q is dest */
3094 while (p < (char *)buf + bytes_read) {
3096 /* if fh is not a device, set ctrl-z flag */
3097 if (!(_osfile(fh) & FDEV))
3098 _osfile(fh) |= FEOFLAG;
3099 break; /* stop translating */
3104 /* *p is CR, so must check next char for LF */
3105 if (p < (char *)buf + bytes_read - 1) {
3108 *q++ = LF; /* convert CR-LF to LF */
3111 *q++ = *p++; /* store char normally */
3114 /* This is the hard part. We found a CR at end of
3115 buffer. We must peek ahead to see if next char
3120 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3121 (LPDWORD)&os_read, NULL))
3122 dosretval = GetLastError();
3124 if (dosretval != 0 || os_read == 0) {
3125 /* couldn't read ahead, store CR */
3129 /* peekchr now has the extra character -- we now
3130 have several possibilities:
3131 1. disk file and char is not LF; just seek back
3133 2. disk file and char is LF; store LF, don't seek back
3134 3. pipe/device and char is LF; store LF.
3135 4. pipe/device and char isn't LF, store CR and
3136 put char in pipe lookahead buffer. */
3137 if (_osfile(fh) & (FDEV|FPIPE)) {
3138 /* non-seekable device */
3143 _pipech(fh) = peekchr;
3148 if (peekchr == LF) {
3149 /* nothing read yet; must make some
3152 /* turn on this flag for tell routine */
3153 _osfile(fh) |= FCRLF;
3156 HANDLE osHandle; /* o.s. handle value */
3158 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3160 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3161 dosretval = GetLastError();
3172 /* we now change bytes_read to reflect the true number of chars
3174 bytes_read = q - (char *)buf;
3178 if (_pioinfo(fh)->lockinitflag)
3179 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3184 #endif /* PERL_MSVCRT_READFIX */
3187 win32_read(int fd, void *buf, unsigned int cnt)
3189 #ifdef PERL_MSVCRT_READFIX
3190 return _fixed_read(fd, buf, cnt);
3192 return read(fd, buf, cnt);
3197 win32_write(int fd, const void *buf, unsigned int cnt)
3199 return write(fd, buf, cnt);
3203 win32_mkdir(const char *dir, int mode)
3207 WCHAR wBuffer[MAX_PATH+1];
3208 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3209 return _wmkdir(PerlDir_mapW(wBuffer));
3211 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3215 win32_rmdir(const char *dir)
3219 WCHAR wBuffer[MAX_PATH+1];
3220 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3221 return _wrmdir(PerlDir_mapW(wBuffer));
3223 return rmdir(PerlDir_mapA(dir));
3227 win32_chdir(const char *dir)
3235 WCHAR wBuffer[MAX_PATH+1];
3236 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3237 return _wchdir(wBuffer);
3243 win32_access(const char *path, int mode)
3247 WCHAR wBuffer[MAX_PATH+1];
3248 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3249 return _waccess(PerlDir_mapW(wBuffer), mode);
3251 return access(PerlDir_mapA(path), mode);
3255 win32_chmod(const char *path, int mode)
3259 WCHAR wBuffer[MAX_PATH+1];
3260 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3261 return _wchmod(PerlDir_mapW(wBuffer), mode);
3263 return chmod(PerlDir_mapA(path), mode);
3268 create_command_line(char *cname, STRLEN clen, const char * const *args)
3275 bool bat_file = FALSE;
3276 bool cmd_shell = FALSE;
3277 bool dumb_shell = FALSE;
3278 bool extra_quotes = FALSE;
3279 bool quote_next = FALSE;
3282 cname = (char*)args[0];
3284 /* The NT cmd.exe shell has the following peculiarity that needs to be
3285 * worked around. It strips a leading and trailing dquote when any
3286 * of the following is true:
3287 * 1. the /S switch was used
3288 * 2. there are more than two dquotes
3289 * 3. there is a special character from this set: &<>()@^|
3290 * 4. no whitespace characters within the two dquotes
3291 * 5. string between two dquotes isn't an executable file
3292 * To work around this, we always add a leading and trailing dquote
3293 * to the string, if the first argument is either "cmd.exe" or "cmd",
3294 * and there were at least two or more arguments passed to cmd.exe
3295 * (not including switches).
3296 * XXX the above rules (from "cmd /?") don't seem to be applied
3297 * always, making for the convolutions below :-(
3301 clen = strlen(cname);
3304 && (stricmp(&cname[clen-4], ".bat") == 0
3305 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3311 char *exe = strrchr(cname, '/');
3312 char *exe2 = strrchr(cname, '\\');
3319 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3323 else if (stricmp(exe, "command.com") == 0
3324 || stricmp(exe, "command") == 0)
3331 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3332 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3333 STRLEN curlen = strlen(arg);
3334 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3335 len += 2; /* assume quoting needed (worst case) */
3337 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3339 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3342 New(1310, cmd, len, char);
3347 extra_quotes = TRUE;
3350 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3352 STRLEN curlen = strlen(arg);
3354 /* we want to protect empty arguments and ones with spaces with
3355 * dquotes, but only if they aren't already there */
3360 else if (quote_next) {
3361 /* see if it really is multiple arguments pretending to
3362 * be one and force a set of quotes around it */
3363 if (*find_next_space(arg))
3366 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3368 while (i < curlen) {
3369 if (isSPACE(arg[i])) {
3372 else if (arg[i] == '"') {
3395 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3397 /* is there a next argument? */
3398 if (args[index+1]) {
3399 /* are there two or more next arguments? */
3400 if (args[index+2]) {
3402 extra_quotes = TRUE;
3405 /* single argument, force quoting if it has spaces */
3421 qualified_path(const char *cmd)
3425 char *fullcmd, *curfullcmd;
3431 fullcmd = (char*)cmd;
3433 if (*fullcmd == '/' || *fullcmd == '\\')
3440 pathstr = PerlEnv_getenv("PATH");
3441 New(0, fullcmd, MAX_PATH+1, char);
3442 curfullcmd = fullcmd;
3447 /* start by appending the name to the current prefix */
3448 strcpy(curfullcmd, cmd);
3449 curfullcmd += cmdlen;
3451 /* if it doesn't end with '.', or has no extension, try adding
3452 * a trailing .exe first */
3453 if (cmd[cmdlen-1] != '.'
3454 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3456 strcpy(curfullcmd, ".exe");
3457 res = GetFileAttributes(fullcmd);
3458 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3463 /* that failed, try the bare name */
3464 res = GetFileAttributes(fullcmd);
3465 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3468 /* quit if no other path exists, or if cmd already has path */
3469 if (!pathstr || !*pathstr || has_slash)
3472 /* skip leading semis */
3473 while (*pathstr == ';')
3476 /* build a new prefix from scratch */
3477 curfullcmd = fullcmd;
3478 while (*pathstr && *pathstr != ';') {
3479 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3480 pathstr++; /* skip initial '"' */
3481 while (*pathstr && *pathstr != '"') {
3482 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3483 *curfullcmd++ = *pathstr;
3487 pathstr++; /* skip trailing '"' */
3490 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3491 *curfullcmd++ = *pathstr;
3496 pathstr++; /* skip trailing semi */
3497 if (curfullcmd > fullcmd /* append a dir separator */
3498 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3500 *curfullcmd++ = '\\';
3508 /* The following are just place holders.
3509 * Some hosts may provide and environment that the OS is
3510 * not tracking, therefore, these host must provide that
3511 * environment and the current directory to CreateProcess
3515 win32_get_childenv(void)
3521 win32_free_childenv(void* d)
3526 win32_clearenv(void)
3528 char *envv = GetEnvironmentStrings();
3532 char *end = strchr(cur,'=');
3533 if (end && end != cur) {
3535 SetEnvironmentVariable(cur, NULL);
3537 cur = end + strlen(end+1)+2;
3539 else if ((len = strlen(cur)))
3542 FreeEnvironmentStrings(envv);
3546 win32_get_childdir(void)
3550 char szfilename[(MAX_PATH+1)*2];
3552 WCHAR wfilename[MAX_PATH+1];
3553 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3554 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3557 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3560 New(0, ptr, strlen(szfilename)+1, char);
3561 strcpy(ptr, szfilename);
3566 win32_free_childdir(char* d)
3573 /* XXX this needs to be made more compatible with the spawnvp()
3574 * provided by the various RTLs. In particular, searching for
3575 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3576 * This doesn't significantly affect perl itself, because we
3577 * always invoke things using PERL5SHELL if a direct attempt to
3578 * spawn the executable fails.
3580 * XXX splitting and rejoining the commandline between do_aspawn()
3581 * and win32_spawnvp() could also be avoided.
3585 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3587 #ifdef USE_RTL_SPAWNVP
3588 return spawnvp(mode, cmdname, (char * const *)argv);
3595 STARTUPINFO StartupInfo;
3596 PROCESS_INFORMATION ProcessInformation;
3599 char *fullcmd = Nullch;
3600 char *cname = (char *)cmdname;
3604 clen = strlen(cname);
3605 /* if command name contains dquotes, must remove them */
3606 if (strchr(cname, '"')) {
3608 New(0,cname,clen+1,char);
3621 cmd = create_command_line(cname, clen, argv);
3623 env = PerlEnv_get_childenv();
3624 dir = PerlEnv_get_childdir();
3627 case P_NOWAIT: /* asynch + remember result */
3628 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3633 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3636 create |= CREATE_NEW_PROCESS_GROUP;
3639 case P_WAIT: /* synchronous execution */
3641 default: /* invalid mode */
3646 memset(&StartupInfo,0,sizeof(StartupInfo));
3647 StartupInfo.cb = sizeof(StartupInfo);
3648 memset(&tbl,0,sizeof(tbl));
3649 PerlEnv_get_child_IO(&tbl);
3650 StartupInfo.dwFlags = tbl.dwFlags;
3651 StartupInfo.dwX = tbl.dwX;
3652 StartupInfo.dwY = tbl.dwY;
3653 StartupInfo.dwXSize = tbl.dwXSize;
3654 StartupInfo.dwYSize = tbl.dwYSize;
3655 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3656 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3657 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3658 StartupInfo.wShowWindow = tbl.wShowWindow;
3659 StartupInfo.hStdInput = tbl.childStdIn;
3660 StartupInfo.hStdOutput = tbl.childStdOut;
3661 StartupInfo.hStdError = tbl.childStdErr;
3662 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3663 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3664 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3666 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3669 create |= CREATE_NEW_CONSOLE;
3671 if (w32_use_showwindow) {
3672 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3673 StartupInfo.wShowWindow = w32_showwindow;
3676 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3679 if (!CreateProcess(cname, /* search PATH to find executable */
3680 cmd, /* executable, and its arguments */
3681 NULL, /* process attributes */
3682 NULL, /* thread attributes */
3683 TRUE, /* inherit handles */
3684 create, /* creation flags */
3685 (LPVOID)env, /* inherit environment */
3686 dir, /* inherit cwd */
3688 &ProcessInformation))
3690 /* initial NULL argument to CreateProcess() does a PATH
3691 * search, but it always first looks in the directory
3692 * where the current process was started, which behavior
3693 * is undesirable for backward compatibility. So we
3694 * jump through our own hoops by picking out the path
3695 * we really want it to use. */
3697 fullcmd = qualified_path(cname);
3699 if (cname != cmdname)
3702 DEBUG_p(PerlIO_printf(Perl_debug_log,
3703 "Retrying [%s] with same args\n",
3713 if (mode == P_NOWAIT) {
3714 /* asynchronous spawn -- store handle, return PID */
3715 ret = (int)ProcessInformation.dwProcessId;
3716 if (IsWin95() && ret < 0)
3719 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3720 w32_child_pids[w32_num_children] = (DWORD)ret;
3725 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3726 /* FIXME: if msgwait returned due to message perhaps forward the
3727 "signal" to the process
3729 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3731 CloseHandle(ProcessInformation.hProcess);
3734 CloseHandle(ProcessInformation.hThread);
3737 PerlEnv_free_childenv(env);
3738 PerlEnv_free_childdir(dir);
3740 if (cname != cmdname)
3747 win32_execv(const char *cmdname, const char *const *argv)
3751 /* if this is a pseudo-forked child, we just want to spawn
3752 * the new program, and return */
3754 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3756 return execv(cmdname, (char *const *)argv);
3760 win32_execvp(const char *cmdname, const char *const *argv)
3764 /* if this is a pseudo-forked child, we just want to spawn
3765 * the new program, and return */
3766 if (w32_pseudo_id) {
3767 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3776 return execvp(cmdname, (char *const *)argv);
3780 win32_perror(const char *str)
3786 win32_setbuf(FILE *pf, char *buf)
3792 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3794 return setvbuf(pf, buf, type, size);
3798 win32_flushall(void)
3804 win32_fcloseall(void)
3810 win32_fgets(char *s, int n, FILE *pf)
3812 return fgets(s, n, pf);
3822 win32_fgetc(FILE *pf)
3828 win32_putc(int c, FILE *pf)
3834 win32_puts(const char *s)
3846 win32_putchar(int c)
3853 #ifndef USE_PERL_SBRK
3855 static char *committed = NULL; /* XXX threadead */
3856 static char *base = NULL; /* XXX threadead */
3857 static char *reserved = NULL; /* XXX threadead */
3858 static char *brk = NULL; /* XXX threadead */
3859 static DWORD pagesize = 0; /* XXX threadead */
3860 static DWORD allocsize = 0; /* XXX threadead */
3868 GetSystemInfo(&info);
3869 /* Pretend page size is larger so we don't perpetually
3870 * call the OS to commit just one page ...
3872 pagesize = info.dwPageSize << 3;
3873 allocsize = info.dwAllocationGranularity;
3875 /* This scheme fails eventually if request for contiguous
3876 * block is denied so reserve big blocks - this is only
3877 * address space not memory ...
3879 if (brk+need >= reserved)
3881 DWORD size = 64*1024*1024;
3883 if (committed && reserved && committed < reserved)
3885 /* Commit last of previous chunk cannot span allocations */
3886 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3888 committed = reserved;
3890 /* Reserve some (more) space
3891 * Note this is a little sneaky, 1st call passes NULL as reserved
3892 * so lets system choose where we start, subsequent calls pass
3893 * the old end address so ask for a contiguous block
3895 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3898 reserved = addr+size;
3913 if (brk > committed)
3915 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3916 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3931 win32_malloc(size_t size)
3933 return malloc(size);
3937 win32_calloc(size_t numitems, size_t size)
3939 return calloc(numitems,size);
3943 win32_realloc(void *block, size_t size)
3945 return realloc(block,size);
3949 win32_free(void *block)
3956 win32_open_osfhandle(long handle, int flags)
3958 #ifdef USE_FIXED_OSFHANDLE
3960 return my_open_osfhandle(handle, flags);
3962 return _open_osfhandle(handle, flags);
3966 win32_get_osfhandle(int fd)
3968 return _get_osfhandle(fd);
3972 win32_dynaload(const char* filename)
3976 char buf[MAX_PATH+1];
3979 /* LoadLibrary() doesn't recognize forward slashes correctly,
3980 * so turn 'em back. */
3981 first = strchr(filename, '/');
3983 STRLEN len = strlen(filename);
3984 if (len <= MAX_PATH) {
3985 strcpy(buf, filename);
3986 filename = &buf[first - filename];
3988 if (*filename == '/')
3989 *(char*)filename = '\\';
3996 WCHAR wfilename[MAX_PATH+1];
3997 A2WHELPER(filename, wfilename, sizeof(wfilename));
3998 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4001 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4011 XS(w32_SetChildShowWindow)
4014 BOOL use_showwindow = w32_use_showwindow;
4015 /* use "unsigned short" because Perl has redefined "WORD" */
4016 unsigned short showwindow = w32_showwindow;
4019 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4021 if (items == 0 || !SvOK(ST(0)))
4022 w32_use_showwindow = FALSE;
4024 w32_use_showwindow = TRUE;
4025 w32_showwindow = (unsigned short)SvIV(ST(0));
4030 ST(0) = sv_2mortal(newSViv(showwindow));
4032 ST(0) = &PL_sv_undef;
4040 /* Make the host for current directory */
4041 char* ptr = PerlEnv_get_childdir();
4044 * then it worked, set PV valid,
4045 * else return 'undef'
4048 SV *sv = sv_newmortal();
4050 PerlEnv_free_childdir(ptr);
4052 #ifndef INCOMPLETE_TAINTS
4069 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4070 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4077 XS(w32_GetNextAvailDrive)
4081 char root[] = "_:\\";
4086 if (GetDriveType(root) == 1) {
4095 XS(w32_GetLastError)
4099 XSRETURN_IV(GetLastError());
4103 XS(w32_SetLastError)
4107 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4108 SetLastError(SvIV(ST(0)));
4116 char *name = w32_getlogin_buffer;
4117 DWORD size = sizeof(w32_getlogin_buffer);
4119 if (GetUserName(name,&size)) {
4120 /* size includes NULL */
4121 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4131 char name[MAX_COMPUTERNAME_LENGTH+1];
4132 DWORD size = sizeof(name);
4134 if (GetComputerName(name,&size)) {
4135 /* size does NOT include NULL :-( */
4136 ST(0) = sv_2mortal(newSVpvn(name,size));
4147 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4148 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4149 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4153 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4154 GetProcAddress(hNetApi32, "NetApiBufferFree");
4155 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4156 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4159 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4160 /* this way is more reliable, in case user has a local account. */
4162 DWORD dnamelen = sizeof(dname);
4164 DWORD wki100_platform_id;
4165 LPWSTR wki100_computername;
4166 LPWSTR wki100_langroup;
4167 DWORD wki100_ver_major;
4168 DWORD wki100_ver_minor;
4170 /* NERR_Success *is* 0*/
4171 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4172 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4173 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4174 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4177 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4178 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4180 pfnNetApiBufferFree(pwi);
4181 FreeLibrary(hNetApi32);
4184 FreeLibrary(hNetApi32);
4187 /* Win95 doesn't have NetWksta*(), so do it the old way */
4189 DWORD size = sizeof(name);
4191 FreeLibrary(hNetApi32);
4192 if (GetUserName(name,&size)) {
4193 char sid[ONE_K_BUFSIZE];
4194 DWORD sidlen = sizeof(sid);
4196 DWORD dnamelen = sizeof(dname);
4198 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4199 dname, &dnamelen, &snu)) {
4200 XSRETURN_PV(dname); /* all that for this */
4212 DWORD flags, filecomplen;
4213 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4214 &flags, fsname, sizeof(fsname))) {
4215 if (GIMME_V == G_ARRAY) {
4216 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4217 XPUSHs(sv_2mortal(newSViv(flags)));
4218 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4223 XSRETURN_PV(fsname);
4229 XS(w32_GetOSVersion)
4232 OSVERSIONINFOA osver;
4235 OSVERSIONINFOW osverw;
4236 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4237 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4238 if (!GetVersionExW(&osverw)) {
4241 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4242 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4243 osver.dwMajorVersion = osverw.dwMajorVersion;
4244 osver.dwMinorVersion = osverw.dwMinorVersion;
4245 osver.dwBuildNumber = osverw.dwBuildNumber;
4246 osver.dwPlatformId = osverw.dwPlatformId;
4249 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4250 if (!GetVersionExA(&osver)) {
4253 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4255 XPUSHs(newSViv(osver.dwMajorVersion));
4256 XPUSHs(newSViv(osver.dwMinorVersion));
4257 XPUSHs(newSViv(osver.dwBuildNumber));
4258 XPUSHs(newSViv(osver.dwPlatformId));
4267 XSRETURN_IV(IsWinNT());
4275 XSRETURN_IV(IsWin95());
4279 XS(w32_FormatMessage)
4283 char msgbuf[ONE_K_BUFSIZE];
4286 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4289 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4290 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4291 &source, SvIV(ST(0)), 0,
4292 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4294 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4295 XSRETURN_PV(msgbuf);
4299 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4300 &source, SvIV(ST(0)), 0,
4301 msgbuf, sizeof(msgbuf)-1, NULL))
4302 XSRETURN_PV(msgbuf);
4315 PROCESS_INFORMATION stProcInfo;
4316 STARTUPINFO stStartInfo;
4317 BOOL bSuccess = FALSE;
4320 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4322 cmd = SvPV_nolen(ST(0));
4323 args = SvPV_nolen(ST(1));
4325 env = PerlEnv_get_childenv();
4326 dir = PerlEnv_get_childdir();
4328 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4329 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4330 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4331 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4334 cmd, /* Image path */
4335 args, /* Arguments for command line */
4336 NULL, /* Default process security */
4337 NULL, /* Default thread security */
4338 FALSE, /* Must be TRUE to use std handles */
4339 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4340 env, /* Inherit our environment block */
4341 dir, /* Inherit our currrent directory */
4342 &stStartInfo, /* -> Startup info */
4343 &stProcInfo)) /* <- Process info (if OK) */
4345 int pid = (int)stProcInfo.dwProcessId;
4346 if (IsWin95() && pid < 0)
4348 sv_setiv(ST(2), pid);
4349 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4352 PerlEnv_free_childenv(env);
4353 PerlEnv_free_childdir(dir);
4354 XSRETURN_IV(bSuccess);
4358 XS(w32_GetTickCount)
4361 DWORD msec = GetTickCount();
4369 XS(w32_GetShortPathName)
4376 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4378 shortpath = sv_mortalcopy(ST(0));
4379 SvUPGRADE(shortpath, SVt_PV);
4380 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4383 /* src == target is allowed */
4385 len = GetShortPathName(SvPVX(shortpath),
4388 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4390 SvCUR_set(shortpath,len);
4398 XS(w32_GetFullPathName)
4407 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4410 fullpath = sv_mortalcopy(filename);
4411 SvUPGRADE(fullpath, SVt_PV);
4412 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4416 len = GetFullPathName(SvPVX(filename),
4420 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4422 if (GIMME_V == G_ARRAY) {
4424 XST_mPV(1,filepart);
4425 len = filepart - SvPVX(fullpath);
4428 SvCUR_set(fullpath,len);
4436 XS(w32_GetLongPathName)
4440 char tmpbuf[MAX_PATH+1];
4445 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4448 pathstr = SvPV(path,len);
4449 strcpy(tmpbuf, pathstr);
4450 pathstr = win32_longpath(tmpbuf);
4452 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4463 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4474 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4476 WCHAR wSourceFile[MAX_PATH+1];
4477 WCHAR wDestFile[MAX_PATH+1];
4478 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4479 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4480 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4481 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4484 char szSourceFile[MAX_PATH+1];
4485 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4486 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4495 Perl_init_os_extras(void)
4498 char *file = __FILE__;
4501 /* these names are Activeware compatible */
4502 newXS("Win32::GetCwd", w32_GetCwd, file);
4503 newXS("Win32::SetCwd", w32_SetCwd, file);
4504 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4505 newXS("Win32::GetLastError", w32_GetLastError, file);
4506 newXS("Win32::SetLastError", w32_SetLastError, file);
4507 newXS("Win32::LoginName", w32_LoginName, file);
4508 newXS("Win32::NodeName", w32_NodeName, file);
4509 newXS("Win32::DomainName", w32_DomainName, file);
4510 newXS("Win32::FsType", w32_FsType, file);
4511 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4512 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4513 newXS("Win32::IsWin95", w32_IsWin95, file);
4514 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4515 newXS("Win32::Spawn", w32_Spawn, file);
4516 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4517 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4518 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4519 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4520 newXS("Win32::CopyFile", w32_CopyFile, file);
4521 newXS("Win32::Sleep", w32_Sleep, file);
4522 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4524 /* XXX Bloat Alert! The following Activeware preloads really
4525 * ought to be part of Win32::Sys::*, so they're not included
4528 /* LookupAccountName
4530 * InitiateSystemShutdown
4531 * AbortSystemShutdown
4532 * ExpandEnvrironmentStrings
4537 win32_signal_context(void)
4541 my_perl = PL_curinterp;
4542 PERL_SET_THX(my_perl);
4548 win32_ctrlhandler(DWORD dwCtrlType)
4550 dTHXa(PERL_GET_SIG_CONTEXT);
4555 switch(dwCtrlType) {
4556 case CTRL_CLOSE_EVENT:
4557 /* A signal that the system sends to all processes attached to a console when
4558 the user closes the console (either by choosing the Close command from the
4559 console window's System menu, or by choosing the End Task command from the
4562 if (do_raise(aTHX_ 1)) /* SIGHUP */
4563 sig_terminate(aTHX_ 1);
4567 /* A CTRL+c signal was received */
4568 if (do_raise(aTHX_ SIGINT))
4569 sig_terminate(aTHX_ SIGINT);
4572 case CTRL_BREAK_EVENT:
4573 /* A CTRL+BREAK signal was received */
4574 if (do_raise(aTHX_ SIGBREAK))
4575 sig_terminate(aTHX_ SIGBREAK);
4578 case CTRL_LOGOFF_EVENT:
4579 /* A signal that the system sends to all console processes when a user is logging
4580 off. This signal does not indicate which user is logging off, so no
4581 assumptions can be made.
4584 case CTRL_SHUTDOWN_EVENT:
4585 /* A signal that the system sends to all console processes when the system is
4588 if (do_raise(aTHX_ SIGTERM))
4589 sig_terminate(aTHX_ SIGTERM);
4599 Perl_win32_init(int *argcp, char ***argvp)
4601 /* Disable floating point errors, Perl will trap the ones we
4602 * care about. VC++ RTL defaults to switching these off
4603 * already, but the Borland RTL doesn't. Since we don't
4604 * want to be at the vendor's whim on the default, we set
4605 * it explicitly here.
4607 #if !defined(_ALPHA_) && !defined(__GNUC__)
4608 _control87(MCW_EM, MCW_EM);
4614 win32_get_child_IO(child_IO_table* ptbl)
4616 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4617 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4618 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4622 win32_signal(int sig, Sighandler_t subcode)
4625 if (sig < SIG_SIZE) {
4626 int save_errno = errno;
4627 Sighandler_t result = signal(sig, subcode);
4628 if (result == SIG_ERR) {
4629 result = w32_sighandler[sig];
4632 w32_sighandler[sig] = subcode;
4642 #ifdef HAVE_INTERP_INTERN
4646 win32_csighandler(int sig)
4649 dTHXa(PERL_GET_SIG_CONTEXT);
4650 Perl_warn(aTHX_ "Got signal %d",sig);
4656 Perl_sys_intern_init(pTHX)
4659 w32_perlshell_tokens = Nullch;
4660 w32_perlshell_vec = (char**)NULL;
4661 w32_perlshell_items = 0;
4662 w32_fdpid = newAV();
4663 New(1313, w32_children, 1, child_tab);
4664 w32_num_children = 0;
4665 # ifdef USE_ITHREADS
4667 New(1313, w32_pseudo_children, 1, child_tab);
4668 w32_num_pseudo_children = 0;
4670 w32_init_socktype = 0;
4673 for (i=0; i < SIG_SIZE; i++) {
4674 w32_sighandler[i] = SIG_DFL;
4676 if (my_perl == PL_curinterp) {
4677 /* Force C runtime signal stuff to set its console handler */
4678 signal(SIGINT,&win32_csighandler);
4679 signal(SIGBREAK,&win32_csighandler);
4680 /* Push our handler on top */
4681 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4686 Perl_sys_intern_clear(pTHX)
4688 Safefree(w32_perlshell_tokens);
4689 Safefree(w32_perlshell_vec);
4690 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4691 Safefree(w32_children);
4693 KillTimer(NULL,w32_timerid);
4696 if (my_perl == PL_curinterp) {
4697 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4699 # ifdef USE_ITHREADS
4700 Safefree(w32_pseudo_children);
4704 # ifdef USE_ITHREADS
4707 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4709 dst->perlshell_tokens = Nullch;
4710 dst->perlshell_vec = (char**)NULL;
4711 dst->perlshell_items = 0;
4712 dst->fdpid = newAV();
4713 Newz(1313, dst->children, 1, child_tab);
4715 Newz(1313, dst->pseudo_children, 1, child_tab);
4716 dst->thr_intern.Winit_socktype = 0;
4718 dst->poll_count = 0;
4719 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4721 # endif /* USE_ITHREADS */
4722 #endif /* HAVE_INTERP_INTERN */
4725 win32_free_argvw(pTHX_ void *ptr)
4727 char** argv = (char**)ptr;
4735 win32_argv2utf8(int argc, char** argv)
4740 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4741 if (lpwStr && argc) {
4743 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4744 Newz(0, psz, length, char);
4745 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4748 call_atexit(win32_free_argvw, argv);
4750 GlobalFree((HGLOBAL)lpwStr);