3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
18 #ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */
19 # include <shellapi.h>
21 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
27 /* #include "config.h" */
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
38 #define PERL_NO_GET_CONTEXT
44 /* assert.h conflicts with #define of assert in perl.h */
51 #if defined(_MSC_VER) || defined(__MINGW32__)
52 #include <sys/utime.h>
57 /* Mingw32 defaults to globing command line
58 * So we turn it off like this:
63 #if defined(__MINGW32__)
64 /* Mingw32 is missing some prototypes */
65 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
72 #if defined(__BORLANDC__)
74 # define _utimbuf utimbuf
79 #define EXECF_SPAWN_NOWAIT 3
81 #if defined(PERL_IMPLICIT_SYS)
82 # undef win32_get_privlib
83 # define win32_get_privlib g_win32_get_privlib
84 # undef win32_get_sitelib
85 # define win32_get_sitelib g_win32_get_sitelib
86 # undef win32_get_vendorlib
87 # define win32_get_vendorlib g_win32_get_vendorlib
89 # define getlogin g_getlogin
92 static void get_shell(void);
93 static long tokenize(const char *str, char **dest, char ***destv);
94 static int do_spawn2(pTHX_ char *cmd, int exectype);
95 static BOOL has_shell_metachars(char *ptr);
96 static long filetime_to_clock(PFILETIME ft);
97 static BOOL filetime_from_time(PFILETIME ft, time_t t);
98 static char * get_emd_part(SV **leading, char *trailing, ...);
99 static void remove_dead_process(long deceased);
100 static long find_pid(int pid);
101 static char * qualified_path(const char *cmd);
102 static char * win32_get_xlib(const char *pl, const char *xlib,
103 const char *libname);
106 static void remove_dead_pseudo_process(long child);
107 static long find_pseudo_pid(int pid);
111 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
112 char w32_module_name[MAX_PATH+1];
115 static DWORD w32_platform = (DWORD)-1;
117 #define ONE_K_BUFSIZE 1024
122 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
128 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
132 set_w32_module_name(void)
135 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
136 ? GetModuleHandle(NULL)
137 : w32_perldll_handle),
138 w32_module_name, sizeof(w32_module_name));
140 /* try to get full path to binary (which may be mangled when perl is
141 * run from a 16-bit app) */
142 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
143 (void)win32_longpath(w32_module_name);
144 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
146 /* normalize to forward slashes */
147 ptr = w32_module_name;
155 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
157 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
159 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
162 const char *subkey = "Software\\Perl";
166 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
167 if (retval == ERROR_SUCCESS) {
169 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
170 if (retval == ERROR_SUCCESS
171 && (type == REG_SZ || type == REG_EXPAND_SZ))
175 *svp = sv_2mortal(newSVpvn("",0));
176 SvGROW(*svp, datalen);
177 retval = RegQueryValueEx(handle, valuename, 0, NULL,
178 (PBYTE)SvPVX(*svp), &datalen);
179 if (retval == ERROR_SUCCESS) {
181 SvCUR_set(*svp,datalen-1);
189 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
191 get_regstr(const char *valuename, SV **svp)
193 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
195 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
199 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
201 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
205 char mod_name[MAX_PATH+1];
211 va_start(ap, trailing_path);
212 strip = va_arg(ap, char *);
214 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
215 baselen = strlen(base);
217 if (!*w32_module_name) {
218 set_w32_module_name();
220 strcpy(mod_name, w32_module_name);
221 ptr = strrchr(mod_name, '/');
222 while (ptr && strip) {
223 /* look for directories to skip back */
226 ptr = strrchr(mod_name, '/');
227 /* avoid stripping component if there is no slash,
228 * or it doesn't match ... */
229 if (!ptr || stricmp(ptr+1, strip) != 0) {
230 /* ... but not if component matches m|5\.$patchlevel.*| */
231 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
232 && strncmp(strip, base, baselen) == 0
233 && strncmp(ptr+1, base, baselen) == 0))
239 strip = va_arg(ap, char *);
247 strcpy(++ptr, trailing_path);
249 /* only add directory if it exists */
250 if (GetFileAttributes(mod_name) != (DWORD) -1) {
251 /* directory exists */
254 *prev_pathp = sv_2mortal(newSVpvn("",0));
255 sv_catpvn(*prev_pathp, ";", 1);
256 sv_catpv(*prev_pathp, mod_name);
257 return SvPVX(*prev_pathp);
264 win32_get_privlib(const char *pl)
267 char *stdlib = "lib";
268 char buffer[MAX_PATH+1];
271 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
272 sprintf(buffer, "%s-%s", stdlib, pl);
273 if (!get_regstr(buffer, &sv))
274 (void)get_regstr(stdlib, &sv);
276 /* $stdlib .= ";$EMD/../../lib" */
277 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
281 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
285 char pathstr[MAX_PATH+1];
289 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
290 sprintf(regstr, "%s-%s", xlib, pl);
291 (void)get_regstr(regstr, &sv1);
294 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
295 sprintf(pathstr, "%s/%s/lib", libname, pl);
296 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
298 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
299 (void)get_regstr(xlib, &sv2);
302 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
303 sprintf(pathstr, "%s/lib", libname);
304 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
313 sv_catpvn(sv1, ";", 1);
320 win32_get_sitelib(const char *pl)
322 return win32_get_xlib(pl, "sitelib", "site");
325 #ifndef PERL_VENDORLIB_NAME
326 # define PERL_VENDORLIB_NAME "vendor"
330 win32_get_vendorlib(const char *pl)
332 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
336 has_shell_metachars(char *ptr)
342 * Scan string looking for redirection (< or >) or pipe
343 * characters (|) that are not in a quoted string.
344 * Shell variable interpolation (%VAR%) can also happen inside strings.
376 #if !defined(PERL_IMPLICIT_SYS)
377 /* since the current process environment is being updated in util.c
378 * the library functions will get the correct environment
381 Perl_my_popen(pTHX_ char *cmd, char *mode)
384 #define fixcmd(x) { \
385 char *pspace = strchr((x),' '); \
388 while (p < pspace) { \
399 PERL_FLUSHALL_FOR_CHILD;
400 return win32_popen(cmd, mode);
404 Perl_my_pclose(pTHX_ PerlIO *fp)
406 return win32_pclose(fp);
410 DllExport unsigned long
413 static OSVERSIONINFO osver;
415 if (osver.dwPlatformId != w32_platform) {
416 memset(&osver, 0, sizeof(OSVERSIONINFO));
417 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
418 GetVersionEx(&osver);
419 w32_platform = osver.dwPlatformId;
421 return (unsigned long)w32_platform;
431 return -((int)w32_pseudo_id);
434 /* Windows 9x appears to always reports a pid for threads and processes
435 * that has the high bit set. So we treat the lower 31 bits as the
436 * "real" PID for Perl's purposes. */
437 if (IsWin95() && pid < 0)
442 /* Tokenize a string. Words are null-separated, and the list
443 * ends with a doubled null. Any character (except null and
444 * including backslash) may be escaped by preceding it with a
445 * backslash (the backslash will be stripped).
446 * Returns number of words in result buffer.
449 tokenize(const char *str, char **dest, char ***destv)
451 char *retstart = Nullch;
452 char **retvstart = 0;
456 int slen = strlen(str);
458 register char **retv;
459 New(1307, ret, slen+2, char);
460 New(1308, retv, (slen+3)/2, char*);
468 if (*ret == '\\' && *str)
470 else if (*ret == ' ') {
486 retvstart[items] = Nullch;
499 if (!w32_perlshell_tokens) {
500 /* we don't use COMSPEC here for two reasons:
501 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
502 * uncontrolled unportability of the ensuing scripts.
503 * 2. PERL5SHELL could be set to a shell that may not be fit for
504 * interactive use (which is what most programs look in COMSPEC
507 const char* defaultshell = (IsWinNT()
508 ? "cmd.exe /x/c" : "command.com /c");
509 const char *usershell = PerlEnv_getenv("PERL5SHELL");
510 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
511 &w32_perlshell_tokens,
517 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
529 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
531 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
536 while (++mark <= sp) {
537 if (*mark && (str = SvPV_nolen(*mark)))
544 status = win32_spawnvp(flag,
545 (const char*)(really ? SvPV_nolen(really) : argv[0]),
546 (const char* const*)argv);
548 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
549 /* possible shell-builtin, invoke with shell */
551 sh_items = w32_perlshell_items;
553 argv[index+sh_items] = argv[index];
554 while (--sh_items >= 0)
555 argv[sh_items] = w32_perlshell_vec[sh_items];
557 status = win32_spawnvp(flag,
558 (const char*)(really ? SvPV_nolen(really) : argv[0]),
559 (const char* const*)argv);
562 if (flag == P_NOWAIT) {
564 PL_statusvalue = -1; /* >16bits hint for pp_system() */
568 if (ckWARN(WARN_EXEC))
569 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
574 PL_statusvalue = status;
580 /* returns pointer to the next unquoted space or the end of the string */
582 find_next_space(const char *s)
584 bool in_quotes = FALSE;
586 /* ignore doubled backslashes, or backslash+quote */
587 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
590 /* keep track of when we're within quotes */
591 else if (*s == '"') {
593 in_quotes = !in_quotes;
595 /* break it up only at spaces that aren't in quotes */
596 else if (!in_quotes && isSPACE(*s))
605 do_spawn2(pTHX_ char *cmd, int exectype)
611 BOOL needToTry = TRUE;
614 /* Save an extra exec if possible. See if there are shell
615 * metacharacters in it */
616 if (!has_shell_metachars(cmd)) {
617 New(1301,argv, strlen(cmd) / 2 + 2, char*);
618 New(1302,cmd2, strlen(cmd) + 1, char);
621 for (s = cmd2; *s;) {
622 while (*s && isSPACE(*s))
626 s = find_next_space(s);
634 status = win32_spawnvp(P_WAIT, argv[0],
635 (const char* const*)argv);
637 case EXECF_SPAWN_NOWAIT:
638 status = win32_spawnvp(P_NOWAIT, argv[0],
639 (const char* const*)argv);
642 status = win32_execvp(argv[0], (const char* const*)argv);
645 if (status != -1 || errno == 0)
655 New(1306, argv, w32_perlshell_items + 2, char*);
656 while (++i < w32_perlshell_items)
657 argv[i] = w32_perlshell_vec[i];
662 status = win32_spawnvp(P_WAIT, argv[0],
663 (const char* const*)argv);
665 case EXECF_SPAWN_NOWAIT:
666 status = win32_spawnvp(P_NOWAIT, argv[0],
667 (const char* const*)argv);
670 status = win32_execvp(argv[0], (const char* const*)argv);
676 if (exectype == EXECF_SPAWN_NOWAIT) {
678 PL_statusvalue = -1; /* >16bits hint for pp_system() */
682 if (ckWARN(WARN_EXEC))
683 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
684 (exectype == EXECF_EXEC ? "exec" : "spawn"),
685 cmd, strerror(errno));
690 PL_statusvalue = status;
696 Perl_do_spawn(pTHX_ char *cmd)
698 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
702 Perl_do_spawn_nowait(pTHX_ char *cmd)
704 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
708 Perl_do_exec(pTHX_ char *cmd)
710 do_spawn2(aTHX_ cmd, EXECF_EXEC);
714 /* The idea here is to read all the directory names into a string table
715 * (separated by nulls) and when one of the other dir functions is called
716 * return the pointer to the current file name.
719 win32_opendir(char *filename)
725 char scanname[MAX_PATH+3];
727 WIN32_FIND_DATAA aFindData;
728 WIN32_FIND_DATAW wFindData;
730 char buffer[MAX_PATH*2];
731 WCHAR wbuffer[MAX_PATH+1];
734 len = strlen(filename);
738 /* check to see if filename is a directory */
739 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
742 /* Get us a DIR structure */
743 Newz(1303, dirp, 1, DIR);
745 /* Create the search pattern */
746 strcpy(scanname, filename);
748 /* bare drive name means look in cwd for drive */
749 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
750 scanname[len++] = '.';
751 scanname[len++] = '/';
753 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
754 scanname[len++] = '/';
756 scanname[len++] = '*';
757 scanname[len] = '\0';
759 /* do the FindFirstFile call */
761 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
762 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
765 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
768 if (fh == INVALID_HANDLE_VALUE) {
769 DWORD err = GetLastError();
770 /* FindFirstFile() fails on empty drives! */
772 case ERROR_FILE_NOT_FOUND:
774 case ERROR_NO_MORE_FILES:
775 case ERROR_PATH_NOT_FOUND:
778 case ERROR_NOT_ENOUGH_MEMORY:
789 /* now allocate the first part of the string table for
790 * the filenames that we find.
793 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
797 ptr = aFindData.cFileName;
804 New(1304, dirp->start, dirp->size, char);
805 strcpy(dirp->start, ptr);
807 dirp->end = dirp->curr = dirp->start;
813 /* Readdir just returns the current string pointer and bumps the
814 * string pointer to the nDllExport entry.
816 DllExport struct direct *
817 win32_readdir(DIR *dirp)
822 /* first set up the structure to return */
823 len = strlen(dirp->curr);
824 strcpy(dirp->dirstr.d_name, dirp->curr);
825 dirp->dirstr.d_namlen = len;
828 dirp->dirstr.d_ino = dirp->curr - dirp->start;
830 /* Now set up for the next call to readdir */
831 dirp->curr += len + 1;
832 if (dirp->curr >= dirp->end) {
836 WIN32_FIND_DATAW wFindData;
837 WIN32_FIND_DATAA aFindData;
838 char buffer[MAX_PATH*2];
840 /* finding the next file that matches the wildcard
841 * (which should be all of them in this directory!).
844 res = FindNextFileW(dirp->handle, &wFindData);
846 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
851 res = FindNextFileA(dirp->handle, &aFindData);
853 ptr = aFindData.cFileName;
856 long endpos = dirp->end - dirp->start;
857 long newsize = endpos + strlen(ptr) + 1;
858 /* bump the string table size by enough for the
859 * new name and its null terminator */
860 while (newsize > dirp->size) {
861 long curpos = dirp->curr - dirp->start;
863 Renew(dirp->start, dirp->size, char);
864 dirp->curr = dirp->start + curpos;
866 strcpy(dirp->start + endpos, ptr);
867 dirp->end = dirp->start + newsize;
873 return &(dirp->dirstr);
879 /* Telldir returns the current string pointer position */
881 win32_telldir(DIR *dirp)
883 return (dirp->curr - dirp->start);
887 /* Seekdir moves the string pointer to a previously saved position
888 * (returned by telldir).
891 win32_seekdir(DIR *dirp, long loc)
893 dirp->curr = dirp->start + loc;
896 /* Rewinddir resets the string pointer to the start */
898 win32_rewinddir(DIR *dirp)
900 dirp->curr = dirp->start;
903 /* free the memory allocated by opendir */
905 win32_closedir(DIR *dirp)
908 if (dirp->handle != INVALID_HANDLE_VALUE)
909 FindClose(dirp->handle);
910 Safefree(dirp->start);
923 * Just pretend that everyone is a superuser. NT will let us know if
924 * we don\'t really have permission to do something.
927 #define ROOT_UID ((uid_t)0)
928 #define ROOT_GID ((gid_t)0)
957 return (auid == ROOT_UID ? 0 : -1);
963 return (agid == ROOT_GID ? 0 : -1);
970 char *buf = w32_getlogin_buffer;
971 DWORD size = sizeof(w32_getlogin_buffer);
972 if (GetUserName(buf,&size))
978 chown(const char *path, uid_t owner, gid_t group)
985 * XXX this needs strengthening (for PerlIO)
988 int mkstemp(const char *path)
991 char buf[MAX_PATH+1];
995 if (i++ > 10) { /* give up */
999 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1003 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1013 long child = w32_num_children;
1014 while (--child >= 0) {
1015 if ((int)w32_child_pids[child] == pid)
1022 remove_dead_process(long child)
1026 CloseHandle(w32_child_handles[child]);
1027 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1028 (w32_num_children-child-1), HANDLE);
1029 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1030 (w32_num_children-child-1), DWORD);
1037 find_pseudo_pid(int pid)
1040 long child = w32_num_pseudo_children;
1041 while (--child >= 0) {
1042 if ((int)w32_pseudo_child_pids[child] == pid)
1049 remove_dead_pseudo_process(long child)
1053 CloseHandle(w32_pseudo_child_handles[child]);
1054 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1055 (w32_num_pseudo_children-child-1), HANDLE);
1056 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1057 (w32_num_pseudo_children-child-1), DWORD);
1058 w32_num_pseudo_children--;
1064 win32_kill(int pid, int sig)
1071 /* it is a pseudo-forked child */
1072 child = find_pseudo_pid(-pid);
1074 hProcess = w32_pseudo_child_handles[child];
1077 /* "Does process exist?" use of kill */
1080 /* kill -9 style un-graceful exit */
1081 if (TerminateThread(hProcess, sig)) {
1082 remove_dead_pseudo_process(child);
1087 /* We fake signals to pseudo-processes using Win32
1088 * message queue. In Win9X the pids are negative already. */
1089 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1090 /* It might be us ... */
1097 else if (IsWin95()) {
1105 child = find_pid(pid);
1107 hProcess = w32_child_handles[child];
1110 /* "Does process exist?" use of kill */
1113 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1116 default: /* For now be backwards compatible with perl5.6 */
1118 if (TerminateProcess(hProcess, sig)) {
1119 remove_dead_process(child);
1127 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1128 (IsWin95() ? -pid : pid));
1132 /* "Does process exist?" use of kill */
1135 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1138 default: /* For now be backwards compatible with perl5.6 */
1140 if (TerminateProcess(hProcess, sig)) {
1141 CloseHandle(hProcess);
1153 win32_stat(const char *path, Stat_t *sbuf)
1156 char buffer[MAX_PATH+1];
1157 int l = strlen(path);
1159 WCHAR wbuffer[MAX_PATH+1];
1165 switch(path[l - 1]) {
1166 /* FindFirstFile() and stat() are buggy with a trailing
1167 * backslash, so change it to a forward slash :-( */
1169 strncpy(buffer, path, l-1);
1170 buffer[l - 1] = '/';
1174 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1176 if (l == 2 && isALPHA(path[0])) {
1177 buffer[0] = path[0];
1188 /* We *must* open & close the file once; otherwise file attribute changes */
1189 /* might not yet have propagated to "other" hard links of the same file. */
1190 /* This also gives us an opportunity to determine the number of links. */
1192 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1193 pwbuffer = PerlDir_mapW(wbuffer);
1194 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1197 path = PerlDir_mapA(path);
1199 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1201 if (handle != INVALID_HANDLE_VALUE) {
1202 BY_HANDLE_FILE_INFORMATION bhi;
1203 if (GetFileInformationByHandle(handle, &bhi))
1204 nlink = bhi.nNumberOfLinks;
1205 CloseHandle(handle);
1208 /* pwbuffer or path will be mapped correctly above */
1210 #if defined(WIN64) || defined(USE_LARGE_FILES)
1211 res = _wstati64(pwbuffer, sbuf);
1213 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1217 #if defined(WIN64) || defined(USE_LARGE_FILES)
1218 res = _stati64(path, sbuf);
1220 res = stat(path, sbuf);
1223 sbuf->st_nlink = nlink;
1226 /* CRT is buggy on sharenames, so make sure it really isn't.
1227 * XXX using GetFileAttributesEx() will enable us to set
1228 * sbuf->st_*time (but note that's not available on the
1229 * Windows of 1995) */
1232 r = GetFileAttributesW(pwbuffer);
1235 r = GetFileAttributesA(path);
1237 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1238 /* sbuf may still contain old garbage since stat() failed */
1239 Zero(sbuf, 1, Stat_t);
1240 sbuf->st_mode = S_IFDIR | S_IREAD;
1242 if (!(r & FILE_ATTRIBUTE_READONLY))
1243 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1248 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1249 && (path[2] == '\\' || path[2] == '/'))
1251 /* The drive can be inaccessible, some _stat()s are buggy */
1253 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1254 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1260 if (S_ISDIR(sbuf->st_mode))
1261 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1262 else if (S_ISREG(sbuf->st_mode)) {
1264 if (l >= 4 && path[l-4] == '.') {
1265 const char *e = path + l - 3;
1266 if (strnicmp(e,"exe",3)
1267 && strnicmp(e,"bat",3)
1268 && strnicmp(e,"com",3)
1269 && (IsWin95() || strnicmp(e,"cmd",3)))
1270 sbuf->st_mode &= ~S_IEXEC;
1272 sbuf->st_mode |= S_IEXEC;
1275 sbuf->st_mode &= ~S_IEXEC;
1276 /* Propagate permissions to _group_ and _others_ */
1277 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1278 sbuf->st_mode |= (perms>>3) | (perms>>6);
1285 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1286 #define SKIP_SLASHES(s) \
1288 while (*(s) && isSLASH(*(s))) \
1291 #define COPY_NONSLASHES(d,s) \
1293 while (*(s) && !isSLASH(*(s))) \
1297 /* Find the longname of a given path. path is destructively modified.
1298 * It should have space for at least MAX_PATH characters. */
1300 win32_longpath(char *path)
1302 WIN32_FIND_DATA fdata;
1304 char tmpbuf[MAX_PATH+1];
1305 char *tmpstart = tmpbuf;
1312 if (isALPHA(path[0]) && path[1] == ':') {
1314 *tmpstart++ = path[0];
1318 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1320 *tmpstart++ = path[0];
1321 *tmpstart++ = path[1];
1322 SKIP_SLASHES(start);
1323 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1325 *tmpstart++ = *start++;
1326 SKIP_SLASHES(start);
1327 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1332 /* copy initial slash, if any */
1333 if (isSLASH(*start)) {
1334 *tmpstart++ = *start++;
1336 SKIP_SLASHES(start);
1339 /* FindFirstFile() expands "." and "..", so we need to pass
1340 * those through unmolested */
1342 && (!start[1] || isSLASH(start[1])
1343 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1345 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1350 /* if this is the end, bust outta here */
1354 /* now we're at a non-slash; walk up to next slash */
1355 while (*start && !isSLASH(*start))
1358 /* stop and find full name of component */
1361 fhand = FindFirstFile(path,&fdata);
1363 if (fhand != INVALID_HANDLE_VALUE) {
1364 STRLEN len = strlen(fdata.cFileName);
1365 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1366 strcpy(tmpstart, fdata.cFileName);
1377 /* failed a step, just return without side effects */
1378 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1383 strcpy(path,tmpbuf);
1388 win32_getenv(const char *name)
1391 WCHAR wBuffer[MAX_PATH+1];
1393 SV *curitem = Nullsv;
1396 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1397 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1400 needlen = GetEnvironmentVariableA(name,NULL,0);
1402 curitem = sv_2mortal(newSVpvn("", 0));
1406 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1407 needlen = GetEnvironmentVariableW(wBuffer,
1408 (WCHAR*)SvPVX(curitem),
1410 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1411 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1412 acuritem = sv_2mortal(newSVsv(curitem));
1413 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1417 SvGROW(curitem, needlen+1);
1418 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1420 } while (needlen >= SvLEN(curitem));
1421 SvCUR_set(curitem, needlen);
1425 /* allow any environment variables that begin with 'PERL'
1426 to be stored in the registry */
1427 if (strncmp(name, "PERL", 4) == 0)
1428 (void)get_regstr(name, &curitem);
1430 if (curitem && SvCUR(curitem))
1431 return SvPVX(curitem);
1437 win32_putenv(const char *name)
1444 int length, relval = -1;
1448 length = strlen(name)+1;
1449 New(1309,wCuritem,length,WCHAR);
1450 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1451 wVal = wcschr(wCuritem, '=');
1454 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1460 New(1309,curitem,strlen(name)+1,char);
1461 strcpy(curitem, name);
1462 val = strchr(curitem, '=');
1464 /* The sane way to deal with the environment.
1465 * Has these advantages over putenv() & co.:
1466 * * enables us to store a truly empty value in the
1467 * environment (like in UNIX).
1468 * * we don't have to deal with RTL globals, bugs and leaks.
1470 * Why you may want to enable USE_WIN32_RTL_ENV:
1471 * * environ[] and RTL functions will not reflect changes,
1472 * which might be an issue if extensions want to access
1473 * the env. via RTL. This cuts both ways, since RTL will
1474 * not see changes made by extensions that call the Win32
1475 * functions directly, either.
1479 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1489 filetime_to_clock(PFILETIME ft)
1491 __int64 qw = ft->dwHighDateTime;
1493 qw |= ft->dwLowDateTime;
1494 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1499 win32_times(struct tms *timebuf)
1504 clock_t process_time_so_far = clock();
1505 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1507 timebuf->tms_utime = filetime_to_clock(&user);
1508 timebuf->tms_stime = filetime_to_clock(&kernel);
1509 timebuf->tms_cutime = 0;
1510 timebuf->tms_cstime = 0;
1512 /* That failed - e.g. Win95 fallback to clock() */
1513 timebuf->tms_utime = process_time_so_far;
1514 timebuf->tms_stime = 0;
1515 timebuf->tms_cutime = 0;
1516 timebuf->tms_cstime = 0;
1518 return process_time_so_far;
1521 /* fix utime() so it works on directories in NT */
1523 filetime_from_time(PFILETIME pFileTime, time_t Time)
1525 struct tm *pTM = localtime(&Time);
1526 SYSTEMTIME SystemTime;
1532 SystemTime.wYear = pTM->tm_year + 1900;
1533 SystemTime.wMonth = pTM->tm_mon + 1;
1534 SystemTime.wDay = pTM->tm_mday;
1535 SystemTime.wHour = pTM->tm_hour;
1536 SystemTime.wMinute = pTM->tm_min;
1537 SystemTime.wSecond = pTM->tm_sec;
1538 SystemTime.wMilliseconds = 0;
1540 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1541 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1545 win32_unlink(const char *filename)
1552 WCHAR wBuffer[MAX_PATH+1];
1555 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1556 pwBuffer = PerlDir_mapW(wBuffer);
1557 attrs = GetFileAttributesW(pwBuffer);
1558 if (attrs == 0xFFFFFFFF)
1560 if (attrs & FILE_ATTRIBUTE_READONLY) {
1561 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1562 ret = _wunlink(pwBuffer);
1564 (void)SetFileAttributesW(pwBuffer, attrs);
1567 ret = _wunlink(pwBuffer);
1570 filename = PerlDir_mapA(filename);
1571 attrs = GetFileAttributesA(filename);
1572 if (attrs == 0xFFFFFFFF)
1574 if (attrs & FILE_ATTRIBUTE_READONLY) {
1575 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1576 ret = unlink(filename);
1578 (void)SetFileAttributesA(filename, attrs);
1581 ret = unlink(filename);
1590 win32_utime(const char *filename, struct utimbuf *times)
1597 struct utimbuf TimeBuffer;
1598 WCHAR wbuffer[MAX_PATH+1];
1603 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1604 pwbuffer = PerlDir_mapW(wbuffer);
1605 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1608 filename = PerlDir_mapA(filename);
1609 rc = utime(filename, times);
1611 /* EACCES: path specifies directory or readonly file */
1612 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1615 if (times == NULL) {
1616 times = &TimeBuffer;
1617 time(×->actime);
1618 times->modtime = times->actime;
1621 /* This will (and should) still fail on readonly files */
1623 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1624 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1625 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1628 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1629 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1630 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1632 if (handle == INVALID_HANDLE_VALUE)
1635 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1636 filetime_from_time(&ftAccess, times->actime) &&
1637 filetime_from_time(&ftWrite, times->modtime) &&
1638 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1643 CloseHandle(handle);
1648 unsigned __int64 ft_i64;
1653 #define Const64(x) x##LL
1655 #define Const64(x) x##i64
1657 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1658 #define EPOCH_BIAS Const64(116444736000000000)
1660 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1661 * and appears to be unsupported even by glibc) */
1663 win32_gettimeofday(struct timeval *tp, void *not_used)
1667 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1668 GetSystemTimeAsFileTime(&ft.ft_val);
1670 /* seconds since epoch */
1671 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1673 /* microseconds remaining */
1674 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1680 win32_uname(struct utsname *name)
1682 struct hostent *hep;
1683 STRLEN nodemax = sizeof(name->nodename)-1;
1684 OSVERSIONINFO osver;
1686 memset(&osver, 0, sizeof(OSVERSIONINFO));
1687 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1688 if (GetVersionEx(&osver)) {
1690 switch (osver.dwPlatformId) {
1691 case VER_PLATFORM_WIN32_WINDOWS:
1692 strcpy(name->sysname, "Windows");
1694 case VER_PLATFORM_WIN32_NT:
1695 strcpy(name->sysname, "Windows NT");
1697 case VER_PLATFORM_WIN32s:
1698 strcpy(name->sysname, "Win32s");
1701 strcpy(name->sysname, "Win32 Unknown");
1706 sprintf(name->release, "%d.%d",
1707 osver.dwMajorVersion, osver.dwMinorVersion);
1710 sprintf(name->version, "Build %d",
1711 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1712 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1713 if (osver.szCSDVersion[0]) {
1714 char *buf = name->version + strlen(name->version);
1715 sprintf(buf, " (%s)", osver.szCSDVersion);
1719 *name->sysname = '\0';
1720 *name->version = '\0';
1721 *name->release = '\0';
1725 hep = win32_gethostbyname("localhost");
1727 STRLEN len = strlen(hep->h_name);
1728 if (len <= nodemax) {
1729 strcpy(name->nodename, hep->h_name);
1732 strncpy(name->nodename, hep->h_name, nodemax);
1733 name->nodename[nodemax] = '\0';
1738 if (!GetComputerName(name->nodename, &sz))
1739 *name->nodename = '\0';
1742 /* machine (architecture) */
1747 GetSystemInfo(&info);
1749 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1750 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1751 procarch = info.u.s.wProcessorArchitecture;
1753 procarch = info.wProcessorArchitecture;
1756 case PROCESSOR_ARCHITECTURE_INTEL:
1757 arch = "x86"; break;
1758 case PROCESSOR_ARCHITECTURE_MIPS:
1759 arch = "mips"; break;
1760 case PROCESSOR_ARCHITECTURE_ALPHA:
1761 arch = "alpha"; break;
1762 case PROCESSOR_ARCHITECTURE_PPC:
1763 arch = "ppc"; break;
1764 #ifdef PROCESSOR_ARCHITECTURE_SHX
1765 case PROCESSOR_ARCHITECTURE_SHX:
1766 arch = "shx"; break;
1768 #ifdef PROCESSOR_ARCHITECTURE_ARM
1769 case PROCESSOR_ARCHITECTURE_ARM:
1770 arch = "arm"; break;
1772 #ifdef PROCESSOR_ARCHITECTURE_IA64
1773 case PROCESSOR_ARCHITECTURE_IA64:
1774 arch = "ia64"; break;
1776 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1777 case PROCESSOR_ARCHITECTURE_ALPHA64:
1778 arch = "alpha64"; break;
1780 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1781 case PROCESSOR_ARCHITECTURE_MSIL:
1782 arch = "msil"; break;
1784 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1785 case PROCESSOR_ARCHITECTURE_AMD64:
1786 arch = "amd64"; break;
1788 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1789 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1790 arch = "ia32-64"; break;
1792 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1793 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1794 arch = "unknown"; break;
1797 sprintf(name->machine, "unknown(0x%x)", procarch);
1798 arch = name->machine;
1801 if (name->machine != arch)
1802 strcpy(name->machine, arch);
1807 /* Timing related stuff */
1810 do_raise(pTHX_ int sig)
1812 if (sig < SIG_SIZE) {
1813 Sighandler_t handler = w32_sighandler[sig];
1814 if (handler == SIG_IGN) {
1817 else if (handler != SIG_DFL) {
1822 /* Choose correct default behaviour */
1838 /* Tell caller to exit thread/process as approriate */
1843 sig_terminate(pTHX_ int sig)
1845 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1846 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1853 win32_async_check(pTHX)
1857 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1858 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1860 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1862 switch(msg.message) {
1865 /* Perhaps some other messages could map to signals ? ... */
1868 /* Treat WM_QUIT like SIGHUP? */
1874 /* We use WM_USER to fake kill() with other signals */
1878 if (do_raise(aTHX_ sig)) {
1879 sig_terminate(aTHX_ sig);
1885 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1887 KillTimer(NULL,w32_timerid);
1890 /* Now fake a call to signal handler */
1891 if (do_raise(aTHX_ 14)) {
1892 sig_terminate(aTHX_ 14);
1897 /* Otherwise do normal Win32 thing - in case it is useful */
1899 TranslateMessage(&msg);
1900 DispatchMessage(&msg);
1907 /* Above or other stuff may have set a signal flag */
1908 if (PL_sig_pending) {
1915 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1917 /* We may need several goes at this - so compute when we stop */
1919 if (timeout != INFINITE) {
1920 ticks = GetTickCount();
1924 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1927 if (result == WAIT_TIMEOUT) {
1928 /* Ran out of time - explicit return of zero to avoid -ve if we
1929 have scheduling issues
1933 if (timeout != INFINITE) {
1934 ticks = GetTickCount();
1936 if (result == WAIT_OBJECT_0 + count) {
1937 /* Message has arrived - check it */
1938 if (win32_async_check(aTHX)) {
1939 /* was one of ours */
1944 /* Not timeout or message - one of handles is ready */
1948 /* compute time left to wait */
1949 ticks = timeout - ticks;
1950 /* If we are past the end say zero */
1951 return (ticks > 0) ? ticks : 0;
1955 win32_internal_wait(int *status, DWORD timeout)
1957 /* XXX this wait emulation only knows about processes
1958 * spawned via win32_spawnvp(P_NOWAIT, ...).
1962 DWORD exitcode, waitcode;
1965 if (w32_num_pseudo_children) {
1966 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1967 timeout, &waitcode);
1968 /* Time out here if there are no other children to wait for. */
1969 if (waitcode == WAIT_TIMEOUT) {
1970 if (!w32_num_children) {
1974 else if (waitcode != WAIT_FAILED) {
1975 if (waitcode >= WAIT_ABANDONED_0
1976 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1977 i = waitcode - WAIT_ABANDONED_0;
1979 i = waitcode - WAIT_OBJECT_0;
1980 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1981 *status = (int)((exitcode & 0xff) << 8);
1982 retval = (int)w32_pseudo_child_pids[i];
1983 remove_dead_pseudo_process(i);
1990 if (!w32_num_children) {
1995 /* if a child exists, wait for it to die */
1996 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1997 if (waitcode == WAIT_TIMEOUT) {
2000 if (waitcode != WAIT_FAILED) {
2001 if (waitcode >= WAIT_ABANDONED_0
2002 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2003 i = waitcode - WAIT_ABANDONED_0;
2005 i = waitcode - WAIT_OBJECT_0;
2006 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2007 *status = (int)((exitcode & 0xff) << 8);
2008 retval = (int)w32_child_pids[i];
2009 remove_dead_process(i);
2014 errno = GetLastError();
2019 win32_waitpid(int pid, int *status, int flags)
2022 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2025 if (pid == -1) /* XXX threadid == 1 ? */
2026 return win32_internal_wait(status, timeout);
2029 child = find_pseudo_pid(-pid);
2031 HANDLE hThread = w32_pseudo_child_handles[child];
2033 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2034 if (waitcode == WAIT_TIMEOUT) {
2037 else if (waitcode == WAIT_OBJECT_0) {
2038 if (GetExitCodeThread(hThread, &waitcode)) {
2039 *status = (int)((waitcode & 0xff) << 8);
2040 retval = (int)w32_pseudo_child_pids[child];
2041 remove_dead_pseudo_process(child);
2048 else if (IsWin95()) {
2057 child = find_pid(pid);
2059 hProcess = w32_child_handles[child];
2060 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2061 if (waitcode == WAIT_TIMEOUT) {
2064 else if (waitcode == WAIT_OBJECT_0) {
2065 if (GetExitCodeProcess(hProcess, &waitcode)) {
2066 *status = (int)((waitcode & 0xff) << 8);
2067 retval = (int)w32_child_pids[child];
2068 remove_dead_process(child);
2077 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2078 (IsWin95() ? -pid : pid));
2080 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2081 if (waitcode == WAIT_TIMEOUT) {
2084 else if (waitcode == WAIT_OBJECT_0) {
2085 if (GetExitCodeProcess(hProcess, &waitcode)) {
2086 *status = (int)((waitcode & 0xff) << 8);
2087 CloseHandle(hProcess);
2091 CloseHandle(hProcess);
2097 return retval >= 0 ? pid : retval;
2101 win32_wait(int *status)
2103 return win32_internal_wait(status, INFINITE);
2106 DllExport unsigned int
2107 win32_sleep(unsigned int t)
2110 /* Win32 times are in ms so *1000 in and /1000 out */
2111 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2114 DllExport unsigned int
2115 win32_alarm(unsigned int sec)
2118 * the 'obvious' implentation is SetTimer() with a callback
2119 * which does whatever receiving SIGALRM would do
2120 * we cannot use SIGALRM even via raise() as it is not
2121 * one of the supported codes in <signal.h>
2125 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2129 KillTimer(NULL,w32_timerid);
2136 #ifdef HAVE_DES_FCRYPT
2137 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2141 win32_crypt(const char *txt, const char *salt)
2144 #ifdef HAVE_DES_FCRYPT
2145 return des_fcrypt(txt, salt, w32_crypt_buffer);
2147 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2152 #ifdef USE_FIXED_OSFHANDLE
2154 #define FOPEN 0x01 /* file handle open */
2155 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2156 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2157 #define FDEV 0x40 /* file handle refers to device */
2158 #define FTEXT 0x80 /* file handle is in text mode */
2161 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2164 * This function allocates a free C Runtime file handle and associates
2165 * it with the Win32 HANDLE specified by the first parameter. This is a
2166 * temperary fix for WIN95's brain damage GetFileType() error on socket
2167 * we just bypass that call for socket
2169 * This works with MSVC++ 4.0+ or GCC/Mingw32
2172 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2173 * int flags - flags to associate with C Runtime file handle.
2176 * returns index of entry in fh, if successful
2177 * return -1, if no free entry is found
2181 *******************************************************************************/
2184 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2185 * this lets sockets work on Win9X with GCC and should fix the problems
2190 /* create an ioinfo entry, kill its handle, and steal the entry */
2195 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2196 int fh = _open_osfhandle((intptr_t)hF, 0);
2200 EnterCriticalSection(&(_pioinfo(fh)->lock));
2205 my_open_osfhandle(intptr_t osfhandle, int flags)
2208 char fileflags; /* _osfile flags */
2210 /* copy relevant flags from second parameter */
2213 if (flags & O_APPEND)
2214 fileflags |= FAPPEND;
2219 if (flags & O_NOINHERIT)
2220 fileflags |= FNOINHERIT;
2222 /* attempt to allocate a C Runtime file handle */
2223 if ((fh = _alloc_osfhnd()) == -1) {
2224 errno = EMFILE; /* too many open files */
2225 _doserrno = 0L; /* not an OS error */
2226 return -1; /* return error to caller */
2229 /* the file is open. now, set the info in _osfhnd array */
2230 _set_osfhnd(fh, osfhandle);
2232 fileflags |= FOPEN; /* mark as open */
2234 _osfile(fh) = fileflags; /* set osfile entry */
2235 LeaveCriticalSection(&_pioinfo(fh)->lock);
2237 return fh; /* return handle */
2240 #endif /* USE_FIXED_OSFHANDLE */
2242 /* simulate flock by locking a range on the file */
2244 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2245 #define LK_LEN 0xffff0000
2248 win32_flock(int fd, int oper)
2256 Perl_croak_nocontext("flock() unimplemented on this platform");
2259 fh = (HANDLE)_get_osfhandle(fd);
2260 memset(&o, 0, sizeof(o));
2263 case LOCK_SH: /* shared lock */
2264 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2266 case LOCK_EX: /* exclusive lock */
2267 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2269 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2270 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2272 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2273 LK_ERR(LockFileEx(fh,
2274 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2275 0, LK_LEN, 0, &o),i);
2277 case LOCK_UN: /* unlock lock */
2278 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2280 default: /* unknown */
2291 * redirected io subsystem for all XS modules
2304 return (&(_environ));
2307 /* the rest are the remapped stdio routines */
2327 win32_ferror(FILE *fp)
2329 return (ferror(fp));
2334 win32_feof(FILE *fp)
2340 * Since the errors returned by the socket error function
2341 * WSAGetLastError() are not known by the library routine strerror
2342 * we have to roll our own.
2346 win32_strerror(int e)
2348 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2349 extern int sys_nerr;
2353 if (e < 0 || e > sys_nerr) {
2358 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2359 w32_strerror_buffer,
2360 sizeof(w32_strerror_buffer), NULL) == 0)
2361 strcpy(w32_strerror_buffer, "Unknown Error");
2363 return w32_strerror_buffer;
2369 win32_str_os_error(void *sv, DWORD dwErr)
2373 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2374 |FORMAT_MESSAGE_IGNORE_INSERTS
2375 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2376 dwErr, 0, (char *)&sMsg, 1, NULL);
2377 /* strip trailing whitespace and period */
2380 --dwLen; /* dwLen doesn't include trailing null */
2381 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2382 if ('.' != sMsg[dwLen])
2387 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2389 dwLen = sprintf(sMsg,
2390 "Unknown error #0x%lX (lookup 0x%lX)",
2391 dwErr, GetLastError());
2395 sv_setpvn((SV*)sv, sMsg, dwLen);
2401 win32_fprintf(FILE *fp, const char *format, ...)
2404 va_start(marker, format); /* Initialize variable arguments. */
2406 return (vfprintf(fp, format, marker));
2410 win32_printf(const char *format, ...)
2413 va_start(marker, format); /* Initialize variable arguments. */
2415 return (vprintf(format, marker));
2419 win32_vfprintf(FILE *fp, const char *format, va_list args)
2421 return (vfprintf(fp, format, args));
2425 win32_vprintf(const char *format, va_list args)
2427 return (vprintf(format, args));
2431 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2433 return fread(buf, size, count, fp);
2437 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2439 return fwrite(buf, size, count, fp);
2442 #define MODE_SIZE 10
2445 win32_fopen(const char *filename, const char *mode)
2448 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2454 if (stricmp(filename, "/dev/null")==0)
2458 A2WHELPER(mode, wMode, sizeof(wMode));
2459 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2460 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2463 f = fopen(PerlDir_mapA(filename), mode);
2464 /* avoid buffering headaches for child processes */
2465 if (f && *mode == 'a')
2466 win32_fseek(f, 0, SEEK_END);
2470 #ifndef USE_SOCKETS_AS_HANDLES
2472 #define fdopen my_fdopen
2476 win32_fdopen(int handle, const char *mode)
2479 WCHAR wMode[MODE_SIZE];
2482 A2WHELPER(mode, wMode, sizeof(wMode));
2483 f = _wfdopen(handle, wMode);
2486 f = fdopen(handle, (char *) mode);
2487 /* avoid buffering headaches for child processes */
2488 if (f && *mode == 'a')
2489 win32_fseek(f, 0, SEEK_END);
2494 win32_freopen(const char *path, const char *mode, FILE *stream)
2497 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2498 if (stricmp(path, "/dev/null")==0)
2502 A2WHELPER(mode, wMode, sizeof(wMode));
2503 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2504 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2506 return freopen(PerlDir_mapA(path), mode, stream);
2510 win32_fclose(FILE *pf)
2512 return my_fclose(pf); /* defined in win32sck.c */
2516 win32_fputs(const char *s,FILE *pf)
2518 return fputs(s, pf);
2522 win32_fputc(int c,FILE *pf)
2528 win32_ungetc(int c,FILE *pf)
2530 return ungetc(c,pf);
2534 win32_getc(FILE *pf)
2540 win32_fileno(FILE *pf)
2546 win32_clearerr(FILE *pf)
2553 win32_fflush(FILE *pf)
2559 win32_ftell(FILE *pf)
2561 #if defined(WIN64) || defined(USE_LARGE_FILES)
2563 if (fgetpos(pf, &pos))
2572 win32_fseek(FILE *pf, Off_t offset,int origin)
2574 #if defined(WIN64) || defined(USE_LARGE_FILES)
2578 if (fgetpos(pf, &pos))
2583 fseek(pf, 0, SEEK_END);
2584 pos = _telli64(fileno(pf));
2593 return fsetpos(pf, &offset);
2595 return fseek(pf, offset, origin);
2600 win32_fgetpos(FILE *pf,fpos_t *p)
2602 return fgetpos(pf, p);
2606 win32_fsetpos(FILE *pf,const fpos_t *p)
2608 return fsetpos(pf, p);
2612 win32_rewind(FILE *pf)
2622 char prefix[MAX_PATH+1];
2623 char filename[MAX_PATH+1];
2624 DWORD len = GetTempPath(MAX_PATH, prefix);
2625 if (len && len < MAX_PATH) {
2626 if (GetTempFileName(prefix, "plx", 0, filename)) {
2627 HANDLE fh = CreateFile(filename,
2628 DELETE | GENERIC_READ | GENERIC_WRITE,
2632 FILE_ATTRIBUTE_NORMAL
2633 | FILE_FLAG_DELETE_ON_CLOSE,
2635 if (fh != INVALID_HANDLE_VALUE) {
2636 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2638 #if defined(__BORLANDC__)
2639 setmode(fd,O_BINARY);
2641 DEBUG_p(PerlIO_printf(Perl_debug_log,
2642 "Created tmpfile=%s\n",filename));
2643 return fdopen(fd, "w+b");
2659 win32_fstat(int fd, Stat_t *sbufptr)
2662 /* A file designated by filehandle is not shown as accessible
2663 * for write operations, probably because it is opened for reading.
2666 int rc = fstat(fd,sbufptr);
2667 BY_HANDLE_FILE_INFORMATION bhfi;
2668 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2669 sbufptr->st_mode &= 0xFE00;
2670 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2671 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2673 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2674 + ((S_IREAD|S_IWRITE) >> 6));
2678 return my_fstat(fd,sbufptr);
2683 win32_pipe(int *pfd, unsigned int size, int mode)
2685 return _pipe(pfd, size, mode);
2689 win32_popenlist(const char *mode, IV narg, SV **args)
2692 Perl_croak(aTHX_ "List form of pipe open not implemented");
2697 * a popen() clone that respects PERL5SHELL
2699 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2703 win32_popen(const char *command, const char *mode)
2705 #ifdef USE_RTL_POPEN
2706 return _popen(command, mode);
2718 /* establish which ends read and write */
2719 if (strchr(mode,'w')) {
2720 stdfd = 0; /* stdin */
2723 nhandle = STD_INPUT_HANDLE;
2725 else if (strchr(mode,'r')) {
2726 stdfd = 1; /* stdout */
2729 nhandle = STD_OUTPUT_HANDLE;
2734 /* set the correct mode */
2735 if (strchr(mode,'b'))
2737 else if (strchr(mode,'t'))
2740 ourmode = _fmode & (O_TEXT | O_BINARY);
2742 /* the child doesn't inherit handles */
2743 ourmode |= O_NOINHERIT;
2745 if (win32_pipe(p, 512, ourmode) == -1)
2748 /* save current stdfd */
2749 if ((oldfd = win32_dup(stdfd)) == -1)
2752 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2753 /* stdfd will be inherited by the child */
2754 if (win32_dup2(p[child], stdfd) == -1)
2757 /* close the child end in parent */
2758 win32_close(p[child]);
2760 /* save the old std handle, and set the std handle */
2763 old_h = GetStdHandle(nhandle);
2764 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2766 /* start the child */
2769 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2772 /* restore the old std handle */
2774 SetStdHandle(nhandle, old_h);
2779 /* revert stdfd to whatever it was before */
2780 if (win32_dup2(oldfd, stdfd) == -1)
2783 /* close saved handle */
2787 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2790 /* set process id so that it can be returned by perl's open() */
2791 PL_forkprocess = childpid;
2794 /* we have an fd, return a file stream */
2795 return (PerlIO_fdopen(p[parent], (char *)mode));
2798 /* we don't need to check for errors here */
2802 SetStdHandle(nhandle, old_h);
2807 win32_dup2(oldfd, stdfd);
2812 #endif /* USE_RTL_POPEN */
2820 win32_pclose(PerlIO *pf)
2822 #ifdef USE_RTL_POPEN
2826 int childpid, status;
2830 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2833 childpid = SvIVX(sv);
2850 if (win32_waitpid(childpid, &status, 0) == -1)
2855 #endif /* USE_RTL_POPEN */
2861 LPCWSTR lpExistingFileName,
2862 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2865 WCHAR wFullName[MAX_PATH+1];
2866 LPVOID lpContext = NULL;
2867 WIN32_STREAM_ID StreamId;
2868 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2873 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2874 BOOL, BOOL, LPVOID*) =
2875 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2876 BOOL, BOOL, LPVOID*))
2877 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2878 if (pfnBackupWrite == NULL)
2881 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2884 dwLen = (dwLen+1)*sizeof(WCHAR);
2886 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2887 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2888 NULL, OPEN_EXISTING, 0, NULL);
2889 if (handle == INVALID_HANDLE_VALUE)
2892 StreamId.dwStreamId = BACKUP_LINK;
2893 StreamId.dwStreamAttributes = 0;
2894 StreamId.dwStreamNameSize = 0;
2895 #if defined(__BORLANDC__) \
2896 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2897 StreamId.Size.u.HighPart = 0;
2898 StreamId.Size.u.LowPart = dwLen;
2900 StreamId.Size.HighPart = 0;
2901 StreamId.Size.LowPart = dwLen;
2904 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2905 FALSE, FALSE, &lpContext);
2907 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2908 FALSE, FALSE, &lpContext);
2909 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2912 CloseHandle(handle);
2917 win32_link(const char *oldname, const char *newname)
2920 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2921 WCHAR wOldName[MAX_PATH+1];
2922 WCHAR wNewName[MAX_PATH+1];
2925 Perl_croak(aTHX_ PL_no_func, "link");
2927 pfnCreateHardLinkW =
2928 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2929 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2930 if (pfnCreateHardLinkW == NULL)
2931 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2933 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2934 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2935 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2936 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2940 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2945 win32_rename(const char *oname, const char *newname)
2947 WCHAR wOldName[MAX_PATH+1];
2948 WCHAR wNewName[MAX_PATH+1];
2949 char szOldName[MAX_PATH+1];
2950 char szNewName[MAX_PATH+1];
2954 /* XXX despite what the documentation says about MoveFileEx(),
2955 * it doesn't work under Windows95!
2958 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2960 A2WHELPER(oname, wOldName, sizeof(wOldName));
2961 A2WHELPER(newname, wNewName, sizeof(wNewName));
2962 if (wcsicmp(wNewName, wOldName))
2963 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2964 wcscpy(wOldName, PerlDir_mapW(wOldName));
2965 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2968 if (stricmp(newname, oname))
2969 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2970 strcpy(szOldName, PerlDir_mapA(oname));
2971 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2974 DWORD err = GetLastError();
2976 case ERROR_BAD_NET_NAME:
2977 case ERROR_BAD_NETPATH:
2978 case ERROR_BAD_PATHNAME:
2979 case ERROR_FILE_NOT_FOUND:
2980 case ERROR_FILENAME_EXCED_RANGE:
2981 case ERROR_INVALID_DRIVE:
2982 case ERROR_NO_MORE_FILES:
2983 case ERROR_PATH_NOT_FOUND:
2996 char szTmpName[MAX_PATH+1];
2997 char dname[MAX_PATH+1];
2998 char *endname = Nullch;
3000 DWORD from_attr, to_attr;
3002 strcpy(szOldName, PerlDir_mapA(oname));
3003 strcpy(szNewName, PerlDir_mapA(newname));
3005 /* if oname doesn't exist, do nothing */
3006 from_attr = GetFileAttributes(szOldName);
3007 if (from_attr == 0xFFFFFFFF) {
3012 /* if newname exists, rename it to a temporary name so that we
3013 * don't delete it in case oname happens to be the same file
3014 * (but perhaps accessed via a different path)
3016 to_attr = GetFileAttributes(szNewName);
3017 if (to_attr != 0xFFFFFFFF) {
3018 /* if newname is a directory, we fail
3019 * XXX could overcome this with yet more convoluted logic */
3020 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3024 tmplen = strlen(szNewName);
3025 strcpy(szTmpName,szNewName);
3026 endname = szTmpName+tmplen;
3027 for (; endname > szTmpName ; --endname) {
3028 if (*endname == '/' || *endname == '\\') {
3033 if (endname > szTmpName)
3034 endname = strcpy(dname,szTmpName);
3038 /* get a temporary filename in same directory
3039 * XXX is this really the best we can do? */
3040 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3044 DeleteFile(szTmpName);
3046 retval = rename(szNewName, szTmpName);
3053 /* rename oname to newname */
3054 retval = rename(szOldName, szNewName);
3056 /* if we created a temporary file before ... */
3057 if (endname != Nullch) {
3058 /* ...and rename succeeded, delete temporary file/directory */
3060 DeleteFile(szTmpName);
3061 /* else restore it to what it was */
3063 (void)rename(szTmpName, szNewName);
3070 win32_setmode(int fd, int mode)
3072 return setmode(fd, mode);
3076 win32_lseek(int fd, Off_t offset, int origin)
3078 #if defined(WIN64) || defined(USE_LARGE_FILES)
3079 return _lseeki64(fd, offset, origin);
3081 return lseek(fd, offset, origin);
3088 #if defined(WIN64) || defined(USE_LARGE_FILES)
3089 return _telli64(fd);
3096 win32_open(const char *path, int flag, ...)
3101 WCHAR wBuffer[MAX_PATH+1];
3104 pmode = va_arg(ap, int);
3107 if (stricmp(path, "/dev/null")==0)
3111 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3112 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3114 return open(PerlDir_mapA(path), flag, pmode);
3117 /* close() that understands socket */
3118 extern int my_close(int); /* in win32sck.c */
3123 return my_close(fd);
3139 win32_dup2(int fd1,int fd2)
3141 return dup2(fd1,fd2);
3144 #ifdef PERL_MSVCRT_READFIX
3146 #define LF 10 /* line feed */
3147 #define CR 13 /* carriage return */
3148 #define CTRLZ 26 /* ctrl-z means eof for text */
3149 #define FOPEN 0x01 /* file handle open */
3150 #define FEOFLAG 0x02 /* end of file has been encountered */
3151 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3152 #define FPIPE 0x08 /* file handle refers to a pipe */
3153 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3154 #define FDEV 0x40 /* file handle refers to device */
3155 #define FTEXT 0x80 /* file handle is in text mode */
3156 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3159 _fixed_read(int fh, void *buf, unsigned cnt)
3161 int bytes_read; /* number of bytes read */
3162 char *buffer; /* buffer to read to */
3163 int os_read; /* bytes read on OS call */
3164 char *p, *q; /* pointers into buffer */
3165 char peekchr; /* peek-ahead character */
3166 ULONG filepos; /* file position after seek */
3167 ULONG dosretval; /* o.s. return value */
3169 /* validate handle */
3170 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3171 !(_osfile(fh) & FOPEN))
3173 /* out of range -- return error */
3175 _doserrno = 0; /* not o.s. error */
3180 * If lockinitflag is FALSE, assume fd is device
3181 * lockinitflag is set to TRUE by open.
3183 if (_pioinfo(fh)->lockinitflag)
3184 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3186 bytes_read = 0; /* nothing read yet */
3187 buffer = (char*)buf;
3189 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3190 /* nothing to read or at EOF, so return 0 read */
3194 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3195 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3197 *buffer++ = _pipech(fh);
3200 _pipech(fh) = LF; /* mark as empty */
3205 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3207 /* ReadFile has reported an error. recognize two special cases.
3209 * 1. map ERROR_ACCESS_DENIED to EBADF
3211 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3212 * means the handle is a read-handle on a pipe for which
3213 * all write-handles have been closed and all data has been
3216 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3217 /* wrong read/write mode should return EBADF, not EACCES */
3219 _doserrno = dosretval;
3223 else if (dosretval == ERROR_BROKEN_PIPE) {
3233 bytes_read += os_read; /* update bytes read */
3235 if (_osfile(fh) & FTEXT) {
3236 /* now must translate CR-LFs to LFs in the buffer */
3238 /* set CRLF flag to indicate LF at beginning of buffer */
3239 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3240 /* _osfile(fh) |= FCRLF; */
3242 /* _osfile(fh) &= ~FCRLF; */
3244 _osfile(fh) &= ~FCRLF;
3246 /* convert chars in the buffer: p is src, q is dest */
3248 while (p < (char *)buf + bytes_read) {
3250 /* if fh is not a device, set ctrl-z flag */
3251 if (!(_osfile(fh) & FDEV))
3252 _osfile(fh) |= FEOFLAG;
3253 break; /* stop translating */
3258 /* *p is CR, so must check next char for LF */
3259 if (p < (char *)buf + bytes_read - 1) {
3262 *q++ = LF; /* convert CR-LF to LF */
3265 *q++ = *p++; /* store char normally */
3268 /* This is the hard part. We found a CR at end of
3269 buffer. We must peek ahead to see if next char
3274 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3275 (LPDWORD)&os_read, NULL))
3276 dosretval = GetLastError();
3278 if (dosretval != 0 || os_read == 0) {
3279 /* couldn't read ahead, store CR */
3283 /* peekchr now has the extra character -- we now
3284 have several possibilities:
3285 1. disk file and char is not LF; just seek back
3287 2. disk file and char is LF; store LF, don't seek back
3288 3. pipe/device and char is LF; store LF.
3289 4. pipe/device and char isn't LF, store CR and
3290 put char in pipe lookahead buffer. */
3291 if (_osfile(fh) & (FDEV|FPIPE)) {
3292 /* non-seekable device */
3297 _pipech(fh) = peekchr;
3302 if (peekchr == LF) {
3303 /* nothing read yet; must make some
3306 /* turn on this flag for tell routine */
3307 _osfile(fh) |= FCRLF;
3310 HANDLE osHandle; /* o.s. handle value */
3312 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3314 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3315 dosretval = GetLastError();
3326 /* we now change bytes_read to reflect the true number of chars
3328 bytes_read = q - (char *)buf;
3332 if (_pioinfo(fh)->lockinitflag)
3333 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3338 #endif /* PERL_MSVCRT_READFIX */
3341 win32_read(int fd, void *buf, unsigned int cnt)
3343 #ifdef PERL_MSVCRT_READFIX
3344 return _fixed_read(fd, buf, cnt);
3346 return read(fd, buf, cnt);
3351 win32_write(int fd, const void *buf, unsigned int cnt)
3353 return write(fd, buf, cnt);
3357 win32_mkdir(const char *dir, int mode)
3361 WCHAR wBuffer[MAX_PATH+1];
3362 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3363 return _wmkdir(PerlDir_mapW(wBuffer));
3365 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3369 win32_rmdir(const char *dir)
3373 WCHAR wBuffer[MAX_PATH+1];
3374 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3375 return _wrmdir(PerlDir_mapW(wBuffer));
3377 return rmdir(PerlDir_mapA(dir));
3381 win32_chdir(const char *dir)
3389 WCHAR wBuffer[MAX_PATH+1];
3390 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3391 return _wchdir(wBuffer);
3397 win32_access(const char *path, int mode)
3401 WCHAR wBuffer[MAX_PATH+1];
3402 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3403 return _waccess(PerlDir_mapW(wBuffer), mode);
3405 return access(PerlDir_mapA(path), mode);
3409 win32_chmod(const char *path, int mode)
3413 WCHAR wBuffer[MAX_PATH+1];
3414 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3415 return _wchmod(PerlDir_mapW(wBuffer), mode);
3417 return chmod(PerlDir_mapA(path), mode);
3422 create_command_line(char *cname, STRLEN clen, const char * const *args)
3429 bool bat_file = FALSE;
3430 bool cmd_shell = FALSE;
3431 bool dumb_shell = FALSE;
3432 bool extra_quotes = FALSE;
3433 bool quote_next = FALSE;
3436 cname = (char*)args[0];
3438 /* The NT cmd.exe shell has the following peculiarity that needs to be
3439 * worked around. It strips a leading and trailing dquote when any
3440 * of the following is true:
3441 * 1. the /S switch was used
3442 * 2. there are more than two dquotes
3443 * 3. there is a special character from this set: &<>()@^|
3444 * 4. no whitespace characters within the two dquotes
3445 * 5. string between two dquotes isn't an executable file
3446 * To work around this, we always add a leading and trailing dquote
3447 * to the string, if the first argument is either "cmd.exe" or "cmd",
3448 * and there were at least two or more arguments passed to cmd.exe
3449 * (not including switches).
3450 * XXX the above rules (from "cmd /?") don't seem to be applied
3451 * always, making for the convolutions below :-(
3455 clen = strlen(cname);
3458 && (stricmp(&cname[clen-4], ".bat") == 0
3459 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3465 char *exe = strrchr(cname, '/');
3466 char *exe2 = strrchr(cname, '\\');
3473 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3477 else if (stricmp(exe, "command.com") == 0
3478 || stricmp(exe, "command") == 0)
3485 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3486 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3487 STRLEN curlen = strlen(arg);
3488 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3489 len += 2; /* assume quoting needed (worst case) */
3491 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3493 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3496 New(1310, cmd, len, char);
3501 extra_quotes = TRUE;
3504 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3506 STRLEN curlen = strlen(arg);
3508 /* we want to protect empty arguments and ones with spaces with
3509 * dquotes, but only if they aren't already there */
3514 else if (quote_next) {
3515 /* see if it really is multiple arguments pretending to
3516 * be one and force a set of quotes around it */
3517 if (*find_next_space(arg))
3520 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3522 while (i < curlen) {
3523 if (isSPACE(arg[i])) {
3526 else if (arg[i] == '"') {
3549 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3551 /* is there a next argument? */
3552 if (args[index+1]) {
3553 /* are there two or more next arguments? */
3554 if (args[index+2]) {
3556 extra_quotes = TRUE;
3559 /* single argument, force quoting if it has spaces */
3575 qualified_path(const char *cmd)
3579 char *fullcmd, *curfullcmd;
3585 fullcmd = (char*)cmd;
3587 if (*fullcmd == '/' || *fullcmd == '\\')
3594 pathstr = PerlEnv_getenv("PATH");
3595 New(0, fullcmd, MAX_PATH+1, char);
3596 curfullcmd = fullcmd;
3601 /* start by appending the name to the current prefix */
3602 strcpy(curfullcmd, cmd);
3603 curfullcmd += cmdlen;
3605 /* if it doesn't end with '.', or has no extension, try adding
3606 * a trailing .exe first */
3607 if (cmd[cmdlen-1] != '.'
3608 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3610 strcpy(curfullcmd, ".exe");
3611 res = GetFileAttributes(fullcmd);
3612 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3617 /* that failed, try the bare name */
3618 res = GetFileAttributes(fullcmd);
3619 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3622 /* quit if no other path exists, or if cmd already has path */
3623 if (!pathstr || !*pathstr || has_slash)
3626 /* skip leading semis */
3627 while (*pathstr == ';')
3630 /* build a new prefix from scratch */
3631 curfullcmd = fullcmd;
3632 while (*pathstr && *pathstr != ';') {
3633 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3634 pathstr++; /* skip initial '"' */
3635 while (*pathstr && *pathstr != '"') {
3636 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3637 *curfullcmd++ = *pathstr;
3641 pathstr++; /* skip trailing '"' */
3644 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3645 *curfullcmd++ = *pathstr;
3650 pathstr++; /* skip trailing semi */
3651 if (curfullcmd > fullcmd /* append a dir separator */
3652 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3654 *curfullcmd++ = '\\';
3662 /* The following are just place holders.
3663 * Some hosts may provide and environment that the OS is
3664 * not tracking, therefore, these host must provide that
3665 * environment and the current directory to CreateProcess
3669 win32_get_childenv(void)
3675 win32_free_childenv(void* d)
3680 win32_clearenv(void)
3682 char *envv = GetEnvironmentStrings();
3686 char *end = strchr(cur,'=');
3687 if (end && end != cur) {
3689 SetEnvironmentVariable(cur, NULL);
3691 cur = end + strlen(end+1)+2;
3693 else if ((len = strlen(cur)))
3696 FreeEnvironmentStrings(envv);
3700 win32_get_childdir(void)
3704 char szfilename[(MAX_PATH+1)*2];
3706 WCHAR wfilename[MAX_PATH+1];
3707 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3708 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3711 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3714 New(0, ptr, strlen(szfilename)+1, char);
3715 strcpy(ptr, szfilename);
3720 win32_free_childdir(char* d)
3727 /* XXX this needs to be made more compatible with the spawnvp()
3728 * provided by the various RTLs. In particular, searching for
3729 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3730 * This doesn't significantly affect perl itself, because we
3731 * always invoke things using PERL5SHELL if a direct attempt to
3732 * spawn the executable fails.
3734 * XXX splitting and rejoining the commandline between do_aspawn()
3735 * and win32_spawnvp() could also be avoided.
3739 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3741 #ifdef USE_RTL_SPAWNVP
3742 return spawnvp(mode, cmdname, (char * const *)argv);
3749 STARTUPINFO StartupInfo;
3750 PROCESS_INFORMATION ProcessInformation;
3753 char *fullcmd = Nullch;
3754 char *cname = (char *)cmdname;
3758 clen = strlen(cname);
3759 /* if command name contains dquotes, must remove them */
3760 if (strchr(cname, '"')) {
3762 New(0,cname,clen+1,char);
3775 cmd = create_command_line(cname, clen, argv);
3777 env = PerlEnv_get_childenv();
3778 dir = PerlEnv_get_childdir();
3781 case P_NOWAIT: /* asynch + remember result */
3782 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3787 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3790 create |= CREATE_NEW_PROCESS_GROUP;
3793 case P_WAIT: /* synchronous execution */
3795 default: /* invalid mode */
3800 memset(&StartupInfo,0,sizeof(StartupInfo));
3801 StartupInfo.cb = sizeof(StartupInfo);
3802 memset(&tbl,0,sizeof(tbl));
3803 PerlEnv_get_child_IO(&tbl);
3804 StartupInfo.dwFlags = tbl.dwFlags;
3805 StartupInfo.dwX = tbl.dwX;
3806 StartupInfo.dwY = tbl.dwY;
3807 StartupInfo.dwXSize = tbl.dwXSize;
3808 StartupInfo.dwYSize = tbl.dwYSize;
3809 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3810 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3811 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3812 StartupInfo.wShowWindow = tbl.wShowWindow;
3813 StartupInfo.hStdInput = tbl.childStdIn;
3814 StartupInfo.hStdOutput = tbl.childStdOut;
3815 StartupInfo.hStdError = tbl.childStdErr;
3816 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3817 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3818 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3820 create |= CREATE_NEW_CONSOLE;
3823 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3825 if (w32_use_showwindow) {
3826 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3827 StartupInfo.wShowWindow = w32_showwindow;
3830 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3833 if (!CreateProcess(cname, /* search PATH to find executable */
3834 cmd, /* executable, and its arguments */
3835 NULL, /* process attributes */
3836 NULL, /* thread attributes */
3837 TRUE, /* inherit handles */
3838 create, /* creation flags */
3839 (LPVOID)env, /* inherit environment */
3840 dir, /* inherit cwd */
3842 &ProcessInformation))
3844 /* initial NULL argument to CreateProcess() does a PATH
3845 * search, but it always first looks in the directory
3846 * where the current process was started, which behavior
3847 * is undesirable for backward compatibility. So we
3848 * jump through our own hoops by picking out the path
3849 * we really want it to use. */
3851 fullcmd = qualified_path(cname);
3853 if (cname != cmdname)
3856 DEBUG_p(PerlIO_printf(Perl_debug_log,
3857 "Retrying [%s] with same args\n",
3867 if (mode == P_NOWAIT) {
3868 /* asynchronous spawn -- store handle, return PID */
3869 ret = (int)ProcessInformation.dwProcessId;
3870 if (IsWin95() && ret < 0)
3873 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3874 w32_child_pids[w32_num_children] = (DWORD)ret;
3879 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3880 /* FIXME: if msgwait returned due to message perhaps forward the
3881 "signal" to the process
3883 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3885 CloseHandle(ProcessInformation.hProcess);
3888 CloseHandle(ProcessInformation.hThread);
3891 PerlEnv_free_childenv(env);
3892 PerlEnv_free_childdir(dir);
3894 if (cname != cmdname)
3901 win32_execv(const char *cmdname, const char *const *argv)
3905 /* if this is a pseudo-forked child, we just want to spawn
3906 * the new program, and return */
3908 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3910 return execv(cmdname, (char *const *)argv);
3914 win32_execvp(const char *cmdname, const char *const *argv)
3918 /* if this is a pseudo-forked child, we just want to spawn
3919 * the new program, and return */
3920 if (w32_pseudo_id) {
3921 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3930 return execvp(cmdname, (char *const *)argv);
3934 win32_perror(const char *str)
3940 win32_setbuf(FILE *pf, char *buf)
3946 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3948 return setvbuf(pf, buf, type, size);
3952 win32_flushall(void)
3958 win32_fcloseall(void)
3964 win32_fgets(char *s, int n, FILE *pf)
3966 return fgets(s, n, pf);
3976 win32_fgetc(FILE *pf)
3982 win32_putc(int c, FILE *pf)
3988 win32_puts(const char *s)
4000 win32_putchar(int c)
4007 #ifndef USE_PERL_SBRK
4009 static char *committed = NULL; /* XXX threadead */
4010 static char *base = NULL; /* XXX threadead */
4011 static char *reserved = NULL; /* XXX threadead */
4012 static char *brk = NULL; /* XXX threadead */
4013 static DWORD pagesize = 0; /* XXX threadead */
4014 static DWORD allocsize = 0; /* XXX threadead */
4017 sbrk(ptrdiff_t need)
4022 GetSystemInfo(&info);
4023 /* Pretend page size is larger so we don't perpetually
4024 * call the OS to commit just one page ...
4026 pagesize = info.dwPageSize << 3;
4027 allocsize = info.dwAllocationGranularity;
4029 /* This scheme fails eventually if request for contiguous
4030 * block is denied so reserve big blocks - this is only
4031 * address space not memory ...
4033 if (brk+need >= reserved)
4035 DWORD size = 64*1024*1024;
4037 if (committed && reserved && committed < reserved)
4039 /* Commit last of previous chunk cannot span allocations */
4040 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4042 committed = reserved;
4044 /* Reserve some (more) space
4045 * Note this is a little sneaky, 1st call passes NULL as reserved
4046 * so lets system choose where we start, subsequent calls pass
4047 * the old end address so ask for a contiguous block
4049 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4052 reserved = addr+size;
4067 if (brk > committed)
4069 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4070 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4085 win32_malloc(size_t size)
4087 return malloc(size);
4091 win32_calloc(size_t numitems, size_t size)
4093 return calloc(numitems,size);
4097 win32_realloc(void *block, size_t size)
4099 return realloc(block,size);
4103 win32_free(void *block)
4110 win32_open_osfhandle(intptr_t handle, int flags)
4112 #ifdef USE_FIXED_OSFHANDLE
4114 return my_open_osfhandle(handle, flags);
4116 return _open_osfhandle(handle, flags);
4120 win32_get_osfhandle(int fd)
4122 return (intptr_t)_get_osfhandle(fd);
4126 win32_fdupopen(FILE *pf)
4131 int fileno = win32_dup(win32_fileno(pf));
4133 /* open the file in the same mode */
4135 if((pf)->flags & _F_READ) {
4139 else if((pf)->flags & _F_WRIT) {
4143 else if((pf)->flags & _F_RDWR) {
4149 if((pf)->_flag & _IOREAD) {
4153 else if((pf)->_flag & _IOWRT) {
4157 else if((pf)->_flag & _IORW) {
4164 /* it appears that the binmode is attached to the
4165 * file descriptor so binmode files will be handled
4168 pfdup = win32_fdopen(fileno, mode);
4170 /* move the file pointer to the same position */
4171 if (!fgetpos(pf, &pos)) {
4172 fsetpos(pfdup, &pos);
4178 win32_dynaload(const char* filename)
4182 char buf[MAX_PATH+1];
4185 /* LoadLibrary() doesn't recognize forward slashes correctly,
4186 * so turn 'em back. */
4187 first = strchr(filename, '/');
4189 STRLEN len = strlen(filename);
4190 if (len <= MAX_PATH) {
4191 strcpy(buf, filename);
4192 filename = &buf[first - filename];
4194 if (*filename == '/')
4195 *(char*)filename = '\\';
4202 WCHAR wfilename[MAX_PATH+1];
4203 A2WHELPER(filename, wfilename, sizeof(wfilename));
4204 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4207 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4217 XS(w32_SetChildShowWindow)
4220 BOOL use_showwindow = w32_use_showwindow;
4221 /* use "unsigned short" because Perl has redefined "WORD" */
4222 unsigned short showwindow = w32_showwindow;
4225 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4227 if (items == 0 || !SvOK(ST(0)))
4228 w32_use_showwindow = FALSE;
4230 w32_use_showwindow = TRUE;
4231 w32_showwindow = (unsigned short)SvIV(ST(0));
4236 ST(0) = sv_2mortal(newSViv(showwindow));
4238 ST(0) = &PL_sv_undef;
4246 /* Make the host for current directory */
4247 char* ptr = PerlEnv_get_childdir();
4250 * then it worked, set PV valid,
4251 * else return 'undef'
4254 SV *sv = sv_newmortal();
4256 PerlEnv_free_childdir(ptr);
4258 #ifndef INCOMPLETE_TAINTS
4275 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4276 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4283 XS(w32_GetNextAvailDrive)
4287 char root[] = "_:\\";
4292 if (GetDriveType(root) == 1) {
4301 XS(w32_GetLastError)
4305 XSRETURN_IV(GetLastError());
4309 XS(w32_SetLastError)
4313 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4314 SetLastError(SvIV(ST(0)));
4322 char *name = w32_getlogin_buffer;
4323 DWORD size = sizeof(w32_getlogin_buffer);
4325 if (GetUserName(name,&size)) {
4326 /* size includes NULL */
4327 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4337 char name[MAX_COMPUTERNAME_LENGTH+1];
4338 DWORD size = sizeof(name);
4340 if (GetComputerName(name,&size)) {
4341 /* size does NOT include NULL :-( */
4342 ST(0) = sv_2mortal(newSVpvn(name,size));
4353 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4354 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4355 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4359 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4360 GetProcAddress(hNetApi32, "NetApiBufferFree");
4361 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4362 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4365 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4366 /* this way is more reliable, in case user has a local account. */
4368 DWORD dnamelen = sizeof(dname);
4370 DWORD wki100_platform_id;
4371 LPWSTR wki100_computername;
4372 LPWSTR wki100_langroup;
4373 DWORD wki100_ver_major;
4374 DWORD wki100_ver_minor;
4376 /* NERR_Success *is* 0*/
4377 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4378 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4379 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4380 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4383 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4384 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4386 pfnNetApiBufferFree(pwi);
4387 FreeLibrary(hNetApi32);
4390 FreeLibrary(hNetApi32);
4393 /* Win95 doesn't have NetWksta*(), so do it the old way */
4395 DWORD size = sizeof(name);
4397 FreeLibrary(hNetApi32);
4398 if (GetUserName(name,&size)) {
4399 char sid[ONE_K_BUFSIZE];
4400 DWORD sidlen = sizeof(sid);
4402 DWORD dnamelen = sizeof(dname);
4404 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4405 dname, &dnamelen, &snu)) {
4406 XSRETURN_PV(dname); /* all that for this */
4418 DWORD flags, filecomplen;
4419 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4420 &flags, fsname, sizeof(fsname))) {
4421 if (GIMME_V == G_ARRAY) {
4422 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4423 XPUSHs(sv_2mortal(newSViv(flags)));
4424 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4429 XSRETURN_PV(fsname);
4435 XS(w32_GetOSVersion)
4438 OSVERSIONINFOA osver;
4441 OSVERSIONINFOW osverw;
4442 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4443 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4444 if (!GetVersionExW(&osverw)) {
4447 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4448 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4449 osver.dwMajorVersion = osverw.dwMajorVersion;
4450 osver.dwMinorVersion = osverw.dwMinorVersion;
4451 osver.dwBuildNumber = osverw.dwBuildNumber;
4452 osver.dwPlatformId = osverw.dwPlatformId;
4455 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4456 if (!GetVersionExA(&osver)) {
4459 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4461 XPUSHs(newSViv(osver.dwMajorVersion));
4462 XPUSHs(newSViv(osver.dwMinorVersion));
4463 XPUSHs(newSViv(osver.dwBuildNumber));
4464 XPUSHs(newSViv(osver.dwPlatformId));
4473 XSRETURN_IV(IsWinNT());
4481 XSRETURN_IV(IsWin95());
4485 XS(w32_FormatMessage)
4489 char msgbuf[ONE_K_BUFSIZE];
4492 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4495 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4496 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4497 &source, SvIV(ST(0)), 0,
4498 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4500 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4501 XSRETURN_PV(msgbuf);
4505 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4506 &source, SvIV(ST(0)), 0,
4507 msgbuf, sizeof(msgbuf)-1, NULL))
4508 XSRETURN_PV(msgbuf);
4521 PROCESS_INFORMATION stProcInfo;
4522 STARTUPINFO stStartInfo;
4523 BOOL bSuccess = FALSE;
4526 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4528 cmd = SvPV_nolen(ST(0));
4529 args = SvPV_nolen(ST(1));
4531 env = PerlEnv_get_childenv();
4532 dir = PerlEnv_get_childdir();
4534 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4535 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4536 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4537 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4540 cmd, /* Image path */
4541 args, /* Arguments for command line */
4542 NULL, /* Default process security */
4543 NULL, /* Default thread security */
4544 FALSE, /* Must be TRUE to use std handles */
4545 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4546 env, /* Inherit our environment block */
4547 dir, /* Inherit our currrent directory */
4548 &stStartInfo, /* -> Startup info */
4549 &stProcInfo)) /* <- Process info (if OK) */
4551 int pid = (int)stProcInfo.dwProcessId;
4552 if (IsWin95() && pid < 0)
4554 sv_setiv(ST(2), pid);
4555 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4558 PerlEnv_free_childenv(env);
4559 PerlEnv_free_childdir(dir);
4560 XSRETURN_IV(bSuccess);
4564 XS(w32_GetTickCount)
4567 DWORD msec = GetTickCount();
4575 XS(w32_GetShortPathName)
4582 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4584 shortpath = sv_mortalcopy(ST(0));
4585 SvUPGRADE(shortpath, SVt_PV);
4586 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4589 /* src == target is allowed */
4591 len = GetShortPathName(SvPVX(shortpath),
4594 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4596 SvCUR_set(shortpath,len);
4604 XS(w32_GetFullPathName)
4613 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4616 fullpath = sv_mortalcopy(filename);
4617 SvUPGRADE(fullpath, SVt_PV);
4618 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4622 len = GetFullPathName(SvPVX(filename),
4626 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4628 if (GIMME_V == G_ARRAY) {
4630 XST_mPV(1,filepart);
4631 len = filepart - SvPVX(fullpath);
4634 SvCUR_set(fullpath,len);
4642 XS(w32_GetLongPathName)
4646 char tmpbuf[MAX_PATH+1];
4651 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4654 pathstr = SvPV(path,len);
4655 strcpy(tmpbuf, pathstr);
4656 pathstr = win32_longpath(tmpbuf);
4658 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4669 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4680 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4682 WCHAR wSourceFile[MAX_PATH+1];
4683 WCHAR wDestFile[MAX_PATH+1];
4684 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4685 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4686 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4687 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4690 char szSourceFile[MAX_PATH+1];
4691 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4692 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4701 Perl_init_os_extras(void)
4704 char *file = __FILE__;
4707 /* these names are Activeware compatible */
4708 newXS("Win32::GetCwd", w32_GetCwd, file);
4709 newXS("Win32::SetCwd", w32_SetCwd, file);
4710 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4711 newXS("Win32::GetLastError", w32_GetLastError, file);
4712 newXS("Win32::SetLastError", w32_SetLastError, file);
4713 newXS("Win32::LoginName", w32_LoginName, file);
4714 newXS("Win32::NodeName", w32_NodeName, file);
4715 newXS("Win32::DomainName", w32_DomainName, file);
4716 newXS("Win32::FsType", w32_FsType, file);
4717 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4718 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4719 newXS("Win32::IsWin95", w32_IsWin95, file);
4720 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4721 newXS("Win32::Spawn", w32_Spawn, file);
4722 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4723 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4724 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4725 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4726 newXS("Win32::CopyFile", w32_CopyFile, file);
4727 newXS("Win32::Sleep", w32_Sleep, file);
4728 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4730 /* XXX Bloat Alert! The following Activeware preloads really
4731 * ought to be part of Win32::Sys::*, so they're not included
4734 /* LookupAccountName
4736 * InitiateSystemShutdown
4737 * AbortSystemShutdown
4738 * ExpandEnvrironmentStrings
4743 win32_signal_context(void)
4748 my_perl = PL_curinterp;
4749 PERL_SET_THX(my_perl);
4753 return PL_curinterp;
4759 win32_ctrlhandler(DWORD dwCtrlType)
4762 dTHXa(PERL_GET_SIG_CONTEXT);
4768 switch(dwCtrlType) {
4769 case CTRL_CLOSE_EVENT:
4770 /* A signal that the system sends to all processes attached to a console when
4771 the user closes the console (either by choosing the Close command from the
4772 console window's System menu, or by choosing the End Task command from the
4775 if (do_raise(aTHX_ 1)) /* SIGHUP */
4776 sig_terminate(aTHX_ 1);
4780 /* A CTRL+c signal was received */
4781 if (do_raise(aTHX_ SIGINT))
4782 sig_terminate(aTHX_ SIGINT);
4785 case CTRL_BREAK_EVENT:
4786 /* A CTRL+BREAK signal was received */
4787 if (do_raise(aTHX_ SIGBREAK))
4788 sig_terminate(aTHX_ SIGBREAK);
4791 case CTRL_LOGOFF_EVENT:
4792 /* A signal that the system sends to all console processes when a user is logging
4793 off. This signal does not indicate which user is logging off, so no
4794 assumptions can be made.
4797 case CTRL_SHUTDOWN_EVENT:
4798 /* A signal that the system sends to all console processes when the system is
4801 if (do_raise(aTHX_ SIGTERM))
4802 sig_terminate(aTHX_ SIGTERM);
4812 Perl_win32_init(int *argcp, char ***argvp)
4814 /* Disable floating point errors, Perl will trap the ones we
4815 * care about. VC++ RTL defaults to switching these off
4816 * already, but the Borland RTL doesn't. Since we don't
4817 * want to be at the vendor's whim on the default, we set
4818 * it explicitly here.
4820 #if !defined(_ALPHA_) && !defined(__GNUC__)
4821 _control87(MCW_EM, MCW_EM);
4827 win32_get_child_IO(child_IO_table* ptbl)
4829 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4830 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4831 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4835 win32_signal(int sig, Sighandler_t subcode)
4838 if (sig < SIG_SIZE) {
4839 int save_errno = errno;
4840 Sighandler_t result = signal(sig, subcode);
4841 if (result == SIG_ERR) {
4842 result = w32_sighandler[sig];
4845 w32_sighandler[sig] = subcode;
4855 #ifdef HAVE_INTERP_INTERN
4859 win32_csighandler(int sig)
4862 dTHXa(PERL_GET_SIG_CONTEXT);
4863 Perl_warn(aTHX_ "Got signal %d",sig);
4869 Perl_sys_intern_init(pTHX)
4872 w32_perlshell_tokens = Nullch;
4873 w32_perlshell_vec = (char**)NULL;
4874 w32_perlshell_items = 0;
4875 w32_fdpid = newAV();
4876 New(1313, w32_children, 1, child_tab);
4877 w32_num_children = 0;
4878 # ifdef USE_ITHREADS
4880 New(1313, w32_pseudo_children, 1, child_tab);
4881 w32_num_pseudo_children = 0;
4883 w32_init_socktype = 0;
4886 for (i=0; i < SIG_SIZE; i++) {
4887 w32_sighandler[i] = SIG_DFL;
4890 if (my_perl == PL_curinterp) {
4894 /* Force C runtime signal stuff to set its console handler */
4895 signal(SIGINT,&win32_csighandler);
4896 signal(SIGBREAK,&win32_csighandler);
4897 /* Push our handler on top */
4898 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4903 Perl_sys_intern_clear(pTHX)
4905 Safefree(w32_perlshell_tokens);
4906 Safefree(w32_perlshell_vec);
4907 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4908 Safefree(w32_children);
4910 KillTimer(NULL,w32_timerid);
4913 # ifdef MULTIPLICITY
4914 if (my_perl == PL_curinterp) {
4918 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4920 # ifdef USE_ITHREADS
4921 Safefree(w32_pseudo_children);
4925 # ifdef USE_ITHREADS
4928 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4930 dst->perlshell_tokens = Nullch;
4931 dst->perlshell_vec = (char**)NULL;
4932 dst->perlshell_items = 0;
4933 dst->fdpid = newAV();
4934 Newz(1313, dst->children, 1, child_tab);
4936 Newz(1313, dst->pseudo_children, 1, child_tab);
4937 dst->thr_intern.Winit_socktype = 0;
4939 dst->poll_count = 0;
4940 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4942 # endif /* USE_ITHREADS */
4943 #endif /* HAVE_INTERP_INTERN */
4946 win32_free_argvw(pTHX_ void *ptr)
4948 char** argv = (char**)ptr;
4956 win32_argv2utf8(int argc, char** argv)
4961 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4962 if (lpwStr && argc) {
4964 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4965 Newz(0, psz, length, char);
4966 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4969 call_atexit(win32_free_argvw, argv);
4971 GlobalFree((HGLOBAL)lpwStr);