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 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20 # include <shellapi.h>
22 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
28 /* #include "config.h" */
30 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
39 #define PERL_NO_GET_CONTEXT
45 /* assert.h conflicts with #define of assert in perl.h */
52 #if defined(_MSC_VER) || defined(__MINGW32__)
53 #include <sys/utime.h>
58 /* Mingw32 defaults to globing command line
59 * So we turn it off like this:
64 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65 /* Mingw32-1.1 is missing some prototypes */
66 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
73 #if defined(__BORLANDC__)
75 # define _utimbuf utimbuf
80 #define EXECF_SPAWN_NOWAIT 3
82 #if defined(PERL_IMPLICIT_SYS)
83 # undef win32_get_privlib
84 # define win32_get_privlib g_win32_get_privlib
85 # undef win32_get_sitelib
86 # define win32_get_sitelib g_win32_get_sitelib
87 # undef win32_get_vendorlib
88 # define win32_get_vendorlib g_win32_get_vendorlib
90 # define getlogin g_getlogin
93 static void get_shell(void);
94 static long tokenize(const char *str, char **dest, char ***destv);
95 static int do_spawn2(pTHX_ const char *cmd, int exectype);
96 static BOOL has_shell_metachars(const char *ptr);
97 static long filetime_to_clock(PFILETIME ft);
98 static BOOL filetime_from_time(PFILETIME ft, time_t t);
99 static char * get_emd_part(SV **leading, char *trailing, ...);
100 static void remove_dead_process(long deceased);
101 static long find_pid(int pid);
102 static char * qualified_path(const char *cmd);
103 static char * win32_get_xlib(const char *pl, const char *xlib,
104 const char *libname);
107 static void remove_dead_pseudo_process(long child);
108 static long find_pseudo_pid(int pid);
112 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113 char w32_module_name[MAX_PATH+1];
116 static DWORD w32_platform = (DWORD)-1;
118 #define ONE_K_BUFSIZE 1024
121 /* Silence STDERR grumblings from Borland's math library. */
123 _matherr(struct _exception *a)
133 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
139 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
143 set_w32_module_name(void)
146 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
147 ? GetModuleHandle(NULL)
148 : w32_perldll_handle),
149 w32_module_name, sizeof(w32_module_name));
151 /* remove \\?\ prefix */
152 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
153 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
155 /* try to get full path to binary (which may be mangled when perl is
156 * run from a 16-bit app) */
157 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
158 (void)win32_longpath(w32_module_name);
159 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
161 /* normalize to forward slashes */
162 ptr = w32_module_name;
170 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
172 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
174 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
177 const char *subkey = "Software\\Perl";
181 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
182 if (retval == ERROR_SUCCESS) {
184 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
185 if (retval == ERROR_SUCCESS
186 && (type == REG_SZ || type == REG_EXPAND_SZ))
190 *svp = sv_2mortal(newSVpvn("",0));
191 SvGROW(*svp, datalen);
192 retval = RegQueryValueEx(handle, valuename, 0, NULL,
193 (PBYTE)SvPVX(*svp), &datalen);
194 if (retval == ERROR_SUCCESS) {
196 SvCUR_set(*svp,datalen-1);
204 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
206 get_regstr(const char *valuename, SV **svp)
208 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
210 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
214 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
216 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
220 char mod_name[MAX_PATH+1];
226 va_start(ap, trailing_path);
227 strip = va_arg(ap, char *);
229 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
230 baselen = strlen(base);
232 if (!*w32_module_name) {
233 set_w32_module_name();
235 strcpy(mod_name, w32_module_name);
236 ptr = strrchr(mod_name, '/');
237 while (ptr && strip) {
238 /* look for directories to skip back */
241 ptr = strrchr(mod_name, '/');
242 /* avoid stripping component if there is no slash,
243 * or it doesn't match ... */
244 if (!ptr || stricmp(ptr+1, strip) != 0) {
245 /* ... but not if component matches m|5\.$patchlevel.*| */
246 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
247 && strncmp(strip, base, baselen) == 0
248 && strncmp(ptr+1, base, baselen) == 0))
254 strip = va_arg(ap, char *);
262 strcpy(++ptr, trailing_path);
264 /* only add directory if it exists */
265 if (GetFileAttributes(mod_name) != (DWORD) -1) {
266 /* directory exists */
269 *prev_pathp = sv_2mortal(newSVpvn("",0));
270 else if (SvPVX(*prev_pathp))
271 sv_catpvn(*prev_pathp, ";", 1);
272 sv_catpv(*prev_pathp, mod_name);
273 return SvPVX(*prev_pathp);
280 win32_get_privlib(const char *pl)
283 char *stdlib = "lib";
284 char buffer[MAX_PATH+1];
287 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
288 sprintf(buffer, "%s-%s", stdlib, pl);
289 if (!get_regstr(buffer, &sv))
290 (void)get_regstr(stdlib, &sv);
292 /* $stdlib .= ";$EMD/../../lib" */
293 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
297 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
301 char pathstr[MAX_PATH+1];
305 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
306 sprintf(regstr, "%s-%s", xlib, pl);
307 (void)get_regstr(regstr, &sv1);
310 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
311 sprintf(pathstr, "%s/%s/lib", libname, pl);
312 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
314 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
315 (void)get_regstr(xlib, &sv2);
318 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
319 sprintf(pathstr, "%s/lib", libname);
320 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
329 sv_catpvn(sv1, ";", 1);
336 win32_get_sitelib(const char *pl)
338 return win32_get_xlib(pl, "sitelib", "site");
341 #ifndef PERL_VENDORLIB_NAME
342 # define PERL_VENDORLIB_NAME "vendor"
346 win32_get_vendorlib(const char *pl)
348 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
352 has_shell_metachars(const char *ptr)
358 * Scan string looking for redirection (< or >) or pipe
359 * characters (|) that are not in a quoted string.
360 * Shell variable interpolation (%VAR%) can also happen inside strings.
392 #if !defined(PERL_IMPLICIT_SYS)
393 /* since the current process environment is being updated in util.c
394 * the library functions will get the correct environment
397 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
400 #define fixcmd(x) { \
401 char *pspace = strchr((x),' '); \
404 while (p < pspace) { \
415 PERL_FLUSHALL_FOR_CHILD;
416 return win32_popen(cmd, mode);
420 Perl_my_pclose(pTHX_ PerlIO *fp)
422 return win32_pclose(fp);
426 DllExport unsigned long
429 static OSVERSIONINFO osver;
431 if (osver.dwPlatformId != w32_platform) {
432 memset(&osver, 0, sizeof(OSVERSIONINFO));
433 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
434 GetVersionEx(&osver);
435 w32_platform = osver.dwPlatformId;
437 return (unsigned long)w32_platform;
447 return -((int)w32_pseudo_id);
450 /* Windows 9x appears to always reports a pid for threads and processes
451 * that has the high bit set. So we treat the lower 31 bits as the
452 * "real" PID for Perl's purposes. */
453 if (IsWin95() && pid < 0)
458 /* Tokenize a string. Words are null-separated, and the list
459 * ends with a doubled null. Any character (except null and
460 * including backslash) may be escaped by preceding it with a
461 * backslash (the backslash will be stripped).
462 * Returns number of words in result buffer.
465 tokenize(const char *str, char **dest, char ***destv)
467 char *retstart = Nullch;
468 char **retvstart = 0;
472 int slen = strlen(str);
474 register char **retv;
475 Newx(ret, slen+2, char);
476 Newx(retv, (slen+3)/2, char*);
484 if (*ret == '\\' && *str)
486 else if (*ret == ' ') {
502 retvstart[items] = Nullch;
515 if (!w32_perlshell_tokens) {
516 /* we don't use COMSPEC here for two reasons:
517 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
518 * uncontrolled unportability of the ensuing scripts.
519 * 2. PERL5SHELL could be set to a shell that may not be fit for
520 * interactive use (which is what most programs look in COMSPEC
523 const char* defaultshell = (IsWinNT()
524 ? "cmd.exe /x/d/c" : "command.com /c");
525 const char *usershell = PerlEnv_getenv("PERL5SHELL");
526 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
527 &w32_perlshell_tokens,
533 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
545 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
547 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
552 while (++mark <= sp) {
553 if (*mark && (str = SvPV_nolen(*mark)))
560 status = win32_spawnvp(flag,
561 (const char*)(really ? SvPV_nolen(really) : argv[0]),
562 (const char* const*)argv);
564 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
565 /* possible shell-builtin, invoke with shell */
567 sh_items = w32_perlshell_items;
569 argv[index+sh_items] = argv[index];
570 while (--sh_items >= 0)
571 argv[sh_items] = w32_perlshell_vec[sh_items];
573 status = win32_spawnvp(flag,
574 (const char*)(really ? SvPV_nolen(really) : argv[0]),
575 (const char* const*)argv);
578 if (flag == P_NOWAIT) {
580 PL_statusvalue = -1; /* >16bits hint for pp_system() */
584 if (ckWARN(WARN_EXEC))
585 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
590 PL_statusvalue = status;
596 /* returns pointer to the next unquoted space or the end of the string */
598 find_next_space(const char *s)
600 bool in_quotes = FALSE;
602 /* ignore doubled backslashes, or backslash+quote */
603 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
606 /* keep track of when we're within quotes */
607 else if (*s == '"') {
609 in_quotes = !in_quotes;
611 /* break it up only at spaces that aren't in quotes */
612 else if (!in_quotes && isSPACE(*s))
621 do_spawn2(pTHX_ const char *cmd, int exectype)
627 BOOL needToTry = TRUE;
630 /* Save an extra exec if possible. See if there are shell
631 * metacharacters in it */
632 if (!has_shell_metachars(cmd)) {
633 Newx(argv, strlen(cmd) / 2 + 2, char*);
634 Newx(cmd2, strlen(cmd) + 1, char);
637 for (s = cmd2; *s;) {
638 while (*s && isSPACE(*s))
642 s = find_next_space(s);
650 status = win32_spawnvp(P_WAIT, argv[0],
651 (const char* const*)argv);
653 case EXECF_SPAWN_NOWAIT:
654 status = win32_spawnvp(P_NOWAIT, argv[0],
655 (const char* const*)argv);
658 status = win32_execvp(argv[0], (const char* const*)argv);
661 if (status != -1 || errno == 0)
671 Newx(argv, w32_perlshell_items + 2, char*);
672 while (++i < w32_perlshell_items)
673 argv[i] = w32_perlshell_vec[i];
674 argv[i++] = (char *)cmd;
678 status = win32_spawnvp(P_WAIT, argv[0],
679 (const char* const*)argv);
681 case EXECF_SPAWN_NOWAIT:
682 status = win32_spawnvp(P_NOWAIT, argv[0],
683 (const char* const*)argv);
686 status = win32_execvp(argv[0], (const char* const*)argv);
692 if (exectype == EXECF_SPAWN_NOWAIT) {
694 PL_statusvalue = -1; /* >16bits hint for pp_system() */
698 if (ckWARN(WARN_EXEC))
699 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
700 (exectype == EXECF_EXEC ? "exec" : "spawn"),
701 cmd, strerror(errno));
706 PL_statusvalue = status;
712 Perl_do_spawn(pTHX_ char *cmd)
714 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
718 Perl_do_spawn_nowait(pTHX_ char *cmd)
720 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
724 Perl_do_exec(pTHX_ const char *cmd)
726 do_spawn2(aTHX_ cmd, EXECF_EXEC);
730 /* The idea here is to read all the directory names into a string table
731 * (separated by nulls) and when one of the other dir functions is called
732 * return the pointer to the current file name.
735 win32_opendir(const char *filename)
741 char scanname[MAX_PATH+3];
743 WIN32_FIND_DATAA aFindData;
745 len = strlen(filename);
749 /* check to see if filename is a directory */
750 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
753 /* Get us a DIR structure */
756 /* Create the search pattern */
757 strcpy(scanname, filename);
759 /* bare drive name means look in cwd for drive */
760 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
761 scanname[len++] = '.';
762 scanname[len++] = '/';
764 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
765 scanname[len++] = '/';
767 scanname[len++] = '*';
768 scanname[len] = '\0';
770 /* do the FindFirstFile call */
771 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
772 if (dirp->handle == INVALID_HANDLE_VALUE) {
773 DWORD err = GetLastError();
774 /* FindFirstFile() fails on empty drives! */
776 case ERROR_FILE_NOT_FOUND:
778 case ERROR_NO_MORE_FILES:
779 case ERROR_PATH_NOT_FOUND:
782 case ERROR_NOT_ENOUGH_MEMORY:
793 /* now allocate the first part of the string table for
794 * the filenames that we find.
796 idx = strlen(aFindData.cFileName)+1;
801 Newx(dirp->start, dirp->size, char);
802 strcpy(dirp->start, aFindData.cFileName);
804 dirp->end = dirp->curr = dirp->start;
810 /* Readdir just returns the current string pointer and bumps the
811 * string pointer to the nDllExport entry.
813 DllExport struct direct *
814 win32_readdir(DIR *dirp)
819 /* first set up the structure to return */
820 len = strlen(dirp->curr);
821 strcpy(dirp->dirstr.d_name, dirp->curr);
822 dirp->dirstr.d_namlen = len;
825 dirp->dirstr.d_ino = dirp->curr - dirp->start;
827 /* Now set up for the next call to readdir */
828 dirp->curr += len + 1;
829 if (dirp->curr >= dirp->end) {
832 WIN32_FIND_DATAA aFindData;
834 /* finding the next file that matches the wildcard
835 * (which should be all of them in this directory!).
837 res = FindNextFileA(dirp->handle, &aFindData);
839 long endpos = dirp->end - dirp->start;
840 long newsize = endpos + strlen(aFindData.cFileName) + 1;
841 /* bump the string table size by enough for the
842 * new name and its null terminator */
843 while (newsize > dirp->size) {
844 long curpos = dirp->curr - dirp->start;
846 Renew(dirp->start, dirp->size, char);
847 dirp->curr = dirp->start + curpos;
849 strcpy(dirp->start + endpos, aFindData.cFileName);
850 dirp->end = dirp->start + newsize;
856 return &(dirp->dirstr);
862 /* Telldir returns the current string pointer position */
864 win32_telldir(DIR *dirp)
866 return (dirp->curr - dirp->start);
870 /* Seekdir moves the string pointer to a previously saved position
871 * (returned by telldir).
874 win32_seekdir(DIR *dirp, long loc)
876 dirp->curr = dirp->start + loc;
879 /* Rewinddir resets the string pointer to the start */
881 win32_rewinddir(DIR *dirp)
883 dirp->curr = dirp->start;
886 /* free the memory allocated by opendir */
888 win32_closedir(DIR *dirp)
891 if (dirp->handle != INVALID_HANDLE_VALUE)
892 FindClose(dirp->handle);
893 Safefree(dirp->start);
906 * Just pretend that everyone is a superuser. NT will let us know if
907 * we don\'t really have permission to do something.
910 #define ROOT_UID ((uid_t)0)
911 #define ROOT_GID ((gid_t)0)
940 return (auid == ROOT_UID ? 0 : -1);
946 return (agid == ROOT_GID ? 0 : -1);
953 char *buf = w32_getlogin_buffer;
954 DWORD size = sizeof(w32_getlogin_buffer);
955 if (GetUserName(buf,&size))
961 chown(const char *path, uid_t owner, gid_t group)
968 * XXX this needs strengthening (for PerlIO)
971 int mkstemp(const char *path)
974 char buf[MAX_PATH+1];
978 if (i++ > 10) { /* give up */
982 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
986 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
996 long child = w32_num_children;
997 while (--child >= 0) {
998 if ((int)w32_child_pids[child] == pid)
1005 remove_dead_process(long child)
1009 CloseHandle(w32_child_handles[child]);
1010 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1011 (w32_num_children-child-1), HANDLE);
1012 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1013 (w32_num_children-child-1), DWORD);
1020 find_pseudo_pid(int pid)
1023 long child = w32_num_pseudo_children;
1024 while (--child >= 0) {
1025 if ((int)w32_pseudo_child_pids[child] == pid)
1032 remove_dead_pseudo_process(long child)
1036 CloseHandle(w32_pseudo_child_handles[child]);
1037 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1038 (w32_num_pseudo_children-child-1), HANDLE);
1039 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1040 (w32_num_pseudo_children-child-1), DWORD);
1041 w32_num_pseudo_children--;
1047 win32_kill(int pid, int sig)
1055 /* it is a pseudo-forked child */
1056 child = find_pseudo_pid(-pid);
1058 hProcess = w32_pseudo_child_handles[child];
1061 /* "Does process exist?" use of kill */
1064 /* kill -9 style un-graceful exit */
1065 if (TerminateThread(hProcess, sig)) {
1066 remove_dead_pseudo_process(child);
1071 /* We fake signals to pseudo-processes using Win32
1072 * message queue. In Win9X the pids are negative already. */
1073 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1074 /* It might be us ... */
1081 else if (IsWin95()) {
1089 child = find_pid(pid);
1091 hProcess = w32_child_handles[child];
1094 /* "Does process exist?" use of kill */
1097 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1102 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1105 default: /* For now be backwards compatible with perl5.6 */
1107 if (TerminateProcess(hProcess, sig)) {
1108 remove_dead_process(child);
1117 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1118 (IsWin95() ? -pid : pid));
1122 /* "Does process exist?" use of kill */
1126 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1131 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1134 default: /* For now be backwards compatible with perl5.6 */
1136 if (TerminateProcess(hProcess, sig))
1141 CloseHandle(hProcess);
1151 win32_stat(const char *path, Stat_t *sbuf)
1154 char buffer[MAX_PATH+1];
1155 int l = strlen(path);
1161 switch(path[l - 1]) {
1162 /* FindFirstFile() and stat() are buggy with a trailing
1163 * backslash, so change it to a forward slash :-( */
1165 if (l >= sizeof(buffer)) {
1166 errno = ENAMETOOLONG;
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. */
1191 path = PerlDir_mapA(path);
1193 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1194 if (handle != INVALID_HANDLE_VALUE) {
1195 BY_HANDLE_FILE_INFORMATION bhi;
1196 if (GetFileInformationByHandle(handle, &bhi))
1197 nlink = bhi.nNumberOfLinks;
1198 CloseHandle(handle);
1201 /* path will be mapped correctly above */
1202 #if defined(WIN64) || defined(USE_LARGE_FILES)
1203 res = _stati64(path, sbuf);
1205 res = stat(path, sbuf);
1207 sbuf->st_nlink = nlink;
1210 /* CRT is buggy on sharenames, so make sure it really isn't.
1211 * XXX using GetFileAttributesEx() will enable us to set
1212 * sbuf->st_*time (but note that's not available on the
1213 * Windows of 1995) */
1214 DWORD r = GetFileAttributesA(path);
1215 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1216 /* sbuf may still contain old garbage since stat() failed */
1217 Zero(sbuf, 1, Stat_t);
1218 sbuf->st_mode = S_IFDIR | S_IREAD;
1220 if (!(r & FILE_ATTRIBUTE_READONLY))
1221 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1226 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1227 && (path[2] == '\\' || path[2] == '/'))
1229 /* The drive can be inaccessible, some _stat()s are buggy */
1230 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1236 if (S_ISDIR(sbuf->st_mode))
1237 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1238 else if (S_ISREG(sbuf->st_mode)) {
1240 if (l >= 4 && path[l-4] == '.') {
1241 const char *e = path + l - 3;
1242 if (strnicmp(e,"exe",3)
1243 && strnicmp(e,"bat",3)
1244 && strnicmp(e,"com",3)
1245 && (IsWin95() || strnicmp(e,"cmd",3)))
1246 sbuf->st_mode &= ~S_IEXEC;
1248 sbuf->st_mode |= S_IEXEC;
1251 sbuf->st_mode &= ~S_IEXEC;
1252 /* Propagate permissions to _group_ and _others_ */
1253 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1254 sbuf->st_mode |= (perms>>3) | (perms>>6);
1261 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1262 #define SKIP_SLASHES(s) \
1264 while (*(s) && isSLASH(*(s))) \
1267 #define COPY_NONSLASHES(d,s) \
1269 while (*(s) && !isSLASH(*(s))) \
1273 /* Find the longname of a given path. path is destructively modified.
1274 * It should have space for at least MAX_PATH characters. */
1276 win32_longpath(char *path)
1278 WIN32_FIND_DATA fdata;
1280 char tmpbuf[MAX_PATH+1];
1281 char *tmpstart = tmpbuf;
1288 if (isALPHA(path[0]) && path[1] == ':') {
1290 *tmpstart++ = path[0];
1294 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1296 *tmpstart++ = path[0];
1297 *tmpstart++ = path[1];
1298 SKIP_SLASHES(start);
1299 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1301 *tmpstart++ = *start++;
1302 SKIP_SLASHES(start);
1303 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1308 /* copy initial slash, if any */
1309 if (isSLASH(*start)) {
1310 *tmpstart++ = *start++;
1312 SKIP_SLASHES(start);
1315 /* FindFirstFile() expands "." and "..", so we need to pass
1316 * those through unmolested */
1318 && (!start[1] || isSLASH(start[1])
1319 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1321 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1326 /* if this is the end, bust outta here */
1330 /* now we're at a non-slash; walk up to next slash */
1331 while (*start && !isSLASH(*start))
1334 /* stop and find full name of component */
1337 fhand = FindFirstFile(path,&fdata);
1339 if (fhand != INVALID_HANDLE_VALUE) {
1340 STRLEN len = strlen(fdata.cFileName);
1341 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1342 strcpy(tmpstart, fdata.cFileName);
1353 /* failed a step, just return without side effects */
1354 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1359 strcpy(path,tmpbuf);
1364 win32_getenv(const char *name)
1368 SV *curitem = Nullsv;
1370 needlen = GetEnvironmentVariableA(name,NULL,0);
1372 curitem = sv_2mortal(newSVpvn("", 0));
1374 SvGROW(curitem, needlen+1);
1375 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1377 } while (needlen >= SvLEN(curitem));
1378 SvCUR_set(curitem, needlen);
1381 /* allow any environment variables that begin with 'PERL'
1382 to be stored in the registry */
1383 if (strncmp(name, "PERL", 4) == 0)
1384 (void)get_regstr(name, &curitem);
1386 if (curitem && SvCUR(curitem))
1387 return SvPVX(curitem);
1393 win32_putenv(const char *name)
1401 Newx(curitem,strlen(name)+1,char);
1402 strcpy(curitem, name);
1403 val = strchr(curitem, '=');
1405 /* The sane way to deal with the environment.
1406 * Has these advantages over putenv() & co.:
1407 * * enables us to store a truly empty value in the
1408 * environment (like in UNIX).
1409 * * we don't have to deal with RTL globals, bugs and leaks.
1411 * Why you may want to enable USE_WIN32_RTL_ENV:
1412 * * environ[] and RTL functions will not reflect changes,
1413 * which might be an issue if extensions want to access
1414 * the env. via RTL. This cuts both ways, since RTL will
1415 * not see changes made by extensions that call the Win32
1416 * functions directly, either.
1420 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1429 filetime_to_clock(PFILETIME ft)
1431 __int64 qw = ft->dwHighDateTime;
1433 qw |= ft->dwLowDateTime;
1434 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1439 win32_times(struct tms *timebuf)
1444 clock_t process_time_so_far = clock();
1445 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1447 timebuf->tms_utime = filetime_to_clock(&user);
1448 timebuf->tms_stime = filetime_to_clock(&kernel);
1449 timebuf->tms_cutime = 0;
1450 timebuf->tms_cstime = 0;
1452 /* That failed - e.g. Win95 fallback to clock() */
1453 timebuf->tms_utime = process_time_so_far;
1454 timebuf->tms_stime = 0;
1455 timebuf->tms_cutime = 0;
1456 timebuf->tms_cstime = 0;
1458 return process_time_so_far;
1461 /* fix utime() so it works on directories in NT */
1463 filetime_from_time(PFILETIME pFileTime, time_t Time)
1465 struct tm *pTM = localtime(&Time);
1466 SYSTEMTIME SystemTime;
1472 SystemTime.wYear = pTM->tm_year + 1900;
1473 SystemTime.wMonth = pTM->tm_mon + 1;
1474 SystemTime.wDay = pTM->tm_mday;
1475 SystemTime.wHour = pTM->tm_hour;
1476 SystemTime.wMinute = pTM->tm_min;
1477 SystemTime.wSecond = pTM->tm_sec;
1478 SystemTime.wMilliseconds = 0;
1480 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1481 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1485 win32_unlink(const char *filename)
1491 filename = PerlDir_mapA(filename);
1492 attrs = GetFileAttributesA(filename);
1493 if (attrs == 0xFFFFFFFF) {
1497 if (attrs & FILE_ATTRIBUTE_READONLY) {
1498 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1499 ret = unlink(filename);
1501 (void)SetFileAttributesA(filename, attrs);
1504 ret = unlink(filename);
1509 win32_utime(const char *filename, struct utimbuf *times)
1516 struct utimbuf TimeBuffer;
1519 filename = PerlDir_mapA(filename);
1520 rc = utime(filename, times);
1522 /* EACCES: path specifies directory or readonly file */
1523 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1526 if (times == NULL) {
1527 times = &TimeBuffer;
1528 time(×->actime);
1529 times->modtime = times->actime;
1532 /* This will (and should) still fail on readonly files */
1533 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1534 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1535 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1536 if (handle == INVALID_HANDLE_VALUE)
1539 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1540 filetime_from_time(&ftAccess, times->actime) &&
1541 filetime_from_time(&ftWrite, times->modtime) &&
1542 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1547 CloseHandle(handle);
1552 unsigned __int64 ft_i64;
1557 #define Const64(x) x##LL
1559 #define Const64(x) x##i64
1561 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1562 #define EPOCH_BIAS Const64(116444736000000000)
1564 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1565 * and appears to be unsupported even by glibc) */
1567 win32_gettimeofday(struct timeval *tp, void *not_used)
1571 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1572 GetSystemTimeAsFileTime(&ft.ft_val);
1574 /* seconds since epoch */
1575 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1577 /* microseconds remaining */
1578 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1584 win32_uname(struct utsname *name)
1586 struct hostent *hep;
1587 STRLEN nodemax = sizeof(name->nodename)-1;
1588 OSVERSIONINFO osver;
1590 memset(&osver, 0, sizeof(OSVERSIONINFO));
1591 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1592 if (GetVersionEx(&osver)) {
1594 switch (osver.dwPlatformId) {
1595 case VER_PLATFORM_WIN32_WINDOWS:
1596 strcpy(name->sysname, "Windows");
1598 case VER_PLATFORM_WIN32_NT:
1599 strcpy(name->sysname, "Windows NT");
1601 case VER_PLATFORM_WIN32s:
1602 strcpy(name->sysname, "Win32s");
1605 strcpy(name->sysname, "Win32 Unknown");
1610 sprintf(name->release, "%d.%d",
1611 osver.dwMajorVersion, osver.dwMinorVersion);
1614 sprintf(name->version, "Build %d",
1615 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1616 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1617 if (osver.szCSDVersion[0]) {
1618 char *buf = name->version + strlen(name->version);
1619 sprintf(buf, " (%s)", osver.szCSDVersion);
1623 *name->sysname = '\0';
1624 *name->version = '\0';
1625 *name->release = '\0';
1629 hep = win32_gethostbyname("localhost");
1631 STRLEN len = strlen(hep->h_name);
1632 if (len <= nodemax) {
1633 strcpy(name->nodename, hep->h_name);
1636 strncpy(name->nodename, hep->h_name, nodemax);
1637 name->nodename[nodemax] = '\0';
1642 if (!GetComputerName(name->nodename, &sz))
1643 *name->nodename = '\0';
1646 /* machine (architecture) */
1651 GetSystemInfo(&info);
1653 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1654 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1655 procarch = info.u.s.wProcessorArchitecture;
1657 procarch = info.wProcessorArchitecture;
1660 case PROCESSOR_ARCHITECTURE_INTEL:
1661 arch = "x86"; break;
1662 case PROCESSOR_ARCHITECTURE_MIPS:
1663 arch = "mips"; break;
1664 case PROCESSOR_ARCHITECTURE_ALPHA:
1665 arch = "alpha"; break;
1666 case PROCESSOR_ARCHITECTURE_PPC:
1667 arch = "ppc"; break;
1668 #ifdef PROCESSOR_ARCHITECTURE_SHX
1669 case PROCESSOR_ARCHITECTURE_SHX:
1670 arch = "shx"; break;
1672 #ifdef PROCESSOR_ARCHITECTURE_ARM
1673 case PROCESSOR_ARCHITECTURE_ARM:
1674 arch = "arm"; break;
1676 #ifdef PROCESSOR_ARCHITECTURE_IA64
1677 case PROCESSOR_ARCHITECTURE_IA64:
1678 arch = "ia64"; break;
1680 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1681 case PROCESSOR_ARCHITECTURE_ALPHA64:
1682 arch = "alpha64"; break;
1684 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1685 case PROCESSOR_ARCHITECTURE_MSIL:
1686 arch = "msil"; break;
1688 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1689 case PROCESSOR_ARCHITECTURE_AMD64:
1690 arch = "amd64"; break;
1692 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1693 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1694 arch = "ia32-64"; break;
1696 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1697 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1698 arch = "unknown"; break;
1701 sprintf(name->machine, "unknown(0x%x)", procarch);
1702 arch = name->machine;
1705 if (name->machine != arch)
1706 strcpy(name->machine, arch);
1711 /* Timing related stuff */
1714 do_raise(pTHX_ int sig)
1716 if (sig < SIG_SIZE) {
1717 Sighandler_t handler = w32_sighandler[sig];
1718 if (handler == SIG_IGN) {
1721 else if (handler != SIG_DFL) {
1726 /* Choose correct default behaviour */
1742 /* Tell caller to exit thread/process as approriate */
1747 sig_terminate(pTHX_ int sig)
1749 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1750 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1757 win32_async_check(pTHX)
1761 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1762 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1764 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1766 switch(msg.message) {
1769 /* Perhaps some other messages could map to signals ? ... */
1772 /* Treat WM_QUIT like SIGHUP? */
1778 /* We use WM_USER to fake kill() with other signals */
1782 if (do_raise(aTHX_ sig)) {
1783 sig_terminate(aTHX_ sig);
1789 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1790 if (w32_timerid && w32_timerid==msg.wParam) {
1791 KillTimer(NULL,w32_timerid);
1796 /* Now fake a call to signal handler */
1797 if (do_raise(aTHX_ 14)) {
1798 sig_terminate(aTHX_ 14);
1803 /* Otherwise do normal Win32 thing - in case it is useful */
1806 TranslateMessage(&msg);
1807 DispatchMessage(&msg);
1814 /* Above or other stuff may have set a signal flag */
1815 if (PL_sig_pending) {
1821 /* This function will not return until the timeout has elapsed, or until
1822 * one of the handles is ready. */
1824 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1826 /* We may need several goes at this - so compute when we stop */
1828 if (timeout != INFINITE) {
1829 ticks = GetTickCount();
1833 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1836 if (result == WAIT_TIMEOUT) {
1837 /* Ran out of time - explicit return of zero to avoid -ve if we
1838 have scheduling issues
1842 if (timeout != INFINITE) {
1843 ticks = GetTickCount();
1845 if (result == WAIT_OBJECT_0 + count) {
1846 /* Message has arrived - check it */
1847 (void)win32_async_check(aTHX);
1850 /* Not timeout or message - one of handles is ready */
1854 /* compute time left to wait */
1855 ticks = timeout - ticks;
1856 /* If we are past the end say zero */
1857 return (ticks > 0) ? ticks : 0;
1861 win32_internal_wait(int *status, DWORD timeout)
1863 /* XXX this wait emulation only knows about processes
1864 * spawned via win32_spawnvp(P_NOWAIT, ...).
1868 DWORD exitcode, waitcode;
1871 if (w32_num_pseudo_children) {
1872 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1873 timeout, &waitcode);
1874 /* Time out here if there are no other children to wait for. */
1875 if (waitcode == WAIT_TIMEOUT) {
1876 if (!w32_num_children) {
1880 else if (waitcode != WAIT_FAILED) {
1881 if (waitcode >= WAIT_ABANDONED_0
1882 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1883 i = waitcode - WAIT_ABANDONED_0;
1885 i = waitcode - WAIT_OBJECT_0;
1886 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1887 *status = (int)((exitcode & 0xff) << 8);
1888 retval = (int)w32_pseudo_child_pids[i];
1889 remove_dead_pseudo_process(i);
1896 if (!w32_num_children) {
1901 /* if a child exists, wait for it to die */
1902 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1903 if (waitcode == WAIT_TIMEOUT) {
1906 if (waitcode != WAIT_FAILED) {
1907 if (waitcode >= WAIT_ABANDONED_0
1908 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1909 i = waitcode - WAIT_ABANDONED_0;
1911 i = waitcode - WAIT_OBJECT_0;
1912 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1913 *status = (int)((exitcode & 0xff) << 8);
1914 retval = (int)w32_child_pids[i];
1915 remove_dead_process(i);
1920 errno = GetLastError();
1925 win32_waitpid(int pid, int *status, int flags)
1928 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1931 if (pid == -1) /* XXX threadid == 1 ? */
1932 return win32_internal_wait(status, timeout);
1935 child = find_pseudo_pid(-pid);
1937 HANDLE hThread = w32_pseudo_child_handles[child];
1939 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1940 if (waitcode == WAIT_TIMEOUT) {
1943 else if (waitcode == WAIT_OBJECT_0) {
1944 if (GetExitCodeThread(hThread, &waitcode)) {
1945 *status = (int)((waitcode & 0xff) << 8);
1946 retval = (int)w32_pseudo_child_pids[child];
1947 remove_dead_pseudo_process(child);
1954 else if (IsWin95()) {
1963 child = find_pid(pid);
1965 hProcess = w32_child_handles[child];
1966 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1967 if (waitcode == WAIT_TIMEOUT) {
1970 else if (waitcode == WAIT_OBJECT_0) {
1971 if (GetExitCodeProcess(hProcess, &waitcode)) {
1972 *status = (int)((waitcode & 0xff) << 8);
1973 retval = (int)w32_child_pids[child];
1974 remove_dead_process(child);
1983 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1984 (IsWin95() ? -pid : pid));
1986 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1987 if (waitcode == WAIT_TIMEOUT) {
1988 CloseHandle(hProcess);
1991 else if (waitcode == WAIT_OBJECT_0) {
1992 if (GetExitCodeProcess(hProcess, &waitcode)) {
1993 *status = (int)((waitcode & 0xff) << 8);
1994 CloseHandle(hProcess);
1998 CloseHandle(hProcess);
2004 return retval >= 0 ? pid : retval;
2008 win32_wait(int *status)
2010 return win32_internal_wait(status, INFINITE);
2013 DllExport unsigned int
2014 win32_sleep(unsigned int t)
2017 /* Win32 times are in ms so *1000 in and /1000 out */
2018 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2021 DllExport unsigned int
2022 win32_alarm(unsigned int sec)
2025 * the 'obvious' implentation is SetTimer() with a callback
2026 * which does whatever receiving SIGALRM would do
2027 * we cannot use SIGALRM even via raise() as it is not
2028 * one of the supported codes in <signal.h>
2032 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2036 KillTimer(NULL,w32_timerid);
2043 #ifdef HAVE_DES_FCRYPT
2044 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2048 win32_crypt(const char *txt, const char *salt)
2051 #ifdef HAVE_DES_FCRYPT
2052 return des_fcrypt(txt, salt, w32_crypt_buffer);
2054 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2059 #ifdef USE_FIXED_OSFHANDLE
2061 #define FOPEN 0x01 /* file handle open */
2062 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2063 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2064 #define FDEV 0x40 /* file handle refers to device */
2065 #define FTEXT 0x80 /* file handle is in text mode */
2068 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2071 * This function allocates a free C Runtime file handle and associates
2072 * it with the Win32 HANDLE specified by the first parameter. This is a
2073 * temperary fix for WIN95's brain damage GetFileType() error on socket
2074 * we just bypass that call for socket
2076 * This works with MSVC++ 4.0+ or GCC/Mingw32
2079 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2080 * int flags - flags to associate with C Runtime file handle.
2083 * returns index of entry in fh, if successful
2084 * return -1, if no free entry is found
2088 *******************************************************************************/
2091 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2092 * this lets sockets work on Win9X with GCC and should fix the problems
2097 /* create an ioinfo entry, kill its handle, and steal the entry */
2102 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2103 int fh = _open_osfhandle((intptr_t)hF, 0);
2107 EnterCriticalSection(&(_pioinfo(fh)->lock));
2112 my_open_osfhandle(intptr_t osfhandle, int flags)
2115 char fileflags; /* _osfile flags */
2117 /* copy relevant flags from second parameter */
2120 if (flags & O_APPEND)
2121 fileflags |= FAPPEND;
2126 if (flags & O_NOINHERIT)
2127 fileflags |= FNOINHERIT;
2129 /* attempt to allocate a C Runtime file handle */
2130 if ((fh = _alloc_osfhnd()) == -1) {
2131 errno = EMFILE; /* too many open files */
2132 _doserrno = 0L; /* not an OS error */
2133 return -1; /* return error to caller */
2136 /* the file is open. now, set the info in _osfhnd array */
2137 _set_osfhnd(fh, osfhandle);
2139 fileflags |= FOPEN; /* mark as open */
2141 _osfile(fh) = fileflags; /* set osfile entry */
2142 LeaveCriticalSection(&_pioinfo(fh)->lock);
2144 return fh; /* return handle */
2147 #endif /* USE_FIXED_OSFHANDLE */
2149 /* simulate flock by locking a range on the file */
2151 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2152 #define LK_LEN 0xffff0000
2155 win32_flock(int fd, int oper)
2163 Perl_croak_nocontext("flock() unimplemented on this platform");
2166 fh = (HANDLE)_get_osfhandle(fd);
2167 memset(&o, 0, sizeof(o));
2170 case LOCK_SH: /* shared lock */
2171 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2173 case LOCK_EX: /* exclusive lock */
2174 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2176 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2177 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2179 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2180 LK_ERR(LockFileEx(fh,
2181 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2182 0, LK_LEN, 0, &o),i);
2184 case LOCK_UN: /* unlock lock */
2185 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2187 default: /* unknown */
2198 * redirected io subsystem for all XS modules
2211 return (&(_environ));
2214 /* the rest are the remapped stdio routines */
2234 win32_ferror(FILE *fp)
2236 return (ferror(fp));
2241 win32_feof(FILE *fp)
2247 * Since the errors returned by the socket error function
2248 * WSAGetLastError() are not known by the library routine strerror
2249 * we have to roll our own.
2253 win32_strerror(int e)
2255 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2256 extern int sys_nerr;
2260 if (e < 0 || e > sys_nerr) {
2265 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2266 w32_strerror_buffer,
2267 sizeof(w32_strerror_buffer), NULL) == 0)
2268 strcpy(w32_strerror_buffer, "Unknown Error");
2270 return w32_strerror_buffer;
2276 win32_str_os_error(void *sv, DWORD dwErr)
2280 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2281 |FORMAT_MESSAGE_IGNORE_INSERTS
2282 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2283 dwErr, 0, (char *)&sMsg, 1, NULL);
2284 /* strip trailing whitespace and period */
2287 --dwLen; /* dwLen doesn't include trailing null */
2288 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2289 if ('.' != sMsg[dwLen])
2294 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2296 dwLen = sprintf(sMsg,
2297 "Unknown error #0x%lX (lookup 0x%lX)",
2298 dwErr, GetLastError());
2302 sv_setpvn((SV*)sv, sMsg, dwLen);
2308 win32_fprintf(FILE *fp, const char *format, ...)
2311 va_start(marker, format); /* Initialize variable arguments. */
2313 return (vfprintf(fp, format, marker));
2317 win32_printf(const char *format, ...)
2320 va_start(marker, format); /* Initialize variable arguments. */
2322 return (vprintf(format, marker));
2326 win32_vfprintf(FILE *fp, const char *format, va_list args)
2328 return (vfprintf(fp, format, args));
2332 win32_vprintf(const char *format, va_list args)
2334 return (vprintf(format, args));
2338 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2340 return fread(buf, size, count, fp);
2344 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2346 return fwrite(buf, size, count, fp);
2349 #define MODE_SIZE 10
2352 win32_fopen(const char *filename, const char *mode)
2360 if (stricmp(filename, "/dev/null")==0)
2363 f = fopen(PerlDir_mapA(filename), mode);
2364 /* avoid buffering headaches for child processes */
2365 if (f && *mode == 'a')
2366 win32_fseek(f, 0, SEEK_END);
2370 #ifndef USE_SOCKETS_AS_HANDLES
2372 #define fdopen my_fdopen
2376 win32_fdopen(int handle, const char *mode)
2380 f = fdopen(handle, (char *) mode);
2381 /* avoid buffering headaches for child processes */
2382 if (f && *mode == 'a')
2383 win32_fseek(f, 0, SEEK_END);
2388 win32_freopen(const char *path, const char *mode, FILE *stream)
2391 if (stricmp(path, "/dev/null")==0)
2394 return freopen(PerlDir_mapA(path), mode, stream);
2398 win32_fclose(FILE *pf)
2400 return my_fclose(pf); /* defined in win32sck.c */
2404 win32_fputs(const char *s,FILE *pf)
2406 return fputs(s, pf);
2410 win32_fputc(int c,FILE *pf)
2416 win32_ungetc(int c,FILE *pf)
2418 return ungetc(c,pf);
2422 win32_getc(FILE *pf)
2428 win32_fileno(FILE *pf)
2434 win32_clearerr(FILE *pf)
2441 win32_fflush(FILE *pf)
2447 win32_ftell(FILE *pf)
2449 #if defined(WIN64) || defined(USE_LARGE_FILES)
2450 #if defined(__BORLANDC__) /* buk */
2451 return win32_tell( fileno( pf ) );
2454 if (fgetpos(pf, &pos))
2464 win32_fseek(FILE *pf, Off_t offset,int origin)
2466 #if defined(WIN64) || defined(USE_LARGE_FILES)
2467 #if defined(__BORLANDC__) /* buk */
2477 if (fgetpos(pf, &pos))
2482 fseek(pf, 0, SEEK_END);
2483 pos = _telli64(fileno(pf));
2492 return fsetpos(pf, &offset);
2495 return fseek(pf, (long)offset, origin);
2500 win32_fgetpos(FILE *pf,fpos_t *p)
2502 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2503 if( win32_tell(fileno(pf)) == -1L ) {
2509 return fgetpos(pf, p);
2514 win32_fsetpos(FILE *pf,const fpos_t *p)
2516 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2517 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2519 return fsetpos(pf, p);
2524 win32_rewind(FILE *pf)
2534 char prefix[MAX_PATH+1];
2535 char filename[MAX_PATH+1];
2536 DWORD len = GetTempPath(MAX_PATH, prefix);
2537 if (len && len < MAX_PATH) {
2538 if (GetTempFileName(prefix, "plx", 0, filename)) {
2539 HANDLE fh = CreateFile(filename,
2540 DELETE | GENERIC_READ | GENERIC_WRITE,
2544 FILE_ATTRIBUTE_NORMAL
2545 | FILE_FLAG_DELETE_ON_CLOSE,
2547 if (fh != INVALID_HANDLE_VALUE) {
2548 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2550 #if defined(__BORLANDC__)
2551 setmode(fd,O_BINARY);
2553 DEBUG_p(PerlIO_printf(Perl_debug_log,
2554 "Created tmpfile=%s\n",filename));
2566 int fd = win32_tmpfd();
2568 return win32_fdopen(fd, "w+b");
2580 win32_fstat(int fd, Stat_t *sbufptr)
2583 /* A file designated by filehandle is not shown as accessible
2584 * for write operations, probably because it is opened for reading.
2587 BY_HANDLE_FILE_INFORMATION bhfi;
2588 #if defined(WIN64) || defined(USE_LARGE_FILES)
2589 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2591 int rc = fstat(fd,&tmp);
2593 sbufptr->st_dev = tmp.st_dev;
2594 sbufptr->st_ino = tmp.st_ino;
2595 sbufptr->st_mode = tmp.st_mode;
2596 sbufptr->st_nlink = tmp.st_nlink;
2597 sbufptr->st_uid = tmp.st_uid;
2598 sbufptr->st_gid = tmp.st_gid;
2599 sbufptr->st_rdev = tmp.st_rdev;
2600 sbufptr->st_size = tmp.st_size;
2601 sbufptr->st_atime = tmp.st_atime;
2602 sbufptr->st_mtime = tmp.st_mtime;
2603 sbufptr->st_ctime = tmp.st_ctime;
2605 int rc = fstat(fd,sbufptr);
2608 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2609 #if defined(WIN64) || defined(USE_LARGE_FILES)
2610 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2612 sbufptr->st_mode &= 0xFE00;
2613 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2614 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2616 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2617 + ((S_IREAD|S_IWRITE) >> 6));
2621 return my_fstat(fd,sbufptr);
2626 win32_pipe(int *pfd, unsigned int size, int mode)
2628 return _pipe(pfd, size, mode);
2632 win32_popenlist(const char *mode, IV narg, SV **args)
2635 Perl_croak(aTHX_ "List form of pipe open not implemented");
2640 * a popen() clone that respects PERL5SHELL
2642 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2646 win32_popen(const char *command, const char *mode)
2648 #ifdef USE_RTL_POPEN
2649 return _popen(command, mode);
2661 /* establish which ends read and write */
2662 if (strchr(mode,'w')) {
2663 stdfd = 0; /* stdin */
2666 nhandle = STD_INPUT_HANDLE;
2668 else if (strchr(mode,'r')) {
2669 stdfd = 1; /* stdout */
2672 nhandle = STD_OUTPUT_HANDLE;
2677 /* set the correct mode */
2678 if (strchr(mode,'b'))
2680 else if (strchr(mode,'t'))
2683 ourmode = _fmode & (O_TEXT | O_BINARY);
2685 /* the child doesn't inherit handles */
2686 ourmode |= O_NOINHERIT;
2688 if (win32_pipe(p, 512, ourmode) == -1)
2691 /* save current stdfd */
2692 if ((oldfd = win32_dup(stdfd)) == -1)
2695 /* save the old std handle (this needs to happen before the
2696 * dup2(), since that might call SetStdHandle() too) */
2699 old_h = GetStdHandle(nhandle);
2701 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2702 /* stdfd will be inherited by the child */
2703 if (win32_dup2(p[child], stdfd) == -1)
2706 /* close the child end in parent */
2707 win32_close(p[child]);
2709 /* set the new std handle (in case dup2() above didn't) */
2710 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2712 /* start the child */
2715 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2718 /* revert stdfd to whatever it was before */
2719 if (win32_dup2(oldfd, stdfd) == -1)
2722 /* restore the old std handle (this needs to happen after the
2723 * dup2(), since that might call SetStdHandle() too */
2725 SetStdHandle(nhandle, old_h);
2730 /* close saved handle */
2734 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2737 /* set process id so that it can be returned by perl's open() */
2738 PL_forkprocess = childpid;
2741 /* we have an fd, return a file stream */
2742 return (PerlIO_fdopen(p[parent], (char *)mode));
2745 /* we don't need to check for errors here */
2749 SetStdHandle(nhandle, old_h);
2754 win32_dup2(oldfd, stdfd);
2759 #endif /* USE_RTL_POPEN */
2767 win32_pclose(PerlIO *pf)
2769 #ifdef USE_RTL_POPEN
2773 int childpid, status;
2777 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2780 childpid = SvIVX(sv);
2797 if (win32_waitpid(childpid, &status, 0) == -1)
2802 #endif /* USE_RTL_POPEN */
2808 LPCWSTR lpExistingFileName,
2809 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2812 WCHAR wFullName[MAX_PATH+1];
2813 LPVOID lpContext = NULL;
2814 WIN32_STREAM_ID StreamId;
2815 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2820 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2821 BOOL, BOOL, LPVOID*) =
2822 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2823 BOOL, BOOL, LPVOID*))
2824 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2825 if (pfnBackupWrite == NULL)
2828 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2831 dwLen = (dwLen+1)*sizeof(WCHAR);
2833 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2834 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2835 NULL, OPEN_EXISTING, 0, NULL);
2836 if (handle == INVALID_HANDLE_VALUE)
2839 StreamId.dwStreamId = BACKUP_LINK;
2840 StreamId.dwStreamAttributes = 0;
2841 StreamId.dwStreamNameSize = 0;
2842 #if defined(__BORLANDC__) \
2843 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2844 StreamId.Size.u.HighPart = 0;
2845 StreamId.Size.u.LowPart = dwLen;
2847 StreamId.Size.HighPart = 0;
2848 StreamId.Size.LowPart = dwLen;
2851 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2852 FALSE, FALSE, &lpContext);
2854 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2855 FALSE, FALSE, &lpContext);
2856 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2859 CloseHandle(handle);
2864 win32_link(const char *oldname, const char *newname)
2867 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2868 WCHAR wOldName[MAX_PATH+1];
2869 WCHAR wNewName[MAX_PATH+1];
2872 Perl_croak(aTHX_ PL_no_func, "link");
2874 pfnCreateHardLinkW =
2875 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2876 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2877 if (pfnCreateHardLinkW == NULL)
2878 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2880 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2881 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2882 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2883 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2887 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2892 win32_rename(const char *oname, const char *newname)
2894 char szOldName[MAX_PATH+1];
2895 char szNewName[MAX_PATH+1];
2899 /* XXX despite what the documentation says about MoveFileEx(),
2900 * it doesn't work under Windows95!
2903 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2904 if (stricmp(newname, oname))
2905 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2906 strcpy(szOldName, PerlDir_mapA(oname));
2907 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2909 DWORD err = GetLastError();
2911 case ERROR_BAD_NET_NAME:
2912 case ERROR_BAD_NETPATH:
2913 case ERROR_BAD_PATHNAME:
2914 case ERROR_FILE_NOT_FOUND:
2915 case ERROR_FILENAME_EXCED_RANGE:
2916 case ERROR_INVALID_DRIVE:
2917 case ERROR_NO_MORE_FILES:
2918 case ERROR_PATH_NOT_FOUND:
2931 char szTmpName[MAX_PATH+1];
2932 char dname[MAX_PATH+1];
2933 char *endname = Nullch;
2935 DWORD from_attr, to_attr;
2937 strcpy(szOldName, PerlDir_mapA(oname));
2938 strcpy(szNewName, PerlDir_mapA(newname));
2940 /* if oname doesn't exist, do nothing */
2941 from_attr = GetFileAttributes(szOldName);
2942 if (from_attr == 0xFFFFFFFF) {
2947 /* if newname exists, rename it to a temporary name so that we
2948 * don't delete it in case oname happens to be the same file
2949 * (but perhaps accessed via a different path)
2951 to_attr = GetFileAttributes(szNewName);
2952 if (to_attr != 0xFFFFFFFF) {
2953 /* if newname is a directory, we fail
2954 * XXX could overcome this with yet more convoluted logic */
2955 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2959 tmplen = strlen(szNewName);
2960 strcpy(szTmpName,szNewName);
2961 endname = szTmpName+tmplen;
2962 for (; endname > szTmpName ; --endname) {
2963 if (*endname == '/' || *endname == '\\') {
2968 if (endname > szTmpName)
2969 endname = strcpy(dname,szTmpName);
2973 /* get a temporary filename in same directory
2974 * XXX is this really the best we can do? */
2975 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2979 DeleteFile(szTmpName);
2981 retval = rename(szNewName, szTmpName);
2988 /* rename oname to newname */
2989 retval = rename(szOldName, szNewName);
2991 /* if we created a temporary file before ... */
2992 if (endname != Nullch) {
2993 /* ...and rename succeeded, delete temporary file/directory */
2995 DeleteFile(szTmpName);
2996 /* else restore it to what it was */
2998 (void)rename(szTmpName, szNewName);
3005 win32_setmode(int fd, int mode)
3007 return setmode(fd, mode);
3011 win32_chsize(int fd, Off_t size)
3013 #if defined(WIN64) || defined(USE_LARGE_FILES)
3015 Off_t cur, end, extend;
3017 cur = win32_tell(fd);
3020 end = win32_lseek(fd, 0, SEEK_END);
3023 extend = size - end;
3027 else if (extend > 0) {
3028 /* must grow the file, padding with nulls */
3030 int oldmode = win32_setmode(fd, O_BINARY);
3032 memset(b, '\0', sizeof(b));
3034 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3035 count = win32_write(fd, b, count);
3036 if ((int)count < 0) {
3040 } while ((extend -= count) > 0);
3041 win32_setmode(fd, oldmode);
3044 /* shrink the file */
3045 win32_lseek(fd, size, SEEK_SET);
3046 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3052 win32_lseek(fd, cur, SEEK_SET);
3055 return chsize(fd, (long)size);
3060 win32_lseek(int fd, Off_t offset, int origin)
3062 #if defined(WIN64) || defined(USE_LARGE_FILES)
3063 #if defined(__BORLANDC__) /* buk */
3065 pos.QuadPart = offset;
3066 pos.LowPart = SetFilePointer(
3067 (HANDLE)_get_osfhandle(fd),
3072 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3076 return pos.QuadPart;
3078 return _lseeki64(fd, offset, origin);
3081 return lseek(fd, (long)offset, origin);
3088 #if defined(WIN64) || defined(USE_LARGE_FILES)
3089 #if defined(__BORLANDC__) /* buk */
3092 pos.LowPart = SetFilePointer(
3093 (HANDLE)_get_osfhandle(fd),
3098 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3102 return pos.QuadPart;
3103 /* return tell(fd); */
3105 return _telli64(fd);
3113 win32_open(const char *path, int flag, ...)
3120 pmode = va_arg(ap, int);
3123 if (stricmp(path, "/dev/null")==0)
3126 return open(PerlDir_mapA(path), flag, pmode);
3129 /* close() that understands socket */
3130 extern int my_close(int); /* in win32sck.c */
3135 return my_close(fd);
3151 win32_dup2(int fd1,int fd2)
3153 return dup2(fd1,fd2);
3156 #ifdef PERL_MSVCRT_READFIX
3158 #define LF 10 /* line feed */
3159 #define CR 13 /* carriage return */
3160 #define CTRLZ 26 /* ctrl-z means eof for text */
3161 #define FOPEN 0x01 /* file handle open */
3162 #define FEOFLAG 0x02 /* end of file has been encountered */
3163 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3164 #define FPIPE 0x08 /* file handle refers to a pipe */
3165 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3166 #define FDEV 0x40 /* file handle refers to device */
3167 #define FTEXT 0x80 /* file handle is in text mode */
3168 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3171 _fixed_read(int fh, void *buf, unsigned cnt)
3173 int bytes_read; /* number of bytes read */
3174 char *buffer; /* buffer to read to */
3175 int os_read; /* bytes read on OS call */
3176 char *p, *q; /* pointers into buffer */
3177 char peekchr; /* peek-ahead character */
3178 ULONG filepos; /* file position after seek */
3179 ULONG dosretval; /* o.s. return value */
3181 /* validate handle */
3182 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3183 !(_osfile(fh) & FOPEN))
3185 /* out of range -- return error */
3187 _doserrno = 0; /* not o.s. error */
3192 * If lockinitflag is FALSE, assume fd is device
3193 * lockinitflag is set to TRUE by open.
3195 if (_pioinfo(fh)->lockinitflag)
3196 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3198 bytes_read = 0; /* nothing read yet */
3199 buffer = (char*)buf;
3201 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3202 /* nothing to read or at EOF, so return 0 read */
3206 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3207 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3209 *buffer++ = _pipech(fh);
3212 _pipech(fh) = LF; /* mark as empty */
3217 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3219 /* ReadFile has reported an error. recognize two special cases.
3221 * 1. map ERROR_ACCESS_DENIED to EBADF
3223 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3224 * means the handle is a read-handle on a pipe for which
3225 * all write-handles have been closed and all data has been
3228 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3229 /* wrong read/write mode should return EBADF, not EACCES */
3231 _doserrno = dosretval;
3235 else if (dosretval == ERROR_BROKEN_PIPE) {
3245 bytes_read += os_read; /* update bytes read */
3247 if (_osfile(fh) & FTEXT) {
3248 /* now must translate CR-LFs to LFs in the buffer */
3250 /* set CRLF flag to indicate LF at beginning of buffer */
3251 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3252 /* _osfile(fh) |= FCRLF; */
3254 /* _osfile(fh) &= ~FCRLF; */
3256 _osfile(fh) &= ~FCRLF;
3258 /* convert chars in the buffer: p is src, q is dest */
3260 while (p < (char *)buf + bytes_read) {
3262 /* if fh is not a device, set ctrl-z flag */
3263 if (!(_osfile(fh) & FDEV))
3264 _osfile(fh) |= FEOFLAG;
3265 break; /* stop translating */
3270 /* *p is CR, so must check next char for LF */
3271 if (p < (char *)buf + bytes_read - 1) {
3274 *q++ = LF; /* convert CR-LF to LF */
3277 *q++ = *p++; /* store char normally */
3280 /* This is the hard part. We found a CR at end of
3281 buffer. We must peek ahead to see if next char
3286 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3287 (LPDWORD)&os_read, NULL))
3288 dosretval = GetLastError();
3290 if (dosretval != 0 || os_read == 0) {
3291 /* couldn't read ahead, store CR */
3295 /* peekchr now has the extra character -- we now
3296 have several possibilities:
3297 1. disk file and char is not LF; just seek back
3299 2. disk file and char is LF; store LF, don't seek back
3300 3. pipe/device and char is LF; store LF.
3301 4. pipe/device and char isn't LF, store CR and
3302 put char in pipe lookahead buffer. */
3303 if (_osfile(fh) & (FDEV|FPIPE)) {
3304 /* non-seekable device */
3309 _pipech(fh) = peekchr;
3314 if (peekchr == LF) {
3315 /* nothing read yet; must make some
3318 /* turn on this flag for tell routine */
3319 _osfile(fh) |= FCRLF;
3322 HANDLE osHandle; /* o.s. handle value */
3324 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3326 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3327 dosretval = GetLastError();
3338 /* we now change bytes_read to reflect the true number of chars
3340 bytes_read = q - (char *)buf;
3344 if (_pioinfo(fh)->lockinitflag)
3345 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3350 #endif /* PERL_MSVCRT_READFIX */
3353 win32_read(int fd, void *buf, unsigned int cnt)
3355 #ifdef PERL_MSVCRT_READFIX
3356 return _fixed_read(fd, buf, cnt);
3358 return read(fd, buf, cnt);
3363 win32_write(int fd, const void *buf, unsigned int cnt)
3365 return write(fd, buf, cnt);
3369 win32_mkdir(const char *dir, int mode)
3372 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3376 win32_rmdir(const char *dir)
3379 return rmdir(PerlDir_mapA(dir));
3383 win32_chdir(const char *dir)
3394 win32_access(const char *path, int mode)
3397 return access(PerlDir_mapA(path), mode);
3401 win32_chmod(const char *path, int mode)
3404 return chmod(PerlDir_mapA(path), mode);
3409 create_command_line(char *cname, STRLEN clen, const char * const *args)
3416 bool bat_file = FALSE;
3417 bool cmd_shell = FALSE;
3418 bool dumb_shell = FALSE;
3419 bool extra_quotes = FALSE;
3420 bool quote_next = FALSE;
3423 cname = (char*)args[0];
3425 /* The NT cmd.exe shell has the following peculiarity that needs to be
3426 * worked around. It strips a leading and trailing dquote when any
3427 * of the following is true:
3428 * 1. the /S switch was used
3429 * 2. there are more than two dquotes
3430 * 3. there is a special character from this set: &<>()@^|
3431 * 4. no whitespace characters within the two dquotes
3432 * 5. string between two dquotes isn't an executable file
3433 * To work around this, we always add a leading and trailing dquote
3434 * to the string, if the first argument is either "cmd.exe" or "cmd",
3435 * and there were at least two or more arguments passed to cmd.exe
3436 * (not including switches).
3437 * XXX the above rules (from "cmd /?") don't seem to be applied
3438 * always, making for the convolutions below :-(
3442 clen = strlen(cname);
3445 && (stricmp(&cname[clen-4], ".bat") == 0
3446 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3453 char *exe = strrchr(cname, '/');
3454 char *exe2 = strrchr(cname, '\\');
3461 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3465 else if (stricmp(exe, "command.com") == 0
3466 || stricmp(exe, "command") == 0)
3473 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3474 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3475 STRLEN curlen = strlen(arg);
3476 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3477 len += 2; /* assume quoting needed (worst case) */
3479 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3481 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3484 Newx(cmd, len, char);
3487 if (bat_file && !IsWin95()) {
3489 extra_quotes = TRUE;
3492 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3494 STRLEN curlen = strlen(arg);
3496 /* we want to protect empty arguments and ones with spaces with
3497 * dquotes, but only if they aren't already there */
3502 else if (quote_next) {
3503 /* see if it really is multiple arguments pretending to
3504 * be one and force a set of quotes around it */
3505 if (*find_next_space(arg))
3508 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3510 while (i < curlen) {
3511 if (isSPACE(arg[i])) {
3514 else if (arg[i] == '"') {
3538 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3539 && stricmp(arg+curlen-2, "/c") == 0)
3541 /* is there a next argument? */
3542 if (args[index+1]) {
3543 /* are there two or more next arguments? */
3544 if (args[index+2]) {
3546 extra_quotes = TRUE;
3549 /* single argument, force quoting if it has spaces */
3565 qualified_path(const char *cmd)
3569 char *fullcmd, *curfullcmd;
3575 fullcmd = (char*)cmd;
3577 if (*fullcmd == '/' || *fullcmd == '\\')
3584 pathstr = PerlEnv_getenv("PATH");
3586 /* worst case: PATH is a single directory; we need additional space
3587 * to append "/", ".exe" and trailing "\0" */
3588 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3589 curfullcmd = fullcmd;
3594 /* start by appending the name to the current prefix */
3595 strcpy(curfullcmd, cmd);
3596 curfullcmd += cmdlen;
3598 /* if it doesn't end with '.', or has no extension, try adding
3599 * a trailing .exe first */
3600 if (cmd[cmdlen-1] != '.'
3601 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3603 strcpy(curfullcmd, ".exe");
3604 res = GetFileAttributes(fullcmd);
3605 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3610 /* that failed, try the bare name */
3611 res = GetFileAttributes(fullcmd);
3612 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3615 /* quit if no other path exists, or if cmd already has path */
3616 if (!pathstr || !*pathstr || has_slash)
3619 /* skip leading semis */
3620 while (*pathstr == ';')
3623 /* build a new prefix from scratch */
3624 curfullcmd = fullcmd;
3625 while (*pathstr && *pathstr != ';') {
3626 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3627 pathstr++; /* skip initial '"' */
3628 while (*pathstr && *pathstr != '"') {
3629 *curfullcmd++ = *pathstr++;
3632 pathstr++; /* skip trailing '"' */
3635 *curfullcmd++ = *pathstr++;
3639 pathstr++; /* skip trailing semi */
3640 if (curfullcmd > fullcmd /* append a dir separator */
3641 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3643 *curfullcmd++ = '\\';
3651 /* The following are just place holders.
3652 * Some hosts may provide and environment that the OS is
3653 * not tracking, therefore, these host must provide that
3654 * environment and the current directory to CreateProcess
3658 win32_get_childenv(void)
3664 win32_free_childenv(void* d)
3669 win32_clearenv(void)
3671 char *envv = GetEnvironmentStrings();
3675 char *end = strchr(cur,'=');
3676 if (end && end != cur) {
3678 SetEnvironmentVariable(cur, NULL);
3680 cur = end + strlen(end+1)+2;
3682 else if ((len = strlen(cur)))
3685 FreeEnvironmentStrings(envv);
3689 win32_get_childdir(void)
3693 char szfilename[MAX_PATH+1];
3695 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3696 Newx(ptr, strlen(szfilename)+1, char);
3697 strcpy(ptr, szfilename);
3702 win32_free_childdir(char* d)
3709 /* XXX this needs to be made more compatible with the spawnvp()
3710 * provided by the various RTLs. In particular, searching for
3711 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3712 * This doesn't significantly affect perl itself, because we
3713 * always invoke things using PERL5SHELL if a direct attempt to
3714 * spawn the executable fails.
3716 * XXX splitting and rejoining the commandline between do_aspawn()
3717 * and win32_spawnvp() could also be avoided.
3721 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3723 #ifdef USE_RTL_SPAWNVP
3724 return spawnvp(mode, cmdname, (char * const *)argv);
3731 STARTUPINFO StartupInfo;
3732 PROCESS_INFORMATION ProcessInformation;
3735 char *fullcmd = Nullch;
3736 char *cname = (char *)cmdname;
3740 clen = strlen(cname);
3741 /* if command name contains dquotes, must remove them */
3742 if (strchr(cname, '"')) {
3744 Newx(cname,clen+1,char);
3757 cmd = create_command_line(cname, clen, argv);
3759 env = PerlEnv_get_childenv();
3760 dir = PerlEnv_get_childdir();
3763 case P_NOWAIT: /* asynch + remember result */
3764 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3769 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3772 create |= CREATE_NEW_PROCESS_GROUP;
3775 case P_WAIT: /* synchronous execution */
3777 default: /* invalid mode */
3782 memset(&StartupInfo,0,sizeof(StartupInfo));
3783 StartupInfo.cb = sizeof(StartupInfo);
3784 memset(&tbl,0,sizeof(tbl));
3785 PerlEnv_get_child_IO(&tbl);
3786 StartupInfo.dwFlags = tbl.dwFlags;
3787 StartupInfo.dwX = tbl.dwX;
3788 StartupInfo.dwY = tbl.dwY;
3789 StartupInfo.dwXSize = tbl.dwXSize;
3790 StartupInfo.dwYSize = tbl.dwYSize;
3791 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3792 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3793 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3794 StartupInfo.wShowWindow = tbl.wShowWindow;
3795 StartupInfo.hStdInput = tbl.childStdIn;
3796 StartupInfo.hStdOutput = tbl.childStdOut;
3797 StartupInfo.hStdError = tbl.childStdErr;
3798 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3799 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3800 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3802 create |= CREATE_NEW_CONSOLE;
3805 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3807 if (w32_use_showwindow) {
3808 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3809 StartupInfo.wShowWindow = w32_showwindow;
3812 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3815 if (!CreateProcess(cname, /* search PATH to find executable */
3816 cmd, /* executable, and its arguments */
3817 NULL, /* process attributes */
3818 NULL, /* thread attributes */
3819 TRUE, /* inherit handles */
3820 create, /* creation flags */
3821 (LPVOID)env, /* inherit environment */
3822 dir, /* inherit cwd */
3824 &ProcessInformation))
3826 /* initial NULL argument to CreateProcess() does a PATH
3827 * search, but it always first looks in the directory
3828 * where the current process was started, which behavior
3829 * is undesirable for backward compatibility. So we
3830 * jump through our own hoops by picking out the path
3831 * we really want it to use. */
3833 fullcmd = qualified_path(cname);
3835 if (cname != cmdname)
3838 DEBUG_p(PerlIO_printf(Perl_debug_log,
3839 "Retrying [%s] with same args\n",
3849 if (mode == P_NOWAIT) {
3850 /* asynchronous spawn -- store handle, return PID */
3851 ret = (int)ProcessInformation.dwProcessId;
3852 if (IsWin95() && ret < 0)
3855 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3856 w32_child_pids[w32_num_children] = (DWORD)ret;
3861 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3862 /* FIXME: if msgwait returned due to message perhaps forward the
3863 "signal" to the process
3865 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3867 CloseHandle(ProcessInformation.hProcess);
3870 CloseHandle(ProcessInformation.hThread);
3873 PerlEnv_free_childenv(env);
3874 PerlEnv_free_childdir(dir);
3876 if (cname != cmdname)
3883 win32_execv(const char *cmdname, const char *const *argv)
3887 /* if this is a pseudo-forked child, we just want to spawn
3888 * the new program, and return */
3890 # ifdef __BORLANDC__
3891 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3893 return spawnv(P_WAIT, cmdname, argv);
3897 return execv(cmdname, (char *const *)argv);
3899 return execv(cmdname, argv);
3904 win32_execvp(const char *cmdname, const char *const *argv)
3908 /* if this is a pseudo-forked child, we just want to spawn
3909 * the new program, and return */
3910 if (w32_pseudo_id) {
3911 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3921 return execvp(cmdname, (char *const *)argv);
3923 return execvp(cmdname, argv);
3928 win32_perror(const char *str)
3934 win32_setbuf(FILE *pf, char *buf)
3940 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3942 return setvbuf(pf, buf, type, size);
3946 win32_flushall(void)
3952 win32_fcloseall(void)
3958 win32_fgets(char *s, int n, FILE *pf)
3960 return fgets(s, n, pf);
3970 win32_fgetc(FILE *pf)
3976 win32_putc(int c, FILE *pf)
3982 win32_puts(const char *s)
3994 win32_putchar(int c)
4001 #ifndef USE_PERL_SBRK
4003 static char *committed = NULL; /* XXX threadead */
4004 static char *base = NULL; /* XXX threadead */
4005 static char *reserved = NULL; /* XXX threadead */
4006 static char *brk = NULL; /* XXX threadead */
4007 static DWORD pagesize = 0; /* XXX threadead */
4010 sbrk(ptrdiff_t need)
4015 GetSystemInfo(&info);
4016 /* Pretend page size is larger so we don't perpetually
4017 * call the OS to commit just one page ...
4019 pagesize = info.dwPageSize << 3;
4021 if (brk+need >= reserved)
4023 DWORD size = brk+need-reserved;
4025 char *prev_committed = NULL;
4026 if (committed && reserved && committed < reserved)
4028 /* Commit last of previous chunk cannot span allocations */
4029 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4032 /* Remember where we committed from in case we want to decommit later */
4033 prev_committed = committed;
4034 committed = reserved;
4037 /* Reserve some (more) space
4038 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4039 * this is only address space not memory...
4040 * Note this is a little sneaky, 1st call passes NULL as reserved
4041 * so lets system choose where we start, subsequent calls pass
4042 * the old end address so ask for a contiguous block
4045 if (size < 64*1024*1024)
4046 size = 64*1024*1024;
4047 size = ((size + pagesize - 1) / pagesize) * pagesize;
4048 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4051 reserved = addr+size;
4061 /* The existing block could not be extended far enough, so decommit
4062 * anything that was just committed above and start anew */
4065 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4068 reserved = base = committed = brk = NULL;
4079 if (brk > committed)
4081 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4083 if (committed+size > reserved)
4084 size = reserved-committed;
4085 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4098 win32_malloc(size_t size)
4100 return malloc(size);
4104 win32_calloc(size_t numitems, size_t size)
4106 return calloc(numitems,size);
4110 win32_realloc(void *block, size_t size)
4112 return realloc(block,size);
4116 win32_free(void *block)
4123 win32_open_osfhandle(intptr_t handle, int flags)
4125 #ifdef USE_FIXED_OSFHANDLE
4127 return my_open_osfhandle(handle, flags);
4129 return _open_osfhandle(handle, flags);
4133 win32_get_osfhandle(int fd)
4135 return (intptr_t)_get_osfhandle(fd);
4139 win32_fdupopen(FILE *pf)
4144 int fileno = win32_dup(win32_fileno(pf));
4146 /* open the file in the same mode */
4148 if((pf)->flags & _F_READ) {
4152 else if((pf)->flags & _F_WRIT) {
4156 else if((pf)->flags & _F_RDWR) {
4162 if((pf)->_flag & _IOREAD) {
4166 else if((pf)->_flag & _IOWRT) {
4170 else if((pf)->_flag & _IORW) {
4177 /* it appears that the binmode is attached to the
4178 * file descriptor so binmode files will be handled
4181 pfdup = win32_fdopen(fileno, mode);
4183 /* move the file pointer to the same position */
4184 if (!fgetpos(pf, &pos)) {
4185 fsetpos(pfdup, &pos);
4191 win32_dynaload(const char* filename)
4194 char buf[MAX_PATH+1];
4197 /* LoadLibrary() doesn't recognize forward slashes correctly,
4198 * so turn 'em back. */
4199 first = strchr(filename, '/');
4201 STRLEN len = strlen(filename);
4202 if (len <= MAX_PATH) {
4203 strcpy(buf, filename);
4204 filename = &buf[first - filename];
4206 if (*filename == '/')
4207 *(char*)filename = '\\';
4213 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4221 XS(w32_SetChildShowWindow)
4224 BOOL use_showwindow = w32_use_showwindow;
4225 /* use "unsigned short" because Perl has redefined "WORD" */
4226 unsigned short showwindow = w32_showwindow;
4229 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4231 if (items == 0 || !SvOK(ST(0)))
4232 w32_use_showwindow = FALSE;
4234 w32_use_showwindow = TRUE;
4235 w32_showwindow = (unsigned short)SvIV(ST(0));
4240 ST(0) = sv_2mortal(newSViv(showwindow));
4242 ST(0) = &PL_sv_undef;
4250 /* Make the host for current directory */
4251 char* ptr = PerlEnv_get_childdir();
4254 * then it worked, set PV valid,
4255 * else return 'undef'
4258 SV *sv = sv_newmortal();
4260 PerlEnv_free_childdir(ptr);
4262 #ifndef INCOMPLETE_TAINTS
4279 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4280 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4287 XS(w32_GetNextAvailDrive)
4291 char root[] = "_:\\";
4296 if (GetDriveType(root) == 1) {
4305 XS(w32_GetLastError)
4309 XSRETURN_IV(GetLastError());
4313 XS(w32_SetLastError)
4317 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4318 SetLastError(SvIV(ST(0)));
4326 char *name = w32_getlogin_buffer;
4327 DWORD size = sizeof(w32_getlogin_buffer);
4329 if (GetUserName(name,&size)) {
4330 /* size includes NULL */
4331 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4341 char name[MAX_COMPUTERNAME_LENGTH+1];
4342 DWORD size = sizeof(name);
4344 if (GetComputerName(name,&size)) {
4345 /* size does NOT include NULL :-( */
4346 ST(0) = sv_2mortal(newSVpvn(name,size));
4357 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4358 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4359 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4363 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4364 GetProcAddress(hNetApi32, "NetApiBufferFree");
4365 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4366 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4369 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4370 /* this way is more reliable, in case user has a local account. */
4372 DWORD dnamelen = sizeof(dname);
4374 DWORD wki100_platform_id;
4375 LPWSTR wki100_computername;
4376 LPWSTR wki100_langroup;
4377 DWORD wki100_ver_major;
4378 DWORD wki100_ver_minor;
4380 /* NERR_Success *is* 0*/
4381 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4382 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4383 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4384 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4387 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4388 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4390 pfnNetApiBufferFree(pwi);
4391 FreeLibrary(hNetApi32);
4394 FreeLibrary(hNetApi32);
4397 /* Win95 doesn't have NetWksta*(), so do it the old way */
4399 DWORD size = sizeof(name);
4401 FreeLibrary(hNetApi32);
4402 if (GetUserName(name,&size)) {
4403 char sid[ONE_K_BUFSIZE];
4404 DWORD sidlen = sizeof(sid);
4406 DWORD dnamelen = sizeof(dname);
4408 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4409 dname, &dnamelen, &snu)) {
4410 XSRETURN_PV(dname); /* all that for this */
4422 DWORD flags, filecomplen;
4423 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4424 &flags, fsname, sizeof(fsname))) {
4425 if (GIMME_V == G_ARRAY) {
4426 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4427 XPUSHs(sv_2mortal(newSViv(flags)));
4428 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4433 XSRETURN_PV(fsname);
4439 XS(w32_GetOSVersion)
4442 /* Use explicit struct definition because wSuiteMask and
4443 * wProductType are not defined in the VC++ 6.0 headers.
4444 * WORD type has been replaced by unsigned short because
4445 * WORD is already used by Perl itself.
4448 DWORD dwOSVersionInfoSize;
4449 DWORD dwMajorVersion;
4450 DWORD dwMinorVersion;
4451 DWORD dwBuildNumber;
4453 CHAR szCSDVersion[128];
4454 unsigned short wServicePackMajor;
4455 unsigned short wServicePackMinor;
4456 unsigned short wSuiteMask;
4462 osver.dwOSVersionInfoSize = sizeof(osver);
4463 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4465 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4466 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4470 if (GIMME_V == G_SCALAR) {
4471 XSRETURN_IV(osver.dwPlatformId);
4473 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4475 XPUSHs(newSViv(osver.dwMajorVersion));
4476 XPUSHs(newSViv(osver.dwMinorVersion));
4477 XPUSHs(newSViv(osver.dwBuildNumber));
4478 XPUSHs(newSViv(osver.dwPlatformId));
4480 XPUSHs(newSViv(osver.wServicePackMajor));
4481 XPUSHs(newSViv(osver.wServicePackMinor));
4482 XPUSHs(newSViv(osver.wSuiteMask));
4483 XPUSHs(newSViv(osver.wProductType));
4493 XSRETURN_IV(IsWinNT());
4501 XSRETURN_IV(IsWin95());
4505 XS(w32_FormatMessage)
4509 char msgbuf[ONE_K_BUFSIZE];
4512 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4514 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4515 &source, SvIV(ST(0)), 0,
4516 msgbuf, sizeof(msgbuf)-1, NULL))
4518 XSRETURN_PV(msgbuf);
4531 PROCESS_INFORMATION stProcInfo;
4532 STARTUPINFO stStartInfo;
4533 BOOL bSuccess = FALSE;
4536 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4538 cmd = SvPV_nolen(ST(0));
4539 args = SvPV_nolen(ST(1));
4541 env = PerlEnv_get_childenv();
4542 dir = PerlEnv_get_childdir();
4544 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4545 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4546 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4547 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4550 cmd, /* Image path */
4551 args, /* Arguments for command line */
4552 NULL, /* Default process security */
4553 NULL, /* Default thread security */
4554 FALSE, /* Must be TRUE to use std handles */
4555 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4556 env, /* Inherit our environment block */
4557 dir, /* Inherit our currrent directory */
4558 &stStartInfo, /* -> Startup info */
4559 &stProcInfo)) /* <- Process info (if OK) */
4561 int pid = (int)stProcInfo.dwProcessId;
4562 if (IsWin95() && pid < 0)
4564 sv_setiv(ST(2), pid);
4565 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4568 PerlEnv_free_childenv(env);
4569 PerlEnv_free_childdir(dir);
4570 XSRETURN_IV(bSuccess);
4574 XS(w32_GetTickCount)
4577 DWORD msec = GetTickCount();
4585 XS(w32_GetShortPathName)
4592 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4594 shortpath = sv_mortalcopy(ST(0));
4595 SvUPGRADE(shortpath, SVt_PV);
4596 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4599 /* src == target is allowed */
4601 len = GetShortPathName(SvPVX(shortpath),
4604 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4606 SvCUR_set(shortpath,len);
4607 *SvEND(shortpath) = '\0';
4615 XS(w32_GetFullPathName)
4622 STRLEN filename_len;
4626 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4629 filename_p = SvPV(filename, filename_len);
4630 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4631 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4635 len = GetFullPathName(SvPVX(filename),
4639 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4641 if (GIMME_V == G_ARRAY) {
4644 XST_mPV(1,filepart);
4645 len = filepart - SvPVX(fullpath);
4652 SvCUR_set(fullpath,len);
4653 *SvEND(fullpath) = '\0';
4661 XS(w32_GetLongPathName)
4665 char tmpbuf[MAX_PATH+1];
4670 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4673 pathstr = SvPV(path,len);
4674 strcpy(tmpbuf, pathstr);
4675 pathstr = win32_longpath(tmpbuf);
4677 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4688 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4698 char szSourceFile[MAX_PATH+1];
4701 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4702 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4703 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4710 Perl_init_os_extras(void)
4713 char *file = __FILE__;
4716 /* these names are Activeware compatible */
4717 newXS("Win32::GetCwd", w32_GetCwd, file);
4718 newXS("Win32::SetCwd", w32_SetCwd, file);
4719 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4720 newXS("Win32::GetLastError", w32_GetLastError, file);
4721 newXS("Win32::SetLastError", w32_SetLastError, file);
4722 newXS("Win32::LoginName", w32_LoginName, file);
4723 newXS("Win32::NodeName", w32_NodeName, file);
4724 newXS("Win32::DomainName", w32_DomainName, file);
4725 newXS("Win32::FsType", w32_FsType, file);
4726 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4727 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4728 newXS("Win32::IsWin95", w32_IsWin95, file);
4729 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4730 newXS("Win32::Spawn", w32_Spawn, file);
4731 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4732 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4733 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4734 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4735 newXS("Win32::CopyFile", w32_CopyFile, file);
4736 newXS("Win32::Sleep", w32_Sleep, file);
4737 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4739 /* XXX Bloat Alert! The following Activeware preloads really
4740 * ought to be part of Win32::Sys::*, so they're not included
4743 /* LookupAccountName
4745 * InitiateSystemShutdown
4746 * AbortSystemShutdown
4747 * ExpandEnvrironmentStrings
4752 win32_signal_context(void)
4757 my_perl = PL_curinterp;
4758 PERL_SET_THX(my_perl);
4762 return PL_curinterp;
4768 win32_ctrlhandler(DWORD dwCtrlType)
4771 dTHXa(PERL_GET_SIG_CONTEXT);
4777 switch(dwCtrlType) {
4778 case CTRL_CLOSE_EVENT:
4779 /* A signal that the system sends to all processes attached to a console when
4780 the user closes the console (either by choosing the Close command from the
4781 console window's System menu, or by choosing the End Task command from the
4784 if (do_raise(aTHX_ 1)) /* SIGHUP */
4785 sig_terminate(aTHX_ 1);
4789 /* A CTRL+c signal was received */
4790 if (do_raise(aTHX_ SIGINT))
4791 sig_terminate(aTHX_ SIGINT);
4794 case CTRL_BREAK_EVENT:
4795 /* A CTRL+BREAK signal was received */
4796 if (do_raise(aTHX_ SIGBREAK))
4797 sig_terminate(aTHX_ SIGBREAK);
4800 case CTRL_LOGOFF_EVENT:
4801 /* A signal that the system sends to all console processes when a user is logging
4802 off. This signal does not indicate which user is logging off, so no
4803 assumptions can be made.
4806 case CTRL_SHUTDOWN_EVENT:
4807 /* A signal that the system sends to all console processes when the system is
4810 if (do_raise(aTHX_ SIGTERM))
4811 sig_terminate(aTHX_ SIGTERM);
4821 Perl_win32_init(int *argcp, char ***argvp)
4823 /* Disable floating point errors, Perl will trap the ones we
4824 * care about. VC++ RTL defaults to switching these off
4825 * already, but the Borland RTL doesn't. Since we don't
4826 * want to be at the vendor's whim on the default, we set
4827 * it explicitly here.
4829 #if !defined(_ALPHA_) && !defined(__GNUC__)
4830 _control87(MCW_EM, MCW_EM);
4836 Perl_win32_term(void)
4843 win32_get_child_IO(child_IO_table* ptbl)
4845 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4846 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4847 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4851 win32_signal(int sig, Sighandler_t subcode)
4854 if (sig < SIG_SIZE) {
4855 int save_errno = errno;
4856 Sighandler_t result = signal(sig, subcode);
4857 if (result == SIG_ERR) {
4858 result = w32_sighandler[sig];
4861 w32_sighandler[sig] = subcode;
4871 #ifdef HAVE_INTERP_INTERN
4875 win32_csighandler(int sig)
4878 dTHXa(PERL_GET_SIG_CONTEXT);
4879 Perl_warn(aTHX_ "Got signal %d",sig);
4885 Perl_sys_intern_init(pTHX)
4888 w32_perlshell_tokens = Nullch;
4889 w32_perlshell_vec = (char**)NULL;
4890 w32_perlshell_items = 0;
4891 w32_fdpid = newAV();
4892 Newx(w32_children, 1, child_tab);
4893 w32_num_children = 0;
4894 # ifdef USE_ITHREADS
4896 Newx(w32_pseudo_children, 1, child_tab);
4897 w32_num_pseudo_children = 0;
4901 for (i=0; i < SIG_SIZE; i++) {
4902 w32_sighandler[i] = SIG_DFL;
4905 if (my_perl == PL_curinterp) {
4909 /* Force C runtime signal stuff to set its console handler */
4910 signal(SIGINT,win32_csighandler);
4911 signal(SIGBREAK,win32_csighandler);
4912 /* Push our handler on top */
4913 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4918 Perl_sys_intern_clear(pTHX)
4920 Safefree(w32_perlshell_tokens);
4921 Safefree(w32_perlshell_vec);
4922 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4923 Safefree(w32_children);
4925 KillTimer(NULL,w32_timerid);
4928 # ifdef MULTIPLICITY
4929 if (my_perl == PL_curinterp) {
4933 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4935 # ifdef USE_ITHREADS
4936 Safefree(w32_pseudo_children);
4940 # ifdef USE_ITHREADS
4943 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4945 dst->perlshell_tokens = Nullch;
4946 dst->perlshell_vec = (char**)NULL;
4947 dst->perlshell_items = 0;
4948 dst->fdpid = newAV();
4949 Newxz(dst->children, 1, child_tab);
4951 Newxz(dst->pseudo_children, 1, child_tab);
4953 dst->poll_count = 0;
4954 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4956 # endif /* USE_ITHREADS */
4957 #endif /* HAVE_INTERP_INTERN */
4960 win32_free_argvw(pTHX_ void *ptr)
4962 char** argv = (char**)ptr;
4970 win32_argv2utf8(int argc, char** argv)
4975 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4976 if (lpwStr && argc) {
4978 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4979 Newxz(psz, length, char);
4980 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4983 call_atexit(win32_free_argvw, argv);
4985 GlobalFree((HGLOBAL)lpwStr);