3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
18 #ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */
19 # include <shellapi.h>
21 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
27 /* #include "config.h" */
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
38 #define PERL_NO_GET_CONTEXT
44 /* assert.h conflicts with #define of assert in perl.h */
51 #if defined(_MSC_VER) || defined(__MINGW32__)
52 #include <sys/utime.h>
57 /* Mingw32 defaults to globing command line
58 * So we turn it off like this:
63 #if defined(__MINGW32__)
64 /* Mingw32 is missing some prototypes */
65 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
72 #if defined(__BORLANDC__)
74 # define _utimbuf utimbuf
79 #define EXECF_SPAWN_NOWAIT 3
81 #if defined(PERL_IMPLICIT_SYS)
82 # undef win32_get_privlib
83 # define win32_get_privlib g_win32_get_privlib
84 # undef win32_get_sitelib
85 # define win32_get_sitelib g_win32_get_sitelib
86 # undef win32_get_vendorlib
87 # define win32_get_vendorlib g_win32_get_vendorlib
89 # define do_spawn g_do_spawn
91 # define getlogin g_getlogin
94 static void get_shell(void);
95 static long tokenize(const char *str, char **dest, char ***destv);
96 int do_spawn2(char *cmd, int exectype);
97 static BOOL has_shell_metachars(char *ptr);
98 static long filetime_to_clock(PFILETIME ft);
99 static BOOL filetime_from_time(PFILETIME ft, time_t t);
100 static char * get_emd_part(SV **leading, char *trailing, ...);
101 static void remove_dead_process(long deceased);
102 static long find_pid(int pid);
103 static char * qualified_path(const char *cmd);
104 static char * win32_get_xlib(const char *pl, const char *xlib,
105 const char *libname);
108 static void remove_dead_pseudo_process(long child);
109 static long find_pseudo_pid(int pid);
113 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
114 char w32_module_name[MAX_PATH+1];
117 static DWORD w32_platform = (DWORD)-1;
119 #define ONE_K_BUFSIZE 1024
124 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
130 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
134 set_w32_module_name(void)
137 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
138 ? GetModuleHandle(NULL)
139 : w32_perldll_handle),
140 w32_module_name, sizeof(w32_module_name));
142 /* try to get full path to binary (which may be mangled when perl is
143 * run from a 16-bit app) */
144 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
145 (void)win32_longpath(w32_module_name);
146 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
148 /* normalize to forward slashes */
149 ptr = w32_module_name;
157 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
159 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
161 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
164 const char *subkey = "Software\\Perl";
168 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
169 if (retval == ERROR_SUCCESS) {
171 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
172 if (retval == ERROR_SUCCESS
173 && (type == REG_SZ || type == REG_EXPAND_SZ))
177 *svp = sv_2mortal(newSVpvn("",0));
178 SvGROW(*svp, datalen);
179 retval = RegQueryValueEx(handle, valuename, 0, NULL,
180 (PBYTE)SvPVX(*svp), &datalen);
181 if (retval == ERROR_SUCCESS) {
183 SvCUR_set(*svp,datalen-1);
191 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
193 get_regstr(const char *valuename, SV **svp)
195 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
197 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
201 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
203 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
207 char mod_name[MAX_PATH+1];
213 va_start(ap, trailing_path);
214 strip = va_arg(ap, char *);
216 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
217 baselen = strlen(base);
219 if (!*w32_module_name) {
220 set_w32_module_name();
222 strcpy(mod_name, w32_module_name);
223 ptr = strrchr(mod_name, '/');
224 while (ptr && strip) {
225 /* look for directories to skip back */
228 ptr = strrchr(mod_name, '/');
229 /* avoid stripping component if there is no slash,
230 * or it doesn't match ... */
231 if (!ptr || stricmp(ptr+1, strip) != 0) {
232 /* ... but not if component matches m|5\.$patchlevel.*| */
233 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
234 && strncmp(strip, base, baselen) == 0
235 && strncmp(ptr+1, base, baselen) == 0))
241 strip = va_arg(ap, char *);
249 strcpy(++ptr, trailing_path);
251 /* only add directory if it exists */
252 if (GetFileAttributes(mod_name) != (DWORD) -1) {
253 /* directory exists */
256 *prev_pathp = sv_2mortal(newSVpvn("",0));
257 sv_catpvn(*prev_pathp, ";", 1);
258 sv_catpv(*prev_pathp, mod_name);
259 return SvPVX(*prev_pathp);
266 win32_get_privlib(const char *pl)
269 char *stdlib = "lib";
270 char buffer[MAX_PATH+1];
273 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
274 sprintf(buffer, "%s-%s", stdlib, pl);
275 if (!get_regstr(buffer, &sv))
276 (void)get_regstr(stdlib, &sv);
278 /* $stdlib .= ";$EMD/../../lib" */
279 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
283 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
287 char pathstr[MAX_PATH+1];
291 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
292 sprintf(regstr, "%s-%s", xlib, pl);
293 (void)get_regstr(regstr, &sv1);
296 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
297 sprintf(pathstr, "%s/%s/lib", libname, pl);
298 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
300 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
301 (void)get_regstr(xlib, &sv2);
304 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
305 sprintf(pathstr, "%s/lib", libname);
306 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
315 sv_catpvn(sv1, ";", 1);
322 win32_get_sitelib(const char *pl)
324 return win32_get_xlib(pl, "sitelib", "site");
327 #ifndef PERL_VENDORLIB_NAME
328 # define PERL_VENDORLIB_NAME "vendor"
332 win32_get_vendorlib(const char *pl)
334 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
338 has_shell_metachars(char *ptr)
344 * Scan string looking for redirection (< or >) or pipe
345 * characters (|) that are not in a quoted string.
346 * Shell variable interpolation (%VAR%) can also happen inside strings.
378 #if !defined(PERL_IMPLICIT_SYS)
379 /* since the current process environment is being updated in util.c
380 * the library functions will get the correct environment
383 Perl_my_popen(pTHX_ char *cmd, char *mode)
386 #define fixcmd(x) { \
387 char *pspace = strchr((x),' '); \
390 while (p < pspace) { \
401 PERL_FLUSHALL_FOR_CHILD;
402 return win32_popen(cmd, mode);
406 Perl_my_pclose(pTHX_ PerlIO *fp)
408 return win32_pclose(fp);
412 DllExport unsigned long
415 static OSVERSIONINFO osver;
417 if (osver.dwPlatformId != w32_platform) {
418 memset(&osver, 0, sizeof(OSVERSIONINFO));
419 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
420 GetVersionEx(&osver);
421 w32_platform = osver.dwPlatformId;
423 return (unsigned long)w32_platform;
433 return -((int)w32_pseudo_id);
436 /* Windows 9x appears to always reports a pid for threads and processes
437 * that has the high bit set. So we treat the lower 31 bits as the
438 * "real" PID for Perl's purposes. */
439 if (IsWin95() && pid < 0)
444 /* Tokenize a string. Words are null-separated, and the list
445 * ends with a doubled null. Any character (except null and
446 * including backslash) may be escaped by preceding it with a
447 * backslash (the backslash will be stripped).
448 * Returns number of words in result buffer.
451 tokenize(const char *str, char **dest, char ***destv)
453 char *retstart = Nullch;
454 char **retvstart = 0;
458 int slen = strlen(str);
460 register char **retv;
461 New(1307, ret, slen+2, char);
462 New(1308, retv, (slen+3)/2, char*);
470 if (*ret == '\\' && *str)
472 else if (*ret == ' ') {
488 retvstart[items] = Nullch;
501 if (!w32_perlshell_tokens) {
502 /* we don't use COMSPEC here for two reasons:
503 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
504 * uncontrolled unportability of the ensuing scripts.
505 * 2. PERL5SHELL could be set to a shell that may not be fit for
506 * interactive use (which is what most programs look in COMSPEC
509 const char* defaultshell = (IsWinNT()
510 ? "cmd.exe /x/c" : "command.com /c");
511 const char *usershell = PerlEnv_getenv("PERL5SHELL");
512 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
513 &w32_perlshell_tokens,
519 do_aspawn(void *vreally, void **vmark, void **vsp)
522 SV *really = (SV*)vreally;
523 SV **mark = (SV**)vmark;
535 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
537 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
542 while (++mark <= sp) {
543 if (*mark && (str = SvPV_nolen(*mark)))
550 status = win32_spawnvp(flag,
551 (const char*)(really ? SvPV_nolen(really) : argv[0]),
552 (const char* const*)argv);
554 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
555 /* possible shell-builtin, invoke with shell */
557 sh_items = w32_perlshell_items;
559 argv[index+sh_items] = argv[index];
560 while (--sh_items >= 0)
561 argv[sh_items] = w32_perlshell_vec[sh_items];
563 status = win32_spawnvp(flag,
564 (const char*)(really ? SvPV_nolen(really) : argv[0]),
565 (const char* const*)argv);
568 if (flag == P_NOWAIT) {
570 PL_statusvalue = -1; /* >16bits hint for pp_system() */
574 if (ckWARN(WARN_EXEC))
575 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
580 PL_statusvalue = status;
586 /* returns pointer to the next unquoted space or the end of the string */
588 find_next_space(const char *s)
590 bool in_quotes = FALSE;
592 /* ignore doubled backslashes, or backslash+quote */
593 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
596 /* keep track of when we're within quotes */
597 else if (*s == '"') {
599 in_quotes = !in_quotes;
601 /* break it up only at spaces that aren't in quotes */
602 else if (!in_quotes && isSPACE(*s))
611 do_spawn2(char *cmd, int exectype)
618 BOOL needToTry = TRUE;
621 /* Save an extra exec if possible. See if there are shell
622 * metacharacters in it */
623 if (!has_shell_metachars(cmd)) {
624 New(1301,argv, strlen(cmd) / 2 + 2, char*);
625 New(1302,cmd2, strlen(cmd) + 1, char);
628 for (s = cmd2; *s;) {
629 while (*s && isSPACE(*s))
633 s = find_next_space(s);
641 status = win32_spawnvp(P_WAIT, argv[0],
642 (const char* const*)argv);
644 case EXECF_SPAWN_NOWAIT:
645 status = win32_spawnvp(P_NOWAIT, argv[0],
646 (const char* const*)argv);
649 status = win32_execvp(argv[0], (const char* const*)argv);
652 if (status != -1 || errno == 0)
662 New(1306, argv, w32_perlshell_items + 2, char*);
663 while (++i < w32_perlshell_items)
664 argv[i] = w32_perlshell_vec[i];
669 status = win32_spawnvp(P_WAIT, argv[0],
670 (const char* const*)argv);
672 case EXECF_SPAWN_NOWAIT:
673 status = win32_spawnvp(P_NOWAIT, argv[0],
674 (const char* const*)argv);
677 status = win32_execvp(argv[0], (const char* const*)argv);
683 if (exectype == EXECF_SPAWN_NOWAIT) {
685 PL_statusvalue = -1; /* >16bits hint for pp_system() */
689 if (ckWARN(WARN_EXEC))
690 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
691 (exectype == EXECF_EXEC ? "exec" : "spawn"),
692 cmd, strerror(errno));
697 PL_statusvalue = status;
705 return do_spawn2(cmd, EXECF_SPAWN);
709 do_spawn_nowait(char *cmd)
711 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
715 Perl_do_exec(pTHX_ char *cmd)
717 do_spawn2(cmd, EXECF_EXEC);
721 /* The idea here is to read all the directory names into a string table
722 * (separated by nulls) and when one of the other dir functions is called
723 * return the pointer to the current file name.
726 win32_opendir(char *filename)
732 char scanname[MAX_PATH+3];
734 WIN32_FIND_DATAA aFindData;
735 WIN32_FIND_DATAW wFindData;
737 char buffer[MAX_PATH*2];
738 WCHAR wbuffer[MAX_PATH+1];
741 len = strlen(filename);
745 /* check to see if filename is a directory */
746 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
749 /* Get us a DIR structure */
750 Newz(1303, dirp, 1, DIR);
752 /* Create the search pattern */
753 strcpy(scanname, filename);
755 /* bare drive name means look in cwd for drive */
756 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
757 scanname[len++] = '.';
758 scanname[len++] = '/';
760 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
761 scanname[len++] = '/';
763 scanname[len++] = '*';
764 scanname[len] = '\0';
766 /* do the FindFirstFile call */
768 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
769 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
772 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
775 if (fh == INVALID_HANDLE_VALUE) {
776 DWORD err = GetLastError();
777 /* FindFirstFile() fails on empty drives! */
779 case ERROR_FILE_NOT_FOUND:
781 case ERROR_NO_MORE_FILES:
782 case ERROR_PATH_NOT_FOUND:
785 case ERROR_NOT_ENOUGH_MEMORY:
796 /* now allocate the first part of the string table for
797 * the filenames that we find.
800 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
804 ptr = aFindData.cFileName;
811 New(1304, dirp->start, dirp->size, char);
812 strcpy(dirp->start, ptr);
814 dirp->end = dirp->curr = dirp->start;
820 /* Readdir just returns the current string pointer and bumps the
821 * string pointer to the nDllExport entry.
823 DllExport struct direct *
824 win32_readdir(DIR *dirp)
829 /* first set up the structure to return */
830 len = strlen(dirp->curr);
831 strcpy(dirp->dirstr.d_name, dirp->curr);
832 dirp->dirstr.d_namlen = len;
835 dirp->dirstr.d_ino = dirp->curr - dirp->start;
837 /* Now set up for the next call to readdir */
838 dirp->curr += len + 1;
839 if (dirp->curr >= dirp->end) {
843 WIN32_FIND_DATAW wFindData;
844 WIN32_FIND_DATAA aFindData;
845 char buffer[MAX_PATH*2];
847 /* finding the next file that matches the wildcard
848 * (which should be all of them in this directory!).
851 res = FindNextFileW(dirp->handle, &wFindData);
853 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
858 res = FindNextFileA(dirp->handle, &aFindData);
860 ptr = aFindData.cFileName;
863 long endpos = dirp->end - dirp->start;
864 long newsize = endpos + strlen(ptr) + 1;
865 /* bump the string table size by enough for the
866 * new name and its null terminator */
867 while (newsize > dirp->size) {
868 long curpos = dirp->curr - dirp->start;
870 Renew(dirp->start, dirp->size, char);
871 dirp->curr = dirp->start + curpos;
873 strcpy(dirp->start + endpos, ptr);
874 dirp->end = dirp->start + newsize;
880 return &(dirp->dirstr);
886 /* Telldir returns the current string pointer position */
888 win32_telldir(DIR *dirp)
890 return (dirp->curr - dirp->start);
894 /* Seekdir moves the string pointer to a previously saved position
895 * (returned by telldir).
898 win32_seekdir(DIR *dirp, long loc)
900 dirp->curr = dirp->start + loc;
903 /* Rewinddir resets the string pointer to the start */
905 win32_rewinddir(DIR *dirp)
907 dirp->curr = dirp->start;
910 /* free the memory allocated by opendir */
912 win32_closedir(DIR *dirp)
915 if (dirp->handle != INVALID_HANDLE_VALUE)
916 FindClose(dirp->handle);
917 Safefree(dirp->start);
930 * Just pretend that everyone is a superuser. NT will let us know if
931 * we don\'t really have permission to do something.
934 #define ROOT_UID ((uid_t)0)
935 #define ROOT_GID ((gid_t)0)
964 return (auid == ROOT_UID ? 0 : -1);
970 return (agid == ROOT_GID ? 0 : -1);
977 char *buf = w32_getlogin_buffer;
978 DWORD size = sizeof(w32_getlogin_buffer);
979 if (GetUserName(buf,&size))
985 chown(const char *path, uid_t owner, gid_t group)
992 * XXX this needs strengthening (for PerlIO)
995 int mkstemp(const char *path)
998 char buf[MAX_PATH+1];
1002 if (i++ > 10) { /* give up */
1006 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1010 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1020 long child = w32_num_children;
1021 while (--child >= 0) {
1022 if ((int)w32_child_pids[child] == pid)
1029 remove_dead_process(long child)
1033 CloseHandle(w32_child_handles[child]);
1034 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1035 (w32_num_children-child-1), HANDLE);
1036 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1037 (w32_num_children-child-1), DWORD);
1044 find_pseudo_pid(int pid)
1047 long child = w32_num_pseudo_children;
1048 while (--child >= 0) {
1049 if ((int)w32_pseudo_child_pids[child] == pid)
1056 remove_dead_pseudo_process(long child)
1060 CloseHandle(w32_pseudo_child_handles[child]);
1061 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1062 (w32_num_pseudo_children-child-1), HANDLE);
1063 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1064 (w32_num_pseudo_children-child-1), DWORD);
1065 w32_num_pseudo_children--;
1071 win32_kill(int pid, int sig)
1078 /* it is a pseudo-forked child */
1079 child = find_pseudo_pid(-pid);
1081 hProcess = w32_pseudo_child_handles[child];
1084 /* "Does process exist?" use of kill */
1087 /* kill -9 style un-graceful exit */
1088 if (TerminateThread(hProcess, sig)) {
1089 remove_dead_pseudo_process(child);
1094 /* We fake signals to pseudo-processes using Win32
1095 * message queue. In Win9X the pids are negative already. */
1096 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1097 /* It might be us ... */
1104 else if (IsWin95()) {
1112 child = find_pid(pid);
1114 hProcess = w32_child_handles[child];
1117 /* "Does process exist?" use of kill */
1120 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1123 default: /* For now be backwards compatible with perl5.6 */
1125 if (TerminateProcess(hProcess, sig)) {
1126 remove_dead_process(child);
1134 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1135 (IsWin95() ? -pid : pid));
1139 /* "Does process exist?" use of kill */
1142 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1145 default: /* For now be backwards compatible with perl5.6 */
1147 if (TerminateProcess(hProcess, sig)) {
1148 CloseHandle(hProcess);
1160 win32_stat(const char *path, Stat_t *sbuf)
1163 char buffer[MAX_PATH+1];
1164 int l = strlen(path);
1166 WCHAR wbuffer[MAX_PATH+1];
1172 switch(path[l - 1]) {
1173 /* FindFirstFile() and stat() are buggy with a trailing
1174 * backslash, so change it to a forward slash :-( */
1176 strncpy(buffer, path, l-1);
1177 buffer[l - 1] = '/';
1181 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1183 if (l == 2 && isALPHA(path[0])) {
1184 buffer[0] = path[0];
1195 /* We *must* open & close the file once; otherwise file attribute changes */
1196 /* might not yet have propagated to "other" hard links of the same file. */
1197 /* This also gives us an opportunity to determine the number of links. */
1199 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1200 pwbuffer = PerlDir_mapW(wbuffer);
1201 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1204 path = PerlDir_mapA(path);
1206 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1208 if (handle != INVALID_HANDLE_VALUE) {
1209 BY_HANDLE_FILE_INFORMATION bhi;
1210 if (GetFileInformationByHandle(handle, &bhi))
1211 nlink = bhi.nNumberOfLinks;
1212 CloseHandle(handle);
1215 /* pwbuffer or path will be mapped correctly above */
1217 #if defined(WIN64) || defined(USE_LARGE_FILES)
1218 res = _wstati64(pwbuffer, sbuf);
1220 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1224 #if defined(WIN64) || defined(USE_LARGE_FILES)
1225 res = _stati64(path, sbuf);
1227 res = stat(path, sbuf);
1230 sbuf->st_nlink = nlink;
1233 /* CRT is buggy on sharenames, so make sure it really isn't.
1234 * XXX using GetFileAttributesEx() will enable us to set
1235 * sbuf->st_*time (but note that's not available on the
1236 * Windows of 1995) */
1239 r = GetFileAttributesW(pwbuffer);
1242 r = GetFileAttributesA(path);
1244 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1245 /* sbuf may still contain old garbage since stat() failed */
1246 Zero(sbuf, 1, Stat_t);
1247 sbuf->st_mode = S_IFDIR | S_IREAD;
1249 if (!(r & FILE_ATTRIBUTE_READONLY))
1250 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1255 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1256 && (path[2] == '\\' || path[2] == '/'))
1258 /* The drive can be inaccessible, some _stat()s are buggy */
1260 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1261 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1267 if (S_ISDIR(sbuf->st_mode))
1268 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1269 else if (S_ISREG(sbuf->st_mode)) {
1271 if (l >= 4 && path[l-4] == '.') {
1272 const char *e = path + l - 3;
1273 if (strnicmp(e,"exe",3)
1274 && strnicmp(e,"bat",3)
1275 && strnicmp(e,"com",3)
1276 && (IsWin95() || strnicmp(e,"cmd",3)))
1277 sbuf->st_mode &= ~S_IEXEC;
1279 sbuf->st_mode |= S_IEXEC;
1282 sbuf->st_mode &= ~S_IEXEC;
1283 /* Propagate permissions to _group_ and _others_ */
1284 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1285 sbuf->st_mode |= (perms>>3) | (perms>>6);
1292 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1293 #define SKIP_SLASHES(s) \
1295 while (*(s) && isSLASH(*(s))) \
1298 #define COPY_NONSLASHES(d,s) \
1300 while (*(s) && !isSLASH(*(s))) \
1304 /* Find the longname of a given path. path is destructively modified.
1305 * It should have space for at least MAX_PATH characters. */
1307 win32_longpath(char *path)
1309 WIN32_FIND_DATA fdata;
1311 char tmpbuf[MAX_PATH+1];
1312 char *tmpstart = tmpbuf;
1319 if (isALPHA(path[0]) && path[1] == ':') {
1321 *tmpstart++ = path[0];
1325 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1327 *tmpstart++ = path[0];
1328 *tmpstart++ = path[1];
1329 SKIP_SLASHES(start);
1330 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1332 *tmpstart++ = *start++;
1333 SKIP_SLASHES(start);
1334 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1339 /* copy initial slash, if any */
1340 if (isSLASH(*start)) {
1341 *tmpstart++ = *start++;
1343 SKIP_SLASHES(start);
1346 /* FindFirstFile() expands "." and "..", so we need to pass
1347 * those through unmolested */
1349 && (!start[1] || isSLASH(start[1])
1350 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1352 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1357 /* if this is the end, bust outta here */
1361 /* now we're at a non-slash; walk up to next slash */
1362 while (*start && !isSLASH(*start))
1365 /* stop and find full name of component */
1368 fhand = FindFirstFile(path,&fdata);
1370 if (fhand != INVALID_HANDLE_VALUE) {
1371 STRLEN len = strlen(fdata.cFileName);
1372 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1373 strcpy(tmpstart, fdata.cFileName);
1384 /* failed a step, just return without side effects */
1385 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1390 strcpy(path,tmpbuf);
1395 win32_getenv(const char *name)
1398 WCHAR wBuffer[MAX_PATH+1];
1400 SV *curitem = Nullsv;
1403 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1404 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1407 needlen = GetEnvironmentVariableA(name,NULL,0);
1409 curitem = sv_2mortal(newSVpvn("", 0));
1413 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1414 needlen = GetEnvironmentVariableW(wBuffer,
1415 (WCHAR*)SvPVX(curitem),
1417 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1418 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1419 acuritem = sv_2mortal(newSVsv(curitem));
1420 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1424 SvGROW(curitem, needlen+1);
1425 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1427 } while (needlen >= SvLEN(curitem));
1428 SvCUR_set(curitem, needlen);
1432 /* allow any environment variables that begin with 'PERL'
1433 to be stored in the registry */
1434 if (strncmp(name, "PERL", 4) == 0)
1435 (void)get_regstr(name, &curitem);
1437 if (curitem && SvCUR(curitem))
1438 return SvPVX(curitem);
1444 win32_putenv(const char *name)
1451 int length, relval = -1;
1455 length = strlen(name)+1;
1456 New(1309,wCuritem,length,WCHAR);
1457 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1458 wVal = wcschr(wCuritem, '=');
1461 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1467 New(1309,curitem,strlen(name)+1,char);
1468 strcpy(curitem, name);
1469 val = strchr(curitem, '=');
1471 /* The sane way to deal with the environment.
1472 * Has these advantages over putenv() & co.:
1473 * * enables us to store a truly empty value in the
1474 * environment (like in UNIX).
1475 * * we don't have to deal with RTL globals, bugs and leaks.
1477 * Why you may want to enable USE_WIN32_RTL_ENV:
1478 * * environ[] and RTL functions will not reflect changes,
1479 * which might be an issue if extensions want to access
1480 * the env. via RTL. This cuts both ways, since RTL will
1481 * not see changes made by extensions that call the Win32
1482 * functions directly, either.
1486 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1496 filetime_to_clock(PFILETIME ft)
1498 __int64 qw = ft->dwHighDateTime;
1500 qw |= ft->dwLowDateTime;
1501 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1506 win32_times(struct tms *timebuf)
1511 clock_t process_time_so_far = clock();
1512 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1514 timebuf->tms_utime = filetime_to_clock(&user);
1515 timebuf->tms_stime = filetime_to_clock(&kernel);
1516 timebuf->tms_cutime = 0;
1517 timebuf->tms_cstime = 0;
1519 /* That failed - e.g. Win95 fallback to clock() */
1520 timebuf->tms_utime = process_time_so_far;
1521 timebuf->tms_stime = 0;
1522 timebuf->tms_cutime = 0;
1523 timebuf->tms_cstime = 0;
1525 return process_time_so_far;
1528 /* fix utime() so it works on directories in NT */
1530 filetime_from_time(PFILETIME pFileTime, time_t Time)
1532 struct tm *pTM = localtime(&Time);
1533 SYSTEMTIME SystemTime;
1539 SystemTime.wYear = pTM->tm_year + 1900;
1540 SystemTime.wMonth = pTM->tm_mon + 1;
1541 SystemTime.wDay = pTM->tm_mday;
1542 SystemTime.wHour = pTM->tm_hour;
1543 SystemTime.wMinute = pTM->tm_min;
1544 SystemTime.wSecond = pTM->tm_sec;
1545 SystemTime.wMilliseconds = 0;
1547 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1548 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1552 win32_unlink(const char *filename)
1559 WCHAR wBuffer[MAX_PATH+1];
1562 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1563 pwBuffer = PerlDir_mapW(wBuffer);
1564 attrs = GetFileAttributesW(pwBuffer);
1565 if (attrs == 0xFFFFFFFF)
1567 if (attrs & FILE_ATTRIBUTE_READONLY) {
1568 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1569 ret = _wunlink(pwBuffer);
1571 (void)SetFileAttributesW(pwBuffer, attrs);
1574 ret = _wunlink(pwBuffer);
1577 filename = PerlDir_mapA(filename);
1578 attrs = GetFileAttributesA(filename);
1579 if (attrs == 0xFFFFFFFF)
1581 if (attrs & FILE_ATTRIBUTE_READONLY) {
1582 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1583 ret = unlink(filename);
1585 (void)SetFileAttributesA(filename, attrs);
1588 ret = unlink(filename);
1597 win32_utime(const char *filename, struct utimbuf *times)
1604 struct utimbuf TimeBuffer;
1605 WCHAR wbuffer[MAX_PATH+1];
1610 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1611 pwbuffer = PerlDir_mapW(wbuffer);
1612 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1615 filename = PerlDir_mapA(filename);
1616 rc = utime(filename, times);
1618 /* EACCES: path specifies directory or readonly file */
1619 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1622 if (times == NULL) {
1623 times = &TimeBuffer;
1624 time(×->actime);
1625 times->modtime = times->actime;
1628 /* This will (and should) still fail on readonly files */
1630 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1631 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1632 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1635 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1636 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1637 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1639 if (handle == INVALID_HANDLE_VALUE)
1642 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1643 filetime_from_time(&ftAccess, times->actime) &&
1644 filetime_from_time(&ftWrite, times->modtime) &&
1645 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1650 CloseHandle(handle);
1655 win32_uname(struct utsname *name)
1657 struct hostent *hep;
1658 STRLEN nodemax = sizeof(name->nodename)-1;
1659 OSVERSIONINFO osver;
1661 memset(&osver, 0, sizeof(OSVERSIONINFO));
1662 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1663 if (GetVersionEx(&osver)) {
1665 switch (osver.dwPlatformId) {
1666 case VER_PLATFORM_WIN32_WINDOWS:
1667 strcpy(name->sysname, "Windows");
1669 case VER_PLATFORM_WIN32_NT:
1670 strcpy(name->sysname, "Windows NT");
1672 case VER_PLATFORM_WIN32s:
1673 strcpy(name->sysname, "Win32s");
1676 strcpy(name->sysname, "Win32 Unknown");
1681 sprintf(name->release, "%d.%d",
1682 osver.dwMajorVersion, osver.dwMinorVersion);
1685 sprintf(name->version, "Build %d",
1686 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1687 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1688 if (osver.szCSDVersion[0]) {
1689 char *buf = name->version + strlen(name->version);
1690 sprintf(buf, " (%s)", osver.szCSDVersion);
1694 *name->sysname = '\0';
1695 *name->version = '\0';
1696 *name->release = '\0';
1700 hep = win32_gethostbyname("localhost");
1702 STRLEN len = strlen(hep->h_name);
1703 if (len <= nodemax) {
1704 strcpy(name->nodename, hep->h_name);
1707 strncpy(name->nodename, hep->h_name, nodemax);
1708 name->nodename[nodemax] = '\0';
1713 if (!GetComputerName(name->nodename, &sz))
1714 *name->nodename = '\0';
1717 /* machine (architecture) */
1721 GetSystemInfo(&info);
1723 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1724 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1725 switch (info.u.s.wProcessorArchitecture) {
1727 switch (info.wProcessorArchitecture) {
1729 case PROCESSOR_ARCHITECTURE_INTEL:
1730 arch = "x86"; break;
1731 case PROCESSOR_ARCHITECTURE_MIPS:
1732 arch = "mips"; break;
1733 case PROCESSOR_ARCHITECTURE_ALPHA:
1734 arch = "alpha"; break;
1735 case PROCESSOR_ARCHITECTURE_PPC:
1736 arch = "ppc"; break;
1738 arch = "unknown"; break;
1740 strcpy(name->machine, arch);
1745 /* Timing related stuff */
1748 do_raise(pTHX_ int sig)
1750 if (sig < SIG_SIZE) {
1751 Sighandler_t handler = w32_sighandler[sig];
1752 if (handler == SIG_IGN) {
1755 else if (handler != SIG_DFL) {
1760 /* Choose correct default behaviour */
1776 /* Tell caller to exit thread/process as approriate */
1781 sig_terminate(pTHX_ int sig)
1783 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1784 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1791 win32_async_check(pTHX)
1795 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1796 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1798 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1800 switch(msg.message) {
1803 /* Perhaps some other messages could map to signals ? ... */
1806 /* Treat WM_QUIT like SIGHUP? */
1812 /* We use WM_USER to fake kill() with other signals */
1816 if (do_raise(aTHX_ sig)) {
1817 sig_terminate(aTHX_ sig);
1823 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1825 KillTimer(NULL,w32_timerid);
1828 /* Now fake a call to signal handler */
1829 if (do_raise(aTHX_ 14)) {
1830 sig_terminate(aTHX_ 14);
1835 /* Otherwise do normal Win32 thing - in case it is useful */
1837 TranslateMessage(&msg);
1838 DispatchMessage(&msg);
1845 /* Above or other stuff may have set a signal flag */
1846 if (PL_sig_pending) {
1853 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1855 /* We may need several goes at this - so compute when we stop */
1857 if (timeout != INFINITE) {
1858 ticks = GetTickCount();
1862 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1865 if (result == WAIT_TIMEOUT) {
1866 /* Ran out of time - explicit return of zero to avoid -ve if we
1867 have scheduling issues
1871 if (timeout != INFINITE) {
1872 ticks = GetTickCount();
1874 if (result == WAIT_OBJECT_0 + count) {
1875 /* Message has arrived - check it */
1876 if (win32_async_check(aTHX)) {
1877 /* was one of ours */
1882 /* Not timeout or message - one of handles is ready */
1886 /* compute time left to wait */
1887 ticks = timeout - ticks;
1888 /* If we are past the end say zero */
1889 return (ticks > 0) ? ticks : 0;
1893 win32_internal_wait(int *status, DWORD timeout)
1895 /* XXX this wait emulation only knows about processes
1896 * spawned via win32_spawnvp(P_NOWAIT, ...).
1900 DWORD exitcode, waitcode;
1903 if (w32_num_pseudo_children) {
1904 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1905 timeout, &waitcode);
1906 /* Time out here if there are no other children to wait for. */
1907 if (waitcode == WAIT_TIMEOUT) {
1908 if (!w32_num_children) {
1912 else if (waitcode != WAIT_FAILED) {
1913 if (waitcode >= WAIT_ABANDONED_0
1914 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1915 i = waitcode - WAIT_ABANDONED_0;
1917 i = waitcode - WAIT_OBJECT_0;
1918 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1919 *status = (int)((exitcode & 0xff) << 8);
1920 retval = (int)w32_pseudo_child_pids[i];
1921 remove_dead_pseudo_process(i);
1928 if (!w32_num_children) {
1933 /* if a child exists, wait for it to die */
1934 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1935 if (waitcode == WAIT_TIMEOUT) {
1938 if (waitcode != WAIT_FAILED) {
1939 if (waitcode >= WAIT_ABANDONED_0
1940 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1941 i = waitcode - WAIT_ABANDONED_0;
1943 i = waitcode - WAIT_OBJECT_0;
1944 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1945 *status = (int)((exitcode & 0xff) << 8);
1946 retval = (int)w32_child_pids[i];
1947 remove_dead_process(i);
1952 errno = GetLastError();
1957 win32_waitpid(int pid, int *status, int flags)
1960 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1963 if (pid == -1) /* XXX threadid == 1 ? */
1964 return win32_internal_wait(status, timeout);
1967 child = find_pseudo_pid(-pid);
1969 HANDLE hThread = w32_pseudo_child_handles[child];
1971 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1972 if (waitcode == WAIT_TIMEOUT) {
1975 else if (waitcode == WAIT_OBJECT_0) {
1976 if (GetExitCodeThread(hThread, &waitcode)) {
1977 *status = (int)((waitcode & 0xff) << 8);
1978 retval = (int)w32_pseudo_child_pids[child];
1979 remove_dead_pseudo_process(child);
1986 else if (IsWin95()) {
1995 child = find_pid(pid);
1997 hProcess = w32_child_handles[child];
1998 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1999 if (waitcode == WAIT_TIMEOUT) {
2002 else if (waitcode == WAIT_OBJECT_0) {
2003 if (GetExitCodeProcess(hProcess, &waitcode)) {
2004 *status = (int)((waitcode & 0xff) << 8);
2005 retval = (int)w32_child_pids[child];
2006 remove_dead_process(child);
2015 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2016 (IsWin95() ? -pid : pid));
2018 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2019 if (waitcode == WAIT_TIMEOUT) {
2022 else if (waitcode == WAIT_OBJECT_0) {
2023 if (GetExitCodeProcess(hProcess, &waitcode)) {
2024 *status = (int)((waitcode & 0xff) << 8);
2025 CloseHandle(hProcess);
2029 CloseHandle(hProcess);
2035 return retval >= 0 ? pid : retval;
2039 win32_wait(int *status)
2041 return win32_internal_wait(status, INFINITE);
2044 DllExport unsigned int
2045 win32_sleep(unsigned int t)
2048 /* Win32 times are in ms so *1000 in and /1000 out */
2049 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2052 DllExport unsigned int
2053 win32_alarm(unsigned int sec)
2056 * the 'obvious' implentation is SetTimer() with a callback
2057 * which does whatever receiving SIGALRM would do
2058 * we cannot use SIGALRM even via raise() as it is not
2059 * one of the supported codes in <signal.h>
2063 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2067 KillTimer(NULL,w32_timerid);
2074 #ifdef HAVE_DES_FCRYPT
2075 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2079 win32_crypt(const char *txt, const char *salt)
2082 #ifdef HAVE_DES_FCRYPT
2083 return des_fcrypt(txt, salt, w32_crypt_buffer);
2085 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2090 #ifdef USE_FIXED_OSFHANDLE
2092 #define FOPEN 0x01 /* file handle open */
2093 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2094 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2095 #define FDEV 0x40 /* file handle refers to device */
2096 #define FTEXT 0x80 /* file handle is in text mode */
2099 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2102 * This function allocates a free C Runtime file handle and associates
2103 * it with the Win32 HANDLE specified by the first parameter. This is a
2104 * temperary fix for WIN95's brain damage GetFileType() error on socket
2105 * we just bypass that call for socket
2107 * This works with MSVC++ 4.0+ or GCC/Mingw32
2110 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2111 * int flags - flags to associate with C Runtime file handle.
2114 * returns index of entry in fh, if successful
2115 * return -1, if no free entry is found
2119 *******************************************************************************/
2122 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2123 * this lets sockets work on Win9X with GCC and should fix the problems
2128 /* create an ioinfo entry, kill its handle, and steal the entry */
2133 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2134 int fh = _open_osfhandle((intptr_t)hF, 0);
2138 EnterCriticalSection(&(_pioinfo(fh)->lock));
2143 my_open_osfhandle(intptr_t osfhandle, int flags)
2146 char fileflags; /* _osfile flags */
2148 /* copy relevant flags from second parameter */
2151 if (flags & O_APPEND)
2152 fileflags |= FAPPEND;
2157 if (flags & O_NOINHERIT)
2158 fileflags |= FNOINHERIT;
2160 /* attempt to allocate a C Runtime file handle */
2161 if ((fh = _alloc_osfhnd()) == -1) {
2162 errno = EMFILE; /* too many open files */
2163 _doserrno = 0L; /* not an OS error */
2164 return -1; /* return error to caller */
2167 /* the file is open. now, set the info in _osfhnd array */
2168 _set_osfhnd(fh, osfhandle);
2170 fileflags |= FOPEN; /* mark as open */
2172 _osfile(fh) = fileflags; /* set osfile entry */
2173 LeaveCriticalSection(&_pioinfo(fh)->lock);
2175 return fh; /* return handle */
2178 #endif /* USE_FIXED_OSFHANDLE */
2180 /* simulate flock by locking a range on the file */
2182 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2183 #define LK_LEN 0xffff0000
2186 win32_flock(int fd, int oper)
2194 Perl_croak_nocontext("flock() unimplemented on this platform");
2197 fh = (HANDLE)_get_osfhandle(fd);
2198 memset(&o, 0, sizeof(o));
2201 case LOCK_SH: /* shared lock */
2202 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2204 case LOCK_EX: /* exclusive lock */
2205 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2207 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2208 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2210 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2211 LK_ERR(LockFileEx(fh,
2212 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2213 0, LK_LEN, 0, &o),i);
2215 case LOCK_UN: /* unlock lock */
2216 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2218 default: /* unknown */
2229 * redirected io subsystem for all XS modules
2242 return (&(_environ));
2245 /* the rest are the remapped stdio routines */
2265 win32_ferror(FILE *fp)
2267 return (ferror(fp));
2272 win32_feof(FILE *fp)
2278 * Since the errors returned by the socket error function
2279 * WSAGetLastError() are not known by the library routine strerror
2280 * we have to roll our own.
2284 win32_strerror(int e)
2286 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2287 extern int sys_nerr;
2291 if (e < 0 || e > sys_nerr) {
2296 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2297 w32_strerror_buffer,
2298 sizeof(w32_strerror_buffer), NULL) == 0)
2299 strcpy(w32_strerror_buffer, "Unknown Error");
2301 return w32_strerror_buffer;
2307 win32_str_os_error(void *sv, DWORD dwErr)
2311 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2312 |FORMAT_MESSAGE_IGNORE_INSERTS
2313 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2314 dwErr, 0, (char *)&sMsg, 1, NULL);
2315 /* strip trailing whitespace and period */
2318 --dwLen; /* dwLen doesn't include trailing null */
2319 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2320 if ('.' != sMsg[dwLen])
2325 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2327 dwLen = sprintf(sMsg,
2328 "Unknown error #0x%lX (lookup 0x%lX)",
2329 dwErr, GetLastError());
2333 sv_setpvn((SV*)sv, sMsg, dwLen);
2339 win32_fprintf(FILE *fp, const char *format, ...)
2342 va_start(marker, format); /* Initialize variable arguments. */
2344 return (vfprintf(fp, format, marker));
2348 win32_printf(const char *format, ...)
2351 va_start(marker, format); /* Initialize variable arguments. */
2353 return (vprintf(format, marker));
2357 win32_vfprintf(FILE *fp, const char *format, va_list args)
2359 return (vfprintf(fp, format, args));
2363 win32_vprintf(const char *format, va_list args)
2365 return (vprintf(format, args));
2369 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2371 return fread(buf, size, count, fp);
2375 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2377 return fwrite(buf, size, count, fp);
2380 #define MODE_SIZE 10
2383 win32_fopen(const char *filename, const char *mode)
2386 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2392 if (stricmp(filename, "/dev/null")==0)
2396 A2WHELPER(mode, wMode, sizeof(wMode));
2397 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2398 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2401 f = fopen(PerlDir_mapA(filename), mode);
2402 /* avoid buffering headaches for child processes */
2403 if (f && *mode == 'a')
2404 win32_fseek(f, 0, SEEK_END);
2408 #ifndef USE_SOCKETS_AS_HANDLES
2410 #define fdopen my_fdopen
2414 win32_fdopen(int handle, const char *mode)
2417 WCHAR wMode[MODE_SIZE];
2420 A2WHELPER(mode, wMode, sizeof(wMode));
2421 f = _wfdopen(handle, wMode);
2424 f = fdopen(handle, (char *) mode);
2425 /* avoid buffering headaches for child processes */
2426 if (f && *mode == 'a')
2427 win32_fseek(f, 0, SEEK_END);
2432 win32_freopen(const char *path, const char *mode, FILE *stream)
2435 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2436 if (stricmp(path, "/dev/null")==0)
2440 A2WHELPER(mode, wMode, sizeof(wMode));
2441 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2442 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2444 return freopen(PerlDir_mapA(path), mode, stream);
2448 win32_fclose(FILE *pf)
2450 return my_fclose(pf); /* defined in win32sck.c */
2454 win32_fputs(const char *s,FILE *pf)
2456 return fputs(s, pf);
2460 win32_fputc(int c,FILE *pf)
2466 win32_ungetc(int c,FILE *pf)
2468 return ungetc(c,pf);
2472 win32_getc(FILE *pf)
2478 win32_fileno(FILE *pf)
2484 win32_clearerr(FILE *pf)
2491 win32_fflush(FILE *pf)
2497 win32_ftell(FILE *pf)
2499 #if defined(WIN64) || defined(USE_LARGE_FILES)
2501 if (fgetpos(pf, &pos))
2510 win32_fseek(FILE *pf, Off_t offset,int origin)
2512 #if defined(WIN64) || defined(USE_LARGE_FILES)
2516 if (fgetpos(pf, &pos))
2521 fseek(pf, 0, SEEK_END);
2522 pos = _telli64(fileno(pf));
2531 return fsetpos(pf, &offset);
2533 return fseek(pf, offset, origin);
2538 win32_fgetpos(FILE *pf,fpos_t *p)
2540 return fgetpos(pf, p);
2544 win32_fsetpos(FILE *pf,const fpos_t *p)
2546 return fsetpos(pf, p);
2550 win32_rewind(FILE *pf)
2560 char prefix[MAX_PATH+1];
2561 char filename[MAX_PATH+1];
2562 DWORD len = GetTempPath(MAX_PATH, prefix);
2563 if (len && len < MAX_PATH) {
2564 if (GetTempFileName(prefix, "plx", 0, filename)) {
2565 HANDLE fh = CreateFile(filename,
2566 DELETE | GENERIC_READ | GENERIC_WRITE,
2570 FILE_ATTRIBUTE_NORMAL
2571 | FILE_FLAG_DELETE_ON_CLOSE,
2573 if (fh != INVALID_HANDLE_VALUE) {
2574 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2576 #if defined(__BORLANDC__)
2577 setmode(fd,O_BINARY);
2579 DEBUG_p(PerlIO_printf(Perl_debug_log,
2580 "Created tmpfile=%s\n",filename));
2581 return fdopen(fd, "w+b");
2597 win32_fstat(int fd, Stat_t *sbufptr)
2600 /* A file designated by filehandle is not shown as accessible
2601 * for write operations, probably because it is opened for reading.
2604 int rc = fstat(fd,sbufptr);
2605 BY_HANDLE_FILE_INFORMATION bhfi;
2606 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2607 sbufptr->st_mode &= 0xFE00;
2608 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2609 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2611 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2612 + ((S_IREAD|S_IWRITE) >> 6));
2616 return my_fstat(fd,sbufptr);
2621 win32_pipe(int *pfd, unsigned int size, int mode)
2623 return _pipe(pfd, size, mode);
2627 win32_popenlist(const char *mode, IV narg, SV **args)
2630 Perl_croak(aTHX_ "List form of pipe open not implemented");
2635 * a popen() clone that respects PERL5SHELL
2637 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2641 win32_popen(const char *command, const char *mode)
2643 #ifdef USE_RTL_POPEN
2644 return _popen(command, mode);
2652 /* establish which ends read and write */
2653 if (strchr(mode,'w')) {
2654 stdfd = 0; /* stdin */
2658 else if (strchr(mode,'r')) {
2659 stdfd = 1; /* stdout */
2666 /* set the correct mode */
2667 if (strchr(mode,'b'))
2669 else if (strchr(mode,'t'))
2672 ourmode = _fmode & (O_TEXT | O_BINARY);
2674 /* the child doesn't inherit handles */
2675 ourmode |= O_NOINHERIT;
2677 if (win32_pipe( p, 512, ourmode) == -1)
2680 /* save current stdfd */
2681 if ((oldfd = win32_dup(stdfd)) == -1)
2684 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2685 /* stdfd will be inherited by the child */
2686 if (win32_dup2(p[child], stdfd) == -1)
2689 /* close the child end in parent */
2690 win32_close(p[child]);
2692 /* start the child */
2695 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2698 /* revert stdfd to whatever it was before */
2699 if (win32_dup2(oldfd, stdfd) == -1)
2702 /* close saved handle */
2706 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2709 /* set process id so that it can be returned by perl's open() */
2710 PL_forkprocess = childpid;
2713 /* we have an fd, return a file stream */
2714 return (PerlIO_fdopen(p[parent], (char *)mode));
2717 /* we don't need to check for errors here */
2721 win32_dup2(oldfd, stdfd);
2726 #endif /* USE_RTL_POPEN */
2734 win32_pclose(PerlIO *pf)
2736 #ifdef USE_RTL_POPEN
2740 int childpid, status;
2744 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2747 childpid = SvIVX(sv);
2764 if (win32_waitpid(childpid, &status, 0) == -1)
2769 #endif /* USE_RTL_POPEN */
2775 LPCWSTR lpExistingFileName,
2776 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2779 WCHAR wFullName[MAX_PATH+1];
2780 LPVOID lpContext = NULL;
2781 WIN32_STREAM_ID StreamId;
2782 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2787 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2788 BOOL, BOOL, LPVOID*) =
2789 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2790 BOOL, BOOL, LPVOID*))
2791 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2792 if (pfnBackupWrite == NULL)
2795 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2798 dwLen = (dwLen+1)*sizeof(WCHAR);
2800 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2801 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2802 NULL, OPEN_EXISTING, 0, NULL);
2803 if (handle == INVALID_HANDLE_VALUE)
2806 StreamId.dwStreamId = BACKUP_LINK;
2807 StreamId.dwStreamAttributes = 0;
2808 StreamId.dwStreamNameSize = 0;
2809 #if defined(__BORLANDC__) \
2810 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2811 StreamId.Size.u.HighPart = 0;
2812 StreamId.Size.u.LowPart = dwLen;
2814 StreamId.Size.HighPart = 0;
2815 StreamId.Size.LowPart = dwLen;
2818 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2819 FALSE, FALSE, &lpContext);
2821 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2822 FALSE, FALSE, &lpContext);
2823 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2826 CloseHandle(handle);
2831 win32_link(const char *oldname, const char *newname)
2834 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2835 WCHAR wOldName[MAX_PATH+1];
2836 WCHAR wNewName[MAX_PATH+1];
2839 Perl_croak(aTHX_ PL_no_func, "link");
2841 pfnCreateHardLinkW =
2842 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2843 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2844 if (pfnCreateHardLinkW == NULL)
2845 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2847 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2848 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2849 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2850 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2854 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2859 win32_rename(const char *oname, const char *newname)
2861 WCHAR wOldName[MAX_PATH+1];
2862 WCHAR wNewName[MAX_PATH+1];
2863 char szOldName[MAX_PATH+1];
2864 char szNewName[MAX_PATH+1];
2868 /* XXX despite what the documentation says about MoveFileEx(),
2869 * it doesn't work under Windows95!
2872 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2874 A2WHELPER(oname, wOldName, sizeof(wOldName));
2875 A2WHELPER(newname, wNewName, sizeof(wNewName));
2876 if (wcsicmp(wNewName, wOldName))
2877 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2878 wcscpy(wOldName, PerlDir_mapW(wOldName));
2879 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2882 if (stricmp(newname, oname))
2883 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2884 strcpy(szOldName, PerlDir_mapA(oname));
2885 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2888 DWORD err = GetLastError();
2890 case ERROR_BAD_NET_NAME:
2891 case ERROR_BAD_NETPATH:
2892 case ERROR_BAD_PATHNAME:
2893 case ERROR_FILE_NOT_FOUND:
2894 case ERROR_FILENAME_EXCED_RANGE:
2895 case ERROR_INVALID_DRIVE:
2896 case ERROR_NO_MORE_FILES:
2897 case ERROR_PATH_NOT_FOUND:
2910 char szTmpName[MAX_PATH+1];
2911 char dname[MAX_PATH+1];
2912 char *endname = Nullch;
2914 DWORD from_attr, to_attr;
2916 strcpy(szOldName, PerlDir_mapA(oname));
2917 strcpy(szNewName, PerlDir_mapA(newname));
2919 /* if oname doesn't exist, do nothing */
2920 from_attr = GetFileAttributes(szOldName);
2921 if (from_attr == 0xFFFFFFFF) {
2926 /* if newname exists, rename it to a temporary name so that we
2927 * don't delete it in case oname happens to be the same file
2928 * (but perhaps accessed via a different path)
2930 to_attr = GetFileAttributes(szNewName);
2931 if (to_attr != 0xFFFFFFFF) {
2932 /* if newname is a directory, we fail
2933 * XXX could overcome this with yet more convoluted logic */
2934 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2938 tmplen = strlen(szNewName);
2939 strcpy(szTmpName,szNewName);
2940 endname = szTmpName+tmplen;
2941 for (; endname > szTmpName ; --endname) {
2942 if (*endname == '/' || *endname == '\\') {
2947 if (endname > szTmpName)
2948 endname = strcpy(dname,szTmpName);
2952 /* get a temporary filename in same directory
2953 * XXX is this really the best we can do? */
2954 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2958 DeleteFile(szTmpName);
2960 retval = rename(szNewName, szTmpName);
2967 /* rename oname to newname */
2968 retval = rename(szOldName, szNewName);
2970 /* if we created a temporary file before ... */
2971 if (endname != Nullch) {
2972 /* ...and rename succeeded, delete temporary file/directory */
2974 DeleteFile(szTmpName);
2975 /* else restore it to what it was */
2977 (void)rename(szTmpName, szNewName);
2984 win32_setmode(int fd, int mode)
2986 return setmode(fd, mode);
2990 win32_lseek(int fd, Off_t offset, int origin)
2992 #if defined(WIN64) || defined(USE_LARGE_FILES)
2993 return _lseeki64(fd, offset, origin);
2995 return lseek(fd, offset, origin);
3002 #if defined(WIN64) || defined(USE_LARGE_FILES)
3003 return _telli64(fd);
3010 win32_open(const char *path, int flag, ...)
3015 WCHAR wBuffer[MAX_PATH+1];
3018 pmode = va_arg(ap, int);
3021 if (stricmp(path, "/dev/null")==0)
3025 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3026 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3028 return open(PerlDir_mapA(path), flag, pmode);
3031 /* close() that understands socket */
3032 extern int my_close(int); /* in win32sck.c */
3037 return my_close(fd);
3053 win32_dup2(int fd1,int fd2)
3055 return dup2(fd1,fd2);
3058 #ifdef PERL_MSVCRT_READFIX
3060 #define LF 10 /* line feed */
3061 #define CR 13 /* carriage return */
3062 #define CTRLZ 26 /* ctrl-z means eof for text */
3063 #define FOPEN 0x01 /* file handle open */
3064 #define FEOFLAG 0x02 /* end of file has been encountered */
3065 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3066 #define FPIPE 0x08 /* file handle refers to a pipe */
3067 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3068 #define FDEV 0x40 /* file handle refers to device */
3069 #define FTEXT 0x80 /* file handle is in text mode */
3070 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3073 _fixed_read(int fh, void *buf, unsigned cnt)
3075 int bytes_read; /* number of bytes read */
3076 char *buffer; /* buffer to read to */
3077 int os_read; /* bytes read on OS call */
3078 char *p, *q; /* pointers into buffer */
3079 char peekchr; /* peek-ahead character */
3080 ULONG filepos; /* file position after seek */
3081 ULONG dosretval; /* o.s. return value */
3083 /* validate handle */
3084 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3085 !(_osfile(fh) & FOPEN))
3087 /* out of range -- return error */
3089 _doserrno = 0; /* not o.s. error */
3094 * If lockinitflag is FALSE, assume fd is device
3095 * lockinitflag is set to TRUE by open.
3097 if (_pioinfo(fh)->lockinitflag)
3098 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3100 bytes_read = 0; /* nothing read yet */
3101 buffer = (char*)buf;
3103 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3104 /* nothing to read or at EOF, so return 0 read */
3108 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3109 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3111 *buffer++ = _pipech(fh);
3114 _pipech(fh) = LF; /* mark as empty */
3119 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3121 /* ReadFile has reported an error. recognize two special cases.
3123 * 1. map ERROR_ACCESS_DENIED to EBADF
3125 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3126 * means the handle is a read-handle on a pipe for which
3127 * all write-handles have been closed and all data has been
3130 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3131 /* wrong read/write mode should return EBADF, not EACCES */
3133 _doserrno = dosretval;
3137 else if (dosretval == ERROR_BROKEN_PIPE) {
3147 bytes_read += os_read; /* update bytes read */
3149 if (_osfile(fh) & FTEXT) {
3150 /* now must translate CR-LFs to LFs in the buffer */
3152 /* set CRLF flag to indicate LF at beginning of buffer */
3153 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3154 /* _osfile(fh) |= FCRLF; */
3156 /* _osfile(fh) &= ~FCRLF; */
3158 _osfile(fh) &= ~FCRLF;
3160 /* convert chars in the buffer: p is src, q is dest */
3162 while (p < (char *)buf + bytes_read) {
3164 /* if fh is not a device, set ctrl-z flag */
3165 if (!(_osfile(fh) & FDEV))
3166 _osfile(fh) |= FEOFLAG;
3167 break; /* stop translating */
3172 /* *p is CR, so must check next char for LF */
3173 if (p < (char *)buf + bytes_read - 1) {
3176 *q++ = LF; /* convert CR-LF to LF */
3179 *q++ = *p++; /* store char normally */
3182 /* This is the hard part. We found a CR at end of
3183 buffer. We must peek ahead to see if next char
3188 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3189 (LPDWORD)&os_read, NULL))
3190 dosretval = GetLastError();
3192 if (dosretval != 0 || os_read == 0) {
3193 /* couldn't read ahead, store CR */
3197 /* peekchr now has the extra character -- we now
3198 have several possibilities:
3199 1. disk file and char is not LF; just seek back
3201 2. disk file and char is LF; store LF, don't seek back
3202 3. pipe/device and char is LF; store LF.
3203 4. pipe/device and char isn't LF, store CR and
3204 put char in pipe lookahead buffer. */
3205 if (_osfile(fh) & (FDEV|FPIPE)) {
3206 /* non-seekable device */
3211 _pipech(fh) = peekchr;
3216 if (peekchr == LF) {
3217 /* nothing read yet; must make some
3220 /* turn on this flag for tell routine */
3221 _osfile(fh) |= FCRLF;
3224 HANDLE osHandle; /* o.s. handle value */
3226 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3228 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3229 dosretval = GetLastError();
3240 /* we now change bytes_read to reflect the true number of chars
3242 bytes_read = q - (char *)buf;
3246 if (_pioinfo(fh)->lockinitflag)
3247 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3252 #endif /* PERL_MSVCRT_READFIX */
3255 win32_read(int fd, void *buf, unsigned int cnt)
3257 #ifdef PERL_MSVCRT_READFIX
3258 return _fixed_read(fd, buf, cnt);
3260 return read(fd, buf, cnt);
3265 win32_write(int fd, const void *buf, unsigned int cnt)
3267 return write(fd, buf, cnt);
3271 win32_mkdir(const char *dir, int mode)
3275 WCHAR wBuffer[MAX_PATH+1];
3276 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3277 return _wmkdir(PerlDir_mapW(wBuffer));
3279 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3283 win32_rmdir(const char *dir)
3287 WCHAR wBuffer[MAX_PATH+1];
3288 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3289 return _wrmdir(PerlDir_mapW(wBuffer));
3291 return rmdir(PerlDir_mapA(dir));
3295 win32_chdir(const char *dir)
3303 WCHAR wBuffer[MAX_PATH+1];
3304 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3305 return _wchdir(wBuffer);
3311 win32_access(const char *path, int mode)
3315 WCHAR wBuffer[MAX_PATH+1];
3316 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3317 return _waccess(PerlDir_mapW(wBuffer), mode);
3319 return access(PerlDir_mapA(path), mode);
3323 win32_chmod(const char *path, int mode)
3327 WCHAR wBuffer[MAX_PATH+1];
3328 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3329 return _wchmod(PerlDir_mapW(wBuffer), mode);
3331 return chmod(PerlDir_mapA(path), mode);
3336 create_command_line(char *cname, STRLEN clen, const char * const *args)
3343 bool bat_file = FALSE;
3344 bool cmd_shell = FALSE;
3345 bool dumb_shell = FALSE;
3346 bool extra_quotes = FALSE;
3347 bool quote_next = FALSE;
3350 cname = (char*)args[0];
3352 /* The NT cmd.exe shell has the following peculiarity that needs to be
3353 * worked around. It strips a leading and trailing dquote when any
3354 * of the following is true:
3355 * 1. the /S switch was used
3356 * 2. there are more than two dquotes
3357 * 3. there is a special character from this set: &<>()@^|
3358 * 4. no whitespace characters within the two dquotes
3359 * 5. string between two dquotes isn't an executable file
3360 * To work around this, we always add a leading and trailing dquote
3361 * to the string, if the first argument is either "cmd.exe" or "cmd",
3362 * and there were at least two or more arguments passed to cmd.exe
3363 * (not including switches).
3364 * XXX the above rules (from "cmd /?") don't seem to be applied
3365 * always, making for the convolutions below :-(
3369 clen = strlen(cname);
3372 && (stricmp(&cname[clen-4], ".bat") == 0
3373 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3379 char *exe = strrchr(cname, '/');
3380 char *exe2 = strrchr(cname, '\\');
3387 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3391 else if (stricmp(exe, "command.com") == 0
3392 || stricmp(exe, "command") == 0)
3399 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3400 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3401 STRLEN curlen = strlen(arg);
3402 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3403 len += 2; /* assume quoting needed (worst case) */
3405 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3407 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3410 New(1310, cmd, len, char);
3415 extra_quotes = TRUE;
3418 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3420 STRLEN curlen = strlen(arg);
3422 /* we want to protect empty arguments and ones with spaces with
3423 * dquotes, but only if they aren't already there */
3428 else if (quote_next) {
3429 /* see if it really is multiple arguments pretending to
3430 * be one and force a set of quotes around it */
3431 if (*find_next_space(arg))
3434 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3436 while (i < curlen) {
3437 if (isSPACE(arg[i])) {
3440 else if (arg[i] == '"') {
3463 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3465 /* is there a next argument? */
3466 if (args[index+1]) {
3467 /* are there two or more next arguments? */
3468 if (args[index+2]) {
3470 extra_quotes = TRUE;
3473 /* single argument, force quoting if it has spaces */
3489 qualified_path(const char *cmd)
3493 char *fullcmd, *curfullcmd;
3499 fullcmd = (char*)cmd;
3501 if (*fullcmd == '/' || *fullcmd == '\\')
3508 pathstr = PerlEnv_getenv("PATH");
3509 New(0, fullcmd, MAX_PATH+1, char);
3510 curfullcmd = fullcmd;
3515 /* start by appending the name to the current prefix */
3516 strcpy(curfullcmd, cmd);
3517 curfullcmd += cmdlen;
3519 /* if it doesn't end with '.', or has no extension, try adding
3520 * a trailing .exe first */
3521 if (cmd[cmdlen-1] != '.'
3522 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3524 strcpy(curfullcmd, ".exe");
3525 res = GetFileAttributes(fullcmd);
3526 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3531 /* that failed, try the bare name */
3532 res = GetFileAttributes(fullcmd);
3533 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3536 /* quit if no other path exists, or if cmd already has path */
3537 if (!pathstr || !*pathstr || has_slash)
3540 /* skip leading semis */
3541 while (*pathstr == ';')
3544 /* build a new prefix from scratch */
3545 curfullcmd = fullcmd;
3546 while (*pathstr && *pathstr != ';') {
3547 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3548 pathstr++; /* skip initial '"' */
3549 while (*pathstr && *pathstr != '"') {
3550 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3551 *curfullcmd++ = *pathstr;
3555 pathstr++; /* skip trailing '"' */
3558 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3559 *curfullcmd++ = *pathstr;
3564 pathstr++; /* skip trailing semi */
3565 if (curfullcmd > fullcmd /* append a dir separator */
3566 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3568 *curfullcmd++ = '\\';
3576 /* The following are just place holders.
3577 * Some hosts may provide and environment that the OS is
3578 * not tracking, therefore, these host must provide that
3579 * environment and the current directory to CreateProcess
3583 win32_get_childenv(void)
3589 win32_free_childenv(void* d)
3594 win32_clearenv(void)
3596 char *envv = GetEnvironmentStrings();
3600 char *end = strchr(cur,'=');
3601 if (end && end != cur) {
3603 SetEnvironmentVariable(cur, NULL);
3605 cur = end + strlen(end+1)+2;
3607 else if ((len = strlen(cur)))
3610 FreeEnvironmentStrings(envv);
3614 win32_get_childdir(void)
3618 char szfilename[(MAX_PATH+1)*2];
3620 WCHAR wfilename[MAX_PATH+1];
3621 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3622 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3625 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3628 New(0, ptr, strlen(szfilename)+1, char);
3629 strcpy(ptr, szfilename);
3634 win32_free_childdir(char* d)
3641 /* XXX this needs to be made more compatible with the spawnvp()
3642 * provided by the various RTLs. In particular, searching for
3643 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3644 * This doesn't significantly affect perl itself, because we
3645 * always invoke things using PERL5SHELL if a direct attempt to
3646 * spawn the executable fails.
3648 * XXX splitting and rejoining the commandline between do_aspawn()
3649 * and win32_spawnvp() could also be avoided.
3653 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3655 #ifdef USE_RTL_SPAWNVP
3656 return spawnvp(mode, cmdname, (char * const *)argv);
3663 STARTUPINFO StartupInfo;
3664 PROCESS_INFORMATION ProcessInformation;
3667 char *fullcmd = Nullch;
3668 char *cname = (char *)cmdname;
3672 clen = strlen(cname);
3673 /* if command name contains dquotes, must remove them */
3674 if (strchr(cname, '"')) {
3676 New(0,cname,clen+1,char);
3689 cmd = create_command_line(cname, clen, argv);
3691 env = PerlEnv_get_childenv();
3692 dir = PerlEnv_get_childdir();
3695 case P_NOWAIT: /* asynch + remember result */
3696 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3701 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3704 create |= CREATE_NEW_PROCESS_GROUP;
3707 case P_WAIT: /* synchronous execution */
3709 default: /* invalid mode */
3714 memset(&StartupInfo,0,sizeof(StartupInfo));
3715 StartupInfo.cb = sizeof(StartupInfo);
3716 memset(&tbl,0,sizeof(tbl));
3717 PerlEnv_get_child_IO(&tbl);
3718 StartupInfo.dwFlags = tbl.dwFlags;
3719 StartupInfo.dwX = tbl.dwX;
3720 StartupInfo.dwY = tbl.dwY;
3721 StartupInfo.dwXSize = tbl.dwXSize;
3722 StartupInfo.dwYSize = tbl.dwYSize;
3723 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3724 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3725 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3726 StartupInfo.wShowWindow = tbl.wShowWindow;
3727 StartupInfo.hStdInput = tbl.childStdIn;
3728 StartupInfo.hStdOutput = tbl.childStdOut;
3729 StartupInfo.hStdError = tbl.childStdErr;
3730 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3731 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3732 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3734 create |= CREATE_NEW_CONSOLE;
3737 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3739 if (w32_use_showwindow) {
3740 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3741 StartupInfo.wShowWindow = w32_showwindow;
3744 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3747 if (!CreateProcess(cname, /* search PATH to find executable */
3748 cmd, /* executable, and its arguments */
3749 NULL, /* process attributes */
3750 NULL, /* thread attributes */
3751 TRUE, /* inherit handles */
3752 create, /* creation flags */
3753 (LPVOID)env, /* inherit environment */
3754 dir, /* inherit cwd */
3756 &ProcessInformation))
3758 /* initial NULL argument to CreateProcess() does a PATH
3759 * search, but it always first looks in the directory
3760 * where the current process was started, which behavior
3761 * is undesirable for backward compatibility. So we
3762 * jump through our own hoops by picking out the path
3763 * we really want it to use. */
3765 fullcmd = qualified_path(cname);
3767 if (cname != cmdname)
3770 DEBUG_p(PerlIO_printf(Perl_debug_log,
3771 "Retrying [%s] with same args\n",
3781 if (mode == P_NOWAIT) {
3782 /* asynchronous spawn -- store handle, return PID */
3783 ret = (int)ProcessInformation.dwProcessId;
3784 if (IsWin95() && ret < 0)
3787 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3788 w32_child_pids[w32_num_children] = (DWORD)ret;
3793 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3794 /* FIXME: if msgwait returned due to message perhaps forward the
3795 "signal" to the process
3797 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3799 CloseHandle(ProcessInformation.hProcess);
3802 CloseHandle(ProcessInformation.hThread);
3805 PerlEnv_free_childenv(env);
3806 PerlEnv_free_childdir(dir);
3808 if (cname != cmdname)
3815 win32_execv(const char *cmdname, const char *const *argv)
3819 /* if this is a pseudo-forked child, we just want to spawn
3820 * the new program, and return */
3822 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3824 return execv(cmdname, (char *const *)argv);
3828 win32_execvp(const char *cmdname, const char *const *argv)
3832 /* if this is a pseudo-forked child, we just want to spawn
3833 * the new program, and return */
3834 if (w32_pseudo_id) {
3835 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3844 return execvp(cmdname, (char *const *)argv);
3848 win32_perror(const char *str)
3854 win32_setbuf(FILE *pf, char *buf)
3860 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3862 return setvbuf(pf, buf, type, size);
3866 win32_flushall(void)
3872 win32_fcloseall(void)
3878 win32_fgets(char *s, int n, FILE *pf)
3880 return fgets(s, n, pf);
3890 win32_fgetc(FILE *pf)
3896 win32_putc(int c, FILE *pf)
3902 win32_puts(const char *s)
3914 win32_putchar(int c)
3921 #ifndef USE_PERL_SBRK
3923 static char *committed = NULL; /* XXX threadead */
3924 static char *base = NULL; /* XXX threadead */
3925 static char *reserved = NULL; /* XXX threadead */
3926 static char *brk = NULL; /* XXX threadead */
3927 static DWORD pagesize = 0; /* XXX threadead */
3928 static DWORD allocsize = 0; /* XXX threadead */
3931 sbrk(ptrdiff_t need)
3936 GetSystemInfo(&info);
3937 /* Pretend page size is larger so we don't perpetually
3938 * call the OS to commit just one page ...
3940 pagesize = info.dwPageSize << 3;
3941 allocsize = info.dwAllocationGranularity;
3943 /* This scheme fails eventually if request for contiguous
3944 * block is denied so reserve big blocks - this is only
3945 * address space not memory ...
3947 if (brk+need >= reserved)
3949 DWORD size = 64*1024*1024;
3951 if (committed && reserved && committed < reserved)
3953 /* Commit last of previous chunk cannot span allocations */
3954 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3956 committed = reserved;
3958 /* Reserve some (more) space
3959 * Note this is a little sneaky, 1st call passes NULL as reserved
3960 * so lets system choose where we start, subsequent calls pass
3961 * the old end address so ask for a contiguous block
3963 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3966 reserved = addr+size;
3981 if (brk > committed)
3983 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3984 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3999 win32_malloc(size_t size)
4001 return malloc(size);
4005 win32_calloc(size_t numitems, size_t size)
4007 return calloc(numitems,size);
4011 win32_realloc(void *block, size_t size)
4013 return realloc(block,size);
4017 win32_free(void *block)
4024 win32_open_osfhandle(intptr_t handle, int flags)
4026 #ifdef USE_FIXED_OSFHANDLE
4028 return my_open_osfhandle(handle, flags);
4030 return _open_osfhandle(handle, flags);
4034 win32_get_osfhandle(int fd)
4036 return (intptr_t)_get_osfhandle(fd);
4040 win32_dynaload(const char* filename)
4044 char buf[MAX_PATH+1];
4047 /* LoadLibrary() doesn't recognize forward slashes correctly,
4048 * so turn 'em back. */
4049 first = strchr(filename, '/');
4051 STRLEN len = strlen(filename);
4052 if (len <= MAX_PATH) {
4053 strcpy(buf, filename);
4054 filename = &buf[first - filename];
4056 if (*filename == '/')
4057 *(char*)filename = '\\';
4064 WCHAR wfilename[MAX_PATH+1];
4065 A2WHELPER(filename, wfilename, sizeof(wfilename));
4066 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4069 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4079 XS(w32_SetChildShowWindow)
4082 BOOL use_showwindow = w32_use_showwindow;
4083 /* use "unsigned short" because Perl has redefined "WORD" */
4084 unsigned short showwindow = w32_showwindow;
4087 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4089 if (items == 0 || !SvOK(ST(0)))
4090 w32_use_showwindow = FALSE;
4092 w32_use_showwindow = TRUE;
4093 w32_showwindow = (unsigned short)SvIV(ST(0));
4098 ST(0) = sv_2mortal(newSViv(showwindow));
4100 ST(0) = &PL_sv_undef;
4108 /* Make the host for current directory */
4109 char* ptr = PerlEnv_get_childdir();
4112 * then it worked, set PV valid,
4113 * else return 'undef'
4116 SV *sv = sv_newmortal();
4118 PerlEnv_free_childdir(ptr);
4120 #ifndef INCOMPLETE_TAINTS
4137 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4138 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4145 XS(w32_GetNextAvailDrive)
4149 char root[] = "_:\\";
4154 if (GetDriveType(root) == 1) {
4163 XS(w32_GetLastError)
4167 XSRETURN_IV(GetLastError());
4171 XS(w32_SetLastError)
4175 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4176 SetLastError(SvIV(ST(0)));
4184 char *name = w32_getlogin_buffer;
4185 DWORD size = sizeof(w32_getlogin_buffer);
4187 if (GetUserName(name,&size)) {
4188 /* size includes NULL */
4189 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4199 char name[MAX_COMPUTERNAME_LENGTH+1];
4200 DWORD size = sizeof(name);
4202 if (GetComputerName(name,&size)) {
4203 /* size does NOT include NULL :-( */
4204 ST(0) = sv_2mortal(newSVpvn(name,size));
4215 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4216 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4217 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4221 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4222 GetProcAddress(hNetApi32, "NetApiBufferFree");
4223 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4224 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4227 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4228 /* this way is more reliable, in case user has a local account. */
4230 DWORD dnamelen = sizeof(dname);
4232 DWORD wki100_platform_id;
4233 LPWSTR wki100_computername;
4234 LPWSTR wki100_langroup;
4235 DWORD wki100_ver_major;
4236 DWORD wki100_ver_minor;
4238 /* NERR_Success *is* 0*/
4239 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4240 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4241 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4242 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4245 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4246 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4248 pfnNetApiBufferFree(pwi);
4249 FreeLibrary(hNetApi32);
4252 FreeLibrary(hNetApi32);
4255 /* Win95 doesn't have NetWksta*(), so do it the old way */
4257 DWORD size = sizeof(name);
4259 FreeLibrary(hNetApi32);
4260 if (GetUserName(name,&size)) {
4261 char sid[ONE_K_BUFSIZE];
4262 DWORD sidlen = sizeof(sid);
4264 DWORD dnamelen = sizeof(dname);
4266 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4267 dname, &dnamelen, &snu)) {
4268 XSRETURN_PV(dname); /* all that for this */
4280 DWORD flags, filecomplen;
4281 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4282 &flags, fsname, sizeof(fsname))) {
4283 if (GIMME_V == G_ARRAY) {
4284 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4285 XPUSHs(sv_2mortal(newSViv(flags)));
4286 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4291 XSRETURN_PV(fsname);
4297 XS(w32_GetOSVersion)
4300 OSVERSIONINFOA osver;
4303 OSVERSIONINFOW osverw;
4304 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4305 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4306 if (!GetVersionExW(&osverw)) {
4309 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4310 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4311 osver.dwMajorVersion = osverw.dwMajorVersion;
4312 osver.dwMinorVersion = osverw.dwMinorVersion;
4313 osver.dwBuildNumber = osverw.dwBuildNumber;
4314 osver.dwPlatformId = osverw.dwPlatformId;
4317 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4318 if (!GetVersionExA(&osver)) {
4321 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4323 XPUSHs(newSViv(osver.dwMajorVersion));
4324 XPUSHs(newSViv(osver.dwMinorVersion));
4325 XPUSHs(newSViv(osver.dwBuildNumber));
4326 XPUSHs(newSViv(osver.dwPlatformId));
4335 XSRETURN_IV(IsWinNT());
4343 XSRETURN_IV(IsWin95());
4347 XS(w32_FormatMessage)
4351 char msgbuf[ONE_K_BUFSIZE];
4354 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4357 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4358 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4359 &source, SvIV(ST(0)), 0,
4360 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4362 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4363 XSRETURN_PV(msgbuf);
4367 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4368 &source, SvIV(ST(0)), 0,
4369 msgbuf, sizeof(msgbuf)-1, NULL))
4370 XSRETURN_PV(msgbuf);
4383 PROCESS_INFORMATION stProcInfo;
4384 STARTUPINFO stStartInfo;
4385 BOOL bSuccess = FALSE;
4388 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4390 cmd = SvPV_nolen(ST(0));
4391 args = SvPV_nolen(ST(1));
4393 env = PerlEnv_get_childenv();
4394 dir = PerlEnv_get_childdir();
4396 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4397 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4398 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4399 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4402 cmd, /* Image path */
4403 args, /* Arguments for command line */
4404 NULL, /* Default process security */
4405 NULL, /* Default thread security */
4406 FALSE, /* Must be TRUE to use std handles */
4407 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4408 env, /* Inherit our environment block */
4409 dir, /* Inherit our currrent directory */
4410 &stStartInfo, /* -> Startup info */
4411 &stProcInfo)) /* <- Process info (if OK) */
4413 int pid = (int)stProcInfo.dwProcessId;
4414 if (IsWin95() && pid < 0)
4416 sv_setiv(ST(2), pid);
4417 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4420 PerlEnv_free_childenv(env);
4421 PerlEnv_free_childdir(dir);
4422 XSRETURN_IV(bSuccess);
4426 XS(w32_GetTickCount)
4429 DWORD msec = GetTickCount();
4437 XS(w32_GetShortPathName)
4444 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4446 shortpath = sv_mortalcopy(ST(0));
4447 SvUPGRADE(shortpath, SVt_PV);
4448 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4451 /* src == target is allowed */
4453 len = GetShortPathName(SvPVX(shortpath),
4456 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4458 SvCUR_set(shortpath,len);
4466 XS(w32_GetFullPathName)
4475 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4478 fullpath = sv_mortalcopy(filename);
4479 SvUPGRADE(fullpath, SVt_PV);
4480 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4484 len = GetFullPathName(SvPVX(filename),
4488 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4490 if (GIMME_V == G_ARRAY) {
4492 XST_mPV(1,filepart);
4493 len = filepart - SvPVX(fullpath);
4496 SvCUR_set(fullpath,len);
4504 XS(w32_GetLongPathName)
4508 char tmpbuf[MAX_PATH+1];
4513 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4516 pathstr = SvPV(path,len);
4517 strcpy(tmpbuf, pathstr);
4518 pathstr = win32_longpath(tmpbuf);
4520 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4531 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4542 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4544 WCHAR wSourceFile[MAX_PATH+1];
4545 WCHAR wDestFile[MAX_PATH+1];
4546 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4547 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4548 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4549 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4552 char szSourceFile[MAX_PATH+1];
4553 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4554 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4563 Perl_init_os_extras(void)
4566 char *file = __FILE__;
4569 /* these names are Activeware compatible */
4570 newXS("Win32::GetCwd", w32_GetCwd, file);
4571 newXS("Win32::SetCwd", w32_SetCwd, file);
4572 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4573 newXS("Win32::GetLastError", w32_GetLastError, file);
4574 newXS("Win32::SetLastError", w32_SetLastError, file);
4575 newXS("Win32::LoginName", w32_LoginName, file);
4576 newXS("Win32::NodeName", w32_NodeName, file);
4577 newXS("Win32::DomainName", w32_DomainName, file);
4578 newXS("Win32::FsType", w32_FsType, file);
4579 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4580 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4581 newXS("Win32::IsWin95", w32_IsWin95, file);
4582 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4583 newXS("Win32::Spawn", w32_Spawn, file);
4584 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4585 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4586 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4587 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4588 newXS("Win32::CopyFile", w32_CopyFile, file);
4589 newXS("Win32::Sleep", w32_Sleep, file);
4590 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4592 /* XXX Bloat Alert! The following Activeware preloads really
4593 * ought to be part of Win32::Sys::*, so they're not included
4596 /* LookupAccountName
4598 * InitiateSystemShutdown
4599 * AbortSystemShutdown
4600 * ExpandEnvrironmentStrings
4607 win32_signal_context(void)
4611 my_perl = PL_curinterp;
4612 PERL_SET_THX(my_perl);
4620 win32_ctrlhandler(DWORD dwCtrlType)
4623 dTHXa(PERL_GET_SIG_CONTEXT);
4629 switch(dwCtrlType) {
4630 case CTRL_CLOSE_EVENT:
4631 /* A signal that the system sends to all processes attached to a console when
4632 the user closes the console (either by choosing the Close command from the
4633 console window's System menu, or by choosing the End Task command from the
4636 if (do_raise(aTHX_ 1)) /* SIGHUP */
4637 sig_terminate(aTHX_ 1);
4641 /* A CTRL+c signal was received */
4642 if (do_raise(aTHX_ SIGINT))
4643 sig_terminate(aTHX_ SIGINT);
4646 case CTRL_BREAK_EVENT:
4647 /* A CTRL+BREAK signal was received */
4648 if (do_raise(aTHX_ SIGBREAK))
4649 sig_terminate(aTHX_ SIGBREAK);
4652 case CTRL_LOGOFF_EVENT:
4653 /* A signal that the system sends to all console processes when a user is logging
4654 off. This signal does not indicate which user is logging off, so no
4655 assumptions can be made.
4658 case CTRL_SHUTDOWN_EVENT:
4659 /* A signal that the system sends to all console processes when the system is
4662 if (do_raise(aTHX_ SIGTERM))
4663 sig_terminate(aTHX_ SIGTERM);
4673 Perl_win32_init(int *argcp, char ***argvp)
4675 /* Disable floating point errors, Perl will trap the ones we
4676 * care about. VC++ RTL defaults to switching these off
4677 * already, but the Borland RTL doesn't. Since we don't
4678 * want to be at the vendor's whim on the default, we set
4679 * it explicitly here.
4681 #if !defined(_ALPHA_) && !defined(__GNUC__)
4682 _control87(MCW_EM, MCW_EM);
4688 win32_get_child_IO(child_IO_table* ptbl)
4690 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4691 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4692 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4696 win32_signal(int sig, Sighandler_t subcode)
4699 if (sig < SIG_SIZE) {
4700 int save_errno = errno;
4701 Sighandler_t result = signal(sig, subcode);
4702 if (result == SIG_ERR) {
4703 result = w32_sighandler[sig];
4706 w32_sighandler[sig] = subcode;
4716 #ifdef HAVE_INTERP_INTERN
4720 win32_csighandler(int sig)
4723 dTHXa(PERL_GET_SIG_CONTEXT);
4724 Perl_warn(aTHX_ "Got signal %d",sig);
4730 Perl_sys_intern_init(pTHX)
4733 w32_perlshell_tokens = Nullch;
4734 w32_perlshell_vec = (char**)NULL;
4735 w32_perlshell_items = 0;
4736 w32_fdpid = newAV();
4737 New(1313, w32_children, 1, child_tab);
4738 w32_num_children = 0;
4739 # ifdef USE_ITHREADS
4741 New(1313, w32_pseudo_children, 1, child_tab);
4742 w32_num_pseudo_children = 0;
4744 w32_init_socktype = 0;
4747 for (i=0; i < SIG_SIZE; i++) {
4748 w32_sighandler[i] = SIG_DFL;
4751 if (my_perl == PL_curinterp) {
4755 /* Force C runtime signal stuff to set its console handler */
4756 signal(SIGINT,&win32_csighandler);
4757 signal(SIGBREAK,&win32_csighandler);
4758 /* Push our handler on top */
4759 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4764 Perl_sys_intern_clear(pTHX)
4766 Safefree(w32_perlshell_tokens);
4767 Safefree(w32_perlshell_vec);
4768 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4769 Safefree(w32_children);
4771 KillTimer(NULL,w32_timerid);
4774 # ifdef MULTIPLICITY
4775 if (my_perl == PL_curinterp) {
4779 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4781 # ifdef USE_ITHREADS
4782 Safefree(w32_pseudo_children);
4786 # ifdef USE_ITHREADS
4789 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4791 dst->perlshell_tokens = Nullch;
4792 dst->perlshell_vec = (char**)NULL;
4793 dst->perlshell_items = 0;
4794 dst->fdpid = newAV();
4795 Newz(1313, dst->children, 1, child_tab);
4797 Newz(1313, dst->pseudo_children, 1, child_tab);
4798 dst->thr_intern.Winit_socktype = 0;
4800 dst->poll_count = 0;
4801 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4803 # endif /* USE_ITHREADS */
4804 #endif /* HAVE_INTERP_INTERN */
4807 win32_free_argvw(pTHX_ void *ptr)
4809 char** argv = (char**)ptr;
4817 win32_argv2utf8(int argc, char** argv)
4822 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4823 if (lpwStr && argc) {
4825 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4826 Newz(0, psz, length, char);
4827 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4830 call_atexit(win32_free_argvw, argv);
4832 GlobalFree((HGLOBAL)lpwStr);