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
19 # define HWND_MESSAGE ((HWND)-3)
21 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
22 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
23 # include <shellapi.h>
25 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
31 /* #include "config.h" */
33 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
42 #define PERL_NO_GET_CONTEXT
48 /* assert.h conflicts with #define of assert in perl.h */
55 #if defined(_MSC_VER) || defined(__MINGW32__)
56 #include <sys/utime.h>
61 /* Mingw32 defaults to globing command line
62 * So we turn it off like this:
67 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
68 /* Mingw32-1.1 is missing some prototypes */
69 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
70 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
71 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
76 #if defined(__BORLANDC__)
78 # define _utimbuf utimbuf
83 #define EXECF_SPAWN_NOWAIT 3
85 #if defined(PERL_IMPLICIT_SYS)
86 # undef win32_get_privlib
87 # define win32_get_privlib g_win32_get_privlib
88 # undef win32_get_sitelib
89 # define win32_get_sitelib g_win32_get_sitelib
90 # undef win32_get_vendorlib
91 # define win32_get_vendorlib g_win32_get_vendorlib
93 # define getlogin g_getlogin
96 static void get_shell(void);
97 static long tokenize(const char *str, char **dest, char ***destv);
98 static int do_spawn2(pTHX_ const char *cmd, int exectype);
99 static BOOL has_shell_metachars(const char *ptr);
100 static long filetime_to_clock(PFILETIME ft);
101 static BOOL filetime_from_time(PFILETIME ft, time_t t);
102 static char * get_emd_part(SV **leading, char *trailing, ...);
103 static void remove_dead_process(long deceased);
104 static long find_pid(int pid);
105 static char * qualified_path(const char *cmd);
106 static char * win32_get_xlib(const char *pl, const char *xlib,
107 const char *libname);
110 static void remove_dead_pseudo_process(long child);
111 static long find_pseudo_pid(int pid);
115 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
116 char w32_module_name[MAX_PATH+1];
119 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
121 #define ONE_K_BUFSIZE 1024
124 /* Silence STDERR grumblings from Borland's math library. */
126 _matherr(struct _exception *a)
136 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
142 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
146 set_w32_module_name(void)
149 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
150 ? GetModuleHandle(NULL)
151 : w32_perldll_handle),
152 w32_module_name, sizeof(w32_module_name));
154 /* remove \\?\ prefix */
155 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
156 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
158 /* try to get full path to binary (which may be mangled when perl is
159 * run from a 16-bit app) */
160 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
161 (void)win32_longpath(w32_module_name);
162 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
164 /* normalize to forward slashes */
165 ptr = w32_module_name;
173 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
175 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
177 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
180 const char *subkey = "Software\\Perl";
184 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
185 if (retval == ERROR_SUCCESS) {
187 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
188 if (retval == ERROR_SUCCESS
189 && (type == REG_SZ || type == REG_EXPAND_SZ))
193 *svp = sv_2mortal(newSVpvn("",0));
194 SvGROW(*svp, datalen);
195 retval = RegQueryValueEx(handle, valuename, 0, NULL,
196 (PBYTE)SvPVX(*svp), &datalen);
197 if (retval == ERROR_SUCCESS) {
199 SvCUR_set(*svp,datalen-1);
207 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
209 get_regstr(const char *valuename, SV **svp)
211 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
213 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
217 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
219 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
223 char mod_name[MAX_PATH+1];
229 va_start(ap, trailing_path);
230 strip = va_arg(ap, char *);
232 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
233 baselen = strlen(base);
235 if (!*w32_module_name) {
236 set_w32_module_name();
238 strcpy(mod_name, w32_module_name);
239 ptr = strrchr(mod_name, '/');
240 while (ptr && strip) {
241 /* look for directories to skip back */
244 ptr = strrchr(mod_name, '/');
245 /* avoid stripping component if there is no slash,
246 * or it doesn't match ... */
247 if (!ptr || stricmp(ptr+1, strip) != 0) {
248 /* ... but not if component matches m|5\.$patchlevel.*| */
249 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
250 && strncmp(strip, base, baselen) == 0
251 && strncmp(ptr+1, base, baselen) == 0))
257 strip = va_arg(ap, char *);
265 strcpy(++ptr, trailing_path);
267 /* only add directory if it exists */
268 if (GetFileAttributes(mod_name) != (DWORD) -1) {
269 /* directory exists */
272 *prev_pathp = sv_2mortal(newSVpvn("",0));
273 else if (SvPVX(*prev_pathp))
274 sv_catpvn(*prev_pathp, ";", 1);
275 sv_catpv(*prev_pathp, mod_name);
276 return SvPVX(*prev_pathp);
283 win32_get_privlib(const char *pl)
286 char *stdlib = "lib";
287 char buffer[MAX_PATH+1];
290 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
291 sprintf(buffer, "%s-%s", stdlib, pl);
292 if (!get_regstr(buffer, &sv))
293 (void)get_regstr(stdlib, &sv);
295 /* $stdlib .= ";$EMD/../../lib" */
296 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
300 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
304 char pathstr[MAX_PATH+1];
308 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
309 sprintf(regstr, "%s-%s", xlib, pl);
310 (void)get_regstr(regstr, &sv1);
313 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
314 sprintf(pathstr, "%s/%s/lib", libname, pl);
315 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
317 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
318 (void)get_regstr(xlib, &sv2);
321 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
322 sprintf(pathstr, "%s/lib", libname);
323 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
332 sv_catpvn(sv1, ";", 1);
339 win32_get_sitelib(const char *pl)
341 return win32_get_xlib(pl, "sitelib", "site");
344 #ifndef PERL_VENDORLIB_NAME
345 # define PERL_VENDORLIB_NAME "vendor"
349 win32_get_vendorlib(const char *pl)
351 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
355 has_shell_metachars(const char *ptr)
361 * Scan string looking for redirection (< or >) or pipe
362 * characters (|) that are not in a quoted string.
363 * Shell variable interpolation (%VAR%) can also happen inside strings.
395 #if !defined(PERL_IMPLICIT_SYS)
396 /* since the current process environment is being updated in util.c
397 * the library functions will get the correct environment
400 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
403 #define fixcmd(x) { \
404 char *pspace = strchr((x),' '); \
407 while (p < pspace) { \
418 PERL_FLUSHALL_FOR_CHILD;
419 return win32_popen(cmd, mode);
423 Perl_my_pclose(pTHX_ PerlIO *fp)
425 return win32_pclose(fp);
429 DllExport unsigned long
432 return (unsigned long)g_osver.dwPlatformId;
442 return -((int)w32_pseudo_id);
445 /* Windows 9x appears to always reports a pid for threads and processes
446 * that has the high bit set. So we treat the lower 31 bits as the
447 * "real" PID for Perl's purposes. */
448 if (IsWin95() && pid < 0)
453 /* Tokenize a string. Words are null-separated, and the list
454 * ends with a doubled null. Any character (except null and
455 * including backslash) may be escaped by preceding it with a
456 * backslash (the backslash will be stripped).
457 * Returns number of words in result buffer.
460 tokenize(const char *str, char **dest, char ***destv)
462 char *retstart = Nullch;
463 char **retvstart = 0;
467 int slen = strlen(str);
469 register char **retv;
470 Newx(ret, slen+2, char);
471 Newx(retv, (slen+3)/2, char*);
479 if (*ret == '\\' && *str)
481 else if (*ret == ' ') {
497 retvstart[items] = Nullch;
510 if (!w32_perlshell_tokens) {
511 /* we don't use COMSPEC here for two reasons:
512 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
513 * uncontrolled unportability of the ensuing scripts.
514 * 2. PERL5SHELL could be set to a shell that may not be fit for
515 * interactive use (which is what most programs look in COMSPEC
518 const char* defaultshell = (IsWinNT()
519 ? "cmd.exe /x/d/c" : "command.com /c");
520 const char *usershell = PerlEnv_getenv("PERL5SHELL");
521 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
522 &w32_perlshell_tokens,
528 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
540 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
542 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
547 while (++mark <= sp) {
548 if (*mark && (str = SvPV_nolen(*mark)))
555 status = win32_spawnvp(flag,
556 (const char*)(really ? SvPV_nolen(really) : argv[0]),
557 (const char* const*)argv);
559 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
560 /* possible shell-builtin, invoke with shell */
562 sh_items = w32_perlshell_items;
564 argv[index+sh_items] = argv[index];
565 while (--sh_items >= 0)
566 argv[sh_items] = w32_perlshell_vec[sh_items];
568 status = win32_spawnvp(flag,
569 (const char*)(really ? SvPV_nolen(really) : argv[0]),
570 (const char* const*)argv);
573 if (flag == P_NOWAIT) {
575 PL_statusvalue = -1; /* >16bits hint for pp_system() */
579 if (ckWARN(WARN_EXEC))
580 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
585 PL_statusvalue = status;
591 /* returns pointer to the next unquoted space or the end of the string */
593 find_next_space(const char *s)
595 bool in_quotes = FALSE;
597 /* ignore doubled backslashes, or backslash+quote */
598 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
601 /* keep track of when we're within quotes */
602 else if (*s == '"') {
604 in_quotes = !in_quotes;
606 /* break it up only at spaces that aren't in quotes */
607 else if (!in_quotes && isSPACE(*s))
616 do_spawn2(pTHX_ const char *cmd, int exectype)
622 BOOL needToTry = TRUE;
625 /* Save an extra exec if possible. See if there are shell
626 * metacharacters in it */
627 if (!has_shell_metachars(cmd)) {
628 Newx(argv, strlen(cmd) / 2 + 2, char*);
629 Newx(cmd2, strlen(cmd) + 1, char);
632 for (s = cmd2; *s;) {
633 while (*s && isSPACE(*s))
637 s = find_next_space(s);
645 status = win32_spawnvp(P_WAIT, argv[0],
646 (const char* const*)argv);
648 case EXECF_SPAWN_NOWAIT:
649 status = win32_spawnvp(P_NOWAIT, argv[0],
650 (const char* const*)argv);
653 status = win32_execvp(argv[0], (const char* const*)argv);
656 if (status != -1 || errno == 0)
666 Newx(argv, w32_perlshell_items + 2, char*);
667 while (++i < w32_perlshell_items)
668 argv[i] = w32_perlshell_vec[i];
669 argv[i++] = (char *)cmd;
673 status = win32_spawnvp(P_WAIT, argv[0],
674 (const char* const*)argv);
676 case EXECF_SPAWN_NOWAIT:
677 status = win32_spawnvp(P_NOWAIT, argv[0],
678 (const char* const*)argv);
681 status = win32_execvp(argv[0], (const char* const*)argv);
687 if (exectype == EXECF_SPAWN_NOWAIT) {
689 PL_statusvalue = -1; /* >16bits hint for pp_system() */
693 if (ckWARN(WARN_EXEC))
694 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
695 (exectype == EXECF_EXEC ? "exec" : "spawn"),
696 cmd, strerror(errno));
701 PL_statusvalue = status;
707 Perl_do_spawn(pTHX_ char *cmd)
709 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
713 Perl_do_spawn_nowait(pTHX_ char *cmd)
715 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
719 Perl_do_exec(pTHX_ const char *cmd)
721 do_spawn2(aTHX_ cmd, EXECF_EXEC);
725 /* The idea here is to read all the directory names into a string table
726 * (separated by nulls) and when one of the other dir functions is called
727 * return the pointer to the current file name.
730 win32_opendir(const char *filename)
736 char scanname[MAX_PATH+3];
738 WIN32_FIND_DATAA aFindData;
740 len = strlen(filename);
744 /* check to see if filename is a directory */
745 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
748 /* Get us a DIR structure */
751 /* Create the search pattern */
752 strcpy(scanname, filename);
754 /* bare drive name means look in cwd for drive */
755 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
756 scanname[len++] = '.';
757 scanname[len++] = '/';
759 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
760 scanname[len++] = '/';
762 scanname[len++] = '*';
763 scanname[len] = '\0';
765 /* do the FindFirstFile call */
766 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
767 if (dirp->handle == INVALID_HANDLE_VALUE) {
768 DWORD err = GetLastError();
769 /* FindFirstFile() fails on empty drives! */
771 case ERROR_FILE_NOT_FOUND:
773 case ERROR_NO_MORE_FILES:
774 case ERROR_PATH_NOT_FOUND:
777 case ERROR_NOT_ENOUGH_MEMORY:
788 /* now allocate the first part of the string table for
789 * the filenames that we find.
791 idx = strlen(aFindData.cFileName)+1;
796 Newx(dirp->start, dirp->size, char);
797 strcpy(dirp->start, aFindData.cFileName);
799 dirp->end = dirp->curr = dirp->start;
805 /* Readdir just returns the current string pointer and bumps the
806 * string pointer to the nDllExport entry.
808 DllExport struct direct *
809 win32_readdir(DIR *dirp)
814 /* first set up the structure to return */
815 len = strlen(dirp->curr);
816 strcpy(dirp->dirstr.d_name, dirp->curr);
817 dirp->dirstr.d_namlen = len;
820 dirp->dirstr.d_ino = dirp->curr - dirp->start;
822 /* Now set up for the next call to readdir */
823 dirp->curr += len + 1;
824 if (dirp->curr >= dirp->end) {
827 WIN32_FIND_DATAA aFindData;
829 /* finding the next file that matches the wildcard
830 * (which should be all of them in this directory!).
832 res = FindNextFileA(dirp->handle, &aFindData);
834 long endpos = dirp->end - dirp->start;
835 long newsize = endpos + strlen(aFindData.cFileName) + 1;
836 /* bump the string table size by enough for the
837 * new name and its null terminator */
838 while (newsize > dirp->size) {
839 long curpos = dirp->curr - dirp->start;
841 Renew(dirp->start, dirp->size, char);
842 dirp->curr = dirp->start + curpos;
844 strcpy(dirp->start + endpos, aFindData.cFileName);
845 dirp->end = dirp->start + newsize;
851 return &(dirp->dirstr);
857 /* Telldir returns the current string pointer position */
859 win32_telldir(DIR *dirp)
861 return (dirp->curr - dirp->start);
865 /* Seekdir moves the string pointer to a previously saved position
866 * (returned by telldir).
869 win32_seekdir(DIR *dirp, long loc)
871 dirp->curr = dirp->start + loc;
874 /* Rewinddir resets the string pointer to the start */
876 win32_rewinddir(DIR *dirp)
878 dirp->curr = dirp->start;
881 /* free the memory allocated by opendir */
883 win32_closedir(DIR *dirp)
886 if (dirp->handle != INVALID_HANDLE_VALUE)
887 FindClose(dirp->handle);
888 Safefree(dirp->start);
901 * Just pretend that everyone is a superuser. NT will let us know if
902 * we don\'t really have permission to do something.
905 #define ROOT_UID ((uid_t)0)
906 #define ROOT_GID ((gid_t)0)
935 return (auid == ROOT_UID ? 0 : -1);
941 return (agid == ROOT_GID ? 0 : -1);
948 char *buf = w32_getlogin_buffer;
949 DWORD size = sizeof(w32_getlogin_buffer);
950 if (GetUserName(buf,&size))
956 chown(const char *path, uid_t owner, gid_t group)
963 * XXX this needs strengthening (for PerlIO)
966 int mkstemp(const char *path)
969 char buf[MAX_PATH+1];
973 if (i++ > 10) { /* give up */
977 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
981 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
991 long child = w32_num_children;
992 while (--child >= 0) {
993 if ((int)w32_child_pids[child] == pid)
1000 remove_dead_process(long child)
1004 CloseHandle(w32_child_handles[child]);
1005 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1006 (w32_num_children-child-1), HANDLE);
1007 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1008 (w32_num_children-child-1), DWORD);
1015 find_pseudo_pid(int pid)
1018 long child = w32_num_pseudo_children;
1019 while (--child >= 0) {
1020 if ((int)w32_pseudo_child_pids[child] == pid)
1027 remove_dead_pseudo_process(long child)
1031 CloseHandle(w32_pseudo_child_handles[child]);
1032 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1033 (w32_num_pseudo_children-child-1), HANDLE);
1034 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1035 (w32_num_pseudo_children-child-1), DWORD);
1036 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1037 (w32_num_pseudo_children-child-1), HWND);
1038 w32_num_pseudo_children--;
1044 win32_kill(int pid, int sig)
1052 /* it is a pseudo-forked child */
1053 child = find_pseudo_pid(-pid);
1055 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1056 hProcess = w32_pseudo_child_handles[child];
1059 /* "Does process exist?" use of kill */
1063 /* kill -9 style un-graceful exit */
1064 if (TerminateThread(hProcess, sig)) {
1065 remove_dead_pseudo_process(child);
1072 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1073 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1074 /* Yield and wait for the other thread to send us its message_hwnd */
1076 win32_async_check(aTHX);
1079 if (hwnd != INVALID_HANDLE_VALUE) {
1080 /* We fake signals to pseudo-processes using Win32
1081 * message queue. In Win9X the pids are negative already. */
1082 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1083 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1085 /* It might be us ... */
1094 else if (IsWin95()) {
1102 child = find_pid(pid);
1104 hProcess = w32_child_handles[child];
1107 /* "Does process exist?" use of kill */
1110 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1115 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1118 default: /* For now be backwards compatible with perl5.6 */
1120 if (TerminateProcess(hProcess, sig)) {
1121 remove_dead_process(child);
1130 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1131 (IsWin95() ? -pid : pid));
1135 /* "Does process exist?" use of kill */
1139 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1144 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1147 default: /* For now be backwards compatible with perl5.6 */
1149 if (TerminateProcess(hProcess, sig))
1154 CloseHandle(hProcess);
1164 win32_stat(const char *path, Stat_t *sbuf)
1167 char buffer[MAX_PATH+1];
1168 int l = strlen(path);
1171 BOOL expect_dir = FALSE;
1173 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1174 GV_NOTQUAL, SVt_PV);
1175 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1178 switch(path[l - 1]) {
1179 /* FindFirstFile() and stat() are buggy with a trailing
1180 * slashes, except for the root directory of a drive */
1183 if (l > sizeof(buffer)) {
1184 errno = ENAMETOOLONG;
1188 strncpy(buffer, path, l);
1189 /* remove additional trailing slashes */
1190 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1192 /* add back slash if we otherwise end up with just a drive letter */
1193 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1200 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1202 if (l == 2 && isALPHA(path[0])) {
1203 buffer[0] = path[0];
1214 path = PerlDir_mapA(path);
1218 /* We must open & close the file once; otherwise file attribute changes */
1219 /* might not yet have propagated to "other" hard links of the same file. */
1220 /* This also gives us an opportunity to determine the number of links. */
1221 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1222 if (handle != INVALID_HANDLE_VALUE) {
1223 BY_HANDLE_FILE_INFORMATION bhi;
1224 if (GetFileInformationByHandle(handle, &bhi))
1225 nlink = bhi.nNumberOfLinks;
1226 CloseHandle(handle);
1230 /* path will be mapped correctly above */
1231 #if defined(WIN64) || defined(USE_LARGE_FILES)
1232 res = _stati64(path, sbuf);
1234 res = stat(path, sbuf);
1236 sbuf->st_nlink = nlink;
1239 /* CRT is buggy on sharenames, so make sure it really isn't.
1240 * XXX using GetFileAttributesEx() will enable us to set
1241 * sbuf->st_*time (but note that's not available on the
1242 * Windows of 1995) */
1243 DWORD r = GetFileAttributesA(path);
1244 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1245 /* sbuf may still contain old garbage since stat() failed */
1246 Zero(sbuf, 1, Stat_t);
1247 sbuf->st_mode = S_IFDIR | S_IREAD;
1249 if (!(r & FILE_ATTRIBUTE_READONLY))
1250 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1255 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1256 && (path[2] == '\\' || path[2] == '/'))
1258 /* The drive can be inaccessible, some _stat()s are buggy */
1259 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1264 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1269 if (S_ISDIR(sbuf->st_mode))
1270 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1271 else if (S_ISREG(sbuf->st_mode)) {
1273 if (l >= 4 && path[l-4] == '.') {
1274 const char *e = path + l - 3;
1275 if (strnicmp(e,"exe",3)
1276 && strnicmp(e,"bat",3)
1277 && strnicmp(e,"com",3)
1278 && (IsWin95() || strnicmp(e,"cmd",3)))
1279 sbuf->st_mode &= ~S_IEXEC;
1281 sbuf->st_mode |= S_IEXEC;
1284 sbuf->st_mode &= ~S_IEXEC;
1285 /* Propagate permissions to _group_ and _others_ */
1286 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1287 sbuf->st_mode |= (perms>>3) | (perms>>6);
1294 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1295 #define SKIP_SLASHES(s) \
1297 while (*(s) && isSLASH(*(s))) \
1300 #define COPY_NONSLASHES(d,s) \
1302 while (*(s) && !isSLASH(*(s))) \
1306 /* Find the longname of a given path. path is destructively modified.
1307 * It should have space for at least MAX_PATH characters. */
1309 win32_longpath(char *path)
1311 WIN32_FIND_DATA fdata;
1313 char tmpbuf[MAX_PATH+1];
1314 char *tmpstart = tmpbuf;
1321 if (isALPHA(path[0]) && path[1] == ':') {
1323 *tmpstart++ = path[0];
1327 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1329 *tmpstart++ = path[0];
1330 *tmpstart++ = path[1];
1331 SKIP_SLASHES(start);
1332 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1334 *tmpstart++ = *start++;
1335 SKIP_SLASHES(start);
1336 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1341 /* copy initial slash, if any */
1342 if (isSLASH(*start)) {
1343 *tmpstart++ = *start++;
1345 SKIP_SLASHES(start);
1348 /* FindFirstFile() expands "." and "..", so we need to pass
1349 * those through unmolested */
1351 && (!start[1] || isSLASH(start[1])
1352 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1354 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1359 /* if this is the end, bust outta here */
1363 /* now we're at a non-slash; walk up to next slash */
1364 while (*start && !isSLASH(*start))
1367 /* stop and find full name of component */
1370 fhand = FindFirstFile(path,&fdata);
1372 if (fhand != INVALID_HANDLE_VALUE) {
1373 STRLEN len = strlen(fdata.cFileName);
1374 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1375 strcpy(tmpstart, fdata.cFileName);
1386 /* failed a step, just return without side effects */
1387 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1392 strcpy(path,tmpbuf);
1397 win32_getenv(const char *name)
1401 SV *curitem = Nullsv;
1403 needlen = GetEnvironmentVariableA(name,NULL,0);
1405 curitem = sv_2mortal(newSVpvn("", 0));
1407 SvGROW(curitem, needlen+1);
1408 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1410 } while (needlen >= SvLEN(curitem));
1411 SvCUR_set(curitem, needlen);
1414 /* allow any environment variables that begin with 'PERL'
1415 to be stored in the registry */
1416 if (strncmp(name, "PERL", 4) == 0)
1417 (void)get_regstr(name, &curitem);
1419 if (curitem && SvCUR(curitem))
1420 return SvPVX(curitem);
1426 win32_putenv(const char *name)
1434 Newx(curitem,strlen(name)+1,char);
1435 strcpy(curitem, name);
1436 val = strchr(curitem, '=');
1438 /* The sane way to deal with the environment.
1439 * Has these advantages over putenv() & co.:
1440 * * enables us to store a truly empty value in the
1441 * environment (like in UNIX).
1442 * * we don't have to deal with RTL globals, bugs and leaks.
1444 * Why you may want to enable USE_WIN32_RTL_ENV:
1445 * * environ[] and RTL functions will not reflect changes,
1446 * which might be an issue if extensions want to access
1447 * the env. via RTL. This cuts both ways, since RTL will
1448 * not see changes made by extensions that call the Win32
1449 * functions directly, either.
1453 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1462 filetime_to_clock(PFILETIME ft)
1464 __int64 qw = ft->dwHighDateTime;
1466 qw |= ft->dwLowDateTime;
1467 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1472 win32_times(struct tms *timebuf)
1477 clock_t process_time_so_far = clock();
1478 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1480 timebuf->tms_utime = filetime_to_clock(&user);
1481 timebuf->tms_stime = filetime_to_clock(&kernel);
1482 timebuf->tms_cutime = 0;
1483 timebuf->tms_cstime = 0;
1485 /* That failed - e.g. Win95 fallback to clock() */
1486 timebuf->tms_utime = process_time_so_far;
1487 timebuf->tms_stime = 0;
1488 timebuf->tms_cutime = 0;
1489 timebuf->tms_cstime = 0;
1491 return process_time_so_far;
1494 /* fix utime() so it works on directories in NT */
1496 filetime_from_time(PFILETIME pFileTime, time_t Time)
1498 struct tm *pTM = localtime(&Time);
1499 SYSTEMTIME SystemTime;
1505 SystemTime.wYear = pTM->tm_year + 1900;
1506 SystemTime.wMonth = pTM->tm_mon + 1;
1507 SystemTime.wDay = pTM->tm_mday;
1508 SystemTime.wHour = pTM->tm_hour;
1509 SystemTime.wMinute = pTM->tm_min;
1510 SystemTime.wSecond = pTM->tm_sec;
1511 SystemTime.wMilliseconds = 0;
1513 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1514 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1518 win32_unlink(const char *filename)
1524 filename = PerlDir_mapA(filename);
1525 attrs = GetFileAttributesA(filename);
1526 if (attrs == 0xFFFFFFFF) {
1530 if (attrs & FILE_ATTRIBUTE_READONLY) {
1531 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1532 ret = unlink(filename);
1534 (void)SetFileAttributesA(filename, attrs);
1537 ret = unlink(filename);
1542 win32_utime(const char *filename, struct utimbuf *times)
1549 struct utimbuf TimeBuffer;
1552 filename = PerlDir_mapA(filename);
1553 rc = utime(filename, times);
1555 /* EACCES: path specifies directory or readonly file */
1556 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1559 if (times == NULL) {
1560 times = &TimeBuffer;
1561 time(×->actime);
1562 times->modtime = times->actime;
1565 /* This will (and should) still fail on readonly files */
1566 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1567 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1568 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1569 if (handle == INVALID_HANDLE_VALUE)
1572 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1573 filetime_from_time(&ftAccess, times->actime) &&
1574 filetime_from_time(&ftWrite, times->modtime) &&
1575 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1580 CloseHandle(handle);
1585 unsigned __int64 ft_i64;
1590 #define Const64(x) x##LL
1592 #define Const64(x) x##i64
1594 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1595 #define EPOCH_BIAS Const64(116444736000000000)
1597 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1598 * and appears to be unsupported even by glibc) */
1600 win32_gettimeofday(struct timeval *tp, void *not_used)
1604 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1605 GetSystemTimeAsFileTime(&ft.ft_val);
1607 /* seconds since epoch */
1608 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1610 /* microseconds remaining */
1611 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1617 win32_uname(struct utsname *name)
1619 struct hostent *hep;
1620 STRLEN nodemax = sizeof(name->nodename)-1;
1623 switch (g_osver.dwPlatformId) {
1624 case VER_PLATFORM_WIN32_WINDOWS:
1625 strcpy(name->sysname, "Windows");
1627 case VER_PLATFORM_WIN32_NT:
1628 strcpy(name->sysname, "Windows NT");
1630 case VER_PLATFORM_WIN32s:
1631 strcpy(name->sysname, "Win32s");
1634 strcpy(name->sysname, "Win32 Unknown");
1639 sprintf(name->release, "%d.%d",
1640 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1643 sprintf(name->version, "Build %d",
1644 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1645 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1646 if (g_osver.szCSDVersion[0]) {
1647 char *buf = name->version + strlen(name->version);
1648 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1652 hep = win32_gethostbyname("localhost");
1654 STRLEN len = strlen(hep->h_name);
1655 if (len <= nodemax) {
1656 strcpy(name->nodename, hep->h_name);
1659 strncpy(name->nodename, hep->h_name, nodemax);
1660 name->nodename[nodemax] = '\0';
1665 if (!GetComputerName(name->nodename, &sz))
1666 *name->nodename = '\0';
1669 /* machine (architecture) */
1674 GetSystemInfo(&info);
1676 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1677 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1678 procarch = info.u.s.wProcessorArchitecture;
1680 procarch = info.wProcessorArchitecture;
1683 case PROCESSOR_ARCHITECTURE_INTEL:
1684 arch = "x86"; break;
1685 case PROCESSOR_ARCHITECTURE_MIPS:
1686 arch = "mips"; break;
1687 case PROCESSOR_ARCHITECTURE_ALPHA:
1688 arch = "alpha"; break;
1689 case PROCESSOR_ARCHITECTURE_PPC:
1690 arch = "ppc"; break;
1691 #ifdef PROCESSOR_ARCHITECTURE_SHX
1692 case PROCESSOR_ARCHITECTURE_SHX:
1693 arch = "shx"; break;
1695 #ifdef PROCESSOR_ARCHITECTURE_ARM
1696 case PROCESSOR_ARCHITECTURE_ARM:
1697 arch = "arm"; break;
1699 #ifdef PROCESSOR_ARCHITECTURE_IA64
1700 case PROCESSOR_ARCHITECTURE_IA64:
1701 arch = "ia64"; break;
1703 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1704 case PROCESSOR_ARCHITECTURE_ALPHA64:
1705 arch = "alpha64"; break;
1707 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1708 case PROCESSOR_ARCHITECTURE_MSIL:
1709 arch = "msil"; break;
1711 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1712 case PROCESSOR_ARCHITECTURE_AMD64:
1713 arch = "amd64"; break;
1715 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1716 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1717 arch = "ia32-64"; break;
1719 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1720 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1721 arch = "unknown"; break;
1724 sprintf(name->machine, "unknown(0x%x)", procarch);
1725 arch = name->machine;
1728 if (name->machine != arch)
1729 strcpy(name->machine, arch);
1734 /* Timing related stuff */
1737 do_raise(pTHX_ int sig)
1739 if (sig < SIG_SIZE) {
1740 Sighandler_t handler = w32_sighandler[sig];
1741 if (handler == SIG_IGN) {
1744 else if (handler != SIG_DFL) {
1749 /* Choose correct default behaviour */
1765 /* Tell caller to exit thread/process as approriate */
1770 sig_terminate(pTHX_ int sig)
1772 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1773 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1780 win32_async_check(pTHX)
1783 HWND hwnd = w32_message_hwnd;
1787 if (hwnd == INVALID_HANDLE_VALUE) {
1788 /* Call PeekMessage() to mark all pending messages in the queue as "old".
1789 * This is necessary when we are being called by win32_msgwait() to
1790 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
1791 * message over and over. An example how this can happen is when
1792 * Perl is calling win32_waitpid() inside a GUI application and the GUI
1793 * is generating messages before the process terminated.
1795 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
1799 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1800 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1805 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
1806 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
1808 switch (msg.message) {
1810 case WM_USER_MESSAGE: {
1811 int child = find_pseudo_pid(msg.wParam);
1813 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
1818 case WM_USER_KILL: {
1819 /* We use WM_USER to fake kill() with other signals */
1820 int sig = msg.wParam;
1821 if (do_raise(aTHX_ sig))
1822 sig_terminate(aTHX_ sig);
1827 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1828 if (w32_timerid && w32_timerid==msg.wParam) {
1829 KillTimer(w32_message_hwnd, w32_timerid);
1832 /* Now fake a call to signal handler */
1833 if (do_raise(aTHX_ 14))
1834 sig_terminate(aTHX_ 14);
1841 /* Above or other stuff may have set a signal flag */
1842 if (PL_sig_pending) {
1848 /* This function will not return until the timeout has elapsed, or until
1849 * one of the handles is ready. */
1851 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1853 /* We may need several goes at this - so compute when we stop */
1855 if (timeout != INFINITE) {
1856 ticks = GetTickCount();
1860 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1863 if (result == WAIT_TIMEOUT) {
1864 /* Ran out of time - explicit return of zero to avoid -ve if we
1865 have scheduling issues
1869 if (timeout != INFINITE) {
1870 ticks = GetTickCount();
1872 if (result == WAIT_OBJECT_0 + count) {
1873 /* Message has arrived - check it */
1874 (void)win32_async_check(aTHX);
1877 /* Not timeout or message - one of handles is ready */
1881 /* compute time left to wait */
1882 ticks = timeout - ticks;
1883 /* If we are past the end say zero */
1884 return (ticks > 0) ? ticks : 0;
1888 win32_internal_wait(int *status, DWORD timeout)
1890 /* XXX this wait emulation only knows about processes
1891 * spawned via win32_spawnvp(P_NOWAIT, ...).
1895 DWORD exitcode, waitcode;
1898 if (w32_num_pseudo_children) {
1899 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1900 timeout, &waitcode);
1901 /* Time out here if there are no other children to wait for. */
1902 if (waitcode == WAIT_TIMEOUT) {
1903 if (!w32_num_children) {
1907 else if (waitcode != WAIT_FAILED) {
1908 if (waitcode >= WAIT_ABANDONED_0
1909 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1910 i = waitcode - WAIT_ABANDONED_0;
1912 i = waitcode - WAIT_OBJECT_0;
1913 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1914 *status = (int)((exitcode & 0xff) << 8);
1915 retval = (int)w32_pseudo_child_pids[i];
1916 remove_dead_pseudo_process(i);
1923 if (!w32_num_children) {
1928 /* if a child exists, wait for it to die */
1929 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1930 if (waitcode == WAIT_TIMEOUT) {
1933 if (waitcode != WAIT_FAILED) {
1934 if (waitcode >= WAIT_ABANDONED_0
1935 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1936 i = waitcode - WAIT_ABANDONED_0;
1938 i = waitcode - WAIT_OBJECT_0;
1939 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1940 *status = (int)((exitcode & 0xff) << 8);
1941 retval = (int)w32_child_pids[i];
1942 remove_dead_process(i);
1947 errno = GetLastError();
1952 win32_waitpid(int pid, int *status, int flags)
1955 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1958 if (pid == -1) /* XXX threadid == 1 ? */
1959 return win32_internal_wait(status, timeout);
1962 child = find_pseudo_pid(-pid);
1964 HANDLE hThread = w32_pseudo_child_handles[child];
1966 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1967 if (waitcode == WAIT_TIMEOUT) {
1970 else if (waitcode == WAIT_OBJECT_0) {
1971 if (GetExitCodeThread(hThread, &waitcode)) {
1972 *status = (int)((waitcode & 0xff) << 8);
1973 retval = (int)w32_pseudo_child_pids[child];
1974 remove_dead_pseudo_process(child);
1981 else if (IsWin95()) {
1990 child = find_pid(pid);
1992 hProcess = w32_child_handles[child];
1993 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1994 if (waitcode == WAIT_TIMEOUT) {
1997 else if (waitcode == WAIT_OBJECT_0) {
1998 if (GetExitCodeProcess(hProcess, &waitcode)) {
1999 *status = (int)((waitcode & 0xff) << 8);
2000 retval = (int)w32_child_pids[child];
2001 remove_dead_process(child);
2010 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2011 (IsWin95() ? -pid : pid));
2013 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2014 if (waitcode == WAIT_TIMEOUT) {
2015 CloseHandle(hProcess);
2018 else if (waitcode == WAIT_OBJECT_0) {
2019 if (GetExitCodeProcess(hProcess, &waitcode)) {
2020 *status = (int)((waitcode & 0xff) << 8);
2021 CloseHandle(hProcess);
2025 CloseHandle(hProcess);
2031 return retval >= 0 ? pid : retval;
2035 win32_wait(int *status)
2037 return win32_internal_wait(status, INFINITE);
2040 DllExport unsigned int
2041 win32_sleep(unsigned int t)
2044 /* Win32 times are in ms so *1000 in and /1000 out */
2045 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2048 DllExport unsigned int
2049 win32_alarm(unsigned int sec)
2052 * the 'obvious' implentation is SetTimer() with a callback
2053 * which does whatever receiving SIGALRM would do
2054 * we cannot use SIGALRM even via raise() as it is not
2055 * one of the supported codes in <signal.h>
2059 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2060 w32_message_hwnd = win32_create_message_window();
2063 if (w32_message_hwnd == NULL)
2064 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2067 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2072 KillTimer(w32_message_hwnd, w32_timerid);
2079 #ifdef HAVE_DES_FCRYPT
2080 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2084 win32_crypt(const char *txt, const char *salt)
2087 #ifdef HAVE_DES_FCRYPT
2088 return des_fcrypt(txt, salt, w32_crypt_buffer);
2090 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2095 #ifdef USE_FIXED_OSFHANDLE
2097 #define FOPEN 0x01 /* file handle open */
2098 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2099 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2100 #define FDEV 0x40 /* file handle refers to device */
2101 #define FTEXT 0x80 /* file handle is in text mode */
2104 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2107 * This function allocates a free C Runtime file handle and associates
2108 * it with the Win32 HANDLE specified by the first parameter. This is a
2109 * temperary fix for WIN95's brain damage GetFileType() error on socket
2110 * we just bypass that call for socket
2112 * This works with MSVC++ 4.0+ or GCC/Mingw32
2115 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2116 * int flags - flags to associate with C Runtime file handle.
2119 * returns index of entry in fh, if successful
2120 * return -1, if no free entry is found
2124 *******************************************************************************/
2127 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2128 * this lets sockets work on Win9X with GCC and should fix the problems
2133 /* create an ioinfo entry, kill its handle, and steal the entry */
2138 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2139 int fh = _open_osfhandle((intptr_t)hF, 0);
2143 EnterCriticalSection(&(_pioinfo(fh)->lock));
2148 my_open_osfhandle(intptr_t osfhandle, int flags)
2151 char fileflags; /* _osfile flags */
2153 /* copy relevant flags from second parameter */
2156 if (flags & O_APPEND)
2157 fileflags |= FAPPEND;
2162 if (flags & O_NOINHERIT)
2163 fileflags |= FNOINHERIT;
2165 /* attempt to allocate a C Runtime file handle */
2166 if ((fh = _alloc_osfhnd()) == -1) {
2167 errno = EMFILE; /* too many open files */
2168 _doserrno = 0L; /* not an OS error */
2169 return -1; /* return error to caller */
2172 /* the file is open. now, set the info in _osfhnd array */
2173 _set_osfhnd(fh, osfhandle);
2175 fileflags |= FOPEN; /* mark as open */
2177 _osfile(fh) = fileflags; /* set osfile entry */
2178 LeaveCriticalSection(&_pioinfo(fh)->lock);
2180 return fh; /* return handle */
2183 #endif /* USE_FIXED_OSFHANDLE */
2185 /* simulate flock by locking a range on the file */
2187 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2188 #define LK_LEN 0xffff0000
2191 win32_flock(int fd, int oper)
2199 Perl_croak_nocontext("flock() unimplemented on this platform");
2202 fh = (HANDLE)_get_osfhandle(fd);
2203 memset(&o, 0, sizeof(o));
2206 case LOCK_SH: /* shared lock */
2207 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2209 case LOCK_EX: /* exclusive lock */
2210 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2212 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2213 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2215 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2216 LK_ERR(LockFileEx(fh,
2217 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2218 0, LK_LEN, 0, &o),i);
2220 case LOCK_UN: /* unlock lock */
2221 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2223 default: /* unknown */
2234 * redirected io subsystem for all XS modules
2247 return (&(_environ));
2250 /* the rest are the remapped stdio routines */
2270 win32_ferror(FILE *fp)
2272 return (ferror(fp));
2277 win32_feof(FILE *fp)
2283 * Since the errors returned by the socket error function
2284 * WSAGetLastError() are not known by the library routine strerror
2285 * we have to roll our own.
2289 win32_strerror(int e)
2291 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2292 extern int sys_nerr;
2296 if (e < 0 || e > sys_nerr) {
2301 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2302 w32_strerror_buffer,
2303 sizeof(w32_strerror_buffer), NULL) == 0)
2304 strcpy(w32_strerror_buffer, "Unknown Error");
2306 return w32_strerror_buffer;
2312 win32_str_os_error(void *sv, DWORD dwErr)
2316 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2317 |FORMAT_MESSAGE_IGNORE_INSERTS
2318 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2319 dwErr, 0, (char *)&sMsg, 1, NULL);
2320 /* strip trailing whitespace and period */
2323 --dwLen; /* dwLen doesn't include trailing null */
2324 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2325 if ('.' != sMsg[dwLen])
2330 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2332 dwLen = sprintf(sMsg,
2333 "Unknown error #0x%lX (lookup 0x%lX)",
2334 dwErr, GetLastError());
2338 sv_setpvn((SV*)sv, sMsg, dwLen);
2344 win32_fprintf(FILE *fp, const char *format, ...)
2347 va_start(marker, format); /* Initialize variable arguments. */
2349 return (vfprintf(fp, format, marker));
2353 win32_printf(const char *format, ...)
2356 va_start(marker, format); /* Initialize variable arguments. */
2358 return (vprintf(format, marker));
2362 win32_vfprintf(FILE *fp, const char *format, va_list args)
2364 return (vfprintf(fp, format, args));
2368 win32_vprintf(const char *format, va_list args)
2370 return (vprintf(format, args));
2374 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2376 return fread(buf, size, count, fp);
2380 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2382 return fwrite(buf, size, count, fp);
2385 #define MODE_SIZE 10
2388 win32_fopen(const char *filename, const char *mode)
2396 if (stricmp(filename, "/dev/null")==0)
2399 f = fopen(PerlDir_mapA(filename), mode);
2400 /* avoid buffering headaches for child processes */
2401 if (f && *mode == 'a')
2402 win32_fseek(f, 0, SEEK_END);
2406 #ifndef USE_SOCKETS_AS_HANDLES
2408 #define fdopen my_fdopen
2412 win32_fdopen(int handle, const char *mode)
2416 f = fdopen(handle, (char *) mode);
2417 /* avoid buffering headaches for child processes */
2418 if (f && *mode == 'a')
2419 win32_fseek(f, 0, SEEK_END);
2424 win32_freopen(const char *path, const char *mode, FILE *stream)
2427 if (stricmp(path, "/dev/null")==0)
2430 return freopen(PerlDir_mapA(path), mode, stream);
2434 win32_fclose(FILE *pf)
2436 return my_fclose(pf); /* defined in win32sck.c */
2440 win32_fputs(const char *s,FILE *pf)
2442 return fputs(s, pf);
2446 win32_fputc(int c,FILE *pf)
2452 win32_ungetc(int c,FILE *pf)
2454 return ungetc(c,pf);
2458 win32_getc(FILE *pf)
2464 win32_fileno(FILE *pf)
2470 win32_clearerr(FILE *pf)
2477 win32_fflush(FILE *pf)
2483 win32_ftell(FILE *pf)
2485 #if defined(WIN64) || defined(USE_LARGE_FILES)
2486 #if defined(__BORLANDC__) /* buk */
2487 return win32_tell( fileno( pf ) );
2490 if (fgetpos(pf, &pos))
2500 win32_fseek(FILE *pf, Off_t offset,int origin)
2502 #if defined(WIN64) || defined(USE_LARGE_FILES)
2503 #if defined(__BORLANDC__) /* buk */
2513 if (fgetpos(pf, &pos))
2518 fseek(pf, 0, SEEK_END);
2519 pos = _telli64(fileno(pf));
2528 return fsetpos(pf, &offset);
2531 return fseek(pf, (long)offset, origin);
2536 win32_fgetpos(FILE *pf,fpos_t *p)
2538 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2539 if( win32_tell(fileno(pf)) == -1L ) {
2545 return fgetpos(pf, p);
2550 win32_fsetpos(FILE *pf,const fpos_t *p)
2552 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2553 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2555 return fsetpos(pf, p);
2560 win32_rewind(FILE *pf)
2570 char prefix[MAX_PATH+1];
2571 char filename[MAX_PATH+1];
2572 DWORD len = GetTempPath(MAX_PATH, prefix);
2573 if (len && len < MAX_PATH) {
2574 if (GetTempFileName(prefix, "plx", 0, filename)) {
2575 HANDLE fh = CreateFile(filename,
2576 DELETE | GENERIC_READ | GENERIC_WRITE,
2580 FILE_ATTRIBUTE_NORMAL
2581 | FILE_FLAG_DELETE_ON_CLOSE,
2583 if (fh != INVALID_HANDLE_VALUE) {
2584 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2586 #if defined(__BORLANDC__)
2587 setmode(fd,O_BINARY);
2589 DEBUG_p(PerlIO_printf(Perl_debug_log,
2590 "Created tmpfile=%s\n",filename));
2602 int fd = win32_tmpfd();
2604 return win32_fdopen(fd, "w+b");
2616 win32_fstat(int fd, Stat_t *sbufptr)
2619 /* A file designated by filehandle is not shown as accessible
2620 * for write operations, probably because it is opened for reading.
2623 BY_HANDLE_FILE_INFORMATION bhfi;
2624 #if defined(WIN64) || defined(USE_LARGE_FILES)
2625 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2627 int rc = fstat(fd,&tmp);
2629 sbufptr->st_dev = tmp.st_dev;
2630 sbufptr->st_ino = tmp.st_ino;
2631 sbufptr->st_mode = tmp.st_mode;
2632 sbufptr->st_nlink = tmp.st_nlink;
2633 sbufptr->st_uid = tmp.st_uid;
2634 sbufptr->st_gid = tmp.st_gid;
2635 sbufptr->st_rdev = tmp.st_rdev;
2636 sbufptr->st_size = tmp.st_size;
2637 sbufptr->st_atime = tmp.st_atime;
2638 sbufptr->st_mtime = tmp.st_mtime;
2639 sbufptr->st_ctime = tmp.st_ctime;
2641 int rc = fstat(fd,sbufptr);
2644 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2645 #if defined(WIN64) || defined(USE_LARGE_FILES)
2646 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2648 sbufptr->st_mode &= 0xFE00;
2649 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2650 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2652 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2653 + ((S_IREAD|S_IWRITE) >> 6));
2657 return my_fstat(fd,sbufptr);
2662 win32_pipe(int *pfd, unsigned int size, int mode)
2664 return _pipe(pfd, size, mode);
2668 win32_popenlist(const char *mode, IV narg, SV **args)
2671 Perl_croak(aTHX_ "List form of pipe open not implemented");
2676 * a popen() clone that respects PERL5SHELL
2678 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2682 win32_popen(const char *command, const char *mode)
2684 #ifdef USE_RTL_POPEN
2685 return _popen(command, mode);
2697 /* establish which ends read and write */
2698 if (strchr(mode,'w')) {
2699 stdfd = 0; /* stdin */
2702 nhandle = STD_INPUT_HANDLE;
2704 else if (strchr(mode,'r')) {
2705 stdfd = 1; /* stdout */
2708 nhandle = STD_OUTPUT_HANDLE;
2713 /* set the correct mode */
2714 if (strchr(mode,'b'))
2716 else if (strchr(mode,'t'))
2719 ourmode = _fmode & (O_TEXT | O_BINARY);
2721 /* the child doesn't inherit handles */
2722 ourmode |= O_NOINHERIT;
2724 if (win32_pipe(p, 512, ourmode) == -1)
2727 /* save current stdfd */
2728 if ((oldfd = win32_dup(stdfd)) == -1)
2731 /* save the old std handle (this needs to happen before the
2732 * dup2(), since that might call SetStdHandle() too) */
2735 old_h = GetStdHandle(nhandle);
2737 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2738 /* stdfd will be inherited by the child */
2739 if (win32_dup2(p[child], stdfd) == -1)
2742 /* close the child end in parent */
2743 win32_close(p[child]);
2745 /* set the new std handle (in case dup2() above didn't) */
2746 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2748 /* start the child */
2751 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2754 /* revert stdfd to whatever it was before */
2755 if (win32_dup2(oldfd, stdfd) == -1)
2758 /* restore the old std handle (this needs to happen after the
2759 * dup2(), since that might call SetStdHandle() too */
2761 SetStdHandle(nhandle, old_h);
2766 /* close saved handle */
2770 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2773 /* set process id so that it can be returned by perl's open() */
2774 PL_forkprocess = childpid;
2777 /* we have an fd, return a file stream */
2778 return (PerlIO_fdopen(p[parent], (char *)mode));
2781 /* we don't need to check for errors here */
2785 SetStdHandle(nhandle, old_h);
2790 win32_dup2(oldfd, stdfd);
2795 #endif /* USE_RTL_POPEN */
2803 win32_pclose(PerlIO *pf)
2805 #ifdef USE_RTL_POPEN
2809 int childpid, status;
2813 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2816 childpid = SvIVX(sv);
2833 if (win32_waitpid(childpid, &status, 0) == -1)
2838 #endif /* USE_RTL_POPEN */
2844 LPCWSTR lpExistingFileName,
2845 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2848 WCHAR wFullName[MAX_PATH+1];
2849 LPVOID lpContext = NULL;
2850 WIN32_STREAM_ID StreamId;
2851 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2856 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2857 BOOL, BOOL, LPVOID*) =
2858 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2859 BOOL, BOOL, LPVOID*))
2860 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2861 if (pfnBackupWrite == NULL)
2864 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2867 dwLen = (dwLen+1)*sizeof(WCHAR);
2869 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2870 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2871 NULL, OPEN_EXISTING, 0, NULL);
2872 if (handle == INVALID_HANDLE_VALUE)
2875 StreamId.dwStreamId = BACKUP_LINK;
2876 StreamId.dwStreamAttributes = 0;
2877 StreamId.dwStreamNameSize = 0;
2878 #if defined(__BORLANDC__) \
2879 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2880 StreamId.Size.u.HighPart = 0;
2881 StreamId.Size.u.LowPart = dwLen;
2883 StreamId.Size.HighPart = 0;
2884 StreamId.Size.LowPart = dwLen;
2887 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2888 FALSE, FALSE, &lpContext);
2890 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2891 FALSE, FALSE, &lpContext);
2892 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2895 CloseHandle(handle);
2900 win32_link(const char *oldname, const char *newname)
2903 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2904 WCHAR wOldName[MAX_PATH+1];
2905 WCHAR wNewName[MAX_PATH+1];
2908 Perl_croak(aTHX_ PL_no_func, "link");
2910 pfnCreateHardLinkW =
2911 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2912 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2913 if (pfnCreateHardLinkW == NULL)
2914 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2916 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2917 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2918 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2919 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2923 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2928 win32_rename(const char *oname, const char *newname)
2930 char szOldName[MAX_PATH+1];
2931 char szNewName[MAX_PATH+1];
2935 /* XXX despite what the documentation says about MoveFileEx(),
2936 * it doesn't work under Windows95!
2939 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2940 if (stricmp(newname, oname))
2941 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2942 strcpy(szOldName, PerlDir_mapA(oname));
2943 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2945 DWORD err = GetLastError();
2947 case ERROR_BAD_NET_NAME:
2948 case ERROR_BAD_NETPATH:
2949 case ERROR_BAD_PATHNAME:
2950 case ERROR_FILE_NOT_FOUND:
2951 case ERROR_FILENAME_EXCED_RANGE:
2952 case ERROR_INVALID_DRIVE:
2953 case ERROR_NO_MORE_FILES:
2954 case ERROR_PATH_NOT_FOUND:
2967 char szTmpName[MAX_PATH+1];
2968 char dname[MAX_PATH+1];
2969 char *endname = Nullch;
2971 DWORD from_attr, to_attr;
2973 strcpy(szOldName, PerlDir_mapA(oname));
2974 strcpy(szNewName, PerlDir_mapA(newname));
2976 /* if oname doesn't exist, do nothing */
2977 from_attr = GetFileAttributes(szOldName);
2978 if (from_attr == 0xFFFFFFFF) {
2983 /* if newname exists, rename it to a temporary name so that we
2984 * don't delete it in case oname happens to be the same file
2985 * (but perhaps accessed via a different path)
2987 to_attr = GetFileAttributes(szNewName);
2988 if (to_attr != 0xFFFFFFFF) {
2989 /* if newname is a directory, we fail
2990 * XXX could overcome this with yet more convoluted logic */
2991 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2995 tmplen = strlen(szNewName);
2996 strcpy(szTmpName,szNewName);
2997 endname = szTmpName+tmplen;
2998 for (; endname > szTmpName ; --endname) {
2999 if (*endname == '/' || *endname == '\\') {
3004 if (endname > szTmpName)
3005 endname = strcpy(dname,szTmpName);
3009 /* get a temporary filename in same directory
3010 * XXX is this really the best we can do? */
3011 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3015 DeleteFile(szTmpName);
3017 retval = rename(szNewName, szTmpName);
3024 /* rename oname to newname */
3025 retval = rename(szOldName, szNewName);
3027 /* if we created a temporary file before ... */
3028 if (endname != Nullch) {
3029 /* ...and rename succeeded, delete temporary file/directory */
3031 DeleteFile(szTmpName);
3032 /* else restore it to what it was */
3034 (void)rename(szTmpName, szNewName);
3041 win32_setmode(int fd, int mode)
3043 return setmode(fd, mode);
3047 win32_chsize(int fd, Off_t size)
3049 #if defined(WIN64) || defined(USE_LARGE_FILES)
3051 Off_t cur, end, extend;
3053 cur = win32_tell(fd);
3056 end = win32_lseek(fd, 0, SEEK_END);
3059 extend = size - end;
3063 else if (extend > 0) {
3064 /* must grow the file, padding with nulls */
3066 int oldmode = win32_setmode(fd, O_BINARY);
3068 memset(b, '\0', sizeof(b));
3070 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3071 count = win32_write(fd, b, count);
3072 if ((int)count < 0) {
3076 } while ((extend -= count) > 0);
3077 win32_setmode(fd, oldmode);
3080 /* shrink the file */
3081 win32_lseek(fd, size, SEEK_SET);
3082 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3088 win32_lseek(fd, cur, SEEK_SET);
3091 return chsize(fd, (long)size);
3096 win32_lseek(int fd, Off_t offset, int origin)
3098 #if defined(WIN64) || defined(USE_LARGE_FILES)
3099 #if defined(__BORLANDC__) /* buk */
3101 pos.QuadPart = offset;
3102 pos.LowPart = SetFilePointer(
3103 (HANDLE)_get_osfhandle(fd),
3108 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3112 return pos.QuadPart;
3114 return _lseeki64(fd, offset, origin);
3117 return lseek(fd, (long)offset, origin);
3124 #if defined(WIN64) || defined(USE_LARGE_FILES)
3125 #if defined(__BORLANDC__) /* buk */
3128 pos.LowPart = SetFilePointer(
3129 (HANDLE)_get_osfhandle(fd),
3134 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3138 return pos.QuadPart;
3139 /* return tell(fd); */
3141 return _telli64(fd);
3149 win32_open(const char *path, int flag, ...)
3156 pmode = va_arg(ap, int);
3159 if (stricmp(path, "/dev/null")==0)
3162 return open(PerlDir_mapA(path), flag, pmode);
3165 /* close() that understands socket */
3166 extern int my_close(int); /* in win32sck.c */
3171 return my_close(fd);
3187 win32_dup2(int fd1,int fd2)
3189 return dup2(fd1,fd2);
3192 #ifdef PERL_MSVCRT_READFIX
3194 #define LF 10 /* line feed */
3195 #define CR 13 /* carriage return */
3196 #define CTRLZ 26 /* ctrl-z means eof for text */
3197 #define FOPEN 0x01 /* file handle open */
3198 #define FEOFLAG 0x02 /* end of file has been encountered */
3199 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3200 #define FPIPE 0x08 /* file handle refers to a pipe */
3201 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3202 #define FDEV 0x40 /* file handle refers to device */
3203 #define FTEXT 0x80 /* file handle is in text mode */
3204 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3207 _fixed_read(int fh, void *buf, unsigned cnt)
3209 int bytes_read; /* number of bytes read */
3210 char *buffer; /* buffer to read to */
3211 int os_read; /* bytes read on OS call */
3212 char *p, *q; /* pointers into buffer */
3213 char peekchr; /* peek-ahead character */
3214 ULONG filepos; /* file position after seek */
3215 ULONG dosretval; /* o.s. return value */
3217 /* validate handle */
3218 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3219 !(_osfile(fh) & FOPEN))
3221 /* out of range -- return error */
3223 _doserrno = 0; /* not o.s. error */
3228 * If lockinitflag is FALSE, assume fd is device
3229 * lockinitflag is set to TRUE by open.
3231 if (_pioinfo(fh)->lockinitflag)
3232 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3234 bytes_read = 0; /* nothing read yet */
3235 buffer = (char*)buf;
3237 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3238 /* nothing to read or at EOF, so return 0 read */
3242 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3243 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3245 *buffer++ = _pipech(fh);
3248 _pipech(fh) = LF; /* mark as empty */
3253 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3255 /* ReadFile has reported an error. recognize two special cases.
3257 * 1. map ERROR_ACCESS_DENIED to EBADF
3259 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3260 * means the handle is a read-handle on a pipe for which
3261 * all write-handles have been closed and all data has been
3264 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3265 /* wrong read/write mode should return EBADF, not EACCES */
3267 _doserrno = dosretval;
3271 else if (dosretval == ERROR_BROKEN_PIPE) {
3281 bytes_read += os_read; /* update bytes read */
3283 if (_osfile(fh) & FTEXT) {
3284 /* now must translate CR-LFs to LFs in the buffer */
3286 /* set CRLF flag to indicate LF at beginning of buffer */
3287 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3288 /* _osfile(fh) |= FCRLF; */
3290 /* _osfile(fh) &= ~FCRLF; */
3292 _osfile(fh) &= ~FCRLF;
3294 /* convert chars in the buffer: p is src, q is dest */
3296 while (p < (char *)buf + bytes_read) {
3298 /* if fh is not a device, set ctrl-z flag */
3299 if (!(_osfile(fh) & FDEV))
3300 _osfile(fh) |= FEOFLAG;
3301 break; /* stop translating */
3306 /* *p is CR, so must check next char for LF */
3307 if (p < (char *)buf + bytes_read - 1) {
3310 *q++ = LF; /* convert CR-LF to LF */
3313 *q++ = *p++; /* store char normally */
3316 /* This is the hard part. We found a CR at end of
3317 buffer. We must peek ahead to see if next char
3322 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3323 (LPDWORD)&os_read, NULL))
3324 dosretval = GetLastError();
3326 if (dosretval != 0 || os_read == 0) {
3327 /* couldn't read ahead, store CR */
3331 /* peekchr now has the extra character -- we now
3332 have several possibilities:
3333 1. disk file and char is not LF; just seek back
3335 2. disk file and char is LF; store LF, don't seek back
3336 3. pipe/device and char is LF; store LF.
3337 4. pipe/device and char isn't LF, store CR and
3338 put char in pipe lookahead buffer. */
3339 if (_osfile(fh) & (FDEV|FPIPE)) {
3340 /* non-seekable device */
3345 _pipech(fh) = peekchr;
3350 if (peekchr == LF) {
3351 /* nothing read yet; must make some
3354 /* turn on this flag for tell routine */
3355 _osfile(fh) |= FCRLF;
3358 HANDLE osHandle; /* o.s. handle value */
3360 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3362 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3363 dosretval = GetLastError();
3374 /* we now change bytes_read to reflect the true number of chars
3376 bytes_read = q - (char *)buf;
3380 if (_pioinfo(fh)->lockinitflag)
3381 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3386 #endif /* PERL_MSVCRT_READFIX */
3389 win32_read(int fd, void *buf, unsigned int cnt)
3391 #ifdef PERL_MSVCRT_READFIX
3392 return _fixed_read(fd, buf, cnt);
3394 return read(fd, buf, cnt);
3399 win32_write(int fd, const void *buf, unsigned int cnt)
3401 return write(fd, buf, cnt);
3405 win32_mkdir(const char *dir, int mode)
3408 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3412 win32_rmdir(const char *dir)
3415 return rmdir(PerlDir_mapA(dir));
3419 win32_chdir(const char *dir)
3430 win32_access(const char *path, int mode)
3433 return access(PerlDir_mapA(path), mode);
3437 win32_chmod(const char *path, int mode)
3440 return chmod(PerlDir_mapA(path), mode);
3445 create_command_line(char *cname, STRLEN clen, const char * const *args)
3452 bool bat_file = FALSE;
3453 bool cmd_shell = FALSE;
3454 bool dumb_shell = FALSE;
3455 bool extra_quotes = FALSE;
3456 bool quote_next = FALSE;
3459 cname = (char*)args[0];
3461 /* The NT cmd.exe shell has the following peculiarity that needs to be
3462 * worked around. It strips a leading and trailing dquote when any
3463 * of the following is true:
3464 * 1. the /S switch was used
3465 * 2. there are more than two dquotes
3466 * 3. there is a special character from this set: &<>()@^|
3467 * 4. no whitespace characters within the two dquotes
3468 * 5. string between two dquotes isn't an executable file
3469 * To work around this, we always add a leading and trailing dquote
3470 * to the string, if the first argument is either "cmd.exe" or "cmd",
3471 * and there were at least two or more arguments passed to cmd.exe
3472 * (not including switches).
3473 * XXX the above rules (from "cmd /?") don't seem to be applied
3474 * always, making for the convolutions below :-(
3478 clen = strlen(cname);
3481 && (stricmp(&cname[clen-4], ".bat") == 0
3482 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3489 char *exe = strrchr(cname, '/');
3490 char *exe2 = strrchr(cname, '\\');
3497 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3501 else if (stricmp(exe, "command.com") == 0
3502 || stricmp(exe, "command") == 0)
3509 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3510 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3511 STRLEN curlen = strlen(arg);
3512 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3513 len += 2; /* assume quoting needed (worst case) */
3515 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3517 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3520 Newx(cmd, len, char);
3523 if (bat_file && !IsWin95()) {
3525 extra_quotes = TRUE;
3528 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3530 STRLEN curlen = strlen(arg);
3532 /* we want to protect empty arguments and ones with spaces with
3533 * dquotes, but only if they aren't already there */
3538 else if (quote_next) {
3539 /* see if it really is multiple arguments pretending to
3540 * be one and force a set of quotes around it */
3541 if (*find_next_space(arg))
3544 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3546 while (i < curlen) {
3547 if (isSPACE(arg[i])) {
3550 else if (arg[i] == '"') {
3574 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3575 && stricmp(arg+curlen-2, "/c") == 0)
3577 /* is there a next argument? */
3578 if (args[index+1]) {
3579 /* are there two or more next arguments? */
3580 if (args[index+2]) {
3582 extra_quotes = TRUE;
3585 /* single argument, force quoting if it has spaces */
3601 qualified_path(const char *cmd)
3605 char *fullcmd, *curfullcmd;
3611 fullcmd = (char*)cmd;
3613 if (*fullcmd == '/' || *fullcmd == '\\')
3620 pathstr = PerlEnv_getenv("PATH");
3622 /* worst case: PATH is a single directory; we need additional space
3623 * to append "/", ".exe" and trailing "\0" */
3624 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3625 curfullcmd = fullcmd;
3630 /* start by appending the name to the current prefix */
3631 strcpy(curfullcmd, cmd);
3632 curfullcmd += cmdlen;
3634 /* if it doesn't end with '.', or has no extension, try adding
3635 * a trailing .exe first */
3636 if (cmd[cmdlen-1] != '.'
3637 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3639 strcpy(curfullcmd, ".exe");
3640 res = GetFileAttributes(fullcmd);
3641 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3646 /* that failed, try the bare name */
3647 res = GetFileAttributes(fullcmd);
3648 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3651 /* quit if no other path exists, or if cmd already has path */
3652 if (!pathstr || !*pathstr || has_slash)
3655 /* skip leading semis */
3656 while (*pathstr == ';')
3659 /* build a new prefix from scratch */
3660 curfullcmd = fullcmd;
3661 while (*pathstr && *pathstr != ';') {
3662 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3663 pathstr++; /* skip initial '"' */
3664 while (*pathstr && *pathstr != '"') {
3665 *curfullcmd++ = *pathstr++;
3668 pathstr++; /* skip trailing '"' */
3671 *curfullcmd++ = *pathstr++;
3675 pathstr++; /* skip trailing semi */
3676 if (curfullcmd > fullcmd /* append a dir separator */
3677 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3679 *curfullcmd++ = '\\';
3687 /* The following are just place holders.
3688 * Some hosts may provide and environment that the OS is
3689 * not tracking, therefore, these host must provide that
3690 * environment and the current directory to CreateProcess
3694 win32_get_childenv(void)
3700 win32_free_childenv(void* d)
3705 win32_clearenv(void)
3707 char *envv = GetEnvironmentStrings();
3711 char *end = strchr(cur,'=');
3712 if (end && end != cur) {
3714 SetEnvironmentVariable(cur, NULL);
3716 cur = end + strlen(end+1)+2;
3718 else if ((len = strlen(cur)))
3721 FreeEnvironmentStrings(envv);
3725 win32_get_childdir(void)
3729 char szfilename[MAX_PATH+1];
3731 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3732 Newx(ptr, strlen(szfilename)+1, char);
3733 strcpy(ptr, szfilename);
3738 win32_free_childdir(char* d)
3745 /* XXX this needs to be made more compatible with the spawnvp()
3746 * provided by the various RTLs. In particular, searching for
3747 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3748 * This doesn't significantly affect perl itself, because we
3749 * always invoke things using PERL5SHELL if a direct attempt to
3750 * spawn the executable fails.
3752 * XXX splitting and rejoining the commandline between do_aspawn()
3753 * and win32_spawnvp() could also be avoided.
3757 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3759 #ifdef USE_RTL_SPAWNVP
3760 return spawnvp(mode, cmdname, (char * const *)argv);
3767 STARTUPINFO StartupInfo;
3768 PROCESS_INFORMATION ProcessInformation;
3771 char *fullcmd = Nullch;
3772 char *cname = (char *)cmdname;
3776 clen = strlen(cname);
3777 /* if command name contains dquotes, must remove them */
3778 if (strchr(cname, '"')) {
3780 Newx(cname,clen+1,char);
3793 cmd = create_command_line(cname, clen, argv);
3795 env = PerlEnv_get_childenv();
3796 dir = PerlEnv_get_childdir();
3799 case P_NOWAIT: /* asynch + remember result */
3800 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3805 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3808 create |= CREATE_NEW_PROCESS_GROUP;
3811 case P_WAIT: /* synchronous execution */
3813 default: /* invalid mode */
3818 memset(&StartupInfo,0,sizeof(StartupInfo));
3819 StartupInfo.cb = sizeof(StartupInfo);
3820 memset(&tbl,0,sizeof(tbl));
3821 PerlEnv_get_child_IO(&tbl);
3822 StartupInfo.dwFlags = tbl.dwFlags;
3823 StartupInfo.dwX = tbl.dwX;
3824 StartupInfo.dwY = tbl.dwY;
3825 StartupInfo.dwXSize = tbl.dwXSize;
3826 StartupInfo.dwYSize = tbl.dwYSize;
3827 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3828 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3829 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3830 StartupInfo.wShowWindow = tbl.wShowWindow;
3831 StartupInfo.hStdInput = tbl.childStdIn;
3832 StartupInfo.hStdOutput = tbl.childStdOut;
3833 StartupInfo.hStdError = tbl.childStdErr;
3834 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3835 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3836 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3838 create |= CREATE_NEW_CONSOLE;
3841 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3843 if (w32_use_showwindow) {
3844 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3845 StartupInfo.wShowWindow = w32_showwindow;
3848 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3851 if (!CreateProcess(cname, /* search PATH to find executable */
3852 cmd, /* executable, and its arguments */
3853 NULL, /* process attributes */
3854 NULL, /* thread attributes */
3855 TRUE, /* inherit handles */
3856 create, /* creation flags */
3857 (LPVOID)env, /* inherit environment */
3858 dir, /* inherit cwd */
3860 &ProcessInformation))
3862 /* initial NULL argument to CreateProcess() does a PATH
3863 * search, but it always first looks in the directory
3864 * where the current process was started, which behavior
3865 * is undesirable for backward compatibility. So we
3866 * jump through our own hoops by picking out the path
3867 * we really want it to use. */
3869 fullcmd = qualified_path(cname);
3871 if (cname != cmdname)
3874 DEBUG_p(PerlIO_printf(Perl_debug_log,
3875 "Retrying [%s] with same args\n",
3885 if (mode == P_NOWAIT) {
3886 /* asynchronous spawn -- store handle, return PID */
3887 ret = (int)ProcessInformation.dwProcessId;
3888 if (IsWin95() && ret < 0)
3891 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3892 w32_child_pids[w32_num_children] = (DWORD)ret;
3897 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3898 /* FIXME: if msgwait returned due to message perhaps forward the
3899 "signal" to the process
3901 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3903 CloseHandle(ProcessInformation.hProcess);
3906 CloseHandle(ProcessInformation.hThread);
3909 PerlEnv_free_childenv(env);
3910 PerlEnv_free_childdir(dir);
3912 if (cname != cmdname)
3919 win32_execv(const char *cmdname, const char *const *argv)
3923 /* if this is a pseudo-forked child, we just want to spawn
3924 * the new program, and return */
3926 # ifdef __BORLANDC__
3927 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3929 return spawnv(P_WAIT, cmdname, argv);
3933 return execv(cmdname, (char *const *)argv);
3935 return execv(cmdname, argv);
3940 win32_execvp(const char *cmdname, const char *const *argv)
3944 /* if this is a pseudo-forked child, we just want to spawn
3945 * the new program, and return */
3946 if (w32_pseudo_id) {
3947 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3957 return execvp(cmdname, (char *const *)argv);
3959 return execvp(cmdname, argv);
3964 win32_perror(const char *str)
3970 win32_setbuf(FILE *pf, char *buf)
3976 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3978 return setvbuf(pf, buf, type, size);
3982 win32_flushall(void)
3988 win32_fcloseall(void)
3994 win32_fgets(char *s, int n, FILE *pf)
3996 return fgets(s, n, pf);
4006 win32_fgetc(FILE *pf)
4012 win32_putc(int c, FILE *pf)
4018 win32_puts(const char *s)
4030 win32_putchar(int c)
4037 #ifndef USE_PERL_SBRK
4039 static char *committed = NULL; /* XXX threadead */
4040 static char *base = NULL; /* XXX threadead */
4041 static char *reserved = NULL; /* XXX threadead */
4042 static char *brk = NULL; /* XXX threadead */
4043 static DWORD pagesize = 0; /* XXX threadead */
4046 sbrk(ptrdiff_t need)
4051 GetSystemInfo(&info);
4052 /* Pretend page size is larger so we don't perpetually
4053 * call the OS to commit just one page ...
4055 pagesize = info.dwPageSize << 3;
4057 if (brk+need >= reserved)
4059 DWORD size = brk+need-reserved;
4061 char *prev_committed = NULL;
4062 if (committed && reserved && committed < reserved)
4064 /* Commit last of previous chunk cannot span allocations */
4065 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4068 /* Remember where we committed from in case we want to decommit later */
4069 prev_committed = committed;
4070 committed = reserved;
4073 /* Reserve some (more) space
4074 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4075 * this is only address space not memory...
4076 * Note this is a little sneaky, 1st call passes NULL as reserved
4077 * so lets system choose where we start, subsequent calls pass
4078 * the old end address so ask for a contiguous block
4081 if (size < 64*1024*1024)
4082 size = 64*1024*1024;
4083 size = ((size + pagesize - 1) / pagesize) * pagesize;
4084 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4087 reserved = addr+size;
4097 /* The existing block could not be extended far enough, so decommit
4098 * anything that was just committed above and start anew */
4101 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4104 reserved = base = committed = brk = NULL;
4115 if (brk > committed)
4117 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4119 if (committed+size > reserved)
4120 size = reserved-committed;
4121 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4134 win32_malloc(size_t size)
4136 return malloc(size);
4140 win32_calloc(size_t numitems, size_t size)
4142 return calloc(numitems,size);
4146 win32_realloc(void *block, size_t size)
4148 return realloc(block,size);
4152 win32_free(void *block)
4159 win32_open_osfhandle(intptr_t handle, int flags)
4161 #ifdef USE_FIXED_OSFHANDLE
4163 return my_open_osfhandle(handle, flags);
4165 return _open_osfhandle(handle, flags);
4169 win32_get_osfhandle(int fd)
4171 return (intptr_t)_get_osfhandle(fd);
4175 win32_fdupopen(FILE *pf)
4180 int fileno = win32_dup(win32_fileno(pf));
4182 /* open the file in the same mode */
4184 if((pf)->flags & _F_READ) {
4188 else if((pf)->flags & _F_WRIT) {
4192 else if((pf)->flags & _F_RDWR) {
4198 if((pf)->_flag & _IOREAD) {
4202 else if((pf)->_flag & _IOWRT) {
4206 else if((pf)->_flag & _IORW) {
4213 /* it appears that the binmode is attached to the
4214 * file descriptor so binmode files will be handled
4217 pfdup = win32_fdopen(fileno, mode);
4219 /* move the file pointer to the same position */
4220 if (!fgetpos(pf, &pos)) {
4221 fsetpos(pfdup, &pos);
4227 win32_dynaload(const char* filename)
4230 char buf[MAX_PATH+1];
4233 /* LoadLibrary() doesn't recognize forward slashes correctly,
4234 * so turn 'em back. */
4235 first = strchr(filename, '/');
4237 STRLEN len = strlen(filename);
4238 if (len <= MAX_PATH) {
4239 strcpy(buf, filename);
4240 filename = &buf[first - filename];
4242 if (*filename == '/')
4243 *(char*)filename = '\\';
4249 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4257 XS(w32_SetChildShowWindow)
4260 BOOL use_showwindow = w32_use_showwindow;
4261 /* use "unsigned short" because Perl has redefined "WORD" */
4262 unsigned short showwindow = w32_showwindow;
4265 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4267 if (items == 0 || !SvOK(ST(0)))
4268 w32_use_showwindow = FALSE;
4270 w32_use_showwindow = TRUE;
4271 w32_showwindow = (unsigned short)SvIV(ST(0));
4276 ST(0) = sv_2mortal(newSViv(showwindow));
4278 ST(0) = &PL_sv_undef;
4286 /* Make the host for current directory */
4287 char* ptr = PerlEnv_get_childdir();
4290 * then it worked, set PV valid,
4291 * else return 'undef'
4294 SV *sv = sv_newmortal();
4296 PerlEnv_free_childdir(ptr);
4298 #ifndef INCOMPLETE_TAINTS
4315 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4316 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4323 XS(w32_GetNextAvailDrive)
4327 char root[] = "_:\\";
4332 if (GetDriveType(root) == 1) {
4341 XS(w32_GetLastError)
4345 XSRETURN_IV(GetLastError());
4349 XS(w32_SetLastError)
4353 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4354 SetLastError(SvIV(ST(0)));
4362 char *name = w32_getlogin_buffer;
4363 DWORD size = sizeof(w32_getlogin_buffer);
4365 if (GetUserName(name,&size)) {
4366 /* size includes NULL */
4367 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4377 char name[MAX_COMPUTERNAME_LENGTH+1];
4378 DWORD size = sizeof(name);
4380 if (GetComputerName(name,&size)) {
4381 /* size does NOT include NULL :-( */
4382 ST(0) = sv_2mortal(newSVpvn(name,size));
4393 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4394 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4395 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4399 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4400 GetProcAddress(hNetApi32, "NetApiBufferFree");
4401 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4402 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4405 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4406 /* this way is more reliable, in case user has a local account. */
4408 DWORD dnamelen = sizeof(dname);
4410 DWORD wki100_platform_id;
4411 LPWSTR wki100_computername;
4412 LPWSTR wki100_langroup;
4413 DWORD wki100_ver_major;
4414 DWORD wki100_ver_minor;
4416 /* NERR_Success *is* 0*/
4417 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4418 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4419 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4420 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4423 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4424 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4426 pfnNetApiBufferFree(pwi);
4427 FreeLibrary(hNetApi32);
4430 FreeLibrary(hNetApi32);
4433 /* Win95 doesn't have NetWksta*(), so do it the old way */
4435 DWORD size = sizeof(name);
4437 FreeLibrary(hNetApi32);
4438 if (GetUserName(name,&size)) {
4439 char sid[ONE_K_BUFSIZE];
4440 DWORD sidlen = sizeof(sid);
4442 DWORD dnamelen = sizeof(dname);
4444 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4445 dname, &dnamelen, &snu)) {
4446 XSRETURN_PV(dname); /* all that for this */
4458 DWORD flags, filecomplen;
4459 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4460 &flags, fsname, sizeof(fsname))) {
4461 if (GIMME_V == G_ARRAY) {
4462 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4463 XPUSHs(sv_2mortal(newSViv(flags)));
4464 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4469 XSRETURN_PV(fsname);
4475 XS(w32_GetOSVersion)
4478 /* Use explicit struct definition because wSuiteMask and
4479 * wProductType are not defined in the VC++ 6.0 headers.
4480 * WORD type has been replaced by unsigned short because
4481 * WORD is already used by Perl itself.
4484 DWORD dwOSVersionInfoSize;
4485 DWORD dwMajorVersion;
4486 DWORD dwMinorVersion;
4487 DWORD dwBuildNumber;
4489 CHAR szCSDVersion[128];
4490 unsigned short wServicePackMajor;
4491 unsigned short wServicePackMinor;
4492 unsigned short wSuiteMask;
4498 osver.dwOSVersionInfoSize = sizeof(osver);
4499 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4501 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4502 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4506 if (GIMME_V == G_SCALAR) {
4507 XSRETURN_IV(osver.dwPlatformId);
4509 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4511 XPUSHs(newSViv(osver.dwMajorVersion));
4512 XPUSHs(newSViv(osver.dwMinorVersion));
4513 XPUSHs(newSViv(osver.dwBuildNumber));
4514 XPUSHs(newSViv(osver.dwPlatformId));
4516 XPUSHs(newSViv(osver.wServicePackMajor));
4517 XPUSHs(newSViv(osver.wServicePackMinor));
4518 XPUSHs(newSViv(osver.wSuiteMask));
4519 XPUSHs(newSViv(osver.wProductType));
4529 XSRETURN_IV(IsWinNT());
4537 XSRETURN_IV(IsWin95());
4541 XS(w32_FormatMessage)
4545 char msgbuf[ONE_K_BUFSIZE];
4548 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4550 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4551 &source, SvIV(ST(0)), 0,
4552 msgbuf, sizeof(msgbuf)-1, NULL))
4554 XSRETURN_PV(msgbuf);
4567 PROCESS_INFORMATION stProcInfo;
4568 STARTUPINFO stStartInfo;
4569 BOOL bSuccess = FALSE;
4572 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4574 cmd = SvPV_nolen(ST(0));
4575 args = SvPV_nolen(ST(1));
4577 env = PerlEnv_get_childenv();
4578 dir = PerlEnv_get_childdir();
4580 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4581 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4582 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4583 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4586 cmd, /* Image path */
4587 args, /* Arguments for command line */
4588 NULL, /* Default process security */
4589 NULL, /* Default thread security */
4590 FALSE, /* Must be TRUE to use std handles */
4591 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4592 env, /* Inherit our environment block */
4593 dir, /* Inherit our currrent directory */
4594 &stStartInfo, /* -> Startup info */
4595 &stProcInfo)) /* <- Process info (if OK) */
4597 int pid = (int)stProcInfo.dwProcessId;
4598 if (IsWin95() && pid < 0)
4600 sv_setiv(ST(2), pid);
4601 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4604 PerlEnv_free_childenv(env);
4605 PerlEnv_free_childdir(dir);
4606 XSRETURN_IV(bSuccess);
4610 XS(w32_GetTickCount)
4613 DWORD msec = GetTickCount();
4621 XS(w32_GetShortPathName)
4628 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4630 shortpath = sv_mortalcopy(ST(0));
4631 SvUPGRADE(shortpath, SVt_PV);
4632 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4635 /* src == target is allowed */
4637 len = GetShortPathName(SvPVX(shortpath),
4640 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4642 SvCUR_set(shortpath,len);
4643 *SvEND(shortpath) = '\0';
4651 XS(w32_GetFullPathName)
4658 STRLEN filename_len;
4662 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4665 filename_p = SvPV(filename, filename_len);
4666 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4667 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4671 len = GetFullPathName(SvPVX(filename),
4675 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4677 if (GIMME_V == G_ARRAY) {
4680 XST_mPV(1,filepart);
4681 len = filepart - SvPVX(fullpath);
4688 SvCUR_set(fullpath,len);
4689 *SvEND(fullpath) = '\0';
4697 XS(w32_GetLongPathName)
4701 char tmpbuf[MAX_PATH+1];
4706 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4709 pathstr = SvPV(path,len);
4710 strcpy(tmpbuf, pathstr);
4711 pathstr = win32_longpath(tmpbuf);
4713 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4724 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4734 char szSourceFile[MAX_PATH+1];
4737 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4738 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4739 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4746 Perl_init_os_extras(void)
4749 char *file = __FILE__;
4752 /* these names are Activeware compatible */
4753 newXS("Win32::GetCwd", w32_GetCwd, file);
4754 newXS("Win32::SetCwd", w32_SetCwd, file);
4755 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4756 newXS("Win32::GetLastError", w32_GetLastError, file);
4757 newXS("Win32::SetLastError", w32_SetLastError, file);
4758 newXS("Win32::LoginName", w32_LoginName, file);
4759 newXS("Win32::NodeName", w32_NodeName, file);
4760 newXS("Win32::DomainName", w32_DomainName, file);
4761 newXS("Win32::FsType", w32_FsType, file);
4762 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4763 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4764 newXS("Win32::IsWin95", w32_IsWin95, file);
4765 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4766 newXS("Win32::Spawn", w32_Spawn, file);
4767 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4768 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4769 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4770 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4771 newXS("Win32::CopyFile", w32_CopyFile, file);
4772 newXS("Win32::Sleep", w32_Sleep, file);
4773 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4775 /* XXX Bloat Alert! The following Activeware preloads really
4776 * ought to be part of Win32::Sys::*, so they're not included
4779 /* LookupAccountName
4781 * InitiateSystemShutdown
4782 * AbortSystemShutdown
4783 * ExpandEnvrironmentStrings
4788 win32_signal_context(void)
4793 my_perl = PL_curinterp;
4794 PERL_SET_THX(my_perl);
4798 return PL_curinterp;
4804 win32_ctrlhandler(DWORD dwCtrlType)
4807 dTHXa(PERL_GET_SIG_CONTEXT);
4813 switch(dwCtrlType) {
4814 case CTRL_CLOSE_EVENT:
4815 /* A signal that the system sends to all processes attached to a console when
4816 the user closes the console (either by choosing the Close command from the
4817 console window's System menu, or by choosing the End Task command from the
4820 if (do_raise(aTHX_ 1)) /* SIGHUP */
4821 sig_terminate(aTHX_ 1);
4825 /* A CTRL+c signal was received */
4826 if (do_raise(aTHX_ SIGINT))
4827 sig_terminate(aTHX_ SIGINT);
4830 case CTRL_BREAK_EVENT:
4831 /* A CTRL+BREAK signal was received */
4832 if (do_raise(aTHX_ SIGBREAK))
4833 sig_terminate(aTHX_ SIGBREAK);
4836 case CTRL_LOGOFF_EVENT:
4837 /* A signal that the system sends to all console processes when a user is logging
4838 off. This signal does not indicate which user is logging off, so no
4839 assumptions can be made.
4842 case CTRL_SHUTDOWN_EVENT:
4843 /* A signal that the system sends to all console processes when the system is
4846 if (do_raise(aTHX_ SIGTERM))
4847 sig_terminate(aTHX_ SIGTERM);
4857 Perl_win32_init(int *argcp, char ***argvp)
4859 /* Disable floating point errors, Perl will trap the ones we
4860 * care about. VC++ RTL defaults to switching these off
4861 * already, but the Borland RTL doesn't. Since we don't
4862 * want to be at the vendor's whim on the default, we set
4863 * it explicitly here.
4865 #if !defined(_ALPHA_) && !defined(__GNUC__)
4866 _control87(MCW_EM, MCW_EM);
4872 Perl_win32_term(void)
4879 win32_get_child_IO(child_IO_table* ptbl)
4881 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4882 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4883 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4887 win32_signal(int sig, Sighandler_t subcode)
4890 if (sig < SIG_SIZE) {
4891 int save_errno = errno;
4892 Sighandler_t result = signal(sig, subcode);
4893 if (result == SIG_ERR) {
4894 result = w32_sighandler[sig];
4897 w32_sighandler[sig] = subcode;
4907 #ifdef HAVE_INTERP_INTERN
4911 win32_csighandler(int sig)
4914 dTHXa(PERL_GET_SIG_CONTEXT);
4915 Perl_warn(aTHX_ "Got signal %d",sig);
4921 win32_create_message_window()
4923 /* "message-only" windows have been implemented in Windows 2000 and later.
4924 * On earlier versions we'll continue to post messages to a specific
4925 * thread and use hwnd==NULL. This is brittle when either an embedding
4926 * application or an XS module is also posting messages to hwnd=NULL
4927 * because once removed from the queue they cannot be delivered to the
4928 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4929 * if there is no window handle.
4931 if (g_osver.dwMajorVersion < 5)
4934 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4938 Perl_sys_intern_init(pTHX)
4942 if (g_osver.dwOSVersionInfoSize == 0) {
4943 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4944 GetVersionEx(&g_osver);
4947 w32_perlshell_tokens = Nullch;
4948 w32_perlshell_vec = (char**)NULL;
4949 w32_perlshell_items = 0;
4950 w32_fdpid = newAV();
4951 Newx(w32_children, 1, child_tab);
4952 w32_num_children = 0;
4953 # ifdef USE_ITHREADS
4955 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4956 w32_num_pseudo_children = 0;
4959 w32_message_hwnd = INVALID_HANDLE_VALUE;
4961 for (i=0; i < SIG_SIZE; i++) {
4962 w32_sighandler[i] = SIG_DFL;
4965 if (my_perl == PL_curinterp) {
4969 /* Force C runtime signal stuff to set its console handler */
4970 signal(SIGINT,win32_csighandler);
4971 signal(SIGBREAK,win32_csighandler);
4972 /* Push our handler on top */
4973 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4978 Perl_sys_intern_clear(pTHX)
4980 Safefree(w32_perlshell_tokens);
4981 Safefree(w32_perlshell_vec);
4982 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4983 Safefree(w32_children);
4985 KillTimer(w32_message_hwnd, w32_timerid);
4988 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4989 DestroyWindow(w32_message_hwnd);
4990 # ifdef MULTIPLICITY
4991 if (my_perl == PL_curinterp) {
4995 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4997 # ifdef USE_ITHREADS
4998 Safefree(w32_pseudo_children);
5002 # ifdef USE_ITHREADS
5005 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5007 dst->perlshell_tokens = Nullch;
5008 dst->perlshell_vec = (char**)NULL;
5009 dst->perlshell_items = 0;
5010 dst->fdpid = newAV();
5011 Newxz(dst->children, 1, child_tab);
5013 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5015 dst->message_hwnd = INVALID_HANDLE_VALUE;
5016 dst->poll_count = 0;
5017 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5019 # endif /* USE_ITHREADS */
5020 #endif /* HAVE_INTERP_INTERN */
5023 win32_free_argvw(pTHX_ void *ptr)
5025 char** argv = (char**)ptr;
5033 win32_argv2utf8(int argc, char** argv)
5038 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5039 if (lpwStr && argc) {
5041 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5042 Newxz(psz, length, char);
5043 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5046 call_atexit(win32_free_argvw, argv);
5048 GlobalFree((HGLOBAL)lpwStr);