3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
18 #ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */
19 # include <shellapi.h>
21 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
27 /* #include "config.h" */
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
38 #define PERL_NO_GET_CONTEXT
44 /* assert.h conflicts with #define of assert in perl.h */
51 #if defined(_MSC_VER) || defined(__MINGW32__)
52 #include <sys/utime.h>
57 /* Mingw32 defaults to globing command line
58 * So we turn it off like this:
63 #if defined(__MINGW32__)
64 /* Mingw32 is missing some prototypes */
65 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
72 #if defined(__BORLANDC__)
74 # define _utimbuf utimbuf
79 #define EXECF_SPAWN_NOWAIT 3
81 #if defined(PERL_IMPLICIT_SYS)
82 # undef win32_get_privlib
83 # define win32_get_privlib g_win32_get_privlib
84 # undef win32_get_sitelib
85 # define win32_get_sitelib g_win32_get_sitelib
86 # undef win32_get_vendorlib
87 # define win32_get_vendorlib g_win32_get_vendorlib
89 # define do_spawn g_do_spawn
91 # define getlogin g_getlogin
94 static void get_shell(void);
95 static long tokenize(const char *str, char **dest, char ***destv);
96 int do_spawn2(char *cmd, int exectype);
97 static BOOL has_shell_metachars(char *ptr);
98 static long filetime_to_clock(PFILETIME ft);
99 static BOOL filetime_from_time(PFILETIME ft, time_t t);
100 static char * get_emd_part(SV **leading, char *trailing, ...);
101 static void remove_dead_process(long deceased);
102 static long find_pid(int pid);
103 static char * qualified_path(const char *cmd);
104 static char * win32_get_xlib(const char *pl, const char *xlib,
105 const char *libname);
108 static void remove_dead_pseudo_process(long child);
109 static long find_pseudo_pid(int pid);
113 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
114 char w32_module_name[MAX_PATH+1];
117 static DWORD w32_platform = (DWORD)-1;
119 #define ONE_K_BUFSIZE 1024
124 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
130 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
134 set_w32_module_name(void)
137 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
138 ? GetModuleHandle(NULL)
139 : w32_perldll_handle),
140 w32_module_name, sizeof(w32_module_name));
142 /* try to get full path to binary (which may be mangled when perl is
143 * run from a 16-bit app) */
144 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
145 (void)win32_longpath(w32_module_name);
146 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
148 /* normalize to forward slashes */
149 ptr = w32_module_name;
157 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
159 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
161 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
164 const char *subkey = "Software\\Perl";
168 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
169 if (retval == ERROR_SUCCESS) {
171 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
172 if (retval == ERROR_SUCCESS
173 && (type == REG_SZ || type == REG_EXPAND_SZ))
177 *svp = sv_2mortal(newSVpvn("",0));
178 SvGROW(*svp, datalen);
179 retval = RegQueryValueEx(handle, valuename, 0, NULL,
180 (PBYTE)SvPVX(*svp), &datalen);
181 if (retval == ERROR_SUCCESS) {
183 SvCUR_set(*svp,datalen-1);
191 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
193 get_regstr(const char *valuename, SV **svp)
195 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
197 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
201 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
203 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
207 char mod_name[MAX_PATH+1];
211 int oldsize, newsize;
214 va_start(ap, trailing_path);
215 strip = va_arg(ap, char *);
217 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
218 baselen = strlen(base);
220 if (!*w32_module_name) {
221 set_w32_module_name();
223 strcpy(mod_name, w32_module_name);
224 ptr = strrchr(mod_name, '/');
225 while (ptr && strip) {
226 /* look for directories to skip back */
229 ptr = strrchr(mod_name, '/');
230 /* avoid stripping component if there is no slash,
231 * or it doesn't match ... */
232 if (!ptr || stricmp(ptr+1, strip) != 0) {
233 /* ... but not if component matches m|5\.$patchlevel.*| */
234 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
235 && strncmp(strip, base, baselen) == 0
236 && strncmp(ptr+1, base, baselen) == 0))
242 strip = va_arg(ap, char *);
250 strcpy(++ptr, trailing_path);
252 /* only add directory if it exists */
253 if (GetFileAttributes(mod_name) != (DWORD) -1) {
254 /* directory exists */
257 *prev_pathp = sv_2mortal(newSVpvn("",0));
258 sv_catpvn(*prev_pathp, ";", 1);
259 sv_catpv(*prev_pathp, mod_name);
260 return SvPVX(*prev_pathp);
267 win32_get_privlib(const char *pl)
270 char *stdlib = "lib";
271 char buffer[MAX_PATH+1];
274 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
275 sprintf(buffer, "%s-%s", stdlib, pl);
276 if (!get_regstr(buffer, &sv))
277 (void)get_regstr(stdlib, &sv);
279 /* $stdlib .= ";$EMD/../../lib" */
280 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
284 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
288 char pathstr[MAX_PATH+1];
294 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
295 sprintf(regstr, "%s-%s", xlib, pl);
296 (void)get_regstr(regstr, &sv1);
299 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
300 sprintf(pathstr, "%s/%s/lib", libname, pl);
301 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
303 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
304 (void)get_regstr(xlib, &sv2);
307 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
308 sprintf(pathstr, "%s/lib", libname);
309 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
318 sv_catpvn(sv1, ";", 1);
325 win32_get_sitelib(const char *pl)
327 return win32_get_xlib(pl, "sitelib", "site");
330 #ifndef PERL_VENDORLIB_NAME
331 # define PERL_VENDORLIB_NAME "vendor"
335 win32_get_vendorlib(const char *pl)
337 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
341 has_shell_metachars(char *ptr)
347 * Scan string looking for redirection (< or >) or pipe
348 * characters (|) that are not in a quoted string.
349 * Shell variable interpolation (%VAR%) can also happen inside strings.
381 #if !defined(PERL_IMPLICIT_SYS)
382 /* since the current process environment is being updated in util.c
383 * the library functions will get the correct environment
386 Perl_my_popen(pTHX_ char *cmd, char *mode)
389 #define fixcmd(x) { \
390 char *pspace = strchr((x),' '); \
393 while (p < pspace) { \
404 PERL_FLUSHALL_FOR_CHILD;
405 return win32_popen(cmd, mode);
409 Perl_my_pclose(pTHX_ PerlIO *fp)
411 return win32_pclose(fp);
415 DllExport unsigned long
418 static OSVERSIONINFO osver;
420 if (osver.dwPlatformId != w32_platform) {
421 memset(&osver, 0, sizeof(OSVERSIONINFO));
422 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
423 GetVersionEx(&osver);
424 w32_platform = osver.dwPlatformId;
426 return (unsigned long)w32_platform;
436 return -((int)w32_pseudo_id);
439 /* Windows 9x appears to always reports a pid for threads and processes
440 * that has the high bit set. So we treat the lower 31 bits as the
441 * "real" PID for Perl's purposes. */
442 if (IsWin95() && pid < 0)
447 /* Tokenize a string. Words are null-separated, and the list
448 * ends with a doubled null. Any character (except null and
449 * including backslash) may be escaped by preceding it with a
450 * backslash (the backslash will be stripped).
451 * Returns number of words in result buffer.
454 tokenize(const char *str, char **dest, char ***destv)
456 char *retstart = Nullch;
457 char **retvstart = 0;
461 int slen = strlen(str);
463 register char **retv;
464 New(1307, ret, slen+2, char);
465 New(1308, retv, (slen+3)/2, char*);
473 if (*ret == '\\' && *str)
475 else if (*ret == ' ') {
491 retvstart[items] = Nullch;
504 if (!w32_perlshell_tokens) {
505 /* we don't use COMSPEC here for two reasons:
506 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
507 * uncontrolled unportability of the ensuing scripts.
508 * 2. PERL5SHELL could be set to a shell that may not be fit for
509 * interactive use (which is what most programs look in COMSPEC
512 const char* defaultshell = (IsWinNT()
513 ? "cmd.exe /x/c" : "command.com /c");
514 const char *usershell = PerlEnv_getenv("PERL5SHELL");
515 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
516 &w32_perlshell_tokens,
522 do_aspawn(void *vreally, void **vmark, void **vsp)
525 SV *really = (SV*)vreally;
526 SV **mark = (SV**)vmark;
538 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
540 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
545 while (++mark <= sp) {
546 if (*mark && (str = SvPV_nolen(*mark)))
553 status = win32_spawnvp(flag,
554 (const char*)(really ? SvPV_nolen(really) : argv[0]),
555 (const char* const*)argv);
557 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
558 /* possible shell-builtin, invoke with shell */
560 sh_items = w32_perlshell_items;
562 argv[index+sh_items] = argv[index];
563 while (--sh_items >= 0)
564 argv[sh_items] = w32_perlshell_vec[sh_items];
566 status = win32_spawnvp(flag,
567 (const char*)(really ? SvPV_nolen(really) : argv[0]),
568 (const char* const*)argv);
571 if (flag == P_NOWAIT) {
573 PL_statusvalue = -1; /* >16bits hint for pp_system() */
577 if (ckWARN(WARN_EXEC))
578 Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
583 PL_statusvalue = status;
589 /* returns pointer to the next unquoted space or the end of the string */
591 find_next_space(const char *s)
593 bool in_quotes = FALSE;
595 /* ignore doubled backslashes, or backslash+quote */
596 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
599 /* keep track of when we're within quotes */
600 else if (*s == '"') {
602 in_quotes = !in_quotes;
604 /* break it up only at spaces that aren't in quotes */
605 else if (!in_quotes && isSPACE(*s))
614 do_spawn2(char *cmd, int exectype)
621 BOOL needToTry = TRUE;
624 /* Save an extra exec if possible. See if there are shell
625 * metacharacters in it */
626 if (!has_shell_metachars(cmd)) {
627 New(1301,argv, strlen(cmd) / 2 + 2, char*);
628 New(1302,cmd2, strlen(cmd) + 1, char);
631 for (s = cmd2; *s;) {
632 while (*s && isSPACE(*s))
636 s = find_next_space(s);
644 status = win32_spawnvp(P_WAIT, argv[0],
645 (const char* const*)argv);
647 case EXECF_SPAWN_NOWAIT:
648 status = win32_spawnvp(P_NOWAIT, argv[0],
649 (const char* const*)argv);
652 status = win32_execvp(argv[0], (const char* const*)argv);
655 if (status != -1 || errno == 0)
665 New(1306, argv, w32_perlshell_items + 2, char*);
666 while (++i < w32_perlshell_items)
667 argv[i] = w32_perlshell_vec[i];
672 status = win32_spawnvp(P_WAIT, argv[0],
673 (const char* const*)argv);
675 case EXECF_SPAWN_NOWAIT:
676 status = win32_spawnvp(P_NOWAIT, argv[0],
677 (const char* const*)argv);
680 status = win32_execvp(argv[0], (const char* const*)argv);
686 if (exectype == EXECF_SPAWN_NOWAIT) {
688 PL_statusvalue = -1; /* >16bits hint for pp_system() */
692 if (ckWARN(WARN_EXEC))
693 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
694 (exectype == EXECF_EXEC ? "exec" : "spawn"),
695 cmd, strerror(errno));
700 PL_statusvalue = status;
708 return do_spawn2(cmd, EXECF_SPAWN);
712 do_spawn_nowait(char *cmd)
714 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
718 Perl_do_exec(pTHX_ char *cmd)
720 do_spawn2(cmd, EXECF_EXEC);
724 /* The idea here is to read all the directory names into a string table
725 * (separated by nulls) and when one of the other dir functions is called
726 * return the pointer to the current file name.
729 win32_opendir(char *filename)
735 char scanname[MAX_PATH+3];
737 WIN32_FIND_DATAA aFindData;
738 WIN32_FIND_DATAW wFindData;
740 char buffer[MAX_PATH*2];
741 WCHAR wbuffer[MAX_PATH+1];
744 len = strlen(filename);
748 /* check to see if filename is a directory */
749 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
752 /* Get us a DIR structure */
753 Newz(1303, dirp, 1, DIR);
755 /* Create the search pattern */
756 strcpy(scanname, filename);
758 /* bare drive name means look in cwd for drive */
759 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
760 scanname[len++] = '.';
761 scanname[len++] = '/';
763 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
764 scanname[len++] = '/';
766 scanname[len++] = '*';
767 scanname[len] = '\0';
769 /* do the FindFirstFile call */
771 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
772 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
775 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
778 if (fh == INVALID_HANDLE_VALUE) {
779 DWORD err = GetLastError();
780 /* FindFirstFile() fails on empty drives! */
782 case ERROR_FILE_NOT_FOUND:
784 case ERROR_NO_MORE_FILES:
785 case ERROR_PATH_NOT_FOUND:
788 case ERROR_NOT_ENOUGH_MEMORY:
799 /* now allocate the first part of the string table for
800 * the filenames that we find.
803 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
807 ptr = aFindData.cFileName;
814 New(1304, dirp->start, dirp->size, char);
815 strcpy(dirp->start, ptr);
817 dirp->end = dirp->curr = dirp->start;
823 /* Readdir just returns the current string pointer and bumps the
824 * string pointer to the nDllExport entry.
826 DllExport struct direct *
827 win32_readdir(DIR *dirp)
832 /* first set up the structure to return */
833 len = strlen(dirp->curr);
834 strcpy(dirp->dirstr.d_name, dirp->curr);
835 dirp->dirstr.d_namlen = len;
838 dirp->dirstr.d_ino = dirp->curr - dirp->start;
840 /* Now set up for the next call to readdir */
841 dirp->curr += len + 1;
842 if (dirp->curr >= dirp->end) {
846 WIN32_FIND_DATAW wFindData;
847 WIN32_FIND_DATAA aFindData;
848 char buffer[MAX_PATH*2];
850 /* finding the next file that matches the wildcard
851 * (which should be all of them in this directory!).
854 res = FindNextFileW(dirp->handle, &wFindData);
856 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
861 res = FindNextFileA(dirp->handle, &aFindData);
863 ptr = aFindData.cFileName;
866 long endpos = dirp->end - dirp->start;
867 long newsize = endpos + strlen(ptr) + 1;
868 /* bump the string table size by enough for the
869 * new name and its null terminator */
870 while (newsize > dirp->size) {
871 long curpos = dirp->curr - dirp->start;
873 Renew(dirp->start, dirp->size, char);
874 dirp->curr = dirp->start + curpos;
876 strcpy(dirp->start + endpos, ptr);
877 dirp->end = dirp->start + newsize;
883 return &(dirp->dirstr);
889 /* Telldir returns the current string pointer position */
891 win32_telldir(DIR *dirp)
893 return (dirp->curr - dirp->start);
897 /* Seekdir moves the string pointer to a previously saved position
898 * (returned by telldir).
901 win32_seekdir(DIR *dirp, long loc)
903 dirp->curr = dirp->start + loc;
906 /* Rewinddir resets the string pointer to the start */
908 win32_rewinddir(DIR *dirp)
910 dirp->curr = dirp->start;
913 /* free the memory allocated by opendir */
915 win32_closedir(DIR *dirp)
918 if (dirp->handle != INVALID_HANDLE_VALUE)
919 FindClose(dirp->handle);
920 Safefree(dirp->start);
933 * Just pretend that everyone is a superuser. NT will let us know if
934 * we don\'t really have permission to do something.
937 #define ROOT_UID ((uid_t)0)
938 #define ROOT_GID ((gid_t)0)
967 return (auid == ROOT_UID ? 0 : -1);
973 return (agid == ROOT_GID ? 0 : -1);
980 char *buf = w32_getlogin_buffer;
981 DWORD size = sizeof(w32_getlogin_buffer);
982 if (GetUserName(buf,&size))
988 chown(const char *path, uid_t owner, gid_t group)
995 * XXX this needs strengthening (for PerlIO)
998 int mkstemp(const char *path)
1001 char buf[MAX_PATH+1];
1005 if (i++ > 10) { /* give up */
1009 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1013 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1023 long child = w32_num_children;
1024 while (--child >= 0) {
1025 if (w32_child_pids[child] == pid)
1032 remove_dead_process(long child)
1036 CloseHandle(w32_child_handles[child]);
1037 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1038 (w32_num_children-child-1), HANDLE);
1039 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1040 (w32_num_children-child-1), DWORD);
1047 find_pseudo_pid(int pid)
1050 long child = w32_num_pseudo_children;
1051 while (--child >= 0) {
1052 if (w32_pseudo_child_pids[child] == pid)
1059 remove_dead_pseudo_process(long child)
1063 CloseHandle(w32_pseudo_child_handles[child]);
1064 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1065 (w32_num_pseudo_children-child-1), HANDLE);
1066 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1067 (w32_num_pseudo_children-child-1), DWORD);
1068 w32_num_pseudo_children--;
1074 win32_kill(int pid, int sig)
1081 /* it is a pseudo-forked child */
1082 child = find_pseudo_pid(-pid);
1084 hProcess = w32_pseudo_child_handles[child];
1087 /* "Does process exist?" use of kill */
1090 /* kill -9 style un-graceful exit */
1091 if (TerminateThread(hProcess, sig)) {
1092 remove_dead_pseudo_process(child);
1097 /* We fake signals to pseudo-processes using Win32 message queue */
1098 if (PostThreadMessage(-pid,WM_USER,sig,0)) {
1099 /* It might be us ... */
1106 else if (IsWin95()) {
1114 child = find_pid(pid);
1116 hProcess = w32_child_handles[child];
1119 /* "Does process exist?" use of kill */
1122 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1125 default: /* For now be backwards compatible with perl5.6 */
1127 if (TerminateProcess(hProcess, sig)) {
1128 remove_dead_process(child);
1136 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1137 (IsWin95() ? -pid : pid));
1141 /* "Does process exist?" use of kill */
1144 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1147 default: /* For now be backwards compatible with perl5.6 */
1149 if (TerminateProcess(hProcess, sig)) {
1150 CloseHandle(hProcess);
1162 win32_stat(const char *path, struct stat *sbuf)
1165 char buffer[MAX_PATH+1];
1166 int l = strlen(path);
1168 WCHAR wbuffer[MAX_PATH+1];
1174 switch(path[l - 1]) {
1175 /* FindFirstFile() and stat() are buggy with a trailing
1176 * backslash, so change it to a forward slash :-( */
1178 strncpy(buffer, path, l-1);
1179 buffer[l - 1] = '/';
1183 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1185 if (l == 2 && isALPHA(path[0])) {
1186 buffer[0] = path[0];
1197 /* We *must* open & close the file once; otherwise file attribute changes */
1198 /* might not yet have propagated to "other" hard links of the same file. */
1199 /* This also gives us an opportunity to determine the number of links. */
1201 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1202 pwbuffer = PerlDir_mapW(wbuffer);
1203 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1206 path = PerlDir_mapA(path);
1208 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1210 if (handle != INVALID_HANDLE_VALUE) {
1211 BY_HANDLE_FILE_INFORMATION bhi;
1212 if (GetFileInformationByHandle(handle, &bhi))
1213 nlink = bhi.nNumberOfLinks;
1214 CloseHandle(handle);
1217 /* pwbuffer or path will be mapped correctly above */
1219 res = _wstat(pwbuffer, (struct _stat *)sbuf);
1222 res = stat(path, sbuf);
1224 sbuf->st_nlink = nlink;
1227 /* CRT is buggy on sharenames, so make sure it really isn't.
1228 * XXX using GetFileAttributesEx() will enable us to set
1229 * sbuf->st_*time (but note that's not available on the
1230 * Windows of 1995) */
1233 r = GetFileAttributesW(pwbuffer);
1236 r = GetFileAttributesA(path);
1238 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1239 /* sbuf may still contain old garbage since stat() failed */
1240 Zero(sbuf, 1, struct stat);
1241 sbuf->st_mode = S_IFDIR | S_IREAD;
1243 if (!(r & FILE_ATTRIBUTE_READONLY))
1244 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1249 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1250 && (path[2] == '\\' || path[2] == '/'))
1252 /* The drive can be inaccessible, some _stat()s are buggy */
1254 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1255 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1261 if (S_ISDIR(sbuf->st_mode))
1262 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1263 else if (S_ISREG(sbuf->st_mode)) {
1265 if (l >= 4 && path[l-4] == '.') {
1266 const char *e = path + l - 3;
1267 if (strnicmp(e,"exe",3)
1268 && strnicmp(e,"bat",3)
1269 && strnicmp(e,"com",3)
1270 && (IsWin95() || strnicmp(e,"cmd",3)))
1271 sbuf->st_mode &= ~S_IEXEC;
1273 sbuf->st_mode |= S_IEXEC;
1276 sbuf->st_mode &= ~S_IEXEC;
1277 /* Propagate permissions to _group_ and _others_ */
1278 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1279 sbuf->st_mode |= (perms>>3) | (perms>>6);
1286 /* Find the longname of a given path. path is destructively modified.
1287 * It should have space for at least MAX_PATH characters. */
1289 win32_longpath(char *path)
1291 WIN32_FIND_DATA fdata;
1293 char tmpbuf[MAX_PATH+1];
1294 char *tmpstart = tmpbuf;
1301 if (isALPHA(path[0]) && path[1] == ':' &&
1302 (path[2] == '/' || path[2] == '\\'))
1305 *tmpstart++ = path[0];
1309 else if ((path[0] == '/' || path[0] == '\\') &&
1310 (path[1] == '/' || path[1] == '\\'))
1313 *tmpstart++ = path[0];
1314 *tmpstart++ = path[1];
1315 /* copy machine name */
1316 while (*start && *start != '/' && *start != '\\')
1317 *tmpstart++ = *start++;
1319 *tmpstart++ = *start;
1321 /* copy share name */
1322 while (*start && *start != '/' && *start != '\\')
1323 *tmpstart++ = *start++;
1327 if (sep == '/' || sep == '\\')
1331 /* walk up to slash */
1332 while (*start && *start != '/' && *start != '\\')
1335 /* discard doubled slashes */
1336 while (*start && (start[1] == '/' || start[1] == '\\'))
1340 /* stop and find full name of component */
1342 fhand = FindFirstFile(path,&fdata);
1343 if (fhand != INVALID_HANDLE_VALUE) {
1344 strcpy(tmpstart, fdata.cFileName);
1345 tmpstart += strlen(fdata.cFileName);
1353 /* failed a step, just return without side effects */
1354 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1359 strcpy(path,tmpbuf);
1364 win32_getenv(const char *name)
1367 WCHAR wBuffer[MAX_PATH+1];
1369 SV *curitem = Nullsv;
1372 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1373 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1376 needlen = GetEnvironmentVariableA(name,NULL,0);
1378 curitem = sv_2mortal(newSVpvn("", 0));
1382 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1383 needlen = GetEnvironmentVariableW(wBuffer,
1384 (WCHAR*)SvPVX(curitem),
1386 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1387 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1388 acuritem = sv_2mortal(newSVsv(curitem));
1389 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1393 SvGROW(curitem, needlen+1);
1394 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1396 } while (needlen >= SvLEN(curitem));
1397 SvCUR_set(curitem, needlen);
1401 /* allow any environment variables that begin with 'PERL'
1402 to be stored in the registry */
1403 if (strncmp(name, "PERL", 4) == 0)
1404 (void)get_regstr(name, &curitem);
1406 if (curitem && SvCUR(curitem))
1407 return SvPVX(curitem);
1413 win32_putenv(const char *name)
1420 int length, relval = -1;
1424 length = strlen(name)+1;
1425 New(1309,wCuritem,length,WCHAR);
1426 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1427 wVal = wcschr(wCuritem, '=');
1430 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1436 New(1309,curitem,strlen(name)+1,char);
1437 strcpy(curitem, name);
1438 val = strchr(curitem, '=');
1440 /* The sane way to deal with the environment.
1441 * Has these advantages over putenv() & co.:
1442 * * enables us to store a truly empty value in the
1443 * environment (like in UNIX).
1444 * * we don't have to deal with RTL globals, bugs and leaks.
1446 * Why you may want to enable USE_WIN32_RTL_ENV:
1447 * * environ[] and RTL functions will not reflect changes,
1448 * which might be an issue if extensions want to access
1449 * the env. via RTL. This cuts both ways, since RTL will
1450 * not see changes made by extensions that call the Win32
1451 * functions directly, either.
1455 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1465 filetime_to_clock(PFILETIME ft)
1467 __int64 qw = ft->dwHighDateTime;
1469 qw |= ft->dwLowDateTime;
1470 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1475 win32_times(struct tms *timebuf)
1480 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1482 timebuf->tms_utime = filetime_to_clock(&user);
1483 timebuf->tms_stime = filetime_to_clock(&kernel);
1484 timebuf->tms_cutime = 0;
1485 timebuf->tms_cstime = 0;
1488 /* That failed - e.g. Win95 fallback to clock() */
1489 clock_t t = clock();
1490 timebuf->tms_utime = t;
1491 timebuf->tms_stime = 0;
1492 timebuf->tms_cutime = 0;
1493 timebuf->tms_cstime = 0;
1498 /* fix utime() so it works on directories in NT */
1500 filetime_from_time(PFILETIME pFileTime, time_t Time)
1502 struct tm *pTM = localtime(&Time);
1503 SYSTEMTIME SystemTime;
1509 SystemTime.wYear = pTM->tm_year + 1900;
1510 SystemTime.wMonth = pTM->tm_mon + 1;
1511 SystemTime.wDay = pTM->tm_mday;
1512 SystemTime.wHour = pTM->tm_hour;
1513 SystemTime.wMinute = pTM->tm_min;
1514 SystemTime.wSecond = pTM->tm_sec;
1515 SystemTime.wMilliseconds = 0;
1517 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1518 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1522 win32_unlink(const char *filename)
1529 WCHAR wBuffer[MAX_PATH+1];
1532 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1533 pwBuffer = PerlDir_mapW(wBuffer);
1534 attrs = GetFileAttributesW(pwBuffer);
1535 if (attrs == 0xFFFFFFFF)
1537 if (attrs & FILE_ATTRIBUTE_READONLY) {
1538 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1539 ret = _wunlink(pwBuffer);
1541 (void)SetFileAttributesW(pwBuffer, attrs);
1544 ret = _wunlink(pwBuffer);
1547 filename = PerlDir_mapA(filename);
1548 attrs = GetFileAttributesA(filename);
1549 if (attrs == 0xFFFFFFFF)
1551 if (attrs & FILE_ATTRIBUTE_READONLY) {
1552 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1553 ret = unlink(filename);
1555 (void)SetFileAttributesA(filename, attrs);
1558 ret = unlink(filename);
1567 win32_utime(const char *filename, struct utimbuf *times)
1574 struct utimbuf TimeBuffer;
1575 WCHAR wbuffer[MAX_PATH+1];
1580 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1581 pwbuffer = PerlDir_mapW(wbuffer);
1582 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1585 filename = PerlDir_mapA(filename);
1586 rc = utime(filename, times);
1588 /* EACCES: path specifies directory or readonly file */
1589 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1592 if (times == NULL) {
1593 times = &TimeBuffer;
1594 time(×->actime);
1595 times->modtime = times->actime;
1598 /* This will (and should) still fail on readonly files */
1600 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1601 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1602 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1605 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1606 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1607 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1609 if (handle == INVALID_HANDLE_VALUE)
1612 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1613 filetime_from_time(&ftAccess, times->actime) &&
1614 filetime_from_time(&ftWrite, times->modtime) &&
1615 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1620 CloseHandle(handle);
1625 win32_uname(struct utsname *name)
1627 struct hostent *hep;
1628 STRLEN nodemax = sizeof(name->nodename)-1;
1629 OSVERSIONINFO osver;
1631 memset(&osver, 0, sizeof(OSVERSIONINFO));
1632 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1633 if (GetVersionEx(&osver)) {
1635 switch (osver.dwPlatformId) {
1636 case VER_PLATFORM_WIN32_WINDOWS:
1637 strcpy(name->sysname, "Windows");
1639 case VER_PLATFORM_WIN32_NT:
1640 strcpy(name->sysname, "Windows NT");
1642 case VER_PLATFORM_WIN32s:
1643 strcpy(name->sysname, "Win32s");
1646 strcpy(name->sysname, "Win32 Unknown");
1651 sprintf(name->release, "%d.%d",
1652 osver.dwMajorVersion, osver.dwMinorVersion);
1655 sprintf(name->version, "Build %d",
1656 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1657 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1658 if (osver.szCSDVersion[0]) {
1659 char *buf = name->version + strlen(name->version);
1660 sprintf(buf, " (%s)", osver.szCSDVersion);
1664 *name->sysname = '\0';
1665 *name->version = '\0';
1666 *name->release = '\0';
1670 hep = win32_gethostbyname("localhost");
1672 STRLEN len = strlen(hep->h_name);
1673 if (len <= nodemax) {
1674 strcpy(name->nodename, hep->h_name);
1677 strncpy(name->nodename, hep->h_name, nodemax);
1678 name->nodename[nodemax] = '\0';
1683 if (!GetComputerName(name->nodename, &sz))
1684 *name->nodename = '\0';
1687 /* machine (architecture) */
1691 GetSystemInfo(&info);
1693 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1694 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1695 switch (info.u.s.wProcessorArchitecture) {
1697 switch (info.wProcessorArchitecture) {
1699 case PROCESSOR_ARCHITECTURE_INTEL:
1700 arch = "x86"; break;
1701 case PROCESSOR_ARCHITECTURE_MIPS:
1702 arch = "mips"; break;
1703 case PROCESSOR_ARCHITECTURE_ALPHA:
1704 arch = "alpha"; break;
1705 case PROCESSOR_ARCHITECTURE_PPC:
1706 arch = "ppc"; break;
1708 arch = "unknown"; break;
1710 strcpy(name->machine, arch);
1715 /* Timing related stuff */
1718 win32_async_check(pTHX)
1722 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1723 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1725 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE)) {
1726 switch(msg.message) {
1729 /* Perhaps some other messages could map to signals ? ... */
1732 /* Treat WM_QUIT like SIGHUP? */
1733 CALL_FPTR(PL_sighandlerp)(1);
1737 /* We use WM_USER to fake kill() with other signals */
1739 CALL_FPTR(PL_sighandlerp)(msg.wParam);
1744 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1745 KillTimer(NULL,w32_timerid);
1747 /* Now fake a call to signal handler */
1748 CALL_FPTR(PL_sighandlerp)(14);
1752 /* Otherwise do normal Win32 thing - in case it is useful */
1754 TranslateMessage(&msg);
1755 DispatchMessage(&msg);
1761 /* Above or other stuff may have set a signal flag */
1762 if (PL_sig_pending) {
1769 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1771 /* We may need several goes at this - so compute when we stop */
1773 if (timeout != INFINITE) {
1774 ticks = GetTickCount();
1778 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1781 if (result == WAIT_TIMEOUT) {
1782 /* Ran out of time - explicit return of zero to avoid -ve if we
1783 have scheduling issues
1787 if (timeout != INFINITE) {
1788 ticks = GetTickCount();
1790 if (result == WAIT_OBJECT_0 + count) {
1791 /* Message has arrived - check it */
1792 if (win32_async_check(aTHX)) {
1793 /* was one of ours */
1798 /* Not timeout or message - one of handles is ready */
1802 /* compute time left to wait */
1803 ticks = timeout - ticks;
1804 /* If we are past the end say zero */
1805 return (ticks > 0) ? ticks : 0;
1809 win32_internal_wait(int *status, DWORD timeout)
1811 /* XXX this wait emulation only knows about processes
1812 * spawned via win32_spawnvp(P_NOWAIT, ...).
1816 DWORD exitcode, waitcode;
1819 if (w32_num_pseudo_children) {
1820 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1821 timeout, &waitcode);
1822 /* Time out here if there are no other children to wait for. */
1823 if (waitcode == WAIT_TIMEOUT) {
1824 if (!w32_num_children) {
1828 else if (waitcode != WAIT_FAILED) {
1829 if (waitcode >= WAIT_ABANDONED_0
1830 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1831 i = waitcode - WAIT_ABANDONED_0;
1833 i = waitcode - WAIT_OBJECT_0;
1834 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1835 *status = (int)((exitcode & 0xff) << 8);
1836 retval = (int)w32_pseudo_child_pids[i];
1837 remove_dead_pseudo_process(i);
1844 if (!w32_num_children) {
1849 /* if a child exists, wait for it to die */
1850 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1851 if (waitcode == WAIT_TIMEOUT) {
1854 if (waitcode != WAIT_FAILED) {
1855 if (waitcode >= WAIT_ABANDONED_0
1856 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1857 i = waitcode - WAIT_ABANDONED_0;
1859 i = waitcode - WAIT_OBJECT_0;
1860 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1861 *status = (int)((exitcode & 0xff) << 8);
1862 retval = (int)w32_child_pids[i];
1863 remove_dead_process(i);
1869 errno = GetLastError();
1874 win32_waitpid(int pid, int *status, int flags)
1877 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1880 if (pid == -1) /* XXX threadid == 1 ? */
1881 return win32_internal_wait(status, timeout);
1884 child = find_pseudo_pid(-pid);
1886 HANDLE hThread = w32_pseudo_child_handles[child];
1888 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1889 if (waitcode == WAIT_TIMEOUT) {
1892 else if (waitcode == WAIT_OBJECT_0) {
1893 if (GetExitCodeThread(hThread, &waitcode)) {
1894 *status = (int)((waitcode & 0xff) << 8);
1895 retval = (int)w32_pseudo_child_pids[child];
1896 remove_dead_pseudo_process(child);
1903 else if (IsWin95()) {
1912 child = find_pid(pid);
1914 hProcess = w32_child_handles[child];
1915 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1916 if (waitcode == WAIT_TIMEOUT) {
1919 else if (waitcode == WAIT_OBJECT_0) {
1920 if (GetExitCodeProcess(hProcess, &waitcode)) {
1921 *status = (int)((waitcode & 0xff) << 8);
1922 retval = (int)w32_child_pids[child];
1923 remove_dead_process(child);
1932 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1933 (IsWin95() ? -pid : pid));
1935 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1936 if (waitcode == WAIT_TIMEOUT) {
1939 else if (waitcode == WAIT_OBJECT_0) {
1940 if (GetExitCodeProcess(hProcess, &waitcode)) {
1941 *status = (int)((waitcode & 0xff) << 8);
1942 CloseHandle(hProcess);
1946 CloseHandle(hProcess);
1952 return retval >= 0 ? pid : retval;
1956 win32_wait(int *status)
1958 return win32_internal_wait(status, INFINITE);
1961 DllExport unsigned int
1962 win32_sleep(unsigned int t)
1965 /* Win32 times are in ms so *1000 in and /1000 out */
1966 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
1969 DllExport unsigned int
1970 win32_alarm(unsigned int sec)
1973 * the 'obvious' implentation is SetTimer() with a callback
1974 * which does whatever receiving SIGALRM would do
1975 * we cannot use SIGALRM even via raise() as it is not
1976 * one of the supported codes in <signal.h>
1980 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
1984 KillTimer(NULL,w32_timerid);
1991 #ifdef HAVE_DES_FCRYPT
1992 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
1996 win32_crypt(const char *txt, const char *salt)
1999 #ifdef HAVE_DES_FCRYPT
2000 return des_fcrypt(txt, salt, w32_crypt_buffer);
2002 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2007 #ifdef USE_FIXED_OSFHANDLE
2009 #define FOPEN 0x01 /* file handle open */
2010 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2011 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2012 #define FDEV 0x40 /* file handle refers to device */
2013 #define FTEXT 0x80 /* file handle is in text mode */
2016 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2019 * This function allocates a free C Runtime file handle and associates
2020 * it with the Win32 HANDLE specified by the first parameter. This is a
2021 * temperary fix for WIN95's brain damage GetFileType() error on socket
2022 * we just bypass that call for socket
2024 * This works with MSVC++ 4.0+ or GCC/Mingw32
2027 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2028 * int flags - flags to associate with C Runtime file handle.
2031 * returns index of entry in fh, if successful
2032 * return -1, if no free entry is found
2036 *******************************************************************************/
2039 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2040 * this lets sockets work on Win9X with GCC and should fix the problems
2045 /* create an ioinfo entry, kill its handle, and steal the entry */
2050 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2051 int fh = _open_osfhandle((long)hF, 0);
2055 EnterCriticalSection(&(_pioinfo(fh)->lock));
2060 my_open_osfhandle(long osfhandle, int flags)
2063 char fileflags; /* _osfile flags */
2065 /* copy relevant flags from second parameter */
2068 if (flags & O_APPEND)
2069 fileflags |= FAPPEND;
2074 if (flags & O_NOINHERIT)
2075 fileflags |= FNOINHERIT;
2077 /* attempt to allocate a C Runtime file handle */
2078 if ((fh = _alloc_osfhnd()) == -1) {
2079 errno = EMFILE; /* too many open files */
2080 _doserrno = 0L; /* not an OS error */
2081 return -1; /* return error to caller */
2084 /* the file is open. now, set the info in _osfhnd array */
2085 _set_osfhnd(fh, osfhandle);
2087 fileflags |= FOPEN; /* mark as open */
2089 _osfile(fh) = fileflags; /* set osfile entry */
2090 LeaveCriticalSection(&_pioinfo(fh)->lock);
2092 return fh; /* return handle */
2095 #endif /* USE_FIXED_OSFHANDLE */
2097 /* simulate flock by locking a range on the file */
2099 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2100 #define LK_LEN 0xffff0000
2103 win32_flock(int fd, int oper)
2111 Perl_croak_nocontext("flock() unimplemented on this platform");
2114 fh = (HANDLE)_get_osfhandle(fd);
2115 memset(&o, 0, sizeof(o));
2118 case LOCK_SH: /* shared lock */
2119 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2121 case LOCK_EX: /* exclusive lock */
2122 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2124 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2125 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2127 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2128 LK_ERR(LockFileEx(fh,
2129 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2130 0, LK_LEN, 0, &o),i);
2132 case LOCK_UN: /* unlock lock */
2133 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2135 default: /* unknown */
2146 * redirected io subsystem for all XS modules
2159 return (&(_environ));
2162 /* the rest are the remapped stdio routines */
2182 win32_ferror(FILE *fp)
2184 return (ferror(fp));
2189 win32_feof(FILE *fp)
2195 * Since the errors returned by the socket error function
2196 * WSAGetLastError() are not known by the library routine strerror
2197 * we have to roll our own.
2201 win32_strerror(int e)
2203 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2204 extern int sys_nerr;
2208 if (e < 0 || e > sys_nerr) {
2213 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2214 w32_strerror_buffer,
2215 sizeof(w32_strerror_buffer), NULL) == 0)
2216 strcpy(w32_strerror_buffer, "Unknown Error");
2218 return w32_strerror_buffer;
2224 win32_str_os_error(void *sv, DWORD dwErr)
2228 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2229 |FORMAT_MESSAGE_IGNORE_INSERTS
2230 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2231 dwErr, 0, (char *)&sMsg, 1, NULL);
2232 /* strip trailing whitespace and period */
2235 --dwLen; /* dwLen doesn't include trailing null */
2236 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2237 if ('.' != sMsg[dwLen])
2242 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2244 dwLen = sprintf(sMsg,
2245 "Unknown error #0x%lX (lookup 0x%lX)",
2246 dwErr, GetLastError());
2250 sv_setpvn((SV*)sv, sMsg, dwLen);
2256 win32_fprintf(FILE *fp, const char *format, ...)
2259 va_start(marker, format); /* Initialize variable arguments. */
2261 return (vfprintf(fp, format, marker));
2265 win32_printf(const char *format, ...)
2268 va_start(marker, format); /* Initialize variable arguments. */
2270 return (vprintf(format, marker));
2274 win32_vfprintf(FILE *fp, const char *format, va_list args)
2276 return (vfprintf(fp, format, args));
2280 win32_vprintf(const char *format, va_list args)
2282 return (vprintf(format, args));
2286 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2288 return fread(buf, size, count, fp);
2292 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2294 return fwrite(buf, size, count, fp);
2297 #define MODE_SIZE 10
2300 win32_fopen(const char *filename, const char *mode)
2303 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2309 if (stricmp(filename, "/dev/null")==0)
2313 A2WHELPER(mode, wMode, sizeof(wMode));
2314 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2315 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2318 f = fopen(PerlDir_mapA(filename), mode);
2319 /* avoid buffering headaches for child processes */
2320 if (f && *mode == 'a')
2321 win32_fseek(f, 0, SEEK_END);
2325 #ifndef USE_SOCKETS_AS_HANDLES
2327 #define fdopen my_fdopen
2331 win32_fdopen(int handle, const char *mode)
2334 WCHAR wMode[MODE_SIZE];
2337 A2WHELPER(mode, wMode, sizeof(wMode));
2338 f = _wfdopen(handle, wMode);
2341 f = fdopen(handle, (char *) mode);
2342 /* avoid buffering headaches for child processes */
2343 if (f && *mode == 'a')
2344 win32_fseek(f, 0, SEEK_END);
2349 win32_freopen(const char *path, const char *mode, FILE *stream)
2352 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2353 if (stricmp(path, "/dev/null")==0)
2357 A2WHELPER(mode, wMode, sizeof(wMode));
2358 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2359 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2361 return freopen(PerlDir_mapA(path), mode, stream);
2365 win32_fclose(FILE *pf)
2367 return my_fclose(pf); /* defined in win32sck.c */
2371 win32_fputs(const char *s,FILE *pf)
2373 return fputs(s, pf);
2377 win32_fputc(int c,FILE *pf)
2383 win32_ungetc(int c,FILE *pf)
2385 return ungetc(c,pf);
2389 win32_getc(FILE *pf)
2395 win32_fileno(FILE *pf)
2401 win32_clearerr(FILE *pf)
2408 win32_fflush(FILE *pf)
2414 win32_ftell(FILE *pf)
2420 win32_fseek(FILE *pf,long offset,int origin)
2422 return fseek(pf, offset, origin);
2426 win32_fgetpos(FILE *pf,fpos_t *p)
2428 return fgetpos(pf, p);
2432 win32_fsetpos(FILE *pf,const fpos_t *p)
2434 return fsetpos(pf, p);
2438 win32_rewind(FILE *pf)
2448 char prefix[MAX_PATH+1];
2449 char filename[MAX_PATH+1];
2450 DWORD len = GetTempPath(MAX_PATH, prefix);
2451 if (len && len < MAX_PATH) {
2452 if (GetTempFileName(prefix, "plx", 0, filename)) {
2453 HANDLE fh = CreateFile(filename,
2454 DELETE | GENERIC_READ | GENERIC_WRITE,
2458 FILE_ATTRIBUTE_NORMAL
2459 | FILE_FLAG_DELETE_ON_CLOSE,
2461 if (fh != INVALID_HANDLE_VALUE) {
2462 int fd = win32_open_osfhandle((long)fh, 0);
2464 DEBUG_p(PerlIO_printf(Perl_debug_log,
2465 "Created tmpfile=%s\n",filename));
2466 return fdopen(fd, "w+b");
2482 win32_fstat(int fd,struct stat *sbufptr)
2485 /* A file designated by filehandle is not shown as accessible
2486 * for write operations, probably because it is opened for reading.
2489 int rc = fstat(fd,sbufptr);
2490 BY_HANDLE_FILE_INFORMATION bhfi;
2491 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2492 sbufptr->st_mode &= 0xFE00;
2493 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2494 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2496 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2497 + ((S_IREAD|S_IWRITE) >> 6));
2501 return my_fstat(fd,sbufptr);
2506 win32_pipe(int *pfd, unsigned int size, int mode)
2508 return _pipe(pfd, size, mode);
2512 win32_popenlist(const char *mode, IV narg, SV **args)
2515 Perl_croak(aTHX_ "List form of pipe open not implemented");
2520 * a popen() clone that respects PERL5SHELL
2522 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2526 win32_popen(const char *command, const char *mode)
2528 #ifdef USE_RTL_POPEN
2529 return _popen(command, mode);
2537 /* establish which ends read and write */
2538 if (strchr(mode,'w')) {
2539 stdfd = 0; /* stdin */
2543 else if (strchr(mode,'r')) {
2544 stdfd = 1; /* stdout */
2551 /* set the correct mode */
2552 if (strchr(mode,'b'))
2554 else if (strchr(mode,'t'))
2557 ourmode = _fmode & (O_TEXT | O_BINARY);
2559 /* the child doesn't inherit handles */
2560 ourmode |= O_NOINHERIT;
2562 if (win32_pipe( p, 512, ourmode) == -1)
2565 /* save current stdfd */
2566 if ((oldfd = win32_dup(stdfd)) == -1)
2569 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2570 /* stdfd will be inherited by the child */
2571 if (win32_dup2(p[child], stdfd) == -1)
2574 /* close the child end in parent */
2575 win32_close(p[child]);
2577 /* start the child */
2580 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2583 /* revert stdfd to whatever it was before */
2584 if (win32_dup2(oldfd, stdfd) == -1)
2587 /* close saved handle */
2591 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2594 /* set process id so that it can be returned by perl's open() */
2595 PL_forkprocess = childpid;
2598 /* we have an fd, return a file stream */
2599 return (PerlIO_fdopen(p[parent], (char *)mode));
2602 /* we don't need to check for errors here */
2606 win32_dup2(oldfd, stdfd);
2611 #endif /* USE_RTL_POPEN */
2619 win32_pclose(PerlIO *pf)
2621 #ifdef USE_RTL_POPEN
2625 int childpid, status;
2629 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2632 childpid = SvIVX(sv);
2649 if (win32_waitpid(childpid, &status, 0) == -1)
2654 #endif /* USE_RTL_POPEN */
2660 LPCWSTR lpExistingFileName,
2661 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2664 WCHAR wFullName[MAX_PATH+1];
2665 LPVOID lpContext = NULL;
2666 WIN32_STREAM_ID StreamId;
2667 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2672 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2673 BOOL, BOOL, LPVOID*) =
2674 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2675 BOOL, BOOL, LPVOID*))
2676 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2677 if (pfnBackupWrite == NULL)
2680 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2683 dwLen = (dwLen+1)*sizeof(WCHAR);
2685 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2686 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2687 NULL, OPEN_EXISTING, 0, NULL);
2688 if (handle == INVALID_HANDLE_VALUE)
2691 StreamId.dwStreamId = BACKUP_LINK;
2692 StreamId.dwStreamAttributes = 0;
2693 StreamId.dwStreamNameSize = 0;
2694 #if defined(__BORLANDC__) \
2695 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2696 StreamId.Size.u.HighPart = 0;
2697 StreamId.Size.u.LowPart = dwLen;
2699 StreamId.Size.HighPart = 0;
2700 StreamId.Size.LowPart = dwLen;
2703 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2704 FALSE, FALSE, &lpContext);
2706 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2707 FALSE, FALSE, &lpContext);
2708 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2711 CloseHandle(handle);
2716 win32_link(const char *oldname, const char *newname)
2719 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2720 WCHAR wOldName[MAX_PATH+1];
2721 WCHAR wNewName[MAX_PATH+1];
2724 Perl_croak(aTHX_ PL_no_func, "link");
2726 pfnCreateHardLinkW =
2727 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2728 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2729 if (pfnCreateHardLinkW == NULL)
2730 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2732 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2733 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2734 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2735 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2739 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2744 win32_rename(const char *oname, const char *newname)
2746 WCHAR wOldName[MAX_PATH+1];
2747 WCHAR wNewName[MAX_PATH+1];
2748 char szOldName[MAX_PATH+1];
2749 char szNewName[MAX_PATH+1];
2753 /* XXX despite what the documentation says about MoveFileEx(),
2754 * it doesn't work under Windows95!
2757 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2759 A2WHELPER(oname, wOldName, sizeof(wOldName));
2760 A2WHELPER(newname, wNewName, sizeof(wNewName));
2761 if (wcsicmp(wNewName, wOldName))
2762 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2763 wcscpy(wOldName, PerlDir_mapW(wOldName));
2764 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2767 if (stricmp(newname, oname))
2768 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2769 strcpy(szOldName, PerlDir_mapA(oname));
2770 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2773 DWORD err = GetLastError();
2775 case ERROR_BAD_NET_NAME:
2776 case ERROR_BAD_NETPATH:
2777 case ERROR_BAD_PATHNAME:
2778 case ERROR_FILE_NOT_FOUND:
2779 case ERROR_FILENAME_EXCED_RANGE:
2780 case ERROR_INVALID_DRIVE:
2781 case ERROR_NO_MORE_FILES:
2782 case ERROR_PATH_NOT_FOUND:
2795 char szTmpName[MAX_PATH+1];
2796 char dname[MAX_PATH+1];
2797 char *endname = Nullch;
2799 DWORD from_attr, to_attr;
2801 strcpy(szOldName, PerlDir_mapA(oname));
2802 strcpy(szNewName, PerlDir_mapA(newname));
2804 /* if oname doesn't exist, do nothing */
2805 from_attr = GetFileAttributes(szOldName);
2806 if (from_attr == 0xFFFFFFFF) {
2811 /* if newname exists, rename it to a temporary name so that we
2812 * don't delete it in case oname happens to be the same file
2813 * (but perhaps accessed via a different path)
2815 to_attr = GetFileAttributes(szNewName);
2816 if (to_attr != 0xFFFFFFFF) {
2817 /* if newname is a directory, we fail
2818 * XXX could overcome this with yet more convoluted logic */
2819 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2823 tmplen = strlen(szNewName);
2824 strcpy(szTmpName,szNewName);
2825 endname = szTmpName+tmplen;
2826 for (; endname > szTmpName ; --endname) {
2827 if (*endname == '/' || *endname == '\\') {
2832 if (endname > szTmpName)
2833 endname = strcpy(dname,szTmpName);
2837 /* get a temporary filename in same directory
2838 * XXX is this really the best we can do? */
2839 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2843 DeleteFile(szTmpName);
2845 retval = rename(szNewName, szTmpName);
2852 /* rename oname to newname */
2853 retval = rename(szOldName, szNewName);
2855 /* if we created a temporary file before ... */
2856 if (endname != Nullch) {
2857 /* ...and rename succeeded, delete temporary file/directory */
2859 DeleteFile(szTmpName);
2860 /* else restore it to what it was */
2862 (void)rename(szTmpName, szNewName);
2869 win32_setmode(int fd, int mode)
2871 return setmode(fd, mode);
2875 win32_lseek(int fd, long offset, int origin)
2877 return lseek(fd, offset, origin);
2887 win32_open(const char *path, int flag, ...)
2892 WCHAR wBuffer[MAX_PATH+1];
2895 pmode = va_arg(ap, int);
2898 if (stricmp(path, "/dev/null")==0)
2902 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2903 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2905 return open(PerlDir_mapA(path), flag, pmode);
2908 /* close() that understands socket */
2909 extern int my_close(int); /* in win32sck.c */
2914 return my_close(fd);
2930 win32_dup2(int fd1,int fd2)
2932 return dup2(fd1,fd2);
2935 #ifdef PERL_MSVCRT_READFIX
2937 #define LF 10 /* line feed */
2938 #define CR 13 /* carriage return */
2939 #define CTRLZ 26 /* ctrl-z means eof for text */
2940 #define FOPEN 0x01 /* file handle open */
2941 #define FEOFLAG 0x02 /* end of file has been encountered */
2942 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2943 #define FPIPE 0x08 /* file handle refers to a pipe */
2944 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2945 #define FDEV 0x40 /* file handle refers to device */
2946 #define FTEXT 0x80 /* file handle is in text mode */
2947 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
2950 _fixed_read(int fh, void *buf, unsigned cnt)
2952 int bytes_read; /* number of bytes read */
2953 char *buffer; /* buffer to read to */
2954 int os_read; /* bytes read on OS call */
2955 char *p, *q; /* pointers into buffer */
2956 char peekchr; /* peek-ahead character */
2957 ULONG filepos; /* file position after seek */
2958 ULONG dosretval; /* o.s. return value */
2960 /* validate handle */
2961 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
2962 !(_osfile(fh) & FOPEN))
2964 /* out of range -- return error */
2966 _doserrno = 0; /* not o.s. error */
2971 * If lockinitflag is FALSE, assume fd is device
2972 * lockinitflag is set to TRUE by open.
2974 if (_pioinfo(fh)->lockinitflag)
2975 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
2977 bytes_read = 0; /* nothing read yet */
2978 buffer = (char*)buf;
2980 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
2981 /* nothing to read or at EOF, so return 0 read */
2985 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
2986 /* a pipe/device and pipe lookahead non-empty: read the lookahead
2988 *buffer++ = _pipech(fh);
2991 _pipech(fh) = LF; /* mark as empty */
2996 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
2998 /* ReadFile has reported an error. recognize two special cases.
3000 * 1. map ERROR_ACCESS_DENIED to EBADF
3002 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3003 * means the handle is a read-handle on a pipe for which
3004 * all write-handles have been closed and all data has been
3007 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3008 /* wrong read/write mode should return EBADF, not EACCES */
3010 _doserrno = dosretval;
3014 else if (dosretval == ERROR_BROKEN_PIPE) {
3024 bytes_read += os_read; /* update bytes read */
3026 if (_osfile(fh) & FTEXT) {
3027 /* now must translate CR-LFs to LFs in the buffer */
3029 /* set CRLF flag to indicate LF at beginning of buffer */
3030 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3031 /* _osfile(fh) |= FCRLF; */
3033 /* _osfile(fh) &= ~FCRLF; */
3035 _osfile(fh) &= ~FCRLF;
3037 /* convert chars in the buffer: p is src, q is dest */
3039 while (p < (char *)buf + bytes_read) {
3041 /* if fh is not a device, set ctrl-z flag */
3042 if (!(_osfile(fh) & FDEV))
3043 _osfile(fh) |= FEOFLAG;
3044 break; /* stop translating */
3049 /* *p is CR, so must check next char for LF */
3050 if (p < (char *)buf + bytes_read - 1) {
3053 *q++ = LF; /* convert CR-LF to LF */
3056 *q++ = *p++; /* store char normally */
3059 /* This is the hard part. We found a CR at end of
3060 buffer. We must peek ahead to see if next char
3065 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3066 (LPDWORD)&os_read, NULL))
3067 dosretval = GetLastError();
3069 if (dosretval != 0 || os_read == 0) {
3070 /* couldn't read ahead, store CR */
3074 /* peekchr now has the extra character -- we now
3075 have several possibilities:
3076 1. disk file and char is not LF; just seek back
3078 2. disk file and char is LF; store LF, don't seek back
3079 3. pipe/device and char is LF; store LF.
3080 4. pipe/device and char isn't LF, store CR and
3081 put char in pipe lookahead buffer. */
3082 if (_osfile(fh) & (FDEV|FPIPE)) {
3083 /* non-seekable device */
3088 _pipech(fh) = peekchr;
3093 if (peekchr == LF) {
3094 /* nothing read yet; must make some
3097 /* turn on this flag for tell routine */
3098 _osfile(fh) |= FCRLF;
3101 HANDLE osHandle; /* o.s. handle value */
3103 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3105 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3106 dosretval = GetLastError();
3117 /* we now change bytes_read to reflect the true number of chars
3119 bytes_read = q - (char *)buf;
3123 if (_pioinfo(fh)->lockinitflag)
3124 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3129 #endif /* PERL_MSVCRT_READFIX */
3132 win32_read(int fd, void *buf, unsigned int cnt)
3134 #ifdef PERL_MSVCRT_READFIX
3135 return _fixed_read(fd, buf, cnt);
3137 return read(fd, buf, cnt);
3142 win32_write(int fd, const void *buf, unsigned int cnt)
3144 return write(fd, buf, cnt);
3148 win32_mkdir(const char *dir, int mode)
3152 WCHAR wBuffer[MAX_PATH+1];
3153 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3154 return _wmkdir(PerlDir_mapW(wBuffer));
3156 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3160 win32_rmdir(const char *dir)
3164 WCHAR wBuffer[MAX_PATH+1];
3165 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3166 return _wrmdir(PerlDir_mapW(wBuffer));
3168 return rmdir(PerlDir_mapA(dir));
3172 win32_chdir(const char *dir)
3180 WCHAR wBuffer[MAX_PATH+1];
3181 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3182 return _wchdir(wBuffer);
3188 win32_access(const char *path, int mode)
3192 WCHAR wBuffer[MAX_PATH+1];
3193 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3194 return _waccess(PerlDir_mapW(wBuffer), mode);
3196 return access(PerlDir_mapA(path), mode);
3200 win32_chmod(const char *path, int mode)
3204 WCHAR wBuffer[MAX_PATH+1];
3205 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3206 return _wchmod(PerlDir_mapW(wBuffer), mode);
3208 return chmod(PerlDir_mapA(path), mode);
3213 create_command_line(char *cname, STRLEN clen, const char * const *args)
3220 bool bat_file = FALSE;
3221 bool cmd_shell = FALSE;
3222 bool dumb_shell = FALSE;
3223 bool extra_quotes = FALSE;
3224 bool quote_next = FALSE;
3227 cname = (char*)args[0];
3229 /* The NT cmd.exe shell has the following peculiarity that needs to be
3230 * worked around. It strips a leading and trailing dquote when any
3231 * of the following is true:
3232 * 1. the /S switch was used
3233 * 2. there are more than two dquotes
3234 * 3. there is a special character from this set: &<>()@^|
3235 * 4. no whitespace characters within the two dquotes
3236 * 5. string between two dquotes isn't an executable file
3237 * To work around this, we always add a leading and trailing dquote
3238 * to the string, if the first argument is either "cmd.exe" or "cmd",
3239 * and there were at least two or more arguments passed to cmd.exe
3240 * (not including switches).
3241 * XXX the above rules (from "cmd /?") don't seem to be applied
3242 * always, making for the convolutions below :-(
3246 clen = strlen(cname);
3249 && (stricmp(&cname[clen-4], ".bat") == 0
3250 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3256 char *exe = strrchr(cname, '/');
3257 char *exe2 = strrchr(cname, '\\');
3264 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3268 else if (stricmp(exe, "command.com") == 0
3269 || stricmp(exe, "command") == 0)
3276 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3277 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3278 STRLEN curlen = strlen(arg);
3279 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3280 len += 2; /* assume quoting needed (worst case) */
3282 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3284 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3287 New(1310, cmd, len, char);
3292 extra_quotes = TRUE;
3295 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3297 STRLEN curlen = strlen(arg);
3299 /* we want to protect empty arguments and ones with spaces with
3300 * dquotes, but only if they aren't already there */
3305 else if (quote_next) {
3306 /* see if it really is multiple arguments pretending to
3307 * be one and force a set of quotes around it */
3308 if (*find_next_space(arg))
3311 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3313 while (i < curlen) {
3314 if (isSPACE(arg[i])) {
3317 else if (arg[i] == '"') {
3340 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3342 /* is there a next argument? */
3343 if (args[index+1]) {
3344 /* are there two or more next arguments? */
3345 if (args[index+2]) {
3347 extra_quotes = TRUE;
3350 /* single argument, force quoting if it has spaces */
3366 qualified_path(const char *cmd)
3370 char *fullcmd, *curfullcmd;
3376 fullcmd = (char*)cmd;
3378 if (*fullcmd == '/' || *fullcmd == '\\')
3385 pathstr = PerlEnv_getenv("PATH");
3386 New(0, fullcmd, MAX_PATH+1, char);
3387 curfullcmd = fullcmd;
3392 /* start by appending the name to the current prefix */
3393 strcpy(curfullcmd, cmd);
3394 curfullcmd += cmdlen;
3396 /* if it doesn't end with '.', or has no extension, try adding
3397 * a trailing .exe first */
3398 if (cmd[cmdlen-1] != '.'
3399 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3401 strcpy(curfullcmd, ".exe");
3402 res = GetFileAttributes(fullcmd);
3403 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3408 /* that failed, try the bare name */
3409 res = GetFileAttributes(fullcmd);
3410 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3413 /* quit if no other path exists, or if cmd already has path */
3414 if (!pathstr || !*pathstr || has_slash)
3417 /* skip leading semis */
3418 while (*pathstr == ';')
3421 /* build a new prefix from scratch */
3422 curfullcmd = fullcmd;
3423 while (*pathstr && *pathstr != ';') {
3424 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3425 pathstr++; /* skip initial '"' */
3426 while (*pathstr && *pathstr != '"') {
3427 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3428 *curfullcmd++ = *pathstr;
3432 pathstr++; /* skip trailing '"' */
3435 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3436 *curfullcmd++ = *pathstr;
3441 pathstr++; /* skip trailing semi */
3442 if (curfullcmd > fullcmd /* append a dir separator */
3443 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3445 *curfullcmd++ = '\\';
3453 /* The following are just place holders.
3454 * Some hosts may provide and environment that the OS is
3455 * not tracking, therefore, these host must provide that
3456 * environment and the current directory to CreateProcess
3460 win32_get_childenv(void)
3466 win32_free_childenv(void* d)
3471 win32_clearenv(void)
3473 char *envv = GetEnvironmentStrings();
3477 char *end = strchr(cur,'=');
3478 if (end && end != cur) {
3480 SetEnvironmentVariable(cur, NULL);
3482 cur = end + strlen(end+1)+2;
3484 else if ((len = strlen(cur)))
3487 FreeEnvironmentStrings(envv);
3491 win32_get_childdir(void)
3495 char szfilename[(MAX_PATH+1)*2];
3497 WCHAR wfilename[MAX_PATH+1];
3498 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3499 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3502 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3505 New(0, ptr, strlen(szfilename)+1, char);
3506 strcpy(ptr, szfilename);
3511 win32_free_childdir(char* d)
3518 /* XXX this needs to be made more compatible with the spawnvp()
3519 * provided by the various RTLs. In particular, searching for
3520 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3521 * This doesn't significantly affect perl itself, because we
3522 * always invoke things using PERL5SHELL if a direct attempt to
3523 * spawn the executable fails.
3525 * XXX splitting and rejoining the commandline between do_aspawn()
3526 * and win32_spawnvp() could also be avoided.
3530 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3532 #ifdef USE_RTL_SPAWNVP
3533 return spawnvp(mode, cmdname, (char * const *)argv);
3540 STARTUPINFO StartupInfo;
3541 PROCESS_INFORMATION ProcessInformation;
3544 char *fullcmd = Nullch;
3545 char *cname = (char *)cmdname;
3549 clen = strlen(cname);
3550 /* if command name contains dquotes, must remove them */
3551 if (strchr(cname, '"')) {
3553 New(0,cname,clen+1,char);
3566 cmd = create_command_line(cname, clen, argv);
3568 env = PerlEnv_get_childenv();
3569 dir = PerlEnv_get_childdir();
3572 case P_NOWAIT: /* asynch + remember result */
3573 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3578 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3581 create |= CREATE_NEW_PROCESS_GROUP;
3584 case P_WAIT: /* synchronous execution */
3586 default: /* invalid mode */
3591 memset(&StartupInfo,0,sizeof(StartupInfo));
3592 StartupInfo.cb = sizeof(StartupInfo);
3593 memset(&tbl,0,sizeof(tbl));
3594 PerlEnv_get_child_IO(&tbl);
3595 StartupInfo.dwFlags = tbl.dwFlags;
3596 StartupInfo.dwX = tbl.dwX;
3597 StartupInfo.dwY = tbl.dwY;
3598 StartupInfo.dwXSize = tbl.dwXSize;
3599 StartupInfo.dwYSize = tbl.dwYSize;
3600 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3601 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3602 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3603 StartupInfo.wShowWindow = tbl.wShowWindow;
3604 StartupInfo.hStdInput = tbl.childStdIn;
3605 StartupInfo.hStdOutput = tbl.childStdOut;
3606 StartupInfo.hStdError = tbl.childStdErr;
3607 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3608 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3609 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3611 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3614 create |= CREATE_NEW_CONSOLE;
3617 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3620 if (!CreateProcess(cname, /* search PATH to find executable */
3621 cmd, /* executable, and its arguments */
3622 NULL, /* process attributes */
3623 NULL, /* thread attributes */
3624 TRUE, /* inherit handles */
3625 create, /* creation flags */
3626 (LPVOID)env, /* inherit environment */
3627 dir, /* inherit cwd */
3629 &ProcessInformation))
3631 /* initial NULL argument to CreateProcess() does a PATH
3632 * search, but it always first looks in the directory
3633 * where the current process was started, which behavior
3634 * is undesirable for backward compatibility. So we
3635 * jump through our own hoops by picking out the path
3636 * we really want it to use. */
3638 fullcmd = qualified_path(cname);
3640 if (cname != cmdname)
3643 DEBUG_p(PerlIO_printf(Perl_debug_log,
3644 "Retrying [%s] with same args\n",
3654 if (mode == P_NOWAIT) {
3655 /* asynchronous spawn -- store handle, return PID */
3656 ret = (int)ProcessInformation.dwProcessId;
3657 if (IsWin95() && ret < 0)
3660 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3661 w32_child_pids[w32_num_children] = (DWORD)ret;
3666 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3667 /* FIXME: if msgwait returned due to message perhaps forward the
3668 "signal" to the process
3670 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3672 CloseHandle(ProcessInformation.hProcess);
3675 CloseHandle(ProcessInformation.hThread);
3678 PerlEnv_free_childenv(env);
3679 PerlEnv_free_childdir(dir);
3681 if (cname != cmdname)
3688 win32_execv(const char *cmdname, const char *const *argv)
3692 /* if this is a pseudo-forked child, we just want to spawn
3693 * the new program, and return */
3695 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3697 return execv(cmdname, (char *const *)argv);
3701 win32_execvp(const char *cmdname, const char *const *argv)
3705 /* if this is a pseudo-forked child, we just want to spawn
3706 * the new program, and return */
3707 if (w32_pseudo_id) {
3708 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3717 return execvp(cmdname, (char *const *)argv);
3721 win32_perror(const char *str)
3727 win32_setbuf(FILE *pf, char *buf)
3733 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3735 return setvbuf(pf, buf, type, size);
3739 win32_flushall(void)
3745 win32_fcloseall(void)
3751 win32_fgets(char *s, int n, FILE *pf)
3753 return fgets(s, n, pf);
3763 win32_fgetc(FILE *pf)
3769 win32_putc(int c, FILE *pf)
3775 win32_puts(const char *s)
3787 win32_putchar(int c)
3794 #ifndef USE_PERL_SBRK
3796 static char *committed = NULL; /* XXX threadead */
3797 static char *base = NULL; /* XXX threadead */
3798 static char *reserved = NULL; /* XXX threadead */
3799 static char *brk = NULL; /* XXX threadead */
3800 static DWORD pagesize = 0; /* XXX threadead */
3801 static DWORD allocsize = 0; /* XXX threadead */
3809 GetSystemInfo(&info);
3810 /* Pretend page size is larger so we don't perpetually
3811 * call the OS to commit just one page ...
3813 pagesize = info.dwPageSize << 3;
3814 allocsize = info.dwAllocationGranularity;
3816 /* This scheme fails eventually if request for contiguous
3817 * block is denied so reserve big blocks - this is only
3818 * address space not memory ...
3820 if (brk+need >= reserved)
3822 DWORD size = 64*1024*1024;
3824 if (committed && reserved && committed < reserved)
3826 /* Commit last of previous chunk cannot span allocations */
3827 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3829 committed = reserved;
3831 /* Reserve some (more) space
3832 * Note this is a little sneaky, 1st call passes NULL as reserved
3833 * so lets system choose where we start, subsequent calls pass
3834 * the old end address so ask for a contiguous block
3836 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3839 reserved = addr+size;
3854 if (brk > committed)
3856 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3857 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3872 win32_malloc(size_t size)
3874 return malloc(size);
3878 win32_calloc(size_t numitems, size_t size)
3880 return calloc(numitems,size);
3884 win32_realloc(void *block, size_t size)
3886 return realloc(block,size);
3890 win32_free(void *block)
3897 win32_open_osfhandle(long handle, int flags)
3899 #ifdef USE_FIXED_OSFHANDLE
3901 return my_open_osfhandle(handle, flags);
3903 return _open_osfhandle(handle, flags);
3907 win32_get_osfhandle(int fd)
3909 return _get_osfhandle(fd);
3913 win32_dynaload(const char* filename)
3917 char buf[MAX_PATH+1];
3920 /* LoadLibrary() doesn't recognize forward slashes correctly,
3921 * so turn 'em back. */
3922 first = strchr(filename, '/');
3924 STRLEN len = strlen(filename);
3925 if (len <= MAX_PATH) {
3926 strcpy(buf, filename);
3927 filename = &buf[first - filename];
3929 if (*filename == '/')
3930 *(char*)filename = '\\';
3937 WCHAR wfilename[MAX_PATH+1];
3938 A2WHELPER(filename, wfilename, sizeof(wfilename));
3939 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3942 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3955 /* Make the host for current directory */
3956 char* ptr = PerlEnv_get_childdir();
3959 * then it worked, set PV valid,
3960 * else return 'undef'
3963 SV *sv = sv_newmortal();
3965 PerlEnv_free_childdir(ptr);
3967 #ifndef INCOMPLETE_TAINTS
3984 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
3985 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
3992 XS(w32_GetNextAvailDrive)
3996 char root[] = "_:\\";
4001 if (GetDriveType(root) == 1) {
4010 XS(w32_GetLastError)
4014 XSRETURN_IV(GetLastError());
4018 XS(w32_SetLastError)
4022 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4023 SetLastError(SvIV(ST(0)));
4031 char *name = w32_getlogin_buffer;
4032 DWORD size = sizeof(w32_getlogin_buffer);
4034 if (GetUserName(name,&size)) {
4035 /* size includes NULL */
4036 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4046 char name[MAX_COMPUTERNAME_LENGTH+1];
4047 DWORD size = sizeof(name);
4049 if (GetComputerName(name,&size)) {
4050 /* size does NOT include NULL :-( */
4051 ST(0) = sv_2mortal(newSVpvn(name,size));
4062 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4063 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4064 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4068 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4069 GetProcAddress(hNetApi32, "NetApiBufferFree");
4070 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4071 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4074 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4075 /* this way is more reliable, in case user has a local account. */
4077 DWORD dnamelen = sizeof(dname);
4079 DWORD wki100_platform_id;
4080 LPWSTR wki100_computername;
4081 LPWSTR wki100_langroup;
4082 DWORD wki100_ver_major;
4083 DWORD wki100_ver_minor;
4085 /* NERR_Success *is* 0*/
4086 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4087 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4088 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4089 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4092 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4093 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4095 pfnNetApiBufferFree(pwi);
4096 FreeLibrary(hNetApi32);
4099 FreeLibrary(hNetApi32);
4102 /* Win95 doesn't have NetWksta*(), so do it the old way */
4104 DWORD size = sizeof(name);
4106 FreeLibrary(hNetApi32);
4107 if (GetUserName(name,&size)) {
4108 char sid[ONE_K_BUFSIZE];
4109 DWORD sidlen = sizeof(sid);
4111 DWORD dnamelen = sizeof(dname);
4113 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4114 dname, &dnamelen, &snu)) {
4115 XSRETURN_PV(dname); /* all that for this */
4127 DWORD flags, filecomplen;
4128 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4129 &flags, fsname, sizeof(fsname))) {
4130 if (GIMME_V == G_ARRAY) {
4131 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4132 XPUSHs(sv_2mortal(newSViv(flags)));
4133 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4138 XSRETURN_PV(fsname);
4144 XS(w32_GetOSVersion)
4147 OSVERSIONINFOA osver;
4150 OSVERSIONINFOW osverw;
4151 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4152 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4153 if (!GetVersionExW(&osverw)) {
4156 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4157 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4158 osver.dwMajorVersion = osverw.dwMajorVersion;
4159 osver.dwMinorVersion = osverw.dwMinorVersion;
4160 osver.dwBuildNumber = osverw.dwBuildNumber;
4161 osver.dwPlatformId = osverw.dwPlatformId;
4164 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4165 if (!GetVersionExA(&osver)) {
4168 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4170 XPUSHs(newSViv(osver.dwMajorVersion));
4171 XPUSHs(newSViv(osver.dwMinorVersion));
4172 XPUSHs(newSViv(osver.dwBuildNumber));
4173 XPUSHs(newSViv(osver.dwPlatformId));
4182 XSRETURN_IV(IsWinNT());
4190 XSRETURN_IV(IsWin95());
4194 XS(w32_FormatMessage)
4198 char msgbuf[ONE_K_BUFSIZE];
4201 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4204 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4205 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4206 &source, SvIV(ST(0)), 0,
4207 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4209 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4210 XSRETURN_PV(msgbuf);
4214 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4215 &source, SvIV(ST(0)), 0,
4216 msgbuf, sizeof(msgbuf)-1, NULL))
4217 XSRETURN_PV(msgbuf);
4230 PROCESS_INFORMATION stProcInfo;
4231 STARTUPINFO stStartInfo;
4232 BOOL bSuccess = FALSE;
4235 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4237 cmd = SvPV_nolen(ST(0));
4238 args = SvPV_nolen(ST(1));
4240 env = PerlEnv_get_childenv();
4241 dir = PerlEnv_get_childdir();
4243 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4244 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4245 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4246 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4249 cmd, /* Image path */
4250 args, /* Arguments for command line */
4251 NULL, /* Default process security */
4252 NULL, /* Default thread security */
4253 FALSE, /* Must be TRUE to use std handles */
4254 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4255 env, /* Inherit our environment block */
4256 dir, /* Inherit our currrent directory */
4257 &stStartInfo, /* -> Startup info */
4258 &stProcInfo)) /* <- Process info (if OK) */
4260 int pid = (int)stProcInfo.dwProcessId;
4261 if (IsWin95() && pid < 0)
4263 sv_setiv(ST(2), pid);
4264 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4267 PerlEnv_free_childenv(env);
4268 PerlEnv_free_childdir(dir);
4269 XSRETURN_IV(bSuccess);
4273 XS(w32_GetTickCount)
4276 DWORD msec = GetTickCount();
4284 XS(w32_GetShortPathName)
4291 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4293 shortpath = sv_mortalcopy(ST(0));
4294 SvUPGRADE(shortpath, SVt_PV);
4295 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4298 /* src == target is allowed */
4300 len = GetShortPathName(SvPVX(shortpath),
4303 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4305 SvCUR_set(shortpath,len);
4313 XS(w32_GetFullPathName)
4322 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4325 fullpath = sv_mortalcopy(filename);
4326 SvUPGRADE(fullpath, SVt_PV);
4327 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4331 len = GetFullPathName(SvPVX(filename),
4335 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4337 if (GIMME_V == G_ARRAY) {
4339 XST_mPV(1,filepart);
4340 len = filepart - SvPVX(fullpath);
4343 SvCUR_set(fullpath,len);
4351 XS(w32_GetLongPathName)
4355 char tmpbuf[MAX_PATH+1];
4360 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4363 pathstr = SvPV(path,len);
4364 strcpy(tmpbuf, pathstr);
4365 pathstr = win32_longpath(tmpbuf);
4367 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4378 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4389 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4391 WCHAR wSourceFile[MAX_PATH+1];
4392 WCHAR wDestFile[MAX_PATH+1];
4393 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4394 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4395 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4396 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4399 char szSourceFile[MAX_PATH+1];
4400 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4401 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4410 Perl_init_os_extras(void)
4413 char *file = __FILE__;
4416 /* these names are Activeware compatible */
4417 newXS("Win32::GetCwd", w32_GetCwd, file);
4418 newXS("Win32::SetCwd", w32_SetCwd, file);
4419 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4420 newXS("Win32::GetLastError", w32_GetLastError, file);
4421 newXS("Win32::SetLastError", w32_SetLastError, file);
4422 newXS("Win32::LoginName", w32_LoginName, file);
4423 newXS("Win32::NodeName", w32_NodeName, file);
4424 newXS("Win32::DomainName", w32_DomainName, file);
4425 newXS("Win32::FsType", w32_FsType, file);
4426 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4427 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4428 newXS("Win32::IsWin95", w32_IsWin95, file);
4429 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4430 newXS("Win32::Spawn", w32_Spawn, file);
4431 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4432 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4433 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4434 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4435 newXS("Win32::CopyFile", w32_CopyFile, file);
4436 newXS("Win32::Sleep", w32_Sleep, file);
4438 /* XXX Bloat Alert! The following Activeware preloads really
4439 * ought to be part of Win32::Sys::*, so they're not included
4442 /* LookupAccountName
4444 * InitiateSystemShutdown
4445 * AbortSystemShutdown
4446 * ExpandEnvrironmentStrings
4450 static PerlInterpreter* win32_process_perl = NULL;
4453 win32_ctrlhandler(DWORD dwCtrlType)
4457 my_perl = win32_process_perl;
4461 PERL_SET_THX(my_perl);
4464 switch(dwCtrlType) {
4465 case CTRL_CLOSE_EVENT:
4466 /* A signal that the system sends to all processes attached to a console when
4467 the user closes the console (either by choosing the Close command from the
4468 console window's System menu, or by choosing the End Task command from the
4471 CALL_FPTR(PL_sighandlerp)(1); /* SIGHUP */
4475 /* A CTRL+c signal was received */
4476 CALL_FPTR(PL_sighandlerp)(2); /* SIGINT */
4479 case CTRL_BREAK_EVENT:
4480 /* A CTRL+BREAK signal was received */
4481 CALL_FPTR(PL_sighandlerp)(3); /* SIGQUIT */
4484 case CTRL_LOGOFF_EVENT:
4485 /* A signal that the system sends to all console processes when a user is logging
4486 off. This signal does not indicate which user is logging off, so no
4487 assumptions can be made.
4490 case CTRL_SHUTDOWN_EVENT:
4491 /* A signal that the system sends to all console processes when the system is
4504 Perl_win32_init(int *argcp, char ***argvp)
4506 /* Disable floating point errors, Perl will trap the ones we
4507 * care about. VC++ RTL defaults to switching these off
4508 * already, but the Borland RTL doesn't. Since we don't
4509 * want to be at the vendor's whim on the default, we set
4510 * it explicitly here.
4512 #if !defined(_ALPHA_) && !defined(__GNUC__)
4513 _control87(MCW_EM, MCW_EM);
4519 win32_get_child_IO(child_IO_table* ptbl)
4521 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4522 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4523 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4526 #ifdef HAVE_INTERP_INTERN
4531 Perl_sys_intern_init(pTHX)
4533 w32_perlshell_tokens = Nullch;
4534 w32_perlshell_vec = (char**)NULL;
4535 w32_perlshell_items = 0;
4536 w32_fdpid = newAV();
4537 New(1313, w32_children, 1, child_tab);
4538 w32_num_children = 0;
4539 # ifdef USE_ITHREADS
4541 New(1313, w32_pseudo_children, 1, child_tab);
4542 w32_num_pseudo_children = 0;
4544 w32_init_socktype = 0;
4545 if (!win32_process_perl) {
4546 win32_process_perl = my_perl;
4547 /* Force C runtime signal stuff to set its console handler */
4548 signal(SIGINT,SIG_DFL);
4549 /* Push our handler on top */
4550 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4555 Perl_sys_intern_clear(pTHX)
4557 Safefree(w32_perlshell_tokens);
4558 Safefree(w32_perlshell_vec);
4559 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4560 Safefree(w32_children);
4561 if (my_perl == win32_process_perl) {
4562 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4563 win32_process_perl = NULL;
4565 # ifdef USE_ITHREADS
4566 Safefree(w32_pseudo_children);
4570 # ifdef USE_ITHREADS
4573 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4575 dst->perlshell_tokens = Nullch;
4576 dst->perlshell_vec = (char**)NULL;
4577 dst->perlshell_items = 0;
4578 dst->fdpid = newAV();
4579 Newz(1313, dst->children, 1, child_tab);
4581 Newz(1313, dst->pseudo_children, 1, child_tab);
4582 dst->thr_intern.Winit_socktype = 0;
4584 # endif /* USE_ITHREADS */
4585 #endif /* HAVE_INTERP_INTERN */
4588 win32_free_argvw(pTHX_ void *ptr)
4590 char** argv = (char**)ptr;
4598 win32_argv2utf8(int argc, char** argv)
4603 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4604 if (lpwStr && argc) {
4606 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4607 Newz(0, psz, length, char);
4608 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4611 call_atexit(win32_free_argvw, argv);
4613 GlobalFree((HGLOBAL)lpwStr);