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|PM_NOYIELD)) {
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 */
1746 KillTimer(NULL,w32_timerid);
1749 /* Now fake a call to signal handler */
1750 CALL_FPTR(PL_sighandlerp)(14);
1754 /* Otherwise do normal Win32 thing - in case it is useful */
1756 TranslateMessage(&msg);
1757 DispatchMessage(&msg);
1764 /* Above or other stuff may have set a signal flag */
1765 if (PL_sig_pending) {
1772 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1774 /* We may need several goes at this - so compute when we stop */
1776 if (timeout != INFINITE) {
1777 ticks = GetTickCount();
1781 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1784 if (result == WAIT_TIMEOUT) {
1785 /* Ran out of time - explicit return of zero to avoid -ve if we
1786 have scheduling issues
1790 if (timeout != INFINITE) {
1791 ticks = GetTickCount();
1793 if (result == WAIT_OBJECT_0 + count) {
1794 /* Message has arrived - check it */
1795 if (win32_async_check(aTHX)) {
1796 /* was one of ours */
1801 /* Not timeout or message - one of handles is ready */
1805 /* compute time left to wait */
1806 ticks = timeout - ticks;
1807 /* If we are past the end say zero */
1808 return (ticks > 0) ? ticks : 0;
1812 win32_internal_wait(int *status, DWORD timeout)
1814 /* XXX this wait emulation only knows about processes
1815 * spawned via win32_spawnvp(P_NOWAIT, ...).
1819 DWORD exitcode, waitcode;
1822 if (w32_num_pseudo_children) {
1823 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1824 timeout, &waitcode);
1825 /* Time out here if there are no other children to wait for. */
1826 if (waitcode == WAIT_TIMEOUT) {
1827 if (!w32_num_children) {
1831 else if (waitcode != WAIT_FAILED) {
1832 if (waitcode >= WAIT_ABANDONED_0
1833 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1834 i = waitcode - WAIT_ABANDONED_0;
1836 i = waitcode - WAIT_OBJECT_0;
1837 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1838 *status = (int)((exitcode & 0xff) << 8);
1839 retval = (int)w32_pseudo_child_pids[i];
1840 remove_dead_pseudo_process(i);
1847 if (!w32_num_children) {
1852 /* if a child exists, wait for it to die */
1853 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1854 if (waitcode == WAIT_TIMEOUT) {
1857 if (waitcode != WAIT_FAILED) {
1858 if (waitcode >= WAIT_ABANDONED_0
1859 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1860 i = waitcode - WAIT_ABANDONED_0;
1862 i = waitcode - WAIT_OBJECT_0;
1863 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1864 *status = (int)((exitcode & 0xff) << 8);
1865 retval = (int)w32_child_pids[i];
1866 remove_dead_process(i);
1872 errno = GetLastError();
1877 win32_waitpid(int pid, int *status, int flags)
1880 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1883 if (pid == -1) /* XXX threadid == 1 ? */
1884 return win32_internal_wait(status, timeout);
1887 child = find_pseudo_pid(-pid);
1889 HANDLE hThread = w32_pseudo_child_handles[child];
1891 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1892 if (waitcode == WAIT_TIMEOUT) {
1895 else if (waitcode == WAIT_OBJECT_0) {
1896 if (GetExitCodeThread(hThread, &waitcode)) {
1897 *status = (int)((waitcode & 0xff) << 8);
1898 retval = (int)w32_pseudo_child_pids[child];
1899 remove_dead_pseudo_process(child);
1906 else if (IsWin95()) {
1915 child = find_pid(pid);
1917 hProcess = w32_child_handles[child];
1918 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1919 if (waitcode == WAIT_TIMEOUT) {
1922 else if (waitcode == WAIT_OBJECT_0) {
1923 if (GetExitCodeProcess(hProcess, &waitcode)) {
1924 *status = (int)((waitcode & 0xff) << 8);
1925 retval = (int)w32_child_pids[child];
1926 remove_dead_process(child);
1935 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1936 (IsWin95() ? -pid : pid));
1938 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1939 if (waitcode == WAIT_TIMEOUT) {
1942 else if (waitcode == WAIT_OBJECT_0) {
1943 if (GetExitCodeProcess(hProcess, &waitcode)) {
1944 *status = (int)((waitcode & 0xff) << 8);
1945 CloseHandle(hProcess);
1949 CloseHandle(hProcess);
1955 return retval >= 0 ? pid : retval;
1959 win32_wait(int *status)
1961 return win32_internal_wait(status, INFINITE);
1964 DllExport unsigned int
1965 win32_sleep(unsigned int t)
1968 /* Win32 times are in ms so *1000 in and /1000 out */
1969 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
1972 DllExport unsigned int
1973 win32_alarm(unsigned int sec)
1976 * the 'obvious' implentation is SetTimer() with a callback
1977 * which does whatever receiving SIGALRM would do
1978 * we cannot use SIGALRM even via raise() as it is not
1979 * one of the supported codes in <signal.h>
1983 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
1987 KillTimer(NULL,w32_timerid);
1994 #ifdef HAVE_DES_FCRYPT
1995 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
1999 win32_crypt(const char *txt, const char *salt)
2002 #ifdef HAVE_DES_FCRYPT
2003 return des_fcrypt(txt, salt, w32_crypt_buffer);
2005 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2010 #ifdef USE_FIXED_OSFHANDLE
2012 #define FOPEN 0x01 /* file handle open */
2013 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2014 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2015 #define FDEV 0x40 /* file handle refers to device */
2016 #define FTEXT 0x80 /* file handle is in text mode */
2019 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2022 * This function allocates a free C Runtime file handle and associates
2023 * it with the Win32 HANDLE specified by the first parameter. This is a
2024 * temperary fix for WIN95's brain damage GetFileType() error on socket
2025 * we just bypass that call for socket
2027 * This works with MSVC++ 4.0+ or GCC/Mingw32
2030 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2031 * int flags - flags to associate with C Runtime file handle.
2034 * returns index of entry in fh, if successful
2035 * return -1, if no free entry is found
2039 *******************************************************************************/
2042 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2043 * this lets sockets work on Win9X with GCC and should fix the problems
2048 /* create an ioinfo entry, kill its handle, and steal the entry */
2053 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2054 int fh = _open_osfhandle((long)hF, 0);
2058 EnterCriticalSection(&(_pioinfo(fh)->lock));
2063 my_open_osfhandle(long osfhandle, int flags)
2066 char fileflags; /* _osfile flags */
2068 /* copy relevant flags from second parameter */
2071 if (flags & O_APPEND)
2072 fileflags |= FAPPEND;
2077 if (flags & O_NOINHERIT)
2078 fileflags |= FNOINHERIT;
2080 /* attempt to allocate a C Runtime file handle */
2081 if ((fh = _alloc_osfhnd()) == -1) {
2082 errno = EMFILE; /* too many open files */
2083 _doserrno = 0L; /* not an OS error */
2084 return -1; /* return error to caller */
2087 /* the file is open. now, set the info in _osfhnd array */
2088 _set_osfhnd(fh, osfhandle);
2090 fileflags |= FOPEN; /* mark as open */
2092 _osfile(fh) = fileflags; /* set osfile entry */
2093 LeaveCriticalSection(&_pioinfo(fh)->lock);
2095 return fh; /* return handle */
2098 #endif /* USE_FIXED_OSFHANDLE */
2100 /* simulate flock by locking a range on the file */
2102 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2103 #define LK_LEN 0xffff0000
2106 win32_flock(int fd, int oper)
2114 Perl_croak_nocontext("flock() unimplemented on this platform");
2117 fh = (HANDLE)_get_osfhandle(fd);
2118 memset(&o, 0, sizeof(o));
2121 case LOCK_SH: /* shared lock */
2122 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2124 case LOCK_EX: /* exclusive lock */
2125 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2127 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2128 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2130 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2131 LK_ERR(LockFileEx(fh,
2132 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2133 0, LK_LEN, 0, &o),i);
2135 case LOCK_UN: /* unlock lock */
2136 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2138 default: /* unknown */
2149 * redirected io subsystem for all XS modules
2162 return (&(_environ));
2165 /* the rest are the remapped stdio routines */
2185 win32_ferror(FILE *fp)
2187 return (ferror(fp));
2192 win32_feof(FILE *fp)
2198 * Since the errors returned by the socket error function
2199 * WSAGetLastError() are not known by the library routine strerror
2200 * we have to roll our own.
2204 win32_strerror(int e)
2206 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2207 extern int sys_nerr;
2211 if (e < 0 || e > sys_nerr) {
2216 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2217 w32_strerror_buffer,
2218 sizeof(w32_strerror_buffer), NULL) == 0)
2219 strcpy(w32_strerror_buffer, "Unknown Error");
2221 return w32_strerror_buffer;
2227 win32_str_os_error(void *sv, DWORD dwErr)
2231 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2232 |FORMAT_MESSAGE_IGNORE_INSERTS
2233 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2234 dwErr, 0, (char *)&sMsg, 1, NULL);
2235 /* strip trailing whitespace and period */
2238 --dwLen; /* dwLen doesn't include trailing null */
2239 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2240 if ('.' != sMsg[dwLen])
2245 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2247 dwLen = sprintf(sMsg,
2248 "Unknown error #0x%lX (lookup 0x%lX)",
2249 dwErr, GetLastError());
2253 sv_setpvn((SV*)sv, sMsg, dwLen);
2259 win32_fprintf(FILE *fp, const char *format, ...)
2262 va_start(marker, format); /* Initialize variable arguments. */
2264 return (vfprintf(fp, format, marker));
2268 win32_printf(const char *format, ...)
2271 va_start(marker, format); /* Initialize variable arguments. */
2273 return (vprintf(format, marker));
2277 win32_vfprintf(FILE *fp, const char *format, va_list args)
2279 return (vfprintf(fp, format, args));
2283 win32_vprintf(const char *format, va_list args)
2285 return (vprintf(format, args));
2289 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2291 return fread(buf, size, count, fp);
2295 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2297 return fwrite(buf, size, count, fp);
2300 #define MODE_SIZE 10
2303 win32_fopen(const char *filename, const char *mode)
2306 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2312 if (stricmp(filename, "/dev/null")==0)
2316 A2WHELPER(mode, wMode, sizeof(wMode));
2317 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2318 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2321 f = fopen(PerlDir_mapA(filename), mode);
2322 /* avoid buffering headaches for child processes */
2323 if (f && *mode == 'a')
2324 win32_fseek(f, 0, SEEK_END);
2328 #ifndef USE_SOCKETS_AS_HANDLES
2330 #define fdopen my_fdopen
2334 win32_fdopen(int handle, const char *mode)
2337 WCHAR wMode[MODE_SIZE];
2340 A2WHELPER(mode, wMode, sizeof(wMode));
2341 f = _wfdopen(handle, wMode);
2344 f = fdopen(handle, (char *) mode);
2345 /* avoid buffering headaches for child processes */
2346 if (f && *mode == 'a')
2347 win32_fseek(f, 0, SEEK_END);
2352 win32_freopen(const char *path, const char *mode, FILE *stream)
2355 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2356 if (stricmp(path, "/dev/null")==0)
2360 A2WHELPER(mode, wMode, sizeof(wMode));
2361 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2362 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2364 return freopen(PerlDir_mapA(path), mode, stream);
2368 win32_fclose(FILE *pf)
2370 return my_fclose(pf); /* defined in win32sck.c */
2374 win32_fputs(const char *s,FILE *pf)
2376 return fputs(s, pf);
2380 win32_fputc(int c,FILE *pf)
2386 win32_ungetc(int c,FILE *pf)
2388 return ungetc(c,pf);
2392 win32_getc(FILE *pf)
2398 win32_fileno(FILE *pf)
2404 win32_clearerr(FILE *pf)
2411 win32_fflush(FILE *pf)
2417 win32_ftell(FILE *pf)
2423 win32_fseek(FILE *pf,long offset,int origin)
2425 return fseek(pf, offset, origin);
2429 win32_fgetpos(FILE *pf,fpos_t *p)
2431 return fgetpos(pf, p);
2435 win32_fsetpos(FILE *pf,const fpos_t *p)
2437 return fsetpos(pf, p);
2441 win32_rewind(FILE *pf)
2451 char prefix[MAX_PATH+1];
2452 char filename[MAX_PATH+1];
2453 DWORD len = GetTempPath(MAX_PATH, prefix);
2454 if (len && len < MAX_PATH) {
2455 if (GetTempFileName(prefix, "plx", 0, filename)) {
2456 HANDLE fh = CreateFile(filename,
2457 DELETE | GENERIC_READ | GENERIC_WRITE,
2461 FILE_ATTRIBUTE_NORMAL
2462 | FILE_FLAG_DELETE_ON_CLOSE,
2464 if (fh != INVALID_HANDLE_VALUE) {
2465 int fd = win32_open_osfhandle((long)fh, 0);
2467 DEBUG_p(PerlIO_printf(Perl_debug_log,
2468 "Created tmpfile=%s\n",filename));
2469 return fdopen(fd, "w+b");
2485 win32_fstat(int fd,struct stat *sbufptr)
2488 /* A file designated by filehandle is not shown as accessible
2489 * for write operations, probably because it is opened for reading.
2492 int rc = fstat(fd,sbufptr);
2493 BY_HANDLE_FILE_INFORMATION bhfi;
2494 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2495 sbufptr->st_mode &= 0xFE00;
2496 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2497 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2499 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2500 + ((S_IREAD|S_IWRITE) >> 6));
2504 return my_fstat(fd,sbufptr);
2509 win32_pipe(int *pfd, unsigned int size, int mode)
2511 return _pipe(pfd, size, mode);
2515 win32_popenlist(const char *mode, IV narg, SV **args)
2518 Perl_croak(aTHX_ "List form of pipe open not implemented");
2523 * a popen() clone that respects PERL5SHELL
2525 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2529 win32_popen(const char *command, const char *mode)
2531 #ifdef USE_RTL_POPEN
2532 return _popen(command, mode);
2540 /* establish which ends read and write */
2541 if (strchr(mode,'w')) {
2542 stdfd = 0; /* stdin */
2546 else if (strchr(mode,'r')) {
2547 stdfd = 1; /* stdout */
2554 /* set the correct mode */
2555 if (strchr(mode,'b'))
2557 else if (strchr(mode,'t'))
2560 ourmode = _fmode & (O_TEXT | O_BINARY);
2562 /* the child doesn't inherit handles */
2563 ourmode |= O_NOINHERIT;
2565 if (win32_pipe( p, 512, ourmode) == -1)
2568 /* save current stdfd */
2569 if ((oldfd = win32_dup(stdfd)) == -1)
2572 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2573 /* stdfd will be inherited by the child */
2574 if (win32_dup2(p[child], stdfd) == -1)
2577 /* close the child end in parent */
2578 win32_close(p[child]);
2580 /* start the child */
2583 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2586 /* revert stdfd to whatever it was before */
2587 if (win32_dup2(oldfd, stdfd) == -1)
2590 /* close saved handle */
2594 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2597 /* set process id so that it can be returned by perl's open() */
2598 PL_forkprocess = childpid;
2601 /* we have an fd, return a file stream */
2602 return (PerlIO_fdopen(p[parent], (char *)mode));
2605 /* we don't need to check for errors here */
2609 win32_dup2(oldfd, stdfd);
2614 #endif /* USE_RTL_POPEN */
2622 win32_pclose(PerlIO *pf)
2624 #ifdef USE_RTL_POPEN
2628 int childpid, status;
2632 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2635 childpid = SvIVX(sv);
2652 if (win32_waitpid(childpid, &status, 0) == -1)
2657 #endif /* USE_RTL_POPEN */
2663 LPCWSTR lpExistingFileName,
2664 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2667 WCHAR wFullName[MAX_PATH+1];
2668 LPVOID lpContext = NULL;
2669 WIN32_STREAM_ID StreamId;
2670 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2675 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2676 BOOL, BOOL, LPVOID*) =
2677 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2678 BOOL, BOOL, LPVOID*))
2679 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2680 if (pfnBackupWrite == NULL)
2683 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2686 dwLen = (dwLen+1)*sizeof(WCHAR);
2688 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2689 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2690 NULL, OPEN_EXISTING, 0, NULL);
2691 if (handle == INVALID_HANDLE_VALUE)
2694 StreamId.dwStreamId = BACKUP_LINK;
2695 StreamId.dwStreamAttributes = 0;
2696 StreamId.dwStreamNameSize = 0;
2697 #if defined(__BORLANDC__) \
2698 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2699 StreamId.Size.u.HighPart = 0;
2700 StreamId.Size.u.LowPart = dwLen;
2702 StreamId.Size.HighPart = 0;
2703 StreamId.Size.LowPart = dwLen;
2706 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2707 FALSE, FALSE, &lpContext);
2709 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2710 FALSE, FALSE, &lpContext);
2711 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2714 CloseHandle(handle);
2719 win32_link(const char *oldname, const char *newname)
2722 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2723 WCHAR wOldName[MAX_PATH+1];
2724 WCHAR wNewName[MAX_PATH+1];
2727 Perl_croak(aTHX_ PL_no_func, "link");
2729 pfnCreateHardLinkW =
2730 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2731 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2732 if (pfnCreateHardLinkW == NULL)
2733 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2735 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2736 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2737 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2738 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2742 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2747 win32_rename(const char *oname, const char *newname)
2749 WCHAR wOldName[MAX_PATH+1];
2750 WCHAR wNewName[MAX_PATH+1];
2751 char szOldName[MAX_PATH+1];
2752 char szNewName[MAX_PATH+1];
2756 /* XXX despite what the documentation says about MoveFileEx(),
2757 * it doesn't work under Windows95!
2760 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2762 A2WHELPER(oname, wOldName, sizeof(wOldName));
2763 A2WHELPER(newname, wNewName, sizeof(wNewName));
2764 if (wcsicmp(wNewName, wOldName))
2765 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2766 wcscpy(wOldName, PerlDir_mapW(wOldName));
2767 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2770 if (stricmp(newname, oname))
2771 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2772 strcpy(szOldName, PerlDir_mapA(oname));
2773 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2776 DWORD err = GetLastError();
2778 case ERROR_BAD_NET_NAME:
2779 case ERROR_BAD_NETPATH:
2780 case ERROR_BAD_PATHNAME:
2781 case ERROR_FILE_NOT_FOUND:
2782 case ERROR_FILENAME_EXCED_RANGE:
2783 case ERROR_INVALID_DRIVE:
2784 case ERROR_NO_MORE_FILES:
2785 case ERROR_PATH_NOT_FOUND:
2798 char szTmpName[MAX_PATH+1];
2799 char dname[MAX_PATH+1];
2800 char *endname = Nullch;
2802 DWORD from_attr, to_attr;
2804 strcpy(szOldName, PerlDir_mapA(oname));
2805 strcpy(szNewName, PerlDir_mapA(newname));
2807 /* if oname doesn't exist, do nothing */
2808 from_attr = GetFileAttributes(szOldName);
2809 if (from_attr == 0xFFFFFFFF) {
2814 /* if newname exists, rename it to a temporary name so that we
2815 * don't delete it in case oname happens to be the same file
2816 * (but perhaps accessed via a different path)
2818 to_attr = GetFileAttributes(szNewName);
2819 if (to_attr != 0xFFFFFFFF) {
2820 /* if newname is a directory, we fail
2821 * XXX could overcome this with yet more convoluted logic */
2822 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2826 tmplen = strlen(szNewName);
2827 strcpy(szTmpName,szNewName);
2828 endname = szTmpName+tmplen;
2829 for (; endname > szTmpName ; --endname) {
2830 if (*endname == '/' || *endname == '\\') {
2835 if (endname > szTmpName)
2836 endname = strcpy(dname,szTmpName);
2840 /* get a temporary filename in same directory
2841 * XXX is this really the best we can do? */
2842 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2846 DeleteFile(szTmpName);
2848 retval = rename(szNewName, szTmpName);
2855 /* rename oname to newname */
2856 retval = rename(szOldName, szNewName);
2858 /* if we created a temporary file before ... */
2859 if (endname != Nullch) {
2860 /* ...and rename succeeded, delete temporary file/directory */
2862 DeleteFile(szTmpName);
2863 /* else restore it to what it was */
2865 (void)rename(szTmpName, szNewName);
2872 win32_setmode(int fd, int mode)
2874 return setmode(fd, mode);
2878 win32_lseek(int fd, long offset, int origin)
2880 return lseek(fd, offset, origin);
2890 win32_open(const char *path, int flag, ...)
2895 WCHAR wBuffer[MAX_PATH+1];
2898 pmode = va_arg(ap, int);
2901 if (stricmp(path, "/dev/null")==0)
2905 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2906 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2908 return open(PerlDir_mapA(path), flag, pmode);
2911 /* close() that understands socket */
2912 extern int my_close(int); /* in win32sck.c */
2917 return my_close(fd);
2933 win32_dup2(int fd1,int fd2)
2935 return dup2(fd1,fd2);
2938 #ifdef PERL_MSVCRT_READFIX
2940 #define LF 10 /* line feed */
2941 #define CR 13 /* carriage return */
2942 #define CTRLZ 26 /* ctrl-z means eof for text */
2943 #define FOPEN 0x01 /* file handle open */
2944 #define FEOFLAG 0x02 /* end of file has been encountered */
2945 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2946 #define FPIPE 0x08 /* file handle refers to a pipe */
2947 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2948 #define FDEV 0x40 /* file handle refers to device */
2949 #define FTEXT 0x80 /* file handle is in text mode */
2950 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
2953 _fixed_read(int fh, void *buf, unsigned cnt)
2955 int bytes_read; /* number of bytes read */
2956 char *buffer; /* buffer to read to */
2957 int os_read; /* bytes read on OS call */
2958 char *p, *q; /* pointers into buffer */
2959 char peekchr; /* peek-ahead character */
2960 ULONG filepos; /* file position after seek */
2961 ULONG dosretval; /* o.s. return value */
2963 /* validate handle */
2964 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
2965 !(_osfile(fh) & FOPEN))
2967 /* out of range -- return error */
2969 _doserrno = 0; /* not o.s. error */
2974 * If lockinitflag is FALSE, assume fd is device
2975 * lockinitflag is set to TRUE by open.
2977 if (_pioinfo(fh)->lockinitflag)
2978 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
2980 bytes_read = 0; /* nothing read yet */
2981 buffer = (char*)buf;
2983 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
2984 /* nothing to read or at EOF, so return 0 read */
2988 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
2989 /* a pipe/device and pipe lookahead non-empty: read the lookahead
2991 *buffer++ = _pipech(fh);
2994 _pipech(fh) = LF; /* mark as empty */
2999 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3001 /* ReadFile has reported an error. recognize two special cases.
3003 * 1. map ERROR_ACCESS_DENIED to EBADF
3005 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3006 * means the handle is a read-handle on a pipe for which
3007 * all write-handles have been closed and all data has been
3010 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3011 /* wrong read/write mode should return EBADF, not EACCES */
3013 _doserrno = dosretval;
3017 else if (dosretval == ERROR_BROKEN_PIPE) {
3027 bytes_read += os_read; /* update bytes read */
3029 if (_osfile(fh) & FTEXT) {
3030 /* now must translate CR-LFs to LFs in the buffer */
3032 /* set CRLF flag to indicate LF at beginning of buffer */
3033 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3034 /* _osfile(fh) |= FCRLF; */
3036 /* _osfile(fh) &= ~FCRLF; */
3038 _osfile(fh) &= ~FCRLF;
3040 /* convert chars in the buffer: p is src, q is dest */
3042 while (p < (char *)buf + bytes_read) {
3044 /* if fh is not a device, set ctrl-z flag */
3045 if (!(_osfile(fh) & FDEV))
3046 _osfile(fh) |= FEOFLAG;
3047 break; /* stop translating */
3052 /* *p is CR, so must check next char for LF */
3053 if (p < (char *)buf + bytes_read - 1) {
3056 *q++ = LF; /* convert CR-LF to LF */
3059 *q++ = *p++; /* store char normally */
3062 /* This is the hard part. We found a CR at end of
3063 buffer. We must peek ahead to see if next char
3068 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3069 (LPDWORD)&os_read, NULL))
3070 dosretval = GetLastError();
3072 if (dosretval != 0 || os_read == 0) {
3073 /* couldn't read ahead, store CR */
3077 /* peekchr now has the extra character -- we now
3078 have several possibilities:
3079 1. disk file and char is not LF; just seek back
3081 2. disk file and char is LF; store LF, don't seek back
3082 3. pipe/device and char is LF; store LF.
3083 4. pipe/device and char isn't LF, store CR and
3084 put char in pipe lookahead buffer. */
3085 if (_osfile(fh) & (FDEV|FPIPE)) {
3086 /* non-seekable device */
3091 _pipech(fh) = peekchr;
3096 if (peekchr == LF) {
3097 /* nothing read yet; must make some
3100 /* turn on this flag for tell routine */
3101 _osfile(fh) |= FCRLF;
3104 HANDLE osHandle; /* o.s. handle value */
3106 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3108 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3109 dosretval = GetLastError();
3120 /* we now change bytes_read to reflect the true number of chars
3122 bytes_read = q - (char *)buf;
3126 if (_pioinfo(fh)->lockinitflag)
3127 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3132 #endif /* PERL_MSVCRT_READFIX */
3135 win32_read(int fd, void *buf, unsigned int cnt)
3137 #ifdef PERL_MSVCRT_READFIX
3138 return _fixed_read(fd, buf, cnt);
3140 return read(fd, buf, cnt);
3145 win32_write(int fd, const void *buf, unsigned int cnt)
3147 return write(fd, buf, cnt);
3151 win32_mkdir(const char *dir, int mode)
3155 WCHAR wBuffer[MAX_PATH+1];
3156 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3157 return _wmkdir(PerlDir_mapW(wBuffer));
3159 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3163 win32_rmdir(const char *dir)
3167 WCHAR wBuffer[MAX_PATH+1];
3168 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3169 return _wrmdir(PerlDir_mapW(wBuffer));
3171 return rmdir(PerlDir_mapA(dir));
3175 win32_chdir(const char *dir)
3183 WCHAR wBuffer[MAX_PATH+1];
3184 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3185 return _wchdir(wBuffer);
3191 win32_access(const char *path, int mode)
3195 WCHAR wBuffer[MAX_PATH+1];
3196 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3197 return _waccess(PerlDir_mapW(wBuffer), mode);
3199 return access(PerlDir_mapA(path), mode);
3203 win32_chmod(const char *path, int mode)
3207 WCHAR wBuffer[MAX_PATH+1];
3208 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3209 return _wchmod(PerlDir_mapW(wBuffer), mode);
3211 return chmod(PerlDir_mapA(path), mode);
3216 create_command_line(char *cname, STRLEN clen, const char * const *args)
3223 bool bat_file = FALSE;
3224 bool cmd_shell = FALSE;
3225 bool dumb_shell = FALSE;
3226 bool extra_quotes = FALSE;
3227 bool quote_next = FALSE;
3230 cname = (char*)args[0];
3232 /* The NT cmd.exe shell has the following peculiarity that needs to be
3233 * worked around. It strips a leading and trailing dquote when any
3234 * of the following is true:
3235 * 1. the /S switch was used
3236 * 2. there are more than two dquotes
3237 * 3. there is a special character from this set: &<>()@^|
3238 * 4. no whitespace characters within the two dquotes
3239 * 5. string between two dquotes isn't an executable file
3240 * To work around this, we always add a leading and trailing dquote
3241 * to the string, if the first argument is either "cmd.exe" or "cmd",
3242 * and there were at least two or more arguments passed to cmd.exe
3243 * (not including switches).
3244 * XXX the above rules (from "cmd /?") don't seem to be applied
3245 * always, making for the convolutions below :-(
3249 clen = strlen(cname);
3252 && (stricmp(&cname[clen-4], ".bat") == 0
3253 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3259 char *exe = strrchr(cname, '/');
3260 char *exe2 = strrchr(cname, '\\');
3267 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3271 else if (stricmp(exe, "command.com") == 0
3272 || stricmp(exe, "command") == 0)
3279 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3280 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3281 STRLEN curlen = strlen(arg);
3282 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3283 len += 2; /* assume quoting needed (worst case) */
3285 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3287 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3290 New(1310, cmd, len, char);
3295 extra_quotes = TRUE;
3298 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3300 STRLEN curlen = strlen(arg);
3302 /* we want to protect empty arguments and ones with spaces with
3303 * dquotes, but only if they aren't already there */
3308 else if (quote_next) {
3309 /* see if it really is multiple arguments pretending to
3310 * be one and force a set of quotes around it */
3311 if (*find_next_space(arg))
3314 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3316 while (i < curlen) {
3317 if (isSPACE(arg[i])) {
3320 else if (arg[i] == '"') {
3343 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3345 /* is there a next argument? */
3346 if (args[index+1]) {
3347 /* are there two or more next arguments? */
3348 if (args[index+2]) {
3350 extra_quotes = TRUE;
3353 /* single argument, force quoting if it has spaces */
3369 qualified_path(const char *cmd)
3373 char *fullcmd, *curfullcmd;
3379 fullcmd = (char*)cmd;
3381 if (*fullcmd == '/' || *fullcmd == '\\')
3388 pathstr = PerlEnv_getenv("PATH");
3389 New(0, fullcmd, MAX_PATH+1, char);
3390 curfullcmd = fullcmd;
3395 /* start by appending the name to the current prefix */
3396 strcpy(curfullcmd, cmd);
3397 curfullcmd += cmdlen;
3399 /* if it doesn't end with '.', or has no extension, try adding
3400 * a trailing .exe first */
3401 if (cmd[cmdlen-1] != '.'
3402 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3404 strcpy(curfullcmd, ".exe");
3405 res = GetFileAttributes(fullcmd);
3406 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3411 /* that failed, try the bare name */
3412 res = GetFileAttributes(fullcmd);
3413 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3416 /* quit if no other path exists, or if cmd already has path */
3417 if (!pathstr || !*pathstr || has_slash)
3420 /* skip leading semis */
3421 while (*pathstr == ';')
3424 /* build a new prefix from scratch */
3425 curfullcmd = fullcmd;
3426 while (*pathstr && *pathstr != ';') {
3427 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3428 pathstr++; /* skip initial '"' */
3429 while (*pathstr && *pathstr != '"') {
3430 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3431 *curfullcmd++ = *pathstr;
3435 pathstr++; /* skip trailing '"' */
3438 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3439 *curfullcmd++ = *pathstr;
3444 pathstr++; /* skip trailing semi */
3445 if (curfullcmd > fullcmd /* append a dir separator */
3446 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3448 *curfullcmd++ = '\\';
3456 /* The following are just place holders.
3457 * Some hosts may provide and environment that the OS is
3458 * not tracking, therefore, these host must provide that
3459 * environment and the current directory to CreateProcess
3463 win32_get_childenv(void)
3469 win32_free_childenv(void* d)
3474 win32_clearenv(void)
3476 char *envv = GetEnvironmentStrings();
3480 char *end = strchr(cur,'=');
3481 if (end && end != cur) {
3483 SetEnvironmentVariable(cur, NULL);
3485 cur = end + strlen(end+1)+2;
3487 else if ((len = strlen(cur)))
3490 FreeEnvironmentStrings(envv);
3494 win32_get_childdir(void)
3498 char szfilename[(MAX_PATH+1)*2];
3500 WCHAR wfilename[MAX_PATH+1];
3501 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3502 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3505 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3508 New(0, ptr, strlen(szfilename)+1, char);
3509 strcpy(ptr, szfilename);
3514 win32_free_childdir(char* d)
3521 /* XXX this needs to be made more compatible with the spawnvp()
3522 * provided by the various RTLs. In particular, searching for
3523 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3524 * This doesn't significantly affect perl itself, because we
3525 * always invoke things using PERL5SHELL if a direct attempt to
3526 * spawn the executable fails.
3528 * XXX splitting and rejoining the commandline between do_aspawn()
3529 * and win32_spawnvp() could also be avoided.
3533 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3535 #ifdef USE_RTL_SPAWNVP
3536 return spawnvp(mode, cmdname, (char * const *)argv);
3543 STARTUPINFO StartupInfo;
3544 PROCESS_INFORMATION ProcessInformation;
3547 char *fullcmd = Nullch;
3548 char *cname = (char *)cmdname;
3552 clen = strlen(cname);
3553 /* if command name contains dquotes, must remove them */
3554 if (strchr(cname, '"')) {
3556 New(0,cname,clen+1,char);
3569 cmd = create_command_line(cname, clen, argv);
3571 env = PerlEnv_get_childenv();
3572 dir = PerlEnv_get_childdir();
3575 case P_NOWAIT: /* asynch + remember result */
3576 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3581 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3584 create |= CREATE_NEW_PROCESS_GROUP;
3587 case P_WAIT: /* synchronous execution */
3589 default: /* invalid mode */
3594 memset(&StartupInfo,0,sizeof(StartupInfo));
3595 StartupInfo.cb = sizeof(StartupInfo);
3596 memset(&tbl,0,sizeof(tbl));
3597 PerlEnv_get_child_IO(&tbl);
3598 StartupInfo.dwFlags = tbl.dwFlags;
3599 StartupInfo.dwX = tbl.dwX;
3600 StartupInfo.dwY = tbl.dwY;
3601 StartupInfo.dwXSize = tbl.dwXSize;
3602 StartupInfo.dwYSize = tbl.dwYSize;
3603 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3604 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3605 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3606 StartupInfo.wShowWindow = tbl.wShowWindow;
3607 StartupInfo.hStdInput = tbl.childStdIn;
3608 StartupInfo.hStdOutput = tbl.childStdOut;
3609 StartupInfo.hStdError = tbl.childStdErr;
3610 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3611 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3612 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3614 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3617 create |= CREATE_NEW_CONSOLE;
3620 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3623 if (!CreateProcess(cname, /* search PATH to find executable */
3624 cmd, /* executable, and its arguments */
3625 NULL, /* process attributes */
3626 NULL, /* thread attributes */
3627 TRUE, /* inherit handles */
3628 create, /* creation flags */
3629 (LPVOID)env, /* inherit environment */
3630 dir, /* inherit cwd */
3632 &ProcessInformation))
3634 /* initial NULL argument to CreateProcess() does a PATH
3635 * search, but it always first looks in the directory
3636 * where the current process was started, which behavior
3637 * is undesirable for backward compatibility. So we
3638 * jump through our own hoops by picking out the path
3639 * we really want it to use. */
3641 fullcmd = qualified_path(cname);
3643 if (cname != cmdname)
3646 DEBUG_p(PerlIO_printf(Perl_debug_log,
3647 "Retrying [%s] with same args\n",
3657 if (mode == P_NOWAIT) {
3658 /* asynchronous spawn -- store handle, return PID */
3659 ret = (int)ProcessInformation.dwProcessId;
3660 if (IsWin95() && ret < 0)
3663 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3664 w32_child_pids[w32_num_children] = (DWORD)ret;
3669 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3670 /* FIXME: if msgwait returned due to message perhaps forward the
3671 "signal" to the process
3673 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3675 CloseHandle(ProcessInformation.hProcess);
3678 CloseHandle(ProcessInformation.hThread);
3681 PerlEnv_free_childenv(env);
3682 PerlEnv_free_childdir(dir);
3684 if (cname != cmdname)
3691 win32_execv(const char *cmdname, const char *const *argv)
3695 /* if this is a pseudo-forked child, we just want to spawn
3696 * the new program, and return */
3698 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3700 return execv(cmdname, (char *const *)argv);
3704 win32_execvp(const char *cmdname, const char *const *argv)
3708 /* if this is a pseudo-forked child, we just want to spawn
3709 * the new program, and return */
3710 if (w32_pseudo_id) {
3711 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3720 return execvp(cmdname, (char *const *)argv);
3724 win32_perror(const char *str)
3730 win32_setbuf(FILE *pf, char *buf)
3736 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3738 return setvbuf(pf, buf, type, size);
3742 win32_flushall(void)
3748 win32_fcloseall(void)
3754 win32_fgets(char *s, int n, FILE *pf)
3756 return fgets(s, n, pf);
3766 win32_fgetc(FILE *pf)
3772 win32_putc(int c, FILE *pf)
3778 win32_puts(const char *s)
3790 win32_putchar(int c)
3797 #ifndef USE_PERL_SBRK
3799 static char *committed = NULL; /* XXX threadead */
3800 static char *base = NULL; /* XXX threadead */
3801 static char *reserved = NULL; /* XXX threadead */
3802 static char *brk = NULL; /* XXX threadead */
3803 static DWORD pagesize = 0; /* XXX threadead */
3804 static DWORD allocsize = 0; /* XXX threadead */
3812 GetSystemInfo(&info);
3813 /* Pretend page size is larger so we don't perpetually
3814 * call the OS to commit just one page ...
3816 pagesize = info.dwPageSize << 3;
3817 allocsize = info.dwAllocationGranularity;
3819 /* This scheme fails eventually if request for contiguous
3820 * block is denied so reserve big blocks - this is only
3821 * address space not memory ...
3823 if (brk+need >= reserved)
3825 DWORD size = 64*1024*1024;
3827 if (committed && reserved && committed < reserved)
3829 /* Commit last of previous chunk cannot span allocations */
3830 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3832 committed = reserved;
3834 /* Reserve some (more) space
3835 * Note this is a little sneaky, 1st call passes NULL as reserved
3836 * so lets system choose where we start, subsequent calls pass
3837 * the old end address so ask for a contiguous block
3839 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3842 reserved = addr+size;
3857 if (brk > committed)
3859 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3860 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3875 win32_malloc(size_t size)
3877 return malloc(size);
3881 win32_calloc(size_t numitems, size_t size)
3883 return calloc(numitems,size);
3887 win32_realloc(void *block, size_t size)
3889 return realloc(block,size);
3893 win32_free(void *block)
3900 win32_open_osfhandle(long handle, int flags)
3902 #ifdef USE_FIXED_OSFHANDLE
3904 return my_open_osfhandle(handle, flags);
3906 return _open_osfhandle(handle, flags);
3910 win32_get_osfhandle(int fd)
3912 return _get_osfhandle(fd);
3916 win32_dynaload(const char* filename)
3920 char buf[MAX_PATH+1];
3923 /* LoadLibrary() doesn't recognize forward slashes correctly,
3924 * so turn 'em back. */
3925 first = strchr(filename, '/');
3927 STRLEN len = strlen(filename);
3928 if (len <= MAX_PATH) {
3929 strcpy(buf, filename);
3930 filename = &buf[first - filename];
3932 if (*filename == '/')
3933 *(char*)filename = '\\';
3940 WCHAR wfilename[MAX_PATH+1];
3941 A2WHELPER(filename, wfilename, sizeof(wfilename));
3942 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3945 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3958 /* Make the host for current directory */
3959 char* ptr = PerlEnv_get_childdir();
3962 * then it worked, set PV valid,
3963 * else return 'undef'
3966 SV *sv = sv_newmortal();
3968 PerlEnv_free_childdir(ptr);
3970 #ifndef INCOMPLETE_TAINTS
3987 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
3988 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
3995 XS(w32_GetNextAvailDrive)
3999 char root[] = "_:\\";
4004 if (GetDriveType(root) == 1) {
4013 XS(w32_GetLastError)
4017 XSRETURN_IV(GetLastError());
4021 XS(w32_SetLastError)
4025 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4026 SetLastError(SvIV(ST(0)));
4034 char *name = w32_getlogin_buffer;
4035 DWORD size = sizeof(w32_getlogin_buffer);
4037 if (GetUserName(name,&size)) {
4038 /* size includes NULL */
4039 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4049 char name[MAX_COMPUTERNAME_LENGTH+1];
4050 DWORD size = sizeof(name);
4052 if (GetComputerName(name,&size)) {
4053 /* size does NOT include NULL :-( */
4054 ST(0) = sv_2mortal(newSVpvn(name,size));
4065 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4066 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4067 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4071 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4072 GetProcAddress(hNetApi32, "NetApiBufferFree");
4073 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4074 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4077 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4078 /* this way is more reliable, in case user has a local account. */
4080 DWORD dnamelen = sizeof(dname);
4082 DWORD wki100_platform_id;
4083 LPWSTR wki100_computername;
4084 LPWSTR wki100_langroup;
4085 DWORD wki100_ver_major;
4086 DWORD wki100_ver_minor;
4088 /* NERR_Success *is* 0*/
4089 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4090 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4091 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4092 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4095 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4096 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4098 pfnNetApiBufferFree(pwi);
4099 FreeLibrary(hNetApi32);
4102 FreeLibrary(hNetApi32);
4105 /* Win95 doesn't have NetWksta*(), so do it the old way */
4107 DWORD size = sizeof(name);
4109 FreeLibrary(hNetApi32);
4110 if (GetUserName(name,&size)) {
4111 char sid[ONE_K_BUFSIZE];
4112 DWORD sidlen = sizeof(sid);
4114 DWORD dnamelen = sizeof(dname);
4116 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4117 dname, &dnamelen, &snu)) {
4118 XSRETURN_PV(dname); /* all that for this */
4130 DWORD flags, filecomplen;
4131 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4132 &flags, fsname, sizeof(fsname))) {
4133 if (GIMME_V == G_ARRAY) {
4134 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4135 XPUSHs(sv_2mortal(newSViv(flags)));
4136 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4141 XSRETURN_PV(fsname);
4147 XS(w32_GetOSVersion)
4150 OSVERSIONINFOA osver;
4153 OSVERSIONINFOW osverw;
4154 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4155 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4156 if (!GetVersionExW(&osverw)) {
4159 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4160 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4161 osver.dwMajorVersion = osverw.dwMajorVersion;
4162 osver.dwMinorVersion = osverw.dwMinorVersion;
4163 osver.dwBuildNumber = osverw.dwBuildNumber;
4164 osver.dwPlatformId = osverw.dwPlatformId;
4167 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4168 if (!GetVersionExA(&osver)) {
4171 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4173 XPUSHs(newSViv(osver.dwMajorVersion));
4174 XPUSHs(newSViv(osver.dwMinorVersion));
4175 XPUSHs(newSViv(osver.dwBuildNumber));
4176 XPUSHs(newSViv(osver.dwPlatformId));
4185 XSRETURN_IV(IsWinNT());
4193 XSRETURN_IV(IsWin95());
4197 XS(w32_FormatMessage)
4201 char msgbuf[ONE_K_BUFSIZE];
4204 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4207 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4208 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4209 &source, SvIV(ST(0)), 0,
4210 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4212 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4213 XSRETURN_PV(msgbuf);
4217 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4218 &source, SvIV(ST(0)), 0,
4219 msgbuf, sizeof(msgbuf)-1, NULL))
4220 XSRETURN_PV(msgbuf);
4233 PROCESS_INFORMATION stProcInfo;
4234 STARTUPINFO stStartInfo;
4235 BOOL bSuccess = FALSE;
4238 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4240 cmd = SvPV_nolen(ST(0));
4241 args = SvPV_nolen(ST(1));
4243 env = PerlEnv_get_childenv();
4244 dir = PerlEnv_get_childdir();
4246 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4247 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4248 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4249 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4252 cmd, /* Image path */
4253 args, /* Arguments for command line */
4254 NULL, /* Default process security */
4255 NULL, /* Default thread security */
4256 FALSE, /* Must be TRUE to use std handles */
4257 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4258 env, /* Inherit our environment block */
4259 dir, /* Inherit our currrent directory */
4260 &stStartInfo, /* -> Startup info */
4261 &stProcInfo)) /* <- Process info (if OK) */
4263 int pid = (int)stProcInfo.dwProcessId;
4264 if (IsWin95() && pid < 0)
4266 sv_setiv(ST(2), pid);
4267 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4270 PerlEnv_free_childenv(env);
4271 PerlEnv_free_childdir(dir);
4272 XSRETURN_IV(bSuccess);
4276 XS(w32_GetTickCount)
4279 DWORD msec = GetTickCount();
4287 XS(w32_GetShortPathName)
4294 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4296 shortpath = sv_mortalcopy(ST(0));
4297 SvUPGRADE(shortpath, SVt_PV);
4298 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4301 /* src == target is allowed */
4303 len = GetShortPathName(SvPVX(shortpath),
4306 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4308 SvCUR_set(shortpath,len);
4316 XS(w32_GetFullPathName)
4325 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4328 fullpath = sv_mortalcopy(filename);
4329 SvUPGRADE(fullpath, SVt_PV);
4330 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4334 len = GetFullPathName(SvPVX(filename),
4338 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4340 if (GIMME_V == G_ARRAY) {
4342 XST_mPV(1,filepart);
4343 len = filepart - SvPVX(fullpath);
4346 SvCUR_set(fullpath,len);
4354 XS(w32_GetLongPathName)
4358 char tmpbuf[MAX_PATH+1];
4363 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4366 pathstr = SvPV(path,len);
4367 strcpy(tmpbuf, pathstr);
4368 pathstr = win32_longpath(tmpbuf);
4370 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4381 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4392 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4394 WCHAR wSourceFile[MAX_PATH+1];
4395 WCHAR wDestFile[MAX_PATH+1];
4396 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4397 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4398 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4399 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4402 char szSourceFile[MAX_PATH+1];
4403 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4404 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4413 Perl_init_os_extras(void)
4416 char *file = __FILE__;
4419 /* these names are Activeware compatible */
4420 newXS("Win32::GetCwd", w32_GetCwd, file);
4421 newXS("Win32::SetCwd", w32_SetCwd, file);
4422 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4423 newXS("Win32::GetLastError", w32_GetLastError, file);
4424 newXS("Win32::SetLastError", w32_SetLastError, file);
4425 newXS("Win32::LoginName", w32_LoginName, file);
4426 newXS("Win32::NodeName", w32_NodeName, file);
4427 newXS("Win32::DomainName", w32_DomainName, file);
4428 newXS("Win32::FsType", w32_FsType, file);
4429 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4430 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4431 newXS("Win32::IsWin95", w32_IsWin95, file);
4432 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4433 newXS("Win32::Spawn", w32_Spawn, file);
4434 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4435 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4436 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4437 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4438 newXS("Win32::CopyFile", w32_CopyFile, file);
4439 newXS("Win32::Sleep", w32_Sleep, file);
4441 /* XXX Bloat Alert! The following Activeware preloads really
4442 * ought to be part of Win32::Sys::*, so they're not included
4445 /* LookupAccountName
4447 * InitiateSystemShutdown
4448 * AbortSystemShutdown
4449 * ExpandEnvrironmentStrings
4454 win32_signal_context(void)
4458 my_perl = PL_curinterp;
4459 PERL_SET_THX(my_perl);
4465 win32_ctrlhandler(DWORD dwCtrlType)
4467 dTHXa(PERL_GET_SIG_CONTEXT);
4472 switch(dwCtrlType) {
4473 case CTRL_CLOSE_EVENT:
4474 /* A signal that the system sends to all processes attached to a console when
4475 the user closes the console (either by choosing the Close command from the
4476 console window's System menu, or by choosing the End Task command from the
4479 CALL_FPTR(PL_sighandlerp)(1); /* SIGHUP */
4483 /* A CTRL+c signal was received */
4484 CALL_FPTR(PL_sighandlerp)(SIGINT); /* SIGINT */
4487 case CTRL_BREAK_EVENT:
4488 /* A CTRL+BREAK signal was received */
4489 CALL_FPTR(PL_sighandlerp)(SIGBREAK); /* unix calls it SIGQUIT */
4492 case CTRL_LOGOFF_EVENT:
4493 /* A signal that the system sends to all console processes when a user is logging
4494 off. This signal does not indicate which user is logging off, so no
4495 assumptions can be made.
4498 case CTRL_SHUTDOWN_EVENT:
4499 /* A signal that the system sends to all console processes when the system is
4502 CALL_FPTR(PL_sighandlerp)(SIGTERM);
4514 Perl_win32_init(int *argcp, char ***argvp)
4516 /* Disable floating point errors, Perl will trap the ones we
4517 * care about. VC++ RTL defaults to switching these off
4518 * already, but the Borland RTL doesn't. Since we don't
4519 * want to be at the vendor's whim on the default, we set
4520 * it explicitly here.
4522 #if !defined(_ALPHA_) && !defined(__GNUC__)
4523 _control87(MCW_EM, MCW_EM);
4529 win32_get_child_IO(child_IO_table* ptbl)
4531 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4532 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4533 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4536 #ifdef HAVE_INTERP_INTERN
4540 win32_csighandler(int sig)
4543 dTHXa(PERL_GET_SIG_CONTEXT);
4544 Perl_warn(aTHX_ "Got signal %d",sig);
4550 Perl_sys_intern_init(pTHX)
4552 w32_perlshell_tokens = Nullch;
4553 w32_perlshell_vec = (char**)NULL;
4554 w32_perlshell_items = 0;
4555 w32_fdpid = newAV();
4556 New(1313, w32_children, 1, child_tab);
4557 w32_num_children = 0;
4558 # ifdef USE_ITHREADS
4560 New(1313, w32_pseudo_children, 1, child_tab);
4561 w32_num_pseudo_children = 0;
4563 w32_init_socktype = 0;
4566 if (my_perl == PL_curinterp) {
4567 /* Force C runtime signal stuff to set its console handler */
4568 signal(SIGINT,&win32_csighandler);
4569 signal(SIGBREAK,&win32_csighandler);
4570 /* Push our handler on top */
4571 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4576 Perl_sys_intern_clear(pTHX)
4578 Safefree(w32_perlshell_tokens);
4579 Safefree(w32_perlshell_vec);
4580 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4581 Safefree(w32_children);
4583 KillTimer(NULL,w32_timerid);
4586 if (my_perl == PL_curinterp) {
4587 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4589 # ifdef USE_ITHREADS
4590 Safefree(w32_pseudo_children);
4594 # ifdef USE_ITHREADS
4597 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4599 dst->perlshell_tokens = Nullch;
4600 dst->perlshell_vec = (char**)NULL;
4601 dst->perlshell_items = 0;
4602 dst->fdpid = newAV();
4603 Newz(1313, dst->children, 1, child_tab);
4605 Newz(1313, dst->pseudo_children, 1, child_tab);
4606 dst->thr_intern.Winit_socktype = 0;
4608 dst->poll_count = 0;
4610 # endif /* USE_ITHREADS */
4611 #endif /* HAVE_INTERP_INTERN */
4614 win32_free_argvw(pTHX_ void *ptr)
4616 char** argv = (char**)ptr;
4624 win32_argv2utf8(int argc, char** argv)
4629 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4630 if (lpwStr && argc) {
4632 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4633 Newz(0, psz, length, char);
4634 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4637 call_atexit(win32_free_argvw, argv);
4639 GlobalFree((HGLOBAL)lpwStr);