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)
1790 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1791 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1796 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
1797 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
1799 switch (msg.message) {
1801 case WM_USER_MESSAGE: {
1802 int child = find_pseudo_pid(msg.wParam);
1804 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
1809 case WM_USER_KILL: {
1810 /* We use WM_USER to fake kill() with other signals */
1811 int sig = msg.wParam;
1812 if (do_raise(aTHX_ sig))
1813 sig_terminate(aTHX_ sig);
1818 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1819 if (w32_timerid && w32_timerid==msg.wParam) {
1820 KillTimer(w32_message_hwnd, w32_timerid);
1823 /* Now fake a call to signal handler */
1824 if (do_raise(aTHX_ 14))
1825 sig_terminate(aTHX_ 14);
1832 /* Above or other stuff may have set a signal flag */
1833 if (PL_sig_pending) {
1839 /* This function will not return until the timeout has elapsed, or until
1840 * one of the handles is ready. */
1842 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1844 /* We may need several goes at this - so compute when we stop */
1846 if (timeout != INFINITE) {
1847 ticks = GetTickCount();
1851 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1854 if (result == WAIT_TIMEOUT) {
1855 /* Ran out of time - explicit return of zero to avoid -ve if we
1856 have scheduling issues
1860 if (timeout != INFINITE) {
1861 ticks = GetTickCount();
1863 if (result == WAIT_OBJECT_0 + count) {
1864 /* Message has arrived - check it */
1865 (void)win32_async_check(aTHX);
1868 /* Not timeout or message - one of handles is ready */
1872 /* compute time left to wait */
1873 ticks = timeout - ticks;
1874 /* If we are past the end say zero */
1875 return (ticks > 0) ? ticks : 0;
1879 win32_internal_wait(int *status, DWORD timeout)
1881 /* XXX this wait emulation only knows about processes
1882 * spawned via win32_spawnvp(P_NOWAIT, ...).
1886 DWORD exitcode, waitcode;
1889 if (w32_num_pseudo_children) {
1890 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1891 timeout, &waitcode);
1892 /* Time out here if there are no other children to wait for. */
1893 if (waitcode == WAIT_TIMEOUT) {
1894 if (!w32_num_children) {
1898 else if (waitcode != WAIT_FAILED) {
1899 if (waitcode >= WAIT_ABANDONED_0
1900 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1901 i = waitcode - WAIT_ABANDONED_0;
1903 i = waitcode - WAIT_OBJECT_0;
1904 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1905 *status = (int)((exitcode & 0xff) << 8);
1906 retval = (int)w32_pseudo_child_pids[i];
1907 remove_dead_pseudo_process(i);
1914 if (!w32_num_children) {
1919 /* if a child exists, wait for it to die */
1920 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1921 if (waitcode == WAIT_TIMEOUT) {
1924 if (waitcode != WAIT_FAILED) {
1925 if (waitcode >= WAIT_ABANDONED_0
1926 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1927 i = waitcode - WAIT_ABANDONED_0;
1929 i = waitcode - WAIT_OBJECT_0;
1930 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1931 *status = (int)((exitcode & 0xff) << 8);
1932 retval = (int)w32_child_pids[i];
1933 remove_dead_process(i);
1938 errno = GetLastError();
1943 win32_waitpid(int pid, int *status, int flags)
1946 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1949 if (pid == -1) /* XXX threadid == 1 ? */
1950 return win32_internal_wait(status, timeout);
1953 child = find_pseudo_pid(-pid);
1955 HANDLE hThread = w32_pseudo_child_handles[child];
1957 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1958 if (waitcode == WAIT_TIMEOUT) {
1961 else if (waitcode == WAIT_OBJECT_0) {
1962 if (GetExitCodeThread(hThread, &waitcode)) {
1963 *status = (int)((waitcode & 0xff) << 8);
1964 retval = (int)w32_pseudo_child_pids[child];
1965 remove_dead_pseudo_process(child);
1972 else if (IsWin95()) {
1981 child = find_pid(pid);
1983 hProcess = w32_child_handles[child];
1984 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1985 if (waitcode == WAIT_TIMEOUT) {
1988 else if (waitcode == WAIT_OBJECT_0) {
1989 if (GetExitCodeProcess(hProcess, &waitcode)) {
1990 *status = (int)((waitcode & 0xff) << 8);
1991 retval = (int)w32_child_pids[child];
1992 remove_dead_process(child);
2001 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2002 (IsWin95() ? -pid : pid));
2004 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2005 if (waitcode == WAIT_TIMEOUT) {
2006 CloseHandle(hProcess);
2009 else if (waitcode == WAIT_OBJECT_0) {
2010 if (GetExitCodeProcess(hProcess, &waitcode)) {
2011 *status = (int)((waitcode & 0xff) << 8);
2012 CloseHandle(hProcess);
2016 CloseHandle(hProcess);
2022 return retval >= 0 ? pid : retval;
2026 win32_wait(int *status)
2028 return win32_internal_wait(status, INFINITE);
2031 DllExport unsigned int
2032 win32_sleep(unsigned int t)
2035 /* Win32 times are in ms so *1000 in and /1000 out */
2036 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2039 DllExport unsigned int
2040 win32_alarm(unsigned int sec)
2043 * the 'obvious' implentation is SetTimer() with a callback
2044 * which does whatever receiving SIGALRM would do
2045 * we cannot use SIGALRM even via raise() as it is not
2046 * one of the supported codes in <signal.h>
2050 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2051 w32_message_hwnd = win32_create_message_window();
2054 if (w32_message_hwnd == NULL)
2055 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2058 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2063 KillTimer(w32_message_hwnd, w32_timerid);
2070 #ifdef HAVE_DES_FCRYPT
2071 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2075 win32_crypt(const char *txt, const char *salt)
2078 #ifdef HAVE_DES_FCRYPT
2079 return des_fcrypt(txt, salt, w32_crypt_buffer);
2081 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2086 #ifdef USE_FIXED_OSFHANDLE
2088 #define FOPEN 0x01 /* file handle open */
2089 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2090 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2091 #define FDEV 0x40 /* file handle refers to device */
2092 #define FTEXT 0x80 /* file handle is in text mode */
2095 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2098 * This function allocates a free C Runtime file handle and associates
2099 * it with the Win32 HANDLE specified by the first parameter. This is a
2100 * temperary fix for WIN95's brain damage GetFileType() error on socket
2101 * we just bypass that call for socket
2103 * This works with MSVC++ 4.0+ or GCC/Mingw32
2106 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2107 * int flags - flags to associate with C Runtime file handle.
2110 * returns index of entry in fh, if successful
2111 * return -1, if no free entry is found
2115 *******************************************************************************/
2118 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2119 * this lets sockets work on Win9X with GCC and should fix the problems
2124 /* create an ioinfo entry, kill its handle, and steal the entry */
2129 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2130 int fh = _open_osfhandle((intptr_t)hF, 0);
2134 EnterCriticalSection(&(_pioinfo(fh)->lock));
2139 my_open_osfhandle(intptr_t osfhandle, int flags)
2142 char fileflags; /* _osfile flags */
2144 /* copy relevant flags from second parameter */
2147 if (flags & O_APPEND)
2148 fileflags |= FAPPEND;
2153 if (flags & O_NOINHERIT)
2154 fileflags |= FNOINHERIT;
2156 /* attempt to allocate a C Runtime file handle */
2157 if ((fh = _alloc_osfhnd()) == -1) {
2158 errno = EMFILE; /* too many open files */
2159 _doserrno = 0L; /* not an OS error */
2160 return -1; /* return error to caller */
2163 /* the file is open. now, set the info in _osfhnd array */
2164 _set_osfhnd(fh, osfhandle);
2166 fileflags |= FOPEN; /* mark as open */
2168 _osfile(fh) = fileflags; /* set osfile entry */
2169 LeaveCriticalSection(&_pioinfo(fh)->lock);
2171 return fh; /* return handle */
2174 #endif /* USE_FIXED_OSFHANDLE */
2176 /* simulate flock by locking a range on the file */
2178 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2179 #define LK_LEN 0xffff0000
2182 win32_flock(int fd, int oper)
2190 Perl_croak_nocontext("flock() unimplemented on this platform");
2193 fh = (HANDLE)_get_osfhandle(fd);
2194 memset(&o, 0, sizeof(o));
2197 case LOCK_SH: /* shared lock */
2198 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2200 case LOCK_EX: /* exclusive lock */
2201 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2203 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2204 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2206 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2207 LK_ERR(LockFileEx(fh,
2208 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2209 0, LK_LEN, 0, &o),i);
2211 case LOCK_UN: /* unlock lock */
2212 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2214 default: /* unknown */
2225 * redirected io subsystem for all XS modules
2238 return (&(_environ));
2241 /* the rest are the remapped stdio routines */
2261 win32_ferror(FILE *fp)
2263 return (ferror(fp));
2268 win32_feof(FILE *fp)
2274 * Since the errors returned by the socket error function
2275 * WSAGetLastError() are not known by the library routine strerror
2276 * we have to roll our own.
2280 win32_strerror(int e)
2282 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2283 extern int sys_nerr;
2287 if (e < 0 || e > sys_nerr) {
2292 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2293 w32_strerror_buffer,
2294 sizeof(w32_strerror_buffer), NULL) == 0)
2295 strcpy(w32_strerror_buffer, "Unknown Error");
2297 return w32_strerror_buffer;
2303 win32_str_os_error(void *sv, DWORD dwErr)
2307 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2308 |FORMAT_MESSAGE_IGNORE_INSERTS
2309 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2310 dwErr, 0, (char *)&sMsg, 1, NULL);
2311 /* strip trailing whitespace and period */
2314 --dwLen; /* dwLen doesn't include trailing null */
2315 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2316 if ('.' != sMsg[dwLen])
2321 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2323 dwLen = sprintf(sMsg,
2324 "Unknown error #0x%lX (lookup 0x%lX)",
2325 dwErr, GetLastError());
2329 sv_setpvn((SV*)sv, sMsg, dwLen);
2335 win32_fprintf(FILE *fp, const char *format, ...)
2338 va_start(marker, format); /* Initialize variable arguments. */
2340 return (vfprintf(fp, format, marker));
2344 win32_printf(const char *format, ...)
2347 va_start(marker, format); /* Initialize variable arguments. */
2349 return (vprintf(format, marker));
2353 win32_vfprintf(FILE *fp, const char *format, va_list args)
2355 return (vfprintf(fp, format, args));
2359 win32_vprintf(const char *format, va_list args)
2361 return (vprintf(format, args));
2365 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2367 return fread(buf, size, count, fp);
2371 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2373 return fwrite(buf, size, count, fp);
2376 #define MODE_SIZE 10
2379 win32_fopen(const char *filename, const char *mode)
2387 if (stricmp(filename, "/dev/null")==0)
2390 f = fopen(PerlDir_mapA(filename), mode);
2391 /* avoid buffering headaches for child processes */
2392 if (f && *mode == 'a')
2393 win32_fseek(f, 0, SEEK_END);
2397 #ifndef USE_SOCKETS_AS_HANDLES
2399 #define fdopen my_fdopen
2403 win32_fdopen(int handle, const char *mode)
2407 f = fdopen(handle, (char *) mode);
2408 /* avoid buffering headaches for child processes */
2409 if (f && *mode == 'a')
2410 win32_fseek(f, 0, SEEK_END);
2415 win32_freopen(const char *path, const char *mode, FILE *stream)
2418 if (stricmp(path, "/dev/null")==0)
2421 return freopen(PerlDir_mapA(path), mode, stream);
2425 win32_fclose(FILE *pf)
2427 return my_fclose(pf); /* defined in win32sck.c */
2431 win32_fputs(const char *s,FILE *pf)
2433 return fputs(s, pf);
2437 win32_fputc(int c,FILE *pf)
2443 win32_ungetc(int c,FILE *pf)
2445 return ungetc(c,pf);
2449 win32_getc(FILE *pf)
2455 win32_fileno(FILE *pf)
2461 win32_clearerr(FILE *pf)
2468 win32_fflush(FILE *pf)
2474 win32_ftell(FILE *pf)
2476 #if defined(WIN64) || defined(USE_LARGE_FILES)
2477 #if defined(__BORLANDC__) /* buk */
2478 return win32_tell( fileno( pf ) );
2481 if (fgetpos(pf, &pos))
2491 win32_fseek(FILE *pf, Off_t offset,int origin)
2493 #if defined(WIN64) || defined(USE_LARGE_FILES)
2494 #if defined(__BORLANDC__) /* buk */
2504 if (fgetpos(pf, &pos))
2509 fseek(pf, 0, SEEK_END);
2510 pos = _telli64(fileno(pf));
2519 return fsetpos(pf, &offset);
2522 return fseek(pf, (long)offset, origin);
2527 win32_fgetpos(FILE *pf,fpos_t *p)
2529 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2530 if( win32_tell(fileno(pf)) == -1L ) {
2536 return fgetpos(pf, p);
2541 win32_fsetpos(FILE *pf,const fpos_t *p)
2543 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2544 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2546 return fsetpos(pf, p);
2551 win32_rewind(FILE *pf)
2561 char prefix[MAX_PATH+1];
2562 char filename[MAX_PATH+1];
2563 DWORD len = GetTempPath(MAX_PATH, prefix);
2564 if (len && len < MAX_PATH) {
2565 if (GetTempFileName(prefix, "plx", 0, filename)) {
2566 HANDLE fh = CreateFile(filename,
2567 DELETE | GENERIC_READ | GENERIC_WRITE,
2571 FILE_ATTRIBUTE_NORMAL
2572 | FILE_FLAG_DELETE_ON_CLOSE,
2574 if (fh != INVALID_HANDLE_VALUE) {
2575 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2577 #if defined(__BORLANDC__)
2578 setmode(fd,O_BINARY);
2580 DEBUG_p(PerlIO_printf(Perl_debug_log,
2581 "Created tmpfile=%s\n",filename));
2593 int fd = win32_tmpfd();
2595 return win32_fdopen(fd, "w+b");
2607 win32_fstat(int fd, Stat_t *sbufptr)
2610 /* A file designated by filehandle is not shown as accessible
2611 * for write operations, probably because it is opened for reading.
2614 BY_HANDLE_FILE_INFORMATION bhfi;
2615 #if defined(WIN64) || defined(USE_LARGE_FILES)
2616 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2618 int rc = fstat(fd,&tmp);
2620 sbufptr->st_dev = tmp.st_dev;
2621 sbufptr->st_ino = tmp.st_ino;
2622 sbufptr->st_mode = tmp.st_mode;
2623 sbufptr->st_nlink = tmp.st_nlink;
2624 sbufptr->st_uid = tmp.st_uid;
2625 sbufptr->st_gid = tmp.st_gid;
2626 sbufptr->st_rdev = tmp.st_rdev;
2627 sbufptr->st_size = tmp.st_size;
2628 sbufptr->st_atime = tmp.st_atime;
2629 sbufptr->st_mtime = tmp.st_mtime;
2630 sbufptr->st_ctime = tmp.st_ctime;
2632 int rc = fstat(fd,sbufptr);
2635 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2636 #if defined(WIN64) || defined(USE_LARGE_FILES)
2637 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2639 sbufptr->st_mode &= 0xFE00;
2640 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2641 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2643 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2644 + ((S_IREAD|S_IWRITE) >> 6));
2648 return my_fstat(fd,sbufptr);
2653 win32_pipe(int *pfd, unsigned int size, int mode)
2655 return _pipe(pfd, size, mode);
2659 win32_popenlist(const char *mode, IV narg, SV **args)
2662 Perl_croak(aTHX_ "List form of pipe open not implemented");
2667 * a popen() clone that respects PERL5SHELL
2669 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2673 win32_popen(const char *command, const char *mode)
2675 #ifdef USE_RTL_POPEN
2676 return _popen(command, mode);
2688 /* establish which ends read and write */
2689 if (strchr(mode,'w')) {
2690 stdfd = 0; /* stdin */
2693 nhandle = STD_INPUT_HANDLE;
2695 else if (strchr(mode,'r')) {
2696 stdfd = 1; /* stdout */
2699 nhandle = STD_OUTPUT_HANDLE;
2704 /* set the correct mode */
2705 if (strchr(mode,'b'))
2707 else if (strchr(mode,'t'))
2710 ourmode = _fmode & (O_TEXT | O_BINARY);
2712 /* the child doesn't inherit handles */
2713 ourmode |= O_NOINHERIT;
2715 if (win32_pipe(p, 512, ourmode) == -1)
2718 /* save current stdfd */
2719 if ((oldfd = win32_dup(stdfd)) == -1)
2722 /* save the old std handle (this needs to happen before the
2723 * dup2(), since that might call SetStdHandle() too) */
2726 old_h = GetStdHandle(nhandle);
2728 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2729 /* stdfd will be inherited by the child */
2730 if (win32_dup2(p[child], stdfd) == -1)
2733 /* close the child end in parent */
2734 win32_close(p[child]);
2736 /* set the new std handle (in case dup2() above didn't) */
2737 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2739 /* start the child */
2742 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2745 /* revert stdfd to whatever it was before */
2746 if (win32_dup2(oldfd, stdfd) == -1)
2749 /* restore the old std handle (this needs to happen after the
2750 * dup2(), since that might call SetStdHandle() too */
2752 SetStdHandle(nhandle, old_h);
2757 /* close saved handle */
2761 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2764 /* set process id so that it can be returned by perl's open() */
2765 PL_forkprocess = childpid;
2768 /* we have an fd, return a file stream */
2769 return (PerlIO_fdopen(p[parent], (char *)mode));
2772 /* we don't need to check for errors here */
2776 SetStdHandle(nhandle, old_h);
2781 win32_dup2(oldfd, stdfd);
2786 #endif /* USE_RTL_POPEN */
2794 win32_pclose(PerlIO *pf)
2796 #ifdef USE_RTL_POPEN
2800 int childpid, status;
2804 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2807 childpid = SvIVX(sv);
2824 if (win32_waitpid(childpid, &status, 0) == -1)
2829 #endif /* USE_RTL_POPEN */
2835 LPCWSTR lpExistingFileName,
2836 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2839 WCHAR wFullName[MAX_PATH+1];
2840 LPVOID lpContext = NULL;
2841 WIN32_STREAM_ID StreamId;
2842 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2847 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2848 BOOL, BOOL, LPVOID*) =
2849 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2850 BOOL, BOOL, LPVOID*))
2851 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2852 if (pfnBackupWrite == NULL)
2855 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2858 dwLen = (dwLen+1)*sizeof(WCHAR);
2860 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2861 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2862 NULL, OPEN_EXISTING, 0, NULL);
2863 if (handle == INVALID_HANDLE_VALUE)
2866 StreamId.dwStreamId = BACKUP_LINK;
2867 StreamId.dwStreamAttributes = 0;
2868 StreamId.dwStreamNameSize = 0;
2869 #if defined(__BORLANDC__) \
2870 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2871 StreamId.Size.u.HighPart = 0;
2872 StreamId.Size.u.LowPart = dwLen;
2874 StreamId.Size.HighPart = 0;
2875 StreamId.Size.LowPart = dwLen;
2878 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2879 FALSE, FALSE, &lpContext);
2881 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2882 FALSE, FALSE, &lpContext);
2883 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2886 CloseHandle(handle);
2891 win32_link(const char *oldname, const char *newname)
2894 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2895 WCHAR wOldName[MAX_PATH+1];
2896 WCHAR wNewName[MAX_PATH+1];
2899 Perl_croak(aTHX_ PL_no_func, "link");
2901 pfnCreateHardLinkW =
2902 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2903 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2904 if (pfnCreateHardLinkW == NULL)
2905 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2907 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2908 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2909 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2910 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2914 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2919 win32_rename(const char *oname, const char *newname)
2921 char szOldName[MAX_PATH+1];
2922 char szNewName[MAX_PATH+1];
2926 /* XXX despite what the documentation says about MoveFileEx(),
2927 * it doesn't work under Windows95!
2930 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2931 if (stricmp(newname, oname))
2932 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2933 strcpy(szOldName, PerlDir_mapA(oname));
2934 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2936 DWORD err = GetLastError();
2938 case ERROR_BAD_NET_NAME:
2939 case ERROR_BAD_NETPATH:
2940 case ERROR_BAD_PATHNAME:
2941 case ERROR_FILE_NOT_FOUND:
2942 case ERROR_FILENAME_EXCED_RANGE:
2943 case ERROR_INVALID_DRIVE:
2944 case ERROR_NO_MORE_FILES:
2945 case ERROR_PATH_NOT_FOUND:
2958 char szTmpName[MAX_PATH+1];
2959 char dname[MAX_PATH+1];
2960 char *endname = Nullch;
2962 DWORD from_attr, to_attr;
2964 strcpy(szOldName, PerlDir_mapA(oname));
2965 strcpy(szNewName, PerlDir_mapA(newname));
2967 /* if oname doesn't exist, do nothing */
2968 from_attr = GetFileAttributes(szOldName);
2969 if (from_attr == 0xFFFFFFFF) {
2974 /* if newname exists, rename it to a temporary name so that we
2975 * don't delete it in case oname happens to be the same file
2976 * (but perhaps accessed via a different path)
2978 to_attr = GetFileAttributes(szNewName);
2979 if (to_attr != 0xFFFFFFFF) {
2980 /* if newname is a directory, we fail
2981 * XXX could overcome this with yet more convoluted logic */
2982 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2986 tmplen = strlen(szNewName);
2987 strcpy(szTmpName,szNewName);
2988 endname = szTmpName+tmplen;
2989 for (; endname > szTmpName ; --endname) {
2990 if (*endname == '/' || *endname == '\\') {
2995 if (endname > szTmpName)
2996 endname = strcpy(dname,szTmpName);
3000 /* get a temporary filename in same directory
3001 * XXX is this really the best we can do? */
3002 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3006 DeleteFile(szTmpName);
3008 retval = rename(szNewName, szTmpName);
3015 /* rename oname to newname */
3016 retval = rename(szOldName, szNewName);
3018 /* if we created a temporary file before ... */
3019 if (endname != Nullch) {
3020 /* ...and rename succeeded, delete temporary file/directory */
3022 DeleteFile(szTmpName);
3023 /* else restore it to what it was */
3025 (void)rename(szTmpName, szNewName);
3032 win32_setmode(int fd, int mode)
3034 return setmode(fd, mode);
3038 win32_chsize(int fd, Off_t size)
3040 #if defined(WIN64) || defined(USE_LARGE_FILES)
3042 Off_t cur, end, extend;
3044 cur = win32_tell(fd);
3047 end = win32_lseek(fd, 0, SEEK_END);
3050 extend = size - end;
3054 else if (extend > 0) {
3055 /* must grow the file, padding with nulls */
3057 int oldmode = win32_setmode(fd, O_BINARY);
3059 memset(b, '\0', sizeof(b));
3061 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3062 count = win32_write(fd, b, count);
3063 if ((int)count < 0) {
3067 } while ((extend -= count) > 0);
3068 win32_setmode(fd, oldmode);
3071 /* shrink the file */
3072 win32_lseek(fd, size, SEEK_SET);
3073 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3079 win32_lseek(fd, cur, SEEK_SET);
3082 return chsize(fd, (long)size);
3087 win32_lseek(int fd, Off_t offset, int origin)
3089 #if defined(WIN64) || defined(USE_LARGE_FILES)
3090 #if defined(__BORLANDC__) /* buk */
3092 pos.QuadPart = offset;
3093 pos.LowPart = SetFilePointer(
3094 (HANDLE)_get_osfhandle(fd),
3099 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3103 return pos.QuadPart;
3105 return _lseeki64(fd, offset, origin);
3108 return lseek(fd, (long)offset, origin);
3115 #if defined(WIN64) || defined(USE_LARGE_FILES)
3116 #if defined(__BORLANDC__) /* buk */
3119 pos.LowPart = SetFilePointer(
3120 (HANDLE)_get_osfhandle(fd),
3125 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3129 return pos.QuadPart;
3130 /* return tell(fd); */
3132 return _telli64(fd);
3140 win32_open(const char *path, int flag, ...)
3147 pmode = va_arg(ap, int);
3150 if (stricmp(path, "/dev/null")==0)
3153 return open(PerlDir_mapA(path), flag, pmode);
3156 /* close() that understands socket */
3157 extern int my_close(int); /* in win32sck.c */
3162 return my_close(fd);
3178 win32_dup2(int fd1,int fd2)
3180 return dup2(fd1,fd2);
3183 #ifdef PERL_MSVCRT_READFIX
3185 #define LF 10 /* line feed */
3186 #define CR 13 /* carriage return */
3187 #define CTRLZ 26 /* ctrl-z means eof for text */
3188 #define FOPEN 0x01 /* file handle open */
3189 #define FEOFLAG 0x02 /* end of file has been encountered */
3190 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3191 #define FPIPE 0x08 /* file handle refers to a pipe */
3192 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3193 #define FDEV 0x40 /* file handle refers to device */
3194 #define FTEXT 0x80 /* file handle is in text mode */
3195 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3198 _fixed_read(int fh, void *buf, unsigned cnt)
3200 int bytes_read; /* number of bytes read */
3201 char *buffer; /* buffer to read to */
3202 int os_read; /* bytes read on OS call */
3203 char *p, *q; /* pointers into buffer */
3204 char peekchr; /* peek-ahead character */
3205 ULONG filepos; /* file position after seek */
3206 ULONG dosretval; /* o.s. return value */
3208 /* validate handle */
3209 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3210 !(_osfile(fh) & FOPEN))
3212 /* out of range -- return error */
3214 _doserrno = 0; /* not o.s. error */
3219 * If lockinitflag is FALSE, assume fd is device
3220 * lockinitflag is set to TRUE by open.
3222 if (_pioinfo(fh)->lockinitflag)
3223 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3225 bytes_read = 0; /* nothing read yet */
3226 buffer = (char*)buf;
3228 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3229 /* nothing to read or at EOF, so return 0 read */
3233 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3234 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3236 *buffer++ = _pipech(fh);
3239 _pipech(fh) = LF; /* mark as empty */
3244 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3246 /* ReadFile has reported an error. recognize two special cases.
3248 * 1. map ERROR_ACCESS_DENIED to EBADF
3250 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3251 * means the handle is a read-handle on a pipe for which
3252 * all write-handles have been closed and all data has been
3255 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3256 /* wrong read/write mode should return EBADF, not EACCES */
3258 _doserrno = dosretval;
3262 else if (dosretval == ERROR_BROKEN_PIPE) {
3272 bytes_read += os_read; /* update bytes read */
3274 if (_osfile(fh) & FTEXT) {
3275 /* now must translate CR-LFs to LFs in the buffer */
3277 /* set CRLF flag to indicate LF at beginning of buffer */
3278 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3279 /* _osfile(fh) |= FCRLF; */
3281 /* _osfile(fh) &= ~FCRLF; */
3283 _osfile(fh) &= ~FCRLF;
3285 /* convert chars in the buffer: p is src, q is dest */
3287 while (p < (char *)buf + bytes_read) {
3289 /* if fh is not a device, set ctrl-z flag */
3290 if (!(_osfile(fh) & FDEV))
3291 _osfile(fh) |= FEOFLAG;
3292 break; /* stop translating */
3297 /* *p is CR, so must check next char for LF */
3298 if (p < (char *)buf + bytes_read - 1) {
3301 *q++ = LF; /* convert CR-LF to LF */
3304 *q++ = *p++; /* store char normally */
3307 /* This is the hard part. We found a CR at end of
3308 buffer. We must peek ahead to see if next char
3313 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3314 (LPDWORD)&os_read, NULL))
3315 dosretval = GetLastError();
3317 if (dosretval != 0 || os_read == 0) {
3318 /* couldn't read ahead, store CR */
3322 /* peekchr now has the extra character -- we now
3323 have several possibilities:
3324 1. disk file and char is not LF; just seek back
3326 2. disk file and char is LF; store LF, don't seek back
3327 3. pipe/device and char is LF; store LF.
3328 4. pipe/device and char isn't LF, store CR and
3329 put char in pipe lookahead buffer. */
3330 if (_osfile(fh) & (FDEV|FPIPE)) {
3331 /* non-seekable device */
3336 _pipech(fh) = peekchr;
3341 if (peekchr == LF) {
3342 /* nothing read yet; must make some
3345 /* turn on this flag for tell routine */
3346 _osfile(fh) |= FCRLF;
3349 HANDLE osHandle; /* o.s. handle value */
3351 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3353 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3354 dosretval = GetLastError();
3365 /* we now change bytes_read to reflect the true number of chars
3367 bytes_read = q - (char *)buf;
3371 if (_pioinfo(fh)->lockinitflag)
3372 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3377 #endif /* PERL_MSVCRT_READFIX */
3380 win32_read(int fd, void *buf, unsigned int cnt)
3382 #ifdef PERL_MSVCRT_READFIX
3383 return _fixed_read(fd, buf, cnt);
3385 return read(fd, buf, cnt);
3390 win32_write(int fd, const void *buf, unsigned int cnt)
3392 return write(fd, buf, cnt);
3396 win32_mkdir(const char *dir, int mode)
3399 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3403 win32_rmdir(const char *dir)
3406 return rmdir(PerlDir_mapA(dir));
3410 win32_chdir(const char *dir)
3421 win32_access(const char *path, int mode)
3424 return access(PerlDir_mapA(path), mode);
3428 win32_chmod(const char *path, int mode)
3431 return chmod(PerlDir_mapA(path), mode);
3436 create_command_line(char *cname, STRLEN clen, const char * const *args)
3443 bool bat_file = FALSE;
3444 bool cmd_shell = FALSE;
3445 bool dumb_shell = FALSE;
3446 bool extra_quotes = FALSE;
3447 bool quote_next = FALSE;
3450 cname = (char*)args[0];
3452 /* The NT cmd.exe shell has the following peculiarity that needs to be
3453 * worked around. It strips a leading and trailing dquote when any
3454 * of the following is true:
3455 * 1. the /S switch was used
3456 * 2. there are more than two dquotes
3457 * 3. there is a special character from this set: &<>()@^|
3458 * 4. no whitespace characters within the two dquotes
3459 * 5. string between two dquotes isn't an executable file
3460 * To work around this, we always add a leading and trailing dquote
3461 * to the string, if the first argument is either "cmd.exe" or "cmd",
3462 * and there were at least two or more arguments passed to cmd.exe
3463 * (not including switches).
3464 * XXX the above rules (from "cmd /?") don't seem to be applied
3465 * always, making for the convolutions below :-(
3469 clen = strlen(cname);
3472 && (stricmp(&cname[clen-4], ".bat") == 0
3473 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3480 char *exe = strrchr(cname, '/');
3481 char *exe2 = strrchr(cname, '\\');
3488 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3492 else if (stricmp(exe, "command.com") == 0
3493 || stricmp(exe, "command") == 0)
3500 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3501 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3502 STRLEN curlen = strlen(arg);
3503 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3504 len += 2; /* assume quoting needed (worst case) */
3506 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3508 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3511 Newx(cmd, len, char);
3514 if (bat_file && !IsWin95()) {
3516 extra_quotes = TRUE;
3519 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3521 STRLEN curlen = strlen(arg);
3523 /* we want to protect empty arguments and ones with spaces with
3524 * dquotes, but only if they aren't already there */
3529 else if (quote_next) {
3530 /* see if it really is multiple arguments pretending to
3531 * be one and force a set of quotes around it */
3532 if (*find_next_space(arg))
3535 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3537 while (i < curlen) {
3538 if (isSPACE(arg[i])) {
3541 else if (arg[i] == '"') {
3565 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3566 && stricmp(arg+curlen-2, "/c") == 0)
3568 /* is there a next argument? */
3569 if (args[index+1]) {
3570 /* are there two or more next arguments? */
3571 if (args[index+2]) {
3573 extra_quotes = TRUE;
3576 /* single argument, force quoting if it has spaces */
3592 qualified_path(const char *cmd)
3596 char *fullcmd, *curfullcmd;
3602 fullcmd = (char*)cmd;
3604 if (*fullcmd == '/' || *fullcmd == '\\')
3611 pathstr = PerlEnv_getenv("PATH");
3613 /* worst case: PATH is a single directory; we need additional space
3614 * to append "/", ".exe" and trailing "\0" */
3615 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3616 curfullcmd = fullcmd;
3621 /* start by appending the name to the current prefix */
3622 strcpy(curfullcmd, cmd);
3623 curfullcmd += cmdlen;
3625 /* if it doesn't end with '.', or has no extension, try adding
3626 * a trailing .exe first */
3627 if (cmd[cmdlen-1] != '.'
3628 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3630 strcpy(curfullcmd, ".exe");
3631 res = GetFileAttributes(fullcmd);
3632 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3637 /* that failed, try the bare name */
3638 res = GetFileAttributes(fullcmd);
3639 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3642 /* quit if no other path exists, or if cmd already has path */
3643 if (!pathstr || !*pathstr || has_slash)
3646 /* skip leading semis */
3647 while (*pathstr == ';')
3650 /* build a new prefix from scratch */
3651 curfullcmd = fullcmd;
3652 while (*pathstr && *pathstr != ';') {
3653 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3654 pathstr++; /* skip initial '"' */
3655 while (*pathstr && *pathstr != '"') {
3656 *curfullcmd++ = *pathstr++;
3659 pathstr++; /* skip trailing '"' */
3662 *curfullcmd++ = *pathstr++;
3666 pathstr++; /* skip trailing semi */
3667 if (curfullcmd > fullcmd /* append a dir separator */
3668 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3670 *curfullcmd++ = '\\';
3678 /* The following are just place holders.
3679 * Some hosts may provide and environment that the OS is
3680 * not tracking, therefore, these host must provide that
3681 * environment and the current directory to CreateProcess
3685 win32_get_childenv(void)
3691 win32_free_childenv(void* d)
3696 win32_clearenv(void)
3698 char *envv = GetEnvironmentStrings();
3702 char *end = strchr(cur,'=');
3703 if (end && end != cur) {
3705 SetEnvironmentVariable(cur, NULL);
3707 cur = end + strlen(end+1)+2;
3709 else if ((len = strlen(cur)))
3712 FreeEnvironmentStrings(envv);
3716 win32_get_childdir(void)
3720 char szfilename[MAX_PATH+1];
3722 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3723 Newx(ptr, strlen(szfilename)+1, char);
3724 strcpy(ptr, szfilename);
3729 win32_free_childdir(char* d)
3736 /* XXX this needs to be made more compatible with the spawnvp()
3737 * provided by the various RTLs. In particular, searching for
3738 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3739 * This doesn't significantly affect perl itself, because we
3740 * always invoke things using PERL5SHELL if a direct attempt to
3741 * spawn the executable fails.
3743 * XXX splitting and rejoining the commandline between do_aspawn()
3744 * and win32_spawnvp() could also be avoided.
3748 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3750 #ifdef USE_RTL_SPAWNVP
3751 return spawnvp(mode, cmdname, (char * const *)argv);
3758 STARTUPINFO StartupInfo;
3759 PROCESS_INFORMATION ProcessInformation;
3762 char *fullcmd = Nullch;
3763 char *cname = (char *)cmdname;
3767 clen = strlen(cname);
3768 /* if command name contains dquotes, must remove them */
3769 if (strchr(cname, '"')) {
3771 Newx(cname,clen+1,char);
3784 cmd = create_command_line(cname, clen, argv);
3786 env = PerlEnv_get_childenv();
3787 dir = PerlEnv_get_childdir();
3790 case P_NOWAIT: /* asynch + remember result */
3791 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3796 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3799 create |= CREATE_NEW_PROCESS_GROUP;
3802 case P_WAIT: /* synchronous execution */
3804 default: /* invalid mode */
3809 memset(&StartupInfo,0,sizeof(StartupInfo));
3810 StartupInfo.cb = sizeof(StartupInfo);
3811 memset(&tbl,0,sizeof(tbl));
3812 PerlEnv_get_child_IO(&tbl);
3813 StartupInfo.dwFlags = tbl.dwFlags;
3814 StartupInfo.dwX = tbl.dwX;
3815 StartupInfo.dwY = tbl.dwY;
3816 StartupInfo.dwXSize = tbl.dwXSize;
3817 StartupInfo.dwYSize = tbl.dwYSize;
3818 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3819 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3820 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3821 StartupInfo.wShowWindow = tbl.wShowWindow;
3822 StartupInfo.hStdInput = tbl.childStdIn;
3823 StartupInfo.hStdOutput = tbl.childStdOut;
3824 StartupInfo.hStdError = tbl.childStdErr;
3825 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3826 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3827 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3829 create |= CREATE_NEW_CONSOLE;
3832 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3834 if (w32_use_showwindow) {
3835 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3836 StartupInfo.wShowWindow = w32_showwindow;
3839 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3842 if (!CreateProcess(cname, /* search PATH to find executable */
3843 cmd, /* executable, and its arguments */
3844 NULL, /* process attributes */
3845 NULL, /* thread attributes */
3846 TRUE, /* inherit handles */
3847 create, /* creation flags */
3848 (LPVOID)env, /* inherit environment */
3849 dir, /* inherit cwd */
3851 &ProcessInformation))
3853 /* initial NULL argument to CreateProcess() does a PATH
3854 * search, but it always first looks in the directory
3855 * where the current process was started, which behavior
3856 * is undesirable for backward compatibility. So we
3857 * jump through our own hoops by picking out the path
3858 * we really want it to use. */
3860 fullcmd = qualified_path(cname);
3862 if (cname != cmdname)
3865 DEBUG_p(PerlIO_printf(Perl_debug_log,
3866 "Retrying [%s] with same args\n",
3876 if (mode == P_NOWAIT) {
3877 /* asynchronous spawn -- store handle, return PID */
3878 ret = (int)ProcessInformation.dwProcessId;
3879 if (IsWin95() && ret < 0)
3882 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3883 w32_child_pids[w32_num_children] = (DWORD)ret;
3888 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3889 /* FIXME: if msgwait returned due to message perhaps forward the
3890 "signal" to the process
3892 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3894 CloseHandle(ProcessInformation.hProcess);
3897 CloseHandle(ProcessInformation.hThread);
3900 PerlEnv_free_childenv(env);
3901 PerlEnv_free_childdir(dir);
3903 if (cname != cmdname)
3910 win32_execv(const char *cmdname, const char *const *argv)
3914 /* if this is a pseudo-forked child, we just want to spawn
3915 * the new program, and return */
3917 # ifdef __BORLANDC__
3918 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3920 return spawnv(P_WAIT, cmdname, argv);
3924 return execv(cmdname, (char *const *)argv);
3926 return execv(cmdname, argv);
3931 win32_execvp(const char *cmdname, const char *const *argv)
3935 /* if this is a pseudo-forked child, we just want to spawn
3936 * the new program, and return */
3937 if (w32_pseudo_id) {
3938 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3948 return execvp(cmdname, (char *const *)argv);
3950 return execvp(cmdname, argv);
3955 win32_perror(const char *str)
3961 win32_setbuf(FILE *pf, char *buf)
3967 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3969 return setvbuf(pf, buf, type, size);
3973 win32_flushall(void)
3979 win32_fcloseall(void)
3985 win32_fgets(char *s, int n, FILE *pf)
3987 return fgets(s, n, pf);
3997 win32_fgetc(FILE *pf)
4003 win32_putc(int c, FILE *pf)
4009 win32_puts(const char *s)
4021 win32_putchar(int c)
4028 #ifndef USE_PERL_SBRK
4030 static char *committed = NULL; /* XXX threadead */
4031 static char *base = NULL; /* XXX threadead */
4032 static char *reserved = NULL; /* XXX threadead */
4033 static char *brk = NULL; /* XXX threadead */
4034 static DWORD pagesize = 0; /* XXX threadead */
4037 sbrk(ptrdiff_t need)
4042 GetSystemInfo(&info);
4043 /* Pretend page size is larger so we don't perpetually
4044 * call the OS to commit just one page ...
4046 pagesize = info.dwPageSize << 3;
4048 if (brk+need >= reserved)
4050 DWORD size = brk+need-reserved;
4052 char *prev_committed = NULL;
4053 if (committed && reserved && committed < reserved)
4055 /* Commit last of previous chunk cannot span allocations */
4056 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4059 /* Remember where we committed from in case we want to decommit later */
4060 prev_committed = committed;
4061 committed = reserved;
4064 /* Reserve some (more) space
4065 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4066 * this is only address space not memory...
4067 * Note this is a little sneaky, 1st call passes NULL as reserved
4068 * so lets system choose where we start, subsequent calls pass
4069 * the old end address so ask for a contiguous block
4072 if (size < 64*1024*1024)
4073 size = 64*1024*1024;
4074 size = ((size + pagesize - 1) / pagesize) * pagesize;
4075 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4078 reserved = addr+size;
4088 /* The existing block could not be extended far enough, so decommit
4089 * anything that was just committed above and start anew */
4092 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4095 reserved = base = committed = brk = NULL;
4106 if (brk > committed)
4108 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4110 if (committed+size > reserved)
4111 size = reserved-committed;
4112 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4125 win32_malloc(size_t size)
4127 return malloc(size);
4131 win32_calloc(size_t numitems, size_t size)
4133 return calloc(numitems,size);
4137 win32_realloc(void *block, size_t size)
4139 return realloc(block,size);
4143 win32_free(void *block)
4150 win32_open_osfhandle(intptr_t handle, int flags)
4152 #ifdef USE_FIXED_OSFHANDLE
4154 return my_open_osfhandle(handle, flags);
4156 return _open_osfhandle(handle, flags);
4160 win32_get_osfhandle(int fd)
4162 return (intptr_t)_get_osfhandle(fd);
4166 win32_fdupopen(FILE *pf)
4171 int fileno = win32_dup(win32_fileno(pf));
4173 /* open the file in the same mode */
4175 if((pf)->flags & _F_READ) {
4179 else if((pf)->flags & _F_WRIT) {
4183 else if((pf)->flags & _F_RDWR) {
4189 if((pf)->_flag & _IOREAD) {
4193 else if((pf)->_flag & _IOWRT) {
4197 else if((pf)->_flag & _IORW) {
4204 /* it appears that the binmode is attached to the
4205 * file descriptor so binmode files will be handled
4208 pfdup = win32_fdopen(fileno, mode);
4210 /* move the file pointer to the same position */
4211 if (!fgetpos(pf, &pos)) {
4212 fsetpos(pfdup, &pos);
4218 win32_dynaload(const char* filename)
4221 char buf[MAX_PATH+1];
4224 /* LoadLibrary() doesn't recognize forward slashes correctly,
4225 * so turn 'em back. */
4226 first = strchr(filename, '/');
4228 STRLEN len = strlen(filename);
4229 if (len <= MAX_PATH) {
4230 strcpy(buf, filename);
4231 filename = &buf[first - filename];
4233 if (*filename == '/')
4234 *(char*)filename = '\\';
4240 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4248 XS(w32_SetChildShowWindow)
4251 BOOL use_showwindow = w32_use_showwindow;
4252 /* use "unsigned short" because Perl has redefined "WORD" */
4253 unsigned short showwindow = w32_showwindow;
4256 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4258 if (items == 0 || !SvOK(ST(0)))
4259 w32_use_showwindow = FALSE;
4261 w32_use_showwindow = TRUE;
4262 w32_showwindow = (unsigned short)SvIV(ST(0));
4267 ST(0) = sv_2mortal(newSViv(showwindow));
4269 ST(0) = &PL_sv_undef;
4277 /* Make the host for current directory */
4278 char* ptr = PerlEnv_get_childdir();
4281 * then it worked, set PV valid,
4282 * else return 'undef'
4285 SV *sv = sv_newmortal();
4287 PerlEnv_free_childdir(ptr);
4289 #ifndef INCOMPLETE_TAINTS
4306 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4307 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4314 XS(w32_GetNextAvailDrive)
4318 char root[] = "_:\\";
4323 if (GetDriveType(root) == 1) {
4332 XS(w32_GetLastError)
4336 XSRETURN_IV(GetLastError());
4340 XS(w32_SetLastError)
4344 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4345 SetLastError(SvIV(ST(0)));
4353 char *name = w32_getlogin_buffer;
4354 DWORD size = sizeof(w32_getlogin_buffer);
4356 if (GetUserName(name,&size)) {
4357 /* size includes NULL */
4358 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4368 char name[MAX_COMPUTERNAME_LENGTH+1];
4369 DWORD size = sizeof(name);
4371 if (GetComputerName(name,&size)) {
4372 /* size does NOT include NULL :-( */
4373 ST(0) = sv_2mortal(newSVpvn(name,size));
4384 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4385 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4386 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4390 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4391 GetProcAddress(hNetApi32, "NetApiBufferFree");
4392 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4393 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4396 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4397 /* this way is more reliable, in case user has a local account. */
4399 DWORD dnamelen = sizeof(dname);
4401 DWORD wki100_platform_id;
4402 LPWSTR wki100_computername;
4403 LPWSTR wki100_langroup;
4404 DWORD wki100_ver_major;
4405 DWORD wki100_ver_minor;
4407 /* NERR_Success *is* 0*/
4408 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4409 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4410 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4411 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4414 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4415 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4417 pfnNetApiBufferFree(pwi);
4418 FreeLibrary(hNetApi32);
4421 FreeLibrary(hNetApi32);
4424 /* Win95 doesn't have NetWksta*(), so do it the old way */
4426 DWORD size = sizeof(name);
4428 FreeLibrary(hNetApi32);
4429 if (GetUserName(name,&size)) {
4430 char sid[ONE_K_BUFSIZE];
4431 DWORD sidlen = sizeof(sid);
4433 DWORD dnamelen = sizeof(dname);
4435 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4436 dname, &dnamelen, &snu)) {
4437 XSRETURN_PV(dname); /* all that for this */
4449 DWORD flags, filecomplen;
4450 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4451 &flags, fsname, sizeof(fsname))) {
4452 if (GIMME_V == G_ARRAY) {
4453 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4454 XPUSHs(sv_2mortal(newSViv(flags)));
4455 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4460 XSRETURN_PV(fsname);
4466 XS(w32_GetOSVersion)
4469 /* Use explicit struct definition because wSuiteMask and
4470 * wProductType are not defined in the VC++ 6.0 headers.
4471 * WORD type has been replaced by unsigned short because
4472 * WORD is already used by Perl itself.
4475 DWORD dwOSVersionInfoSize;
4476 DWORD dwMajorVersion;
4477 DWORD dwMinorVersion;
4478 DWORD dwBuildNumber;
4480 CHAR szCSDVersion[128];
4481 unsigned short wServicePackMajor;
4482 unsigned short wServicePackMinor;
4483 unsigned short wSuiteMask;
4489 osver.dwOSVersionInfoSize = sizeof(osver);
4490 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4492 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4493 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4497 if (GIMME_V == G_SCALAR) {
4498 XSRETURN_IV(osver.dwPlatformId);
4500 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4502 XPUSHs(newSViv(osver.dwMajorVersion));
4503 XPUSHs(newSViv(osver.dwMinorVersion));
4504 XPUSHs(newSViv(osver.dwBuildNumber));
4505 XPUSHs(newSViv(osver.dwPlatformId));
4507 XPUSHs(newSViv(osver.wServicePackMajor));
4508 XPUSHs(newSViv(osver.wServicePackMinor));
4509 XPUSHs(newSViv(osver.wSuiteMask));
4510 XPUSHs(newSViv(osver.wProductType));
4520 XSRETURN_IV(IsWinNT());
4528 XSRETURN_IV(IsWin95());
4532 XS(w32_FormatMessage)
4536 char msgbuf[ONE_K_BUFSIZE];
4539 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4541 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4542 &source, SvIV(ST(0)), 0,
4543 msgbuf, sizeof(msgbuf)-1, NULL))
4545 XSRETURN_PV(msgbuf);
4558 PROCESS_INFORMATION stProcInfo;
4559 STARTUPINFO stStartInfo;
4560 BOOL bSuccess = FALSE;
4563 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4565 cmd = SvPV_nolen(ST(0));
4566 args = SvPV_nolen(ST(1));
4568 env = PerlEnv_get_childenv();
4569 dir = PerlEnv_get_childdir();
4571 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4572 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4573 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4574 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4577 cmd, /* Image path */
4578 args, /* Arguments for command line */
4579 NULL, /* Default process security */
4580 NULL, /* Default thread security */
4581 FALSE, /* Must be TRUE to use std handles */
4582 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4583 env, /* Inherit our environment block */
4584 dir, /* Inherit our currrent directory */
4585 &stStartInfo, /* -> Startup info */
4586 &stProcInfo)) /* <- Process info (if OK) */
4588 int pid = (int)stProcInfo.dwProcessId;
4589 if (IsWin95() && pid < 0)
4591 sv_setiv(ST(2), pid);
4592 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4595 PerlEnv_free_childenv(env);
4596 PerlEnv_free_childdir(dir);
4597 XSRETURN_IV(bSuccess);
4601 XS(w32_GetTickCount)
4604 DWORD msec = GetTickCount();
4612 XS(w32_GetShortPathName)
4619 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4621 shortpath = sv_mortalcopy(ST(0));
4622 SvUPGRADE(shortpath, SVt_PV);
4623 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4626 /* src == target is allowed */
4628 len = GetShortPathName(SvPVX(shortpath),
4631 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4633 SvCUR_set(shortpath,len);
4634 *SvEND(shortpath) = '\0';
4642 XS(w32_GetFullPathName)
4649 STRLEN filename_len;
4653 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4656 filename_p = SvPV(filename, filename_len);
4657 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4658 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4662 len = GetFullPathName(SvPVX(filename),
4666 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4668 if (GIMME_V == G_ARRAY) {
4671 XST_mPV(1,filepart);
4672 len = filepart - SvPVX(fullpath);
4679 SvCUR_set(fullpath,len);
4680 *SvEND(fullpath) = '\0';
4688 XS(w32_GetLongPathName)
4692 char tmpbuf[MAX_PATH+1];
4697 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4700 pathstr = SvPV(path,len);
4701 strcpy(tmpbuf, pathstr);
4702 pathstr = win32_longpath(tmpbuf);
4704 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4715 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4725 char szSourceFile[MAX_PATH+1];
4728 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4729 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4730 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4737 Perl_init_os_extras(void)
4740 char *file = __FILE__;
4743 /* these names are Activeware compatible */
4744 newXS("Win32::GetCwd", w32_GetCwd, file);
4745 newXS("Win32::SetCwd", w32_SetCwd, file);
4746 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4747 newXS("Win32::GetLastError", w32_GetLastError, file);
4748 newXS("Win32::SetLastError", w32_SetLastError, file);
4749 newXS("Win32::LoginName", w32_LoginName, file);
4750 newXS("Win32::NodeName", w32_NodeName, file);
4751 newXS("Win32::DomainName", w32_DomainName, file);
4752 newXS("Win32::FsType", w32_FsType, file);
4753 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4754 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4755 newXS("Win32::IsWin95", w32_IsWin95, file);
4756 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4757 newXS("Win32::Spawn", w32_Spawn, file);
4758 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4759 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4760 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4761 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4762 newXS("Win32::CopyFile", w32_CopyFile, file);
4763 newXS("Win32::Sleep", w32_Sleep, file);
4764 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4766 /* XXX Bloat Alert! The following Activeware preloads really
4767 * ought to be part of Win32::Sys::*, so they're not included
4770 /* LookupAccountName
4772 * InitiateSystemShutdown
4773 * AbortSystemShutdown
4774 * ExpandEnvrironmentStrings
4779 win32_signal_context(void)
4784 my_perl = PL_curinterp;
4785 PERL_SET_THX(my_perl);
4789 return PL_curinterp;
4795 win32_ctrlhandler(DWORD dwCtrlType)
4798 dTHXa(PERL_GET_SIG_CONTEXT);
4804 switch(dwCtrlType) {
4805 case CTRL_CLOSE_EVENT:
4806 /* A signal that the system sends to all processes attached to a console when
4807 the user closes the console (either by choosing the Close command from the
4808 console window's System menu, or by choosing the End Task command from the
4811 if (do_raise(aTHX_ 1)) /* SIGHUP */
4812 sig_terminate(aTHX_ 1);
4816 /* A CTRL+c signal was received */
4817 if (do_raise(aTHX_ SIGINT))
4818 sig_terminate(aTHX_ SIGINT);
4821 case CTRL_BREAK_EVENT:
4822 /* A CTRL+BREAK signal was received */
4823 if (do_raise(aTHX_ SIGBREAK))
4824 sig_terminate(aTHX_ SIGBREAK);
4827 case CTRL_LOGOFF_EVENT:
4828 /* A signal that the system sends to all console processes when a user is logging
4829 off. This signal does not indicate which user is logging off, so no
4830 assumptions can be made.
4833 case CTRL_SHUTDOWN_EVENT:
4834 /* A signal that the system sends to all console processes when the system is
4837 if (do_raise(aTHX_ SIGTERM))
4838 sig_terminate(aTHX_ SIGTERM);
4848 Perl_win32_init(int *argcp, char ***argvp)
4850 /* Disable floating point errors, Perl will trap the ones we
4851 * care about. VC++ RTL defaults to switching these off
4852 * already, but the Borland RTL doesn't. Since we don't
4853 * want to be at the vendor's whim on the default, we set
4854 * it explicitly here.
4856 #if !defined(_ALPHA_) && !defined(__GNUC__)
4857 _control87(MCW_EM, MCW_EM);
4863 Perl_win32_term(void)
4870 win32_get_child_IO(child_IO_table* ptbl)
4872 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4873 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4874 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4878 win32_signal(int sig, Sighandler_t subcode)
4881 if (sig < SIG_SIZE) {
4882 int save_errno = errno;
4883 Sighandler_t result = signal(sig, subcode);
4884 if (result == SIG_ERR) {
4885 result = w32_sighandler[sig];
4888 w32_sighandler[sig] = subcode;
4898 #ifdef HAVE_INTERP_INTERN
4902 win32_csighandler(int sig)
4905 dTHXa(PERL_GET_SIG_CONTEXT);
4906 Perl_warn(aTHX_ "Got signal %d",sig);
4912 win32_create_message_window()
4914 /* "message-only" windows have been implemented in Windows 2000 and later.
4915 * On earlier versions we'll continue to post messages to a specific
4916 * thread and use hwnd==NULL. This is brittle when either an embedding
4917 * application or an XS module is also posting messages to hwnd=NULL
4918 * because once removed from the queue they cannot be delivered to the
4919 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4920 * if there is no window handle.
4922 if (g_osver.dwMajorVersion < 5)
4925 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4929 Perl_sys_intern_init(pTHX)
4933 if (g_osver.dwOSVersionInfoSize == 0) {
4934 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4935 GetVersionEx(&g_osver);
4938 w32_perlshell_tokens = Nullch;
4939 w32_perlshell_vec = (char**)NULL;
4940 w32_perlshell_items = 0;
4941 w32_fdpid = newAV();
4942 Newx(w32_children, 1, child_tab);
4943 w32_num_children = 0;
4944 # ifdef USE_ITHREADS
4946 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4947 w32_num_pseudo_children = 0;
4950 w32_message_hwnd = INVALID_HANDLE_VALUE;
4952 for (i=0; i < SIG_SIZE; i++) {
4953 w32_sighandler[i] = SIG_DFL;
4956 if (my_perl == PL_curinterp) {
4960 /* Force C runtime signal stuff to set its console handler */
4961 signal(SIGINT,win32_csighandler);
4962 signal(SIGBREAK,win32_csighandler);
4963 /* Push our handler on top */
4964 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4969 Perl_sys_intern_clear(pTHX)
4971 Safefree(w32_perlshell_tokens);
4972 Safefree(w32_perlshell_vec);
4973 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4974 Safefree(w32_children);
4976 KillTimer(w32_message_hwnd, w32_timerid);
4979 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4980 DestroyWindow(w32_message_hwnd);
4981 # ifdef MULTIPLICITY
4982 if (my_perl == PL_curinterp) {
4986 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4988 # ifdef USE_ITHREADS
4989 Safefree(w32_pseudo_children);
4993 # ifdef USE_ITHREADS
4996 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4998 dst->perlshell_tokens = Nullch;
4999 dst->perlshell_vec = (char**)NULL;
5000 dst->perlshell_items = 0;
5001 dst->fdpid = newAV();
5002 Newxz(dst->children, 1, child_tab);
5004 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5006 dst->message_hwnd = INVALID_HANDLE_VALUE;
5007 dst->poll_count = 0;
5008 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5010 # endif /* USE_ITHREADS */
5011 #endif /* HAVE_INTERP_INTERN */
5014 win32_free_argvw(pTHX_ void *ptr)
5016 char** argv = (char**)ptr;
5024 win32_argv2utf8(int argc, char** argv)
5029 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5030 if (lpwStr && argc) {
5032 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5033 Newxz(psz, length, char);
5034 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5037 call_atexit(win32_free_argvw, argv);
5039 GlobalFree((HGLOBAL)lpwStr);