3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
10 #define PERLIO_NOT_STDIO 0
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
19 # define HWND_MESSAGE ((HWND)-3)
25 /* #include "config.h" */
27 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
35 /* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
36 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
37 # include <shellapi.h>
39 EXTERN_C LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
43 #define PERL_NO_GET_CONTEXT
49 /* assert.h conflicts with #define of assert in perl.h */
56 #if defined(_MSC_VER) || defined(__MINGW32__)
57 #include <sys/utime.h>
62 /* Mingw32 defaults to globing command line
63 * So we turn it off like this:
68 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
69 /* Mingw32-1.1 is missing some prototypes */
71 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
72 FILE * _wfdopen(int nFd, LPCWSTR wszMode);
73 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
79 #if defined(__BORLANDC__)
81 # define _utimbuf utimbuf
86 #define EXECF_SPAWN_NOWAIT 3
88 #if defined(PERL_IMPLICIT_SYS)
89 # undef win32_get_privlib
90 # define win32_get_privlib g_win32_get_privlib
91 # undef win32_get_sitelib
92 # define win32_get_sitelib g_win32_get_sitelib
93 # undef win32_get_vendorlib
94 # define win32_get_vendorlib g_win32_get_vendorlib
96 # define getlogin g_getlogin
99 static void get_shell(void);
100 static long tokenize(const char *str, char **dest, char ***destv);
101 static int do_spawn2(pTHX_ const char *cmd, int exectype);
102 static BOOL has_shell_metachars(const char *ptr);
103 static long filetime_to_clock(PFILETIME ft);
104 static BOOL filetime_from_time(PFILETIME ft, time_t t);
105 static char * get_emd_part(SV **leading, char *trailing, ...);
106 static void remove_dead_process(long deceased);
107 static long find_pid(int pid);
108 static char * qualified_path(const char *cmd);
109 static char * win32_get_xlib(const char *pl, const char *xlib,
110 const char *libname);
113 static void remove_dead_pseudo_process(long child);
114 static long find_pseudo_pid(int pid);
118 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
119 char w32_module_name[MAX_PATH+1];
122 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
124 #define ONE_K_BUFSIZE 1024
127 /* Silence STDERR grumblings from Borland's math library. */
129 _matherr(struct _exception *a)
137 void my_invalid_parameter_handler(const wchar_t* expression,
138 const wchar_t* function,
144 wprintf(L"Invalid parameter detected in function %s."
145 L" File: %s Line: %d\n", function, file, line);
146 wprintf(L"Expression: %s\n", expression);
154 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
160 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
164 set_w32_module_name(void)
167 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
168 ? GetModuleHandle(NULL)
169 : w32_perldll_handle),
170 w32_module_name, sizeof(w32_module_name));
172 /* remove \\?\ prefix */
173 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
174 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
176 /* try to get full path to binary (which may be mangled when perl is
177 * run from a 16-bit app) */
178 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
179 (void)win32_longpath(w32_module_name);
180 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
182 /* normalize to forward slashes */
183 ptr = w32_module_name;
191 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
193 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
195 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
198 const char *subkey = "Software\\Perl";
202 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
203 if (retval == ERROR_SUCCESS) {
205 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
206 if (retval == ERROR_SUCCESS
207 && (type == REG_SZ || type == REG_EXPAND_SZ))
211 *svp = sv_2mortal(newSVpvn("",0));
212 SvGROW(*svp, datalen);
213 retval = RegQueryValueEx(handle, valuename, 0, NULL,
214 (PBYTE)SvPVX(*svp), &datalen);
215 if (retval == ERROR_SUCCESS) {
217 SvCUR_set(*svp,datalen-1);
225 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
227 get_regstr(const char *valuename, SV **svp)
229 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
231 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
235 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
237 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
241 char mod_name[MAX_PATH+1];
247 va_start(ap, trailing_path);
248 strip = va_arg(ap, char *);
250 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
251 baselen = strlen(base);
253 if (!*w32_module_name) {
254 set_w32_module_name();
256 strcpy(mod_name, w32_module_name);
257 ptr = strrchr(mod_name, '/');
258 while (ptr && strip) {
259 /* look for directories to skip back */
262 ptr = strrchr(mod_name, '/');
263 /* avoid stripping component if there is no slash,
264 * or it doesn't match ... */
265 if (!ptr || stricmp(ptr+1, strip) != 0) {
266 /* ... but not if component matches m|5\.$patchlevel.*| */
267 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
268 && strncmp(strip, base, baselen) == 0
269 && strncmp(ptr+1, base, baselen) == 0))
275 strip = va_arg(ap, char *);
283 strcpy(++ptr, trailing_path);
285 /* only add directory if it exists */
286 if (GetFileAttributes(mod_name) != (DWORD) -1) {
287 /* directory exists */
290 *prev_pathp = sv_2mortal(newSVpvn("",0));
291 else if (SvPVX(*prev_pathp))
292 sv_catpvn(*prev_pathp, ";", 1);
293 sv_catpv(*prev_pathp, mod_name);
294 return SvPVX(*prev_pathp);
301 win32_get_privlib(const char *pl)
304 char *stdlib = "lib";
305 char buffer[MAX_PATH+1];
308 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
309 sprintf(buffer, "%s-%s", stdlib, pl);
310 if (!get_regstr(buffer, &sv))
311 (void)get_regstr(stdlib, &sv);
313 /* $stdlib .= ";$EMD/../../lib" */
314 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
318 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
322 char pathstr[MAX_PATH+1];
326 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
327 sprintf(regstr, "%s-%s", xlib, pl);
328 (void)get_regstr(regstr, &sv1);
331 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
332 sprintf(pathstr, "%s/%s/lib", libname, pl);
333 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
335 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
336 (void)get_regstr(xlib, &sv2);
339 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
340 sprintf(pathstr, "%s/lib", libname);
341 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
350 sv_catpvn(sv1, ";", 1);
357 win32_get_sitelib(const char *pl)
359 return win32_get_xlib(pl, "sitelib", "site");
362 #ifndef PERL_VENDORLIB_NAME
363 # define PERL_VENDORLIB_NAME "vendor"
367 win32_get_vendorlib(const char *pl)
369 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
373 has_shell_metachars(const char *ptr)
379 * Scan string looking for redirection (< or >) or pipe
380 * characters (|) that are not in a quoted string.
381 * Shell variable interpolation (%VAR%) can also happen inside strings.
413 #if !defined(PERL_IMPLICIT_SYS)
414 /* since the current process environment is being updated in util.c
415 * the library functions will get the correct environment
418 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
421 #define fixcmd(x) { \
422 char *pspace = strchr((x),' '); \
425 while (p < pspace) { \
436 PERL_FLUSHALL_FOR_CHILD;
437 return win32_popen(cmd, mode);
441 Perl_my_pclose(pTHX_ PerlIO *fp)
443 return win32_pclose(fp);
447 DllExport unsigned long
450 return (unsigned long)g_osver.dwPlatformId;
460 return -((int)w32_pseudo_id);
463 /* Windows 9x appears to always reports a pid for threads and processes
464 * that has the high bit set. So we treat the lower 31 bits as the
465 * "real" PID for Perl's purposes. */
466 if (IsWin95() && pid < 0)
471 /* Tokenize a string. Words are null-separated, and the list
472 * ends with a doubled null. Any character (except null and
473 * including backslash) may be escaped by preceding it with a
474 * backslash (the backslash will be stripped).
475 * Returns number of words in result buffer.
478 tokenize(const char *str, char **dest, char ***destv)
480 char *retstart = Nullch;
481 char **retvstart = 0;
485 int slen = strlen(str);
487 register char **retv;
488 Newx(ret, slen+2, char);
489 Newx(retv, (slen+3)/2, char*);
497 if (*ret == '\\' && *str)
499 else if (*ret == ' ') {
515 retvstart[items] = Nullch;
528 if (!w32_perlshell_tokens) {
529 /* we don't use COMSPEC here for two reasons:
530 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
531 * uncontrolled unportability of the ensuing scripts.
532 * 2. PERL5SHELL could be set to a shell that may not be fit for
533 * interactive use (which is what most programs look in COMSPEC
536 const char* defaultshell = (IsWinNT()
537 ? "cmd.exe /x/d/c" : "command.com /c");
538 const char *usershell = PerlEnv_getenv("PERL5SHELL");
539 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
540 &w32_perlshell_tokens,
546 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
558 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
560 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
565 while (++mark <= sp) {
566 if (*mark && (str = SvPV_nolen(*mark)))
573 status = win32_spawnvp(flag,
574 (const char*)(really ? SvPV_nolen(really) : argv[0]),
575 (const char* const*)argv);
577 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
578 /* possible shell-builtin, invoke with shell */
580 sh_items = w32_perlshell_items;
582 argv[index+sh_items] = argv[index];
583 while (--sh_items >= 0)
584 argv[sh_items] = w32_perlshell_vec[sh_items];
586 status = win32_spawnvp(flag,
587 (const char*)(really ? SvPV_nolen(really) : argv[0]),
588 (const char* const*)argv);
591 if (flag == P_NOWAIT) {
593 PL_statusvalue = -1; /* >16bits hint for pp_system() */
597 if (ckWARN(WARN_EXEC))
598 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
603 PL_statusvalue = status;
609 /* returns pointer to the next unquoted space or the end of the string */
611 find_next_space(const char *s)
613 bool in_quotes = FALSE;
615 /* ignore doubled backslashes, or backslash+quote */
616 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
619 /* keep track of when we're within quotes */
620 else if (*s == '"') {
622 in_quotes = !in_quotes;
624 /* break it up only at spaces that aren't in quotes */
625 else if (!in_quotes && isSPACE(*s))
634 do_spawn2(pTHX_ const char *cmd, int exectype)
640 BOOL needToTry = TRUE;
643 /* Save an extra exec if possible. See if there are shell
644 * metacharacters in it */
645 if (!has_shell_metachars(cmd)) {
646 Newx(argv, strlen(cmd) / 2 + 2, char*);
647 Newx(cmd2, strlen(cmd) + 1, char);
650 for (s = cmd2; *s;) {
651 while (*s && isSPACE(*s))
655 s = find_next_space(s);
663 status = win32_spawnvp(P_WAIT, argv[0],
664 (const char* const*)argv);
666 case EXECF_SPAWN_NOWAIT:
667 status = win32_spawnvp(P_NOWAIT, argv[0],
668 (const char* const*)argv);
671 status = win32_execvp(argv[0], (const char* const*)argv);
674 if (status != -1 || errno == 0)
684 Newx(argv, w32_perlshell_items + 2, char*);
685 while (++i < w32_perlshell_items)
686 argv[i] = w32_perlshell_vec[i];
687 argv[i++] = (char *)cmd;
691 status = win32_spawnvp(P_WAIT, argv[0],
692 (const char* const*)argv);
694 case EXECF_SPAWN_NOWAIT:
695 status = win32_spawnvp(P_NOWAIT, argv[0],
696 (const char* const*)argv);
699 status = win32_execvp(argv[0], (const char* const*)argv);
705 if (exectype == EXECF_SPAWN_NOWAIT) {
707 PL_statusvalue = -1; /* >16bits hint for pp_system() */
711 if (ckWARN(WARN_EXEC))
712 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
713 (exectype == EXECF_EXEC ? "exec" : "spawn"),
714 cmd, strerror(errno));
719 PL_statusvalue = status;
725 Perl_do_spawn(pTHX_ char *cmd)
727 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
731 Perl_do_spawn_nowait(pTHX_ char *cmd)
733 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
737 Perl_do_exec(pTHX_ const char *cmd)
739 do_spawn2(aTHX_ cmd, EXECF_EXEC);
743 /* The idea here is to read all the directory names into a string table
744 * (separated by nulls) and when one of the other dir functions is called
745 * return the pointer to the current file name.
748 win32_opendir(const char *filename)
754 char scanname[MAX_PATH+3];
756 WIN32_FIND_DATAA aFindData;
758 len = strlen(filename);
762 /* check to see if filename is a directory */
763 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
766 /* Get us a DIR structure */
769 /* Create the search pattern */
770 strcpy(scanname, filename);
772 /* bare drive name means look in cwd for drive */
773 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
774 scanname[len++] = '.';
775 scanname[len++] = '/';
777 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
778 scanname[len++] = '/';
780 scanname[len++] = '*';
781 scanname[len] = '\0';
783 /* do the FindFirstFile call */
784 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
785 if (dirp->handle == INVALID_HANDLE_VALUE) {
786 DWORD err = GetLastError();
787 /* FindFirstFile() fails on empty drives! */
789 case ERROR_FILE_NOT_FOUND:
791 case ERROR_NO_MORE_FILES:
792 case ERROR_PATH_NOT_FOUND:
795 case ERROR_NOT_ENOUGH_MEMORY:
806 /* now allocate the first part of the string table for
807 * the filenames that we find.
809 idx = strlen(aFindData.cFileName)+1;
814 Newx(dirp->start, dirp->size, char);
815 strcpy(dirp->start, aFindData.cFileName);
817 dirp->end = dirp->curr = dirp->start;
823 /* Readdir just returns the current string pointer and bumps the
824 * string pointer to the nDllExport entry.
826 DllExport struct direct *
827 win32_readdir(DIR *dirp)
832 /* first set up the structure to return */
833 len = strlen(dirp->curr);
834 strcpy(dirp->dirstr.d_name, dirp->curr);
835 dirp->dirstr.d_namlen = len;
838 dirp->dirstr.d_ino = dirp->curr - dirp->start;
840 /* Now set up for the next call to readdir */
841 dirp->curr += len + 1;
842 if (dirp->curr >= dirp->end) {
845 WIN32_FIND_DATAA aFindData;
847 /* finding the next file that matches the wildcard
848 * (which should be all of them in this directory!).
850 res = FindNextFileA(dirp->handle, &aFindData);
852 long endpos = dirp->end - dirp->start;
853 long newsize = endpos + strlen(aFindData.cFileName) + 1;
854 /* bump the string table size by enough for the
855 * new name and its null terminator */
856 while (newsize > dirp->size) {
857 long curpos = dirp->curr - dirp->start;
859 Renew(dirp->start, dirp->size, char);
860 dirp->curr = dirp->start + curpos;
862 strcpy(dirp->start + endpos, aFindData.cFileName);
863 dirp->end = dirp->start + newsize;
869 return &(dirp->dirstr);
875 /* Telldir returns the current string pointer position */
877 win32_telldir(DIR *dirp)
879 return (dirp->curr - dirp->start);
883 /* Seekdir moves the string pointer to a previously saved position
884 * (returned by telldir).
887 win32_seekdir(DIR *dirp, long loc)
889 dirp->curr = dirp->start + loc;
892 /* Rewinddir resets the string pointer to the start */
894 win32_rewinddir(DIR *dirp)
896 dirp->curr = dirp->start;
899 /* free the memory allocated by opendir */
901 win32_closedir(DIR *dirp)
904 if (dirp->handle != INVALID_HANDLE_VALUE)
905 FindClose(dirp->handle);
906 Safefree(dirp->start);
919 * Just pretend that everyone is a superuser. NT will let us know if
920 * we don\'t really have permission to do something.
923 #define ROOT_UID ((uid_t)0)
924 #define ROOT_GID ((gid_t)0)
953 return (auid == ROOT_UID ? 0 : -1);
959 return (agid == ROOT_GID ? 0 : -1);
966 char *buf = w32_getlogin_buffer;
967 DWORD size = sizeof(w32_getlogin_buffer);
968 if (GetUserName(buf,&size))
974 chown(const char *path, uid_t owner, gid_t group)
981 * XXX this needs strengthening (for PerlIO)
984 int mkstemp(const char *path)
987 char buf[MAX_PATH+1];
991 if (i++ > 10) { /* give up */
995 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
999 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1009 long child = w32_num_children;
1010 while (--child >= 0) {
1011 if ((int)w32_child_pids[child] == pid)
1018 remove_dead_process(long child)
1022 CloseHandle(w32_child_handles[child]);
1023 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1024 (w32_num_children-child-1), HANDLE);
1025 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1026 (w32_num_children-child-1), DWORD);
1033 find_pseudo_pid(int pid)
1036 long child = w32_num_pseudo_children;
1037 while (--child >= 0) {
1038 if ((int)w32_pseudo_child_pids[child] == pid)
1045 remove_dead_pseudo_process(long child)
1049 CloseHandle(w32_pseudo_child_handles[child]);
1050 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1051 (w32_num_pseudo_children-child-1), HANDLE);
1052 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1053 (w32_num_pseudo_children-child-1), DWORD);
1054 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1055 (w32_num_pseudo_children-child-1), HWND);
1056 w32_num_pseudo_children--;
1062 win32_kill(int pid, int sig)
1070 /* it is a pseudo-forked child */
1071 child = find_pseudo_pid(-pid);
1073 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1074 hProcess = w32_pseudo_child_handles[child];
1077 /* "Does process exist?" use of kill */
1081 /* kill -9 style un-graceful exit */
1082 if (TerminateThread(hProcess, sig)) {
1083 remove_dead_pseudo_process(child);
1090 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1091 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1092 /* Yield and wait for the other thread to send us its message_hwnd */
1094 win32_async_check(aTHX);
1097 if (hwnd != INVALID_HANDLE_VALUE) {
1098 /* We fake signals to pseudo-processes using Win32
1099 * message queue. In Win9X the pids are negative already. */
1100 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1101 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1103 /* It might be us ... */
1112 else if (IsWin95()) {
1120 child = find_pid(pid);
1122 hProcess = w32_child_handles[child];
1125 /* "Does process exist?" use of kill */
1128 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1133 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1136 default: /* For now be backwards compatible with perl5.6 */
1138 if (TerminateProcess(hProcess, sig)) {
1139 remove_dead_process(child);
1148 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1149 (IsWin95() ? -pid : pid));
1153 /* "Does process exist?" use of kill */
1157 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1162 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1165 default: /* For now be backwards compatible with perl5.6 */
1167 if (TerminateProcess(hProcess, sig))
1172 CloseHandle(hProcess);
1182 win32_stat(const char *path, Stat_t *sbuf)
1185 char buffer[MAX_PATH+1];
1186 int l = strlen(path);
1189 BOOL expect_dir = FALSE;
1191 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1192 GV_NOTQUAL, SVt_PV);
1193 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1196 switch(path[l - 1]) {
1197 /* FindFirstFile() and stat() are buggy with a trailing
1198 * slashes, except for the root directory of a drive */
1201 if (l > sizeof(buffer)) {
1202 errno = ENAMETOOLONG;
1206 strncpy(buffer, path, l);
1207 /* remove additional trailing slashes */
1208 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1210 /* add back slash if we otherwise end up with just a drive letter */
1211 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1218 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1220 if (l == 2 && isALPHA(path[0])) {
1221 buffer[0] = path[0];
1232 path = PerlDir_mapA(path);
1236 /* We must open & close the file once; otherwise file attribute changes */
1237 /* might not yet have propagated to "other" hard links of the same file. */
1238 /* This also gives us an opportunity to determine the number of links. */
1239 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1240 if (handle != INVALID_HANDLE_VALUE) {
1241 BY_HANDLE_FILE_INFORMATION bhi;
1242 if (GetFileInformationByHandle(handle, &bhi))
1243 nlink = bhi.nNumberOfLinks;
1244 CloseHandle(handle);
1248 /* path will be mapped correctly above */
1249 #if defined(WIN64) || defined(USE_LARGE_FILES)
1250 res = _stati64(path, sbuf);
1252 res = stat(path, sbuf);
1254 sbuf->st_nlink = nlink;
1257 /* CRT is buggy on sharenames, so make sure it really isn't.
1258 * XXX using GetFileAttributesEx() will enable us to set
1259 * sbuf->st_*time (but note that's not available on the
1260 * Windows of 1995) */
1261 DWORD r = GetFileAttributesA(path);
1262 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1263 /* sbuf may still contain old garbage since stat() failed */
1264 Zero(sbuf, 1, Stat_t);
1265 sbuf->st_mode = S_IFDIR | S_IREAD;
1267 if (!(r & FILE_ATTRIBUTE_READONLY))
1268 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1273 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1274 && (path[2] == '\\' || path[2] == '/'))
1276 /* The drive can be inaccessible, some _stat()s are buggy */
1277 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1282 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1287 if (S_ISDIR(sbuf->st_mode))
1288 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1289 else if (S_ISREG(sbuf->st_mode)) {
1291 if (l >= 4 && path[l-4] == '.') {
1292 const char *e = path + l - 3;
1293 if (strnicmp(e,"exe",3)
1294 && strnicmp(e,"bat",3)
1295 && strnicmp(e,"com",3)
1296 && (IsWin95() || strnicmp(e,"cmd",3)))
1297 sbuf->st_mode &= ~S_IEXEC;
1299 sbuf->st_mode |= S_IEXEC;
1302 sbuf->st_mode &= ~S_IEXEC;
1303 /* Propagate permissions to _group_ and _others_ */
1304 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1305 sbuf->st_mode |= (perms>>3) | (perms>>6);
1312 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1313 #define SKIP_SLASHES(s) \
1315 while (*(s) && isSLASH(*(s))) \
1318 #define COPY_NONSLASHES(d,s) \
1320 while (*(s) && !isSLASH(*(s))) \
1324 /* Find the longname of a given path. path is destructively modified.
1325 * It should have space for at least MAX_PATH characters. */
1327 win32_longpath(char *path)
1329 WIN32_FIND_DATA fdata;
1331 char tmpbuf[MAX_PATH+1];
1332 char *tmpstart = tmpbuf;
1339 if (isALPHA(path[0]) && path[1] == ':') {
1341 *tmpstart++ = path[0];
1345 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1347 *tmpstart++ = path[0];
1348 *tmpstart++ = path[1];
1349 SKIP_SLASHES(start);
1350 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1352 *tmpstart++ = *start++;
1353 SKIP_SLASHES(start);
1354 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1359 /* copy initial slash, if any */
1360 if (isSLASH(*start)) {
1361 *tmpstart++ = *start++;
1363 SKIP_SLASHES(start);
1366 /* FindFirstFile() expands "." and "..", so we need to pass
1367 * those through unmolested */
1369 && (!start[1] || isSLASH(start[1])
1370 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1372 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1377 /* if this is the end, bust outta here */
1381 /* now we're at a non-slash; walk up to next slash */
1382 while (*start && !isSLASH(*start))
1385 /* stop and find full name of component */
1388 fhand = FindFirstFile(path,&fdata);
1390 if (fhand != INVALID_HANDLE_VALUE) {
1391 STRLEN len = strlen(fdata.cFileName);
1392 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1393 strcpy(tmpstart, fdata.cFileName);
1404 /* failed a step, just return without side effects */
1405 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1410 strcpy(path,tmpbuf);
1415 win32_getenv(const char *name)
1419 SV *curitem = Nullsv;
1421 needlen = GetEnvironmentVariableA(name,NULL,0);
1423 curitem = sv_2mortal(newSVpvn("", 0));
1425 SvGROW(curitem, needlen+1);
1426 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1428 } while (needlen >= SvLEN(curitem));
1429 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)
1452 Newx(curitem,strlen(name)+1,char);
1453 strcpy(curitem, name);
1454 val = strchr(curitem, '=');
1456 /* The sane way to deal with the environment.
1457 * Has these advantages over putenv() & co.:
1458 * * enables us to store a truly empty value in the
1459 * environment (like in UNIX).
1460 * * we don't have to deal with RTL globals, bugs and leaks.
1462 * Why you may want to enable USE_WIN32_RTL_ENV:
1463 * * environ[] and RTL functions will not reflect changes,
1464 * which might be an issue if extensions want to access
1465 * the env. via RTL. This cuts both ways, since RTL will
1466 * not see changes made by extensions that call the Win32
1467 * functions directly, either.
1471 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1480 filetime_to_clock(PFILETIME ft)
1482 __int64 qw = ft->dwHighDateTime;
1484 qw |= ft->dwLowDateTime;
1485 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1490 win32_times(struct tms *timebuf)
1495 clock_t process_time_so_far = clock();
1496 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1498 timebuf->tms_utime = filetime_to_clock(&user);
1499 timebuf->tms_stime = filetime_to_clock(&kernel);
1500 timebuf->tms_cutime = 0;
1501 timebuf->tms_cstime = 0;
1503 /* That failed - e.g. Win95 fallback to clock() */
1504 timebuf->tms_utime = process_time_so_far;
1505 timebuf->tms_stime = 0;
1506 timebuf->tms_cutime = 0;
1507 timebuf->tms_cstime = 0;
1509 return process_time_so_far;
1512 /* fix utime() so it works on directories in NT */
1514 filetime_from_time(PFILETIME pFileTime, time_t Time)
1516 struct tm *pTM = localtime(&Time);
1517 SYSTEMTIME SystemTime;
1523 SystemTime.wYear = pTM->tm_year + 1900;
1524 SystemTime.wMonth = pTM->tm_mon + 1;
1525 SystemTime.wDay = pTM->tm_mday;
1526 SystemTime.wHour = pTM->tm_hour;
1527 SystemTime.wMinute = pTM->tm_min;
1528 SystemTime.wSecond = pTM->tm_sec;
1529 SystemTime.wMilliseconds = 0;
1531 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1532 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1536 win32_unlink(const char *filename)
1542 filename = PerlDir_mapA(filename);
1543 attrs = GetFileAttributesA(filename);
1544 if (attrs == 0xFFFFFFFF) {
1548 if (attrs & FILE_ATTRIBUTE_READONLY) {
1549 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1550 ret = unlink(filename);
1552 (void)SetFileAttributesA(filename, attrs);
1555 ret = unlink(filename);
1560 win32_utime(const char *filename, struct utimbuf *times)
1567 struct utimbuf TimeBuffer;
1570 filename = PerlDir_mapA(filename);
1571 rc = utime(filename, times);
1573 /* EACCES: path specifies directory or readonly file */
1574 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1577 if (times == NULL) {
1578 times = &TimeBuffer;
1579 time(×->actime);
1580 times->modtime = times->actime;
1583 /* This will (and should) still fail on readonly files */
1584 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1585 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1586 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1587 if (handle == INVALID_HANDLE_VALUE)
1590 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1591 filetime_from_time(&ftAccess, times->actime) &&
1592 filetime_from_time(&ftWrite, times->modtime) &&
1593 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1598 CloseHandle(handle);
1603 unsigned __int64 ft_i64;
1608 #define Const64(x) x##LL
1610 #define Const64(x) x##i64
1612 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1613 #define EPOCH_BIAS Const64(116444736000000000)
1615 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1616 * and appears to be unsupported even by glibc) */
1618 win32_gettimeofday(struct timeval *tp, void *not_used)
1622 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1623 GetSystemTimeAsFileTime(&ft.ft_val);
1625 /* seconds since epoch */
1626 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1628 /* microseconds remaining */
1629 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1635 win32_uname(struct utsname *name)
1637 struct hostent *hep;
1638 STRLEN nodemax = sizeof(name->nodename)-1;
1641 switch (g_osver.dwPlatformId) {
1642 case VER_PLATFORM_WIN32_WINDOWS:
1643 strcpy(name->sysname, "Windows");
1645 case VER_PLATFORM_WIN32_NT:
1646 strcpy(name->sysname, "Windows NT");
1648 case VER_PLATFORM_WIN32s:
1649 strcpy(name->sysname, "Win32s");
1652 strcpy(name->sysname, "Win32 Unknown");
1657 sprintf(name->release, "%d.%d",
1658 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1661 sprintf(name->version, "Build %d",
1662 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1663 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1664 if (g_osver.szCSDVersion[0]) {
1665 char *buf = name->version + strlen(name->version);
1666 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1670 hep = win32_gethostbyname("localhost");
1672 STRLEN len = strlen(hep->h_name);
1673 if (len <= nodemax) {
1674 strcpy(name->nodename, hep->h_name);
1677 strncpy(name->nodename, hep->h_name, nodemax);
1678 name->nodename[nodemax] = '\0';
1683 if (!GetComputerName(name->nodename, &sz))
1684 *name->nodename = '\0';
1687 /* machine (architecture) */
1692 GetSystemInfo(&info);
1694 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1695 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1696 procarch = info.u.s.wProcessorArchitecture;
1698 procarch = info.wProcessorArchitecture;
1701 case PROCESSOR_ARCHITECTURE_INTEL:
1702 arch = "x86"; break;
1703 case PROCESSOR_ARCHITECTURE_MIPS:
1704 arch = "mips"; break;
1705 case PROCESSOR_ARCHITECTURE_ALPHA:
1706 arch = "alpha"; break;
1707 case PROCESSOR_ARCHITECTURE_PPC:
1708 arch = "ppc"; break;
1709 #ifdef PROCESSOR_ARCHITECTURE_SHX
1710 case PROCESSOR_ARCHITECTURE_SHX:
1711 arch = "shx"; break;
1713 #ifdef PROCESSOR_ARCHITECTURE_ARM
1714 case PROCESSOR_ARCHITECTURE_ARM:
1715 arch = "arm"; break;
1717 #ifdef PROCESSOR_ARCHITECTURE_IA64
1718 case PROCESSOR_ARCHITECTURE_IA64:
1719 arch = "ia64"; break;
1721 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1722 case PROCESSOR_ARCHITECTURE_ALPHA64:
1723 arch = "alpha64"; break;
1725 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1726 case PROCESSOR_ARCHITECTURE_MSIL:
1727 arch = "msil"; break;
1729 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1730 case PROCESSOR_ARCHITECTURE_AMD64:
1731 arch = "amd64"; break;
1733 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1734 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1735 arch = "ia32-64"; break;
1737 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1738 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1739 arch = "unknown"; break;
1742 sprintf(name->machine, "unknown(0x%x)", procarch);
1743 arch = name->machine;
1746 if (name->machine != arch)
1747 strcpy(name->machine, arch);
1752 /* Timing related stuff */
1755 do_raise(pTHX_ int sig)
1757 if (sig < SIG_SIZE) {
1758 Sighandler_t handler = w32_sighandler[sig];
1759 if (handler == SIG_IGN) {
1762 else if (handler != SIG_DFL) {
1767 /* Choose correct default behaviour */
1783 /* Tell caller to exit thread/process as approriate */
1788 sig_terminate(pTHX_ int sig)
1790 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1791 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1798 win32_async_check(pTHX)
1801 HWND hwnd = w32_message_hwnd;
1805 if (hwnd == INVALID_HANDLE_VALUE) {
1806 /* Call PeekMessage() to mark all pending messages in the queue as "old".
1807 * This is necessary when we are being called by win32_msgwait() to
1808 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
1809 * message over and over. An example how this can happen is when
1810 * Perl is calling win32_waitpid() inside a GUI application and the GUI
1811 * is generating messages before the process terminated.
1813 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
1819 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1820 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1825 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
1826 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
1828 switch (msg.message) {
1830 case WM_USER_MESSAGE: {
1831 int child = find_pseudo_pid(msg.wParam);
1833 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
1838 case WM_USER_KILL: {
1839 /* We use WM_USER to fake kill() with other signals */
1840 int sig = msg.wParam;
1841 if (do_raise(aTHX_ sig))
1842 sig_terminate(aTHX_ sig);
1847 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1848 if (w32_timerid && w32_timerid==msg.wParam) {
1849 KillTimer(w32_message_hwnd, w32_timerid);
1852 /* Now fake a call to signal handler */
1853 if (do_raise(aTHX_ 14))
1854 sig_terminate(aTHX_ 14);
1861 /* Above or other stuff may have set a signal flag */
1862 if (PL_sig_pending) {
1868 /* This function will not return until the timeout has elapsed, or until
1869 * one of the handles is ready. */
1871 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1873 /* We may need several goes at this - so compute when we stop */
1875 if (timeout != INFINITE) {
1876 ticks = GetTickCount();
1880 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1883 if (result == WAIT_TIMEOUT) {
1884 /* Ran out of time - explicit return of zero to avoid -ve if we
1885 have scheduling issues
1889 if (timeout != INFINITE) {
1890 ticks = GetTickCount();
1892 if (result == WAIT_OBJECT_0 + count) {
1893 /* Message has arrived - check it */
1894 (void)win32_async_check(aTHX);
1897 /* Not timeout or message - one of handles is ready */
1901 /* compute time left to wait */
1902 ticks = timeout - ticks;
1903 /* If we are past the end say zero */
1904 return (ticks > 0) ? ticks : 0;
1908 win32_internal_wait(int *status, DWORD timeout)
1910 /* XXX this wait emulation only knows about processes
1911 * spawned via win32_spawnvp(P_NOWAIT, ...).
1915 DWORD exitcode, waitcode;
1918 if (w32_num_pseudo_children) {
1919 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1920 timeout, &waitcode);
1921 /* Time out here if there are no other children to wait for. */
1922 if (waitcode == WAIT_TIMEOUT) {
1923 if (!w32_num_children) {
1927 else if (waitcode != WAIT_FAILED) {
1928 if (waitcode >= WAIT_ABANDONED_0
1929 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1930 i = waitcode - WAIT_ABANDONED_0;
1932 i = waitcode - WAIT_OBJECT_0;
1933 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1934 *status = (int)((exitcode & 0xff) << 8);
1935 retval = (int)w32_pseudo_child_pids[i];
1936 remove_dead_pseudo_process(i);
1943 if (!w32_num_children) {
1948 /* if a child exists, wait for it to die */
1949 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1950 if (waitcode == WAIT_TIMEOUT) {
1953 if (waitcode != WAIT_FAILED) {
1954 if (waitcode >= WAIT_ABANDONED_0
1955 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1956 i = waitcode - WAIT_ABANDONED_0;
1958 i = waitcode - WAIT_OBJECT_0;
1959 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1960 *status = (int)((exitcode & 0xff) << 8);
1961 retval = (int)w32_child_pids[i];
1962 remove_dead_process(i);
1967 errno = GetLastError();
1972 win32_waitpid(int pid, int *status, int flags)
1975 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1978 if (pid == -1) /* XXX threadid == 1 ? */
1979 return win32_internal_wait(status, timeout);
1982 child = find_pseudo_pid(-pid);
1984 HANDLE hThread = w32_pseudo_child_handles[child];
1986 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1987 if (waitcode == WAIT_TIMEOUT) {
1990 else if (waitcode == WAIT_OBJECT_0) {
1991 if (GetExitCodeThread(hThread, &waitcode)) {
1992 *status = (int)((waitcode & 0xff) << 8);
1993 retval = (int)w32_pseudo_child_pids[child];
1994 remove_dead_pseudo_process(child);
2001 else if (IsWin95()) {
2010 child = find_pid(pid);
2012 hProcess = w32_child_handles[child];
2013 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2014 if (waitcode == WAIT_TIMEOUT) {
2017 else if (waitcode == WAIT_OBJECT_0) {
2018 if (GetExitCodeProcess(hProcess, &waitcode)) {
2019 *status = (int)((waitcode & 0xff) << 8);
2020 retval = (int)w32_child_pids[child];
2021 remove_dead_process(child);
2030 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2031 (IsWin95() ? -pid : pid));
2033 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2034 if (waitcode == WAIT_TIMEOUT) {
2035 CloseHandle(hProcess);
2038 else if (waitcode == WAIT_OBJECT_0) {
2039 if (GetExitCodeProcess(hProcess, &waitcode)) {
2040 *status = (int)((waitcode & 0xff) << 8);
2041 CloseHandle(hProcess);
2045 CloseHandle(hProcess);
2051 return retval >= 0 ? pid : retval;
2055 win32_wait(int *status)
2057 return win32_internal_wait(status, INFINITE);
2060 DllExport unsigned int
2061 win32_sleep(unsigned int t)
2064 /* Win32 times are in ms so *1000 in and /1000 out */
2065 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2068 DllExport unsigned int
2069 win32_alarm(unsigned int sec)
2072 * the 'obvious' implentation is SetTimer() with a callback
2073 * which does whatever receiving SIGALRM would do
2074 * we cannot use SIGALRM even via raise() as it is not
2075 * one of the supported codes in <signal.h>
2079 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2080 w32_message_hwnd = win32_create_message_window();
2083 if (w32_message_hwnd == NULL)
2084 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2087 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2092 KillTimer(w32_message_hwnd, w32_timerid);
2099 #ifdef HAVE_DES_FCRYPT
2100 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2104 win32_crypt(const char *txt, const char *salt)
2107 #ifdef HAVE_DES_FCRYPT
2108 return des_fcrypt(txt, salt, w32_crypt_buffer);
2110 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2115 #ifdef USE_FIXED_OSFHANDLE
2117 #define FOPEN 0x01 /* file handle open */
2118 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2119 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2120 #define FDEV 0x40 /* file handle refers to device */
2121 #define FTEXT 0x80 /* file handle is in text mode */
2124 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2127 * This function allocates a free C Runtime file handle and associates
2128 * it with the Win32 HANDLE specified by the first parameter. This is a
2129 * temperary fix for WIN95's brain damage GetFileType() error on socket
2130 * we just bypass that call for socket
2132 * This works with MSVC++ 4.0+ or GCC/Mingw32
2135 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2136 * int flags - flags to associate with C Runtime file handle.
2139 * returns index of entry in fh, if successful
2140 * return -1, if no free entry is found
2144 *******************************************************************************/
2147 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2148 * this lets sockets work on Win9X with GCC and should fix the problems
2153 /* create an ioinfo entry, kill its handle, and steal the entry */
2158 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2159 int fh = _open_osfhandle((intptr_t)hF, 0);
2163 EnterCriticalSection(&(_pioinfo(fh)->lock));
2168 my_open_osfhandle(intptr_t osfhandle, int flags)
2171 char fileflags; /* _osfile flags */
2173 /* copy relevant flags from second parameter */
2176 if (flags & O_APPEND)
2177 fileflags |= FAPPEND;
2182 if (flags & O_NOINHERIT)
2183 fileflags |= FNOINHERIT;
2185 /* attempt to allocate a C Runtime file handle */
2186 if ((fh = _alloc_osfhnd()) == -1) {
2187 errno = EMFILE; /* too many open files */
2188 _doserrno = 0L; /* not an OS error */
2189 return -1; /* return error to caller */
2192 /* the file is open. now, set the info in _osfhnd array */
2193 _set_osfhnd(fh, osfhandle);
2195 fileflags |= FOPEN; /* mark as open */
2197 _osfile(fh) = fileflags; /* set osfile entry */
2198 LeaveCriticalSection(&_pioinfo(fh)->lock);
2200 return fh; /* return handle */
2203 #endif /* USE_FIXED_OSFHANDLE */
2205 /* simulate flock by locking a range on the file */
2207 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2208 #define LK_LEN 0xffff0000
2211 win32_flock(int fd, int oper)
2219 Perl_croak_nocontext("flock() unimplemented on this platform");
2222 fh = (HANDLE)_get_osfhandle(fd);
2223 memset(&o, 0, sizeof(o));
2226 case LOCK_SH: /* shared lock */
2227 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2229 case LOCK_EX: /* exclusive lock */
2230 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2232 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2233 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2235 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2236 LK_ERR(LockFileEx(fh,
2237 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2238 0, LK_LEN, 0, &o),i);
2240 case LOCK_UN: /* unlock lock */
2241 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2243 default: /* unknown */
2254 * redirected io subsystem for all XS modules
2267 return (&(_environ));
2270 /* the rest are the remapped stdio routines */
2290 win32_ferror(FILE *fp)
2292 return (ferror(fp));
2297 win32_feof(FILE *fp)
2303 * Since the errors returned by the socket error function
2304 * WSAGetLastError() are not known by the library routine strerror
2305 * we have to roll our own.
2309 win32_strerror(int e)
2311 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2312 extern int sys_nerr;
2316 if (e < 0 || e > sys_nerr) {
2321 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2322 w32_strerror_buffer,
2323 sizeof(w32_strerror_buffer), NULL) == 0)
2324 strcpy(w32_strerror_buffer, "Unknown Error");
2326 return w32_strerror_buffer;
2332 win32_str_os_error(void *sv, DWORD dwErr)
2336 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2337 |FORMAT_MESSAGE_IGNORE_INSERTS
2338 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2339 dwErr, 0, (char *)&sMsg, 1, NULL);
2340 /* strip trailing whitespace and period */
2343 --dwLen; /* dwLen doesn't include trailing null */
2344 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2345 if ('.' != sMsg[dwLen])
2350 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2352 dwLen = sprintf(sMsg,
2353 "Unknown error #0x%lX (lookup 0x%lX)",
2354 dwErr, GetLastError());
2358 sv_setpvn((SV*)sv, sMsg, dwLen);
2364 win32_fprintf(FILE *fp, const char *format, ...)
2367 va_start(marker, format); /* Initialize variable arguments. */
2369 return (vfprintf(fp, format, marker));
2373 win32_printf(const char *format, ...)
2376 va_start(marker, format); /* Initialize variable arguments. */
2378 return (vprintf(format, marker));
2382 win32_vfprintf(FILE *fp, const char *format, va_list args)
2384 return (vfprintf(fp, format, args));
2388 win32_vprintf(const char *format, va_list args)
2390 return (vprintf(format, args));
2394 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2396 return fread(buf, size, count, fp);
2400 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2402 return fwrite(buf, size, count, fp);
2405 #define MODE_SIZE 10
2408 win32_fopen(const char *filename, const char *mode)
2416 if (stricmp(filename, "/dev/null")==0)
2419 f = fopen(PerlDir_mapA(filename), mode);
2420 /* avoid buffering headaches for child processes */
2421 if (f && *mode == 'a')
2422 win32_fseek(f, 0, SEEK_END);
2426 #ifndef USE_SOCKETS_AS_HANDLES
2428 #define fdopen my_fdopen
2432 win32_fdopen(int handle, const char *mode)
2436 f = fdopen(handle, (char *) mode);
2437 /* avoid buffering headaches for child processes */
2438 if (f && *mode == 'a')
2439 win32_fseek(f, 0, SEEK_END);
2444 win32_freopen(const char *path, const char *mode, FILE *stream)
2447 if (stricmp(path, "/dev/null")==0)
2450 return freopen(PerlDir_mapA(path), mode, stream);
2454 win32_fclose(FILE *pf)
2456 return my_fclose(pf); /* defined in win32sck.c */
2460 win32_fputs(const char *s,FILE *pf)
2462 return fputs(s, pf);
2466 win32_fputc(int c,FILE *pf)
2472 win32_ungetc(int c,FILE *pf)
2474 return ungetc(c,pf);
2478 win32_getc(FILE *pf)
2484 win32_fileno(FILE *pf)
2490 win32_clearerr(FILE *pf)
2497 win32_fflush(FILE *pf)
2503 win32_ftell(FILE *pf)
2505 #if defined(WIN64) || defined(USE_LARGE_FILES)
2506 #if defined(__BORLANDC__) /* buk */
2507 return win32_tell( fileno( pf ) );
2510 if (fgetpos(pf, &pos))
2520 win32_fseek(FILE *pf, Off_t offset,int origin)
2522 #if defined(WIN64) || defined(USE_LARGE_FILES)
2523 #if defined(__BORLANDC__) /* buk */
2533 if (fgetpos(pf, &pos))
2538 fseek(pf, 0, SEEK_END);
2539 pos = _telli64(fileno(pf));
2548 return fsetpos(pf, &offset);
2551 return fseek(pf, (long)offset, origin);
2556 win32_fgetpos(FILE *pf,fpos_t *p)
2558 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2559 if( win32_tell(fileno(pf)) == -1L ) {
2565 return fgetpos(pf, p);
2570 win32_fsetpos(FILE *pf,const fpos_t *p)
2572 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2573 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2575 return fsetpos(pf, p);
2580 win32_rewind(FILE *pf)
2590 char prefix[MAX_PATH+1];
2591 char filename[MAX_PATH+1];
2592 DWORD len = GetTempPath(MAX_PATH, prefix);
2593 if (len && len < MAX_PATH) {
2594 if (GetTempFileName(prefix, "plx", 0, filename)) {
2595 HANDLE fh = CreateFile(filename,
2596 DELETE | GENERIC_READ | GENERIC_WRITE,
2600 FILE_ATTRIBUTE_NORMAL
2601 | FILE_FLAG_DELETE_ON_CLOSE,
2603 if (fh != INVALID_HANDLE_VALUE) {
2604 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2606 #if defined(__BORLANDC__)
2607 setmode(fd,O_BINARY);
2609 DEBUG_p(PerlIO_printf(Perl_debug_log,
2610 "Created tmpfile=%s\n",filename));
2622 int fd = win32_tmpfd();
2624 return win32_fdopen(fd, "w+b");
2636 win32_fstat(int fd, Stat_t *sbufptr)
2639 /* A file designated by filehandle is not shown as accessible
2640 * for write operations, probably because it is opened for reading.
2643 BY_HANDLE_FILE_INFORMATION bhfi;
2644 #if defined(WIN64) || defined(USE_LARGE_FILES)
2645 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2647 int rc = fstat(fd,&tmp);
2649 sbufptr->st_dev = tmp.st_dev;
2650 sbufptr->st_ino = tmp.st_ino;
2651 sbufptr->st_mode = tmp.st_mode;
2652 sbufptr->st_nlink = tmp.st_nlink;
2653 sbufptr->st_uid = tmp.st_uid;
2654 sbufptr->st_gid = tmp.st_gid;
2655 sbufptr->st_rdev = tmp.st_rdev;
2656 sbufptr->st_size = tmp.st_size;
2657 sbufptr->st_atime = tmp.st_atime;
2658 sbufptr->st_mtime = tmp.st_mtime;
2659 sbufptr->st_ctime = tmp.st_ctime;
2661 int rc = fstat(fd,sbufptr);
2664 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2665 #if defined(WIN64) || defined(USE_LARGE_FILES)
2666 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2668 sbufptr->st_mode &= 0xFE00;
2669 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2670 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2672 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2673 + ((S_IREAD|S_IWRITE) >> 6));
2677 return my_fstat(fd,sbufptr);
2682 win32_pipe(int *pfd, unsigned int size, int mode)
2684 return _pipe(pfd, size, mode);
2688 win32_popenlist(const char *mode, IV narg, SV **args)
2691 Perl_croak(aTHX_ "List form of pipe open not implemented");
2696 * a popen() clone that respects PERL5SHELL
2698 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2702 win32_popen(const char *command, const char *mode)
2704 #ifdef USE_RTL_POPEN
2705 return _popen(command, mode);
2717 /* establish which ends read and write */
2718 if (strchr(mode,'w')) {
2719 stdfd = 0; /* stdin */
2722 nhandle = STD_INPUT_HANDLE;
2724 else if (strchr(mode,'r')) {
2725 stdfd = 1; /* stdout */
2728 nhandle = STD_OUTPUT_HANDLE;
2733 /* set the correct mode */
2734 if (strchr(mode,'b'))
2736 else if (strchr(mode,'t'))
2739 ourmode = _fmode & (O_TEXT | O_BINARY);
2741 /* the child doesn't inherit handles */
2742 ourmode |= O_NOINHERIT;
2744 if (win32_pipe(p, 512, ourmode) == -1)
2747 /* save the old std handle (this needs to happen before the
2748 * dup2(), since that might call SetStdHandle() too) */
2751 old_h = GetStdHandle(nhandle);
2753 /* save current stdfd */
2754 if ((oldfd = win32_dup(stdfd)) == -1)
2757 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2758 /* stdfd will be inherited by the child */
2759 if (win32_dup2(p[child], stdfd) == -1)
2762 /* close the child end in parent */
2763 win32_close(p[child]);
2765 /* set the new std handle (in case dup2() above didn't) */
2766 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2768 /* start the child */
2771 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2774 /* revert stdfd to whatever it was before */
2775 if (win32_dup2(oldfd, stdfd) == -1)
2778 /* close saved handle */
2781 /* restore the old std handle (this needs to happen after the
2782 * dup2(), since that might call SetStdHandle() too */
2784 SetStdHandle(nhandle, old_h);
2790 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2793 /* set process id so that it can be returned by perl's open() */
2794 PL_forkprocess = childpid;
2797 /* we have an fd, return a file stream */
2798 return (PerlIO_fdopen(p[parent], (char *)mode));
2801 /* we don't need to check for errors here */
2805 win32_dup2(oldfd, stdfd);
2809 SetStdHandle(nhandle, old_h);
2815 #endif /* USE_RTL_POPEN */
2823 win32_pclose(PerlIO *pf)
2825 #ifdef USE_RTL_POPEN
2829 int childpid, status;
2833 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2836 childpid = SvIVX(sv);
2854 if (win32_waitpid(childpid, &status, 0) == -1)
2859 #endif /* USE_RTL_POPEN */
2865 LPCWSTR lpExistingFileName,
2866 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2869 WCHAR wFullName[MAX_PATH+1];
2870 LPVOID lpContext = NULL;
2871 WIN32_STREAM_ID StreamId;
2872 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2877 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2878 BOOL, BOOL, LPVOID*) =
2879 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2880 BOOL, BOOL, LPVOID*))
2881 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2882 if (pfnBackupWrite == NULL)
2885 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2888 dwLen = (dwLen+1)*sizeof(WCHAR);
2890 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2891 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2892 NULL, OPEN_EXISTING, 0, NULL);
2893 if (handle == INVALID_HANDLE_VALUE)
2896 StreamId.dwStreamId = BACKUP_LINK;
2897 StreamId.dwStreamAttributes = 0;
2898 StreamId.dwStreamNameSize = 0;
2899 #if defined(__BORLANDC__) \
2900 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2901 StreamId.Size.u.HighPart = 0;
2902 StreamId.Size.u.LowPart = dwLen;
2904 StreamId.Size.HighPart = 0;
2905 StreamId.Size.LowPart = dwLen;
2908 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2909 FALSE, FALSE, &lpContext);
2911 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2912 FALSE, FALSE, &lpContext);
2913 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2916 CloseHandle(handle);
2921 win32_link(const char *oldname, const char *newname)
2924 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2925 WCHAR wOldName[MAX_PATH+1];
2926 WCHAR wNewName[MAX_PATH+1];
2929 Perl_croak(aTHX_ PL_no_func, "link");
2931 pfnCreateHardLinkW =
2932 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2933 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2934 if (pfnCreateHardLinkW == NULL)
2935 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2937 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2938 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2939 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2940 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2944 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2949 win32_rename(const char *oname, const char *newname)
2951 char szOldName[MAX_PATH+1];
2952 char szNewName[MAX_PATH+1];
2956 /* XXX despite what the documentation says about MoveFileEx(),
2957 * it doesn't work under Windows95!
2960 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2961 if (stricmp(newname, oname))
2962 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2963 strcpy(szOldName, PerlDir_mapA(oname));
2964 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2966 DWORD err = GetLastError();
2968 case ERROR_BAD_NET_NAME:
2969 case ERROR_BAD_NETPATH:
2970 case ERROR_BAD_PATHNAME:
2971 case ERROR_FILE_NOT_FOUND:
2972 case ERROR_FILENAME_EXCED_RANGE:
2973 case ERROR_INVALID_DRIVE:
2974 case ERROR_NO_MORE_FILES:
2975 case ERROR_PATH_NOT_FOUND:
2988 char szTmpName[MAX_PATH+1];
2989 char dname[MAX_PATH+1];
2990 char *endname = Nullch;
2992 DWORD from_attr, to_attr;
2994 strcpy(szOldName, PerlDir_mapA(oname));
2995 strcpy(szNewName, PerlDir_mapA(newname));
2997 /* if oname doesn't exist, do nothing */
2998 from_attr = GetFileAttributes(szOldName);
2999 if (from_attr == 0xFFFFFFFF) {
3004 /* if newname exists, rename it to a temporary name so that we
3005 * don't delete it in case oname happens to be the same file
3006 * (but perhaps accessed via a different path)
3008 to_attr = GetFileAttributes(szNewName);
3009 if (to_attr != 0xFFFFFFFF) {
3010 /* if newname is a directory, we fail
3011 * XXX could overcome this with yet more convoluted logic */
3012 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3016 tmplen = strlen(szNewName);
3017 strcpy(szTmpName,szNewName);
3018 endname = szTmpName+tmplen;
3019 for (; endname > szTmpName ; --endname) {
3020 if (*endname == '/' || *endname == '\\') {
3025 if (endname > szTmpName)
3026 endname = strcpy(dname,szTmpName);
3030 /* get a temporary filename in same directory
3031 * XXX is this really the best we can do? */
3032 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3036 DeleteFile(szTmpName);
3038 retval = rename(szNewName, szTmpName);
3045 /* rename oname to newname */
3046 retval = rename(szOldName, szNewName);
3048 /* if we created a temporary file before ... */
3049 if (endname != Nullch) {
3050 /* ...and rename succeeded, delete temporary file/directory */
3052 DeleteFile(szTmpName);
3053 /* else restore it to what it was */
3055 (void)rename(szTmpName, szNewName);
3062 win32_setmode(int fd, int mode)
3064 return setmode(fd, mode);
3068 win32_chsize(int fd, Off_t size)
3070 #if defined(WIN64) || defined(USE_LARGE_FILES)
3072 Off_t cur, end, extend;
3074 cur = win32_tell(fd);
3077 end = win32_lseek(fd, 0, SEEK_END);
3080 extend = size - end;
3084 else if (extend > 0) {
3085 /* must grow the file, padding with nulls */
3087 int oldmode = win32_setmode(fd, O_BINARY);
3089 memset(b, '\0', sizeof(b));
3091 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3092 count = win32_write(fd, b, count);
3093 if ((int)count < 0) {
3097 } while ((extend -= count) > 0);
3098 win32_setmode(fd, oldmode);
3101 /* shrink the file */
3102 win32_lseek(fd, size, SEEK_SET);
3103 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3109 win32_lseek(fd, cur, SEEK_SET);
3112 return chsize(fd, (long)size);
3117 win32_lseek(int fd, Off_t offset, int origin)
3119 #if defined(WIN64) || defined(USE_LARGE_FILES)
3120 #if defined(__BORLANDC__) /* buk */
3122 pos.QuadPart = offset;
3123 pos.LowPart = SetFilePointer(
3124 (HANDLE)_get_osfhandle(fd),
3129 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3133 return pos.QuadPart;
3135 return _lseeki64(fd, offset, origin);
3138 return lseek(fd, (long)offset, origin);
3145 #if defined(WIN64) || defined(USE_LARGE_FILES)
3146 #if defined(__BORLANDC__) /* buk */
3149 pos.LowPart = SetFilePointer(
3150 (HANDLE)_get_osfhandle(fd),
3155 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3159 return pos.QuadPart;
3160 /* return tell(fd); */
3162 return _telli64(fd);
3170 win32_open(const char *path, int flag, ...)
3177 pmode = va_arg(ap, int);
3180 if (stricmp(path, "/dev/null")==0)
3183 return open(PerlDir_mapA(path), flag, pmode);
3186 /* close() that understands socket */
3187 extern int my_close(int); /* in win32sck.c */
3192 return my_close(fd);
3208 win32_dup2(int fd1,int fd2)
3210 return dup2(fd1,fd2);
3213 #ifdef PERL_MSVCRT_READFIX
3215 #define LF 10 /* line feed */
3216 #define CR 13 /* carriage return */
3217 #define CTRLZ 26 /* ctrl-z means eof for text */
3218 #define FOPEN 0x01 /* file handle open */
3219 #define FEOFLAG 0x02 /* end of file has been encountered */
3220 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3221 #define FPIPE 0x08 /* file handle refers to a pipe */
3222 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3223 #define FDEV 0x40 /* file handle refers to device */
3224 #define FTEXT 0x80 /* file handle is in text mode */
3225 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3228 _fixed_read(int fh, void *buf, unsigned cnt)
3230 int bytes_read; /* number of bytes read */
3231 char *buffer; /* buffer to read to */
3232 int os_read; /* bytes read on OS call */
3233 char *p, *q; /* pointers into buffer */
3234 char peekchr; /* peek-ahead character */
3235 ULONG filepos; /* file position after seek */
3236 ULONG dosretval; /* o.s. return value */
3238 /* validate handle */
3239 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3240 !(_osfile(fh) & FOPEN))
3242 /* out of range -- return error */
3244 _doserrno = 0; /* not o.s. error */
3249 * If lockinitflag is FALSE, assume fd is device
3250 * lockinitflag is set to TRUE by open.
3252 if (_pioinfo(fh)->lockinitflag)
3253 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3255 bytes_read = 0; /* nothing read yet */
3256 buffer = (char*)buf;
3258 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3259 /* nothing to read or at EOF, so return 0 read */
3263 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3264 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3266 *buffer++ = _pipech(fh);
3269 _pipech(fh) = LF; /* mark as empty */
3274 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3276 /* ReadFile has reported an error. recognize two special cases.
3278 * 1. map ERROR_ACCESS_DENIED to EBADF
3280 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3281 * means the handle is a read-handle on a pipe for which
3282 * all write-handles have been closed and all data has been
3285 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3286 /* wrong read/write mode should return EBADF, not EACCES */
3288 _doserrno = dosretval;
3292 else if (dosretval == ERROR_BROKEN_PIPE) {
3302 bytes_read += os_read; /* update bytes read */
3304 if (_osfile(fh) & FTEXT) {
3305 /* now must translate CR-LFs to LFs in the buffer */
3307 /* set CRLF flag to indicate LF at beginning of buffer */
3308 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3309 /* _osfile(fh) |= FCRLF; */
3311 /* _osfile(fh) &= ~FCRLF; */
3313 _osfile(fh) &= ~FCRLF;
3315 /* convert chars in the buffer: p is src, q is dest */
3317 while (p < (char *)buf + bytes_read) {
3319 /* if fh is not a device, set ctrl-z flag */
3320 if (!(_osfile(fh) & FDEV))
3321 _osfile(fh) |= FEOFLAG;
3322 break; /* stop translating */
3327 /* *p is CR, so must check next char for LF */
3328 if (p < (char *)buf + bytes_read - 1) {
3331 *q++ = LF; /* convert CR-LF to LF */
3334 *q++ = *p++; /* store char normally */
3337 /* This is the hard part. We found a CR at end of
3338 buffer. We must peek ahead to see if next char
3343 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3344 (LPDWORD)&os_read, NULL))
3345 dosretval = GetLastError();
3347 if (dosretval != 0 || os_read == 0) {
3348 /* couldn't read ahead, store CR */
3352 /* peekchr now has the extra character -- we now
3353 have several possibilities:
3354 1. disk file and char is not LF; just seek back
3356 2. disk file and char is LF; store LF, don't seek back
3357 3. pipe/device and char is LF; store LF.
3358 4. pipe/device and char isn't LF, store CR and
3359 put char in pipe lookahead buffer. */
3360 if (_osfile(fh) & (FDEV|FPIPE)) {
3361 /* non-seekable device */
3366 _pipech(fh) = peekchr;
3371 if (peekchr == LF) {
3372 /* nothing read yet; must make some
3375 /* turn on this flag for tell routine */
3376 _osfile(fh) |= FCRLF;
3379 HANDLE osHandle; /* o.s. handle value */
3381 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3383 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3384 dosretval = GetLastError();
3395 /* we now change bytes_read to reflect the true number of chars
3397 bytes_read = q - (char *)buf;
3401 if (_pioinfo(fh)->lockinitflag)
3402 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3407 #endif /* PERL_MSVCRT_READFIX */
3410 win32_read(int fd, void *buf, unsigned int cnt)
3412 #ifdef PERL_MSVCRT_READFIX
3413 return _fixed_read(fd, buf, cnt);
3415 return read(fd, buf, cnt);
3420 win32_write(int fd, const void *buf, unsigned int cnt)
3422 return write(fd, buf, cnt);
3426 win32_mkdir(const char *dir, int mode)
3429 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3433 win32_rmdir(const char *dir)
3436 return rmdir(PerlDir_mapA(dir));
3440 win32_chdir(const char *dir)
3451 win32_access(const char *path, int mode)
3454 return access(PerlDir_mapA(path), mode);
3458 win32_chmod(const char *path, int mode)
3461 return chmod(PerlDir_mapA(path), mode);
3466 create_command_line(char *cname, STRLEN clen, const char * const *args)
3473 bool bat_file = FALSE;
3474 bool cmd_shell = FALSE;
3475 bool dumb_shell = FALSE;
3476 bool extra_quotes = FALSE;
3477 bool quote_next = FALSE;
3480 cname = (char*)args[0];
3482 /* The NT cmd.exe shell has the following peculiarity that needs to be
3483 * worked around. It strips a leading and trailing dquote when any
3484 * of the following is true:
3485 * 1. the /S switch was used
3486 * 2. there are more than two dquotes
3487 * 3. there is a special character from this set: &<>()@^|
3488 * 4. no whitespace characters within the two dquotes
3489 * 5. string between two dquotes isn't an executable file
3490 * To work around this, we always add a leading and trailing dquote
3491 * to the string, if the first argument is either "cmd.exe" or "cmd",
3492 * and there were at least two or more arguments passed to cmd.exe
3493 * (not including switches).
3494 * XXX the above rules (from "cmd /?") don't seem to be applied
3495 * always, making for the convolutions below :-(
3499 clen = strlen(cname);
3502 && (stricmp(&cname[clen-4], ".bat") == 0
3503 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3510 char *exe = strrchr(cname, '/');
3511 char *exe2 = strrchr(cname, '\\');
3518 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3522 else if (stricmp(exe, "command.com") == 0
3523 || stricmp(exe, "command") == 0)
3530 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3531 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3532 STRLEN curlen = strlen(arg);
3533 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3534 len += 2; /* assume quoting needed (worst case) */
3536 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3538 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3541 Newx(cmd, len, char);
3544 if (bat_file && !IsWin95()) {
3546 extra_quotes = TRUE;
3549 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3551 STRLEN curlen = strlen(arg);
3553 /* we want to protect empty arguments and ones with spaces with
3554 * dquotes, but only if they aren't already there */
3559 else if (quote_next) {
3560 /* see if it really is multiple arguments pretending to
3561 * be one and force a set of quotes around it */
3562 if (*find_next_space(arg))
3565 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3567 while (i < curlen) {
3568 if (isSPACE(arg[i])) {
3571 else if (arg[i] == '"') {
3595 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3596 && stricmp(arg+curlen-2, "/c") == 0)
3598 /* is there a next argument? */
3599 if (args[index+1]) {
3600 /* are there two or more next arguments? */
3601 if (args[index+2]) {
3603 extra_quotes = TRUE;
3606 /* single argument, force quoting if it has spaces */
3622 qualified_path(const char *cmd)
3626 char *fullcmd, *curfullcmd;
3632 fullcmd = (char*)cmd;
3634 if (*fullcmd == '/' || *fullcmd == '\\')
3641 pathstr = PerlEnv_getenv("PATH");
3643 /* worst case: PATH is a single directory; we need additional space
3644 * to append "/", ".exe" and trailing "\0" */
3645 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3646 curfullcmd = fullcmd;
3651 /* start by appending the name to the current prefix */
3652 strcpy(curfullcmd, cmd);
3653 curfullcmd += cmdlen;
3655 /* if it doesn't end with '.', or has no extension, try adding
3656 * a trailing .exe first */
3657 if (cmd[cmdlen-1] != '.'
3658 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3660 strcpy(curfullcmd, ".exe");
3661 res = GetFileAttributes(fullcmd);
3662 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3667 /* that failed, try the bare name */
3668 res = GetFileAttributes(fullcmd);
3669 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3672 /* quit if no other path exists, or if cmd already has path */
3673 if (!pathstr || !*pathstr || has_slash)
3676 /* skip leading semis */
3677 while (*pathstr == ';')
3680 /* build a new prefix from scratch */
3681 curfullcmd = fullcmd;
3682 while (*pathstr && *pathstr != ';') {
3683 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3684 pathstr++; /* skip initial '"' */
3685 while (*pathstr && *pathstr != '"') {
3686 *curfullcmd++ = *pathstr++;
3689 pathstr++; /* skip trailing '"' */
3692 *curfullcmd++ = *pathstr++;
3696 pathstr++; /* skip trailing semi */
3697 if (curfullcmd > fullcmd /* append a dir separator */
3698 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3700 *curfullcmd++ = '\\';
3708 /* The following are just place holders.
3709 * Some hosts may provide and environment that the OS is
3710 * not tracking, therefore, these host must provide that
3711 * environment and the current directory to CreateProcess
3715 win32_get_childenv(void)
3721 win32_free_childenv(void* d)
3726 win32_clearenv(void)
3728 char *envv = GetEnvironmentStrings();
3732 char *end = strchr(cur,'=');
3733 if (end && end != cur) {
3735 SetEnvironmentVariable(cur, NULL);
3737 cur = end + strlen(end+1)+2;
3739 else if ((len = strlen(cur)))
3742 FreeEnvironmentStrings(envv);
3746 win32_get_childdir(void)
3750 char szfilename[MAX_PATH+1];
3752 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3753 Newx(ptr, strlen(szfilename)+1, char);
3754 strcpy(ptr, szfilename);
3759 win32_free_childdir(char* d)
3766 /* XXX this needs to be made more compatible with the spawnvp()
3767 * provided by the various RTLs. In particular, searching for
3768 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3769 * This doesn't significantly affect perl itself, because we
3770 * always invoke things using PERL5SHELL if a direct attempt to
3771 * spawn the executable fails.
3773 * XXX splitting and rejoining the commandline between do_aspawn()
3774 * and win32_spawnvp() could also be avoided.
3778 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3780 #ifdef USE_RTL_SPAWNVP
3781 return spawnvp(mode, cmdname, (char * const *)argv);
3788 STARTUPINFO StartupInfo;
3789 PROCESS_INFORMATION ProcessInformation;
3792 char *fullcmd = Nullch;
3793 char *cname = (char *)cmdname;
3797 clen = strlen(cname);
3798 /* if command name contains dquotes, must remove them */
3799 if (strchr(cname, '"')) {
3801 Newx(cname,clen+1,char);
3814 cmd = create_command_line(cname, clen, argv);
3816 env = PerlEnv_get_childenv();
3817 dir = PerlEnv_get_childdir();
3820 case P_NOWAIT: /* asynch + remember result */
3821 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3826 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3829 create |= CREATE_NEW_PROCESS_GROUP;
3832 case P_WAIT: /* synchronous execution */
3834 default: /* invalid mode */
3839 memset(&StartupInfo,0,sizeof(StartupInfo));
3840 StartupInfo.cb = sizeof(StartupInfo);
3841 memset(&tbl,0,sizeof(tbl));
3842 PerlEnv_get_child_IO(&tbl);
3843 StartupInfo.dwFlags = tbl.dwFlags;
3844 StartupInfo.dwX = tbl.dwX;
3845 StartupInfo.dwY = tbl.dwY;
3846 StartupInfo.dwXSize = tbl.dwXSize;
3847 StartupInfo.dwYSize = tbl.dwYSize;
3848 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3849 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3850 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3851 StartupInfo.wShowWindow = tbl.wShowWindow;
3852 StartupInfo.hStdInput = tbl.childStdIn;
3853 StartupInfo.hStdOutput = tbl.childStdOut;
3854 StartupInfo.hStdError = tbl.childStdErr;
3855 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3856 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3857 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3859 create |= CREATE_NEW_CONSOLE;
3862 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3864 if (w32_use_showwindow) {
3865 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3866 StartupInfo.wShowWindow = w32_showwindow;
3869 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3872 if (!CreateProcess(cname, /* search PATH to find executable */
3873 cmd, /* executable, and its arguments */
3874 NULL, /* process attributes */
3875 NULL, /* thread attributes */
3876 TRUE, /* inherit handles */
3877 create, /* creation flags */
3878 (LPVOID)env, /* inherit environment */
3879 dir, /* inherit cwd */
3881 &ProcessInformation))
3883 /* initial NULL argument to CreateProcess() does a PATH
3884 * search, but it always first looks in the directory
3885 * where the current process was started, which behavior
3886 * is undesirable for backward compatibility. So we
3887 * jump through our own hoops by picking out the path
3888 * we really want it to use. */
3890 fullcmd = qualified_path(cname);
3892 if (cname != cmdname)
3895 DEBUG_p(PerlIO_printf(Perl_debug_log,
3896 "Retrying [%s] with same args\n",
3906 if (mode == P_NOWAIT) {
3907 /* asynchronous spawn -- store handle, return PID */
3908 ret = (int)ProcessInformation.dwProcessId;
3909 if (IsWin95() && ret < 0)
3912 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3913 w32_child_pids[w32_num_children] = (DWORD)ret;
3918 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3919 /* FIXME: if msgwait returned due to message perhaps forward the
3920 "signal" to the process
3922 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3924 CloseHandle(ProcessInformation.hProcess);
3927 CloseHandle(ProcessInformation.hThread);
3930 PerlEnv_free_childenv(env);
3931 PerlEnv_free_childdir(dir);
3933 if (cname != cmdname)
3940 win32_execv(const char *cmdname, const char *const *argv)
3944 /* if this is a pseudo-forked child, we just want to spawn
3945 * the new program, and return */
3947 # ifdef __BORLANDC__
3948 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3950 return spawnv(P_WAIT, cmdname, argv);
3954 return execv(cmdname, (char *const *)argv);
3956 return execv(cmdname, argv);
3961 win32_execvp(const char *cmdname, const char *const *argv)
3965 /* if this is a pseudo-forked child, we just want to spawn
3966 * the new program, and return */
3967 if (w32_pseudo_id) {
3968 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3978 return execvp(cmdname, (char *const *)argv);
3980 return execvp(cmdname, argv);
3985 win32_perror(const char *str)
3991 win32_setbuf(FILE *pf, char *buf)
3997 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3999 return setvbuf(pf, buf, type, size);
4003 win32_flushall(void)
4009 win32_fcloseall(void)
4015 win32_fgets(char *s, int n, FILE *pf)
4017 return fgets(s, n, pf);
4027 win32_fgetc(FILE *pf)
4033 win32_putc(int c, FILE *pf)
4039 win32_puts(const char *s)
4051 win32_putchar(int c)
4058 #ifndef USE_PERL_SBRK
4060 static char *committed = NULL; /* XXX threadead */
4061 static char *base = NULL; /* XXX threadead */
4062 static char *reserved = NULL; /* XXX threadead */
4063 static char *brk = NULL; /* XXX threadead */
4064 static DWORD pagesize = 0; /* XXX threadead */
4067 sbrk(ptrdiff_t need)
4072 GetSystemInfo(&info);
4073 /* Pretend page size is larger so we don't perpetually
4074 * call the OS to commit just one page ...
4076 pagesize = info.dwPageSize << 3;
4078 if (brk+need >= reserved)
4080 DWORD size = brk+need-reserved;
4082 char *prev_committed = NULL;
4083 if (committed && reserved && committed < reserved)
4085 /* Commit last of previous chunk cannot span allocations */
4086 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4089 /* Remember where we committed from in case we want to decommit later */
4090 prev_committed = committed;
4091 committed = reserved;
4094 /* Reserve some (more) space
4095 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4096 * this is only address space not memory...
4097 * Note this is a little sneaky, 1st call passes NULL as reserved
4098 * so lets system choose where we start, subsequent calls pass
4099 * the old end address so ask for a contiguous block
4102 if (size < 64*1024*1024)
4103 size = 64*1024*1024;
4104 size = ((size + pagesize - 1) / pagesize) * pagesize;
4105 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4108 reserved = addr+size;
4118 /* The existing block could not be extended far enough, so decommit
4119 * anything that was just committed above and start anew */
4122 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4125 reserved = base = committed = brk = NULL;
4136 if (brk > committed)
4138 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4140 if (committed+size > reserved)
4141 size = reserved-committed;
4142 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4155 win32_malloc(size_t size)
4157 return malloc(size);
4161 win32_calloc(size_t numitems, size_t size)
4163 return calloc(numitems,size);
4167 win32_realloc(void *block, size_t size)
4169 return realloc(block,size);
4173 win32_free(void *block)
4180 win32_open_osfhandle(intptr_t handle, int flags)
4182 #ifdef USE_FIXED_OSFHANDLE
4184 return my_open_osfhandle(handle, flags);
4186 return _open_osfhandle(handle, flags);
4190 win32_get_osfhandle(int fd)
4192 return (intptr_t)_get_osfhandle(fd);
4196 win32_fdupopen(FILE *pf)
4201 int fileno = win32_dup(win32_fileno(pf));
4203 /* open the file in the same mode */
4205 if((pf)->flags & _F_READ) {
4209 else if((pf)->flags & _F_WRIT) {
4213 else if((pf)->flags & _F_RDWR) {
4219 if((pf)->_flag & _IOREAD) {
4223 else if((pf)->_flag & _IOWRT) {
4227 else if((pf)->_flag & _IORW) {
4234 /* it appears that the binmode is attached to the
4235 * file descriptor so binmode files will be handled
4238 pfdup = win32_fdopen(fileno, mode);
4240 /* move the file pointer to the same position */
4241 if (!fgetpos(pf, &pos)) {
4242 fsetpos(pfdup, &pos);
4248 win32_dynaload(const char* filename)
4251 char buf[MAX_PATH+1];
4254 /* LoadLibrary() doesn't recognize forward slashes correctly,
4255 * so turn 'em back. */
4256 first = strchr(filename, '/');
4258 STRLEN len = strlen(filename);
4259 if (len <= MAX_PATH) {
4260 strcpy(buf, filename);
4261 filename = &buf[first - filename];
4263 if (*filename == '/')
4264 *(char*)filename = '\\';
4270 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4278 XS(w32_SetChildShowWindow)
4281 BOOL use_showwindow = w32_use_showwindow;
4282 /* use "unsigned short" because Perl has redefined "WORD" */
4283 unsigned short showwindow = w32_showwindow;
4286 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4288 if (items == 0 || !SvOK(ST(0)))
4289 w32_use_showwindow = FALSE;
4291 w32_use_showwindow = TRUE;
4292 w32_showwindow = (unsigned short)SvIV(ST(0));
4297 ST(0) = sv_2mortal(newSViv(showwindow));
4299 ST(0) = &PL_sv_undef;
4307 /* Make the host for current directory */
4308 char* ptr = PerlEnv_get_childdir();
4311 * then it worked, set PV valid,
4312 * else return 'undef'
4315 SV *sv = sv_newmortal();
4317 PerlEnv_free_childdir(ptr);
4319 #ifndef INCOMPLETE_TAINTS
4336 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4337 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4344 XS(w32_GetNextAvailDrive)
4348 char root[] = "_:\\";
4353 if (GetDriveType(root) == 1) {
4362 XS(w32_GetLastError)
4366 XSRETURN_IV(GetLastError());
4370 XS(w32_SetLastError)
4374 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4375 SetLastError(SvIV(ST(0)));
4383 char *name = w32_getlogin_buffer;
4384 DWORD size = sizeof(w32_getlogin_buffer);
4386 if (GetUserName(name,&size)) {
4387 /* size includes NULL */
4388 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4398 char name[MAX_COMPUTERNAME_LENGTH+1];
4399 DWORD size = sizeof(name);
4401 if (GetComputerName(name,&size)) {
4402 /* size does NOT include NULL :-( */
4403 ST(0) = sv_2mortal(newSVpvn(name,size));
4414 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4415 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4416 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4420 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4421 GetProcAddress(hNetApi32, "NetApiBufferFree");
4422 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4423 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4426 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4427 /* this way is more reliable, in case user has a local account. */
4429 DWORD dnamelen = sizeof(dname);
4431 DWORD wki100_platform_id;
4432 LPWSTR wki100_computername;
4433 LPWSTR wki100_langroup;
4434 DWORD wki100_ver_major;
4435 DWORD wki100_ver_minor;
4437 /* NERR_Success *is* 0*/
4438 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4439 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4440 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4441 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4444 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4445 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4447 pfnNetApiBufferFree(pwi);
4448 FreeLibrary(hNetApi32);
4451 FreeLibrary(hNetApi32);
4454 /* Win95 doesn't have NetWksta*(), so do it the old way */
4456 DWORD size = sizeof(name);
4458 FreeLibrary(hNetApi32);
4459 if (GetUserName(name,&size)) {
4460 char sid[ONE_K_BUFSIZE];
4461 DWORD sidlen = sizeof(sid);
4463 DWORD dnamelen = sizeof(dname);
4465 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4466 dname, &dnamelen, &snu)) {
4467 XSRETURN_PV(dname); /* all that for this */
4479 DWORD flags, filecomplen;
4480 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4481 &flags, fsname, sizeof(fsname))) {
4482 if (GIMME_V == G_ARRAY) {
4483 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4484 XPUSHs(sv_2mortal(newSViv(flags)));
4485 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4490 XSRETURN_PV(fsname);
4496 XS(w32_GetOSVersion)
4499 /* Use explicit struct definition because wSuiteMask and
4500 * wProductType are not defined in the VC++ 6.0 headers.
4501 * WORD type has been replaced by unsigned short because
4502 * WORD is already used by Perl itself.
4505 DWORD dwOSVersionInfoSize;
4506 DWORD dwMajorVersion;
4507 DWORD dwMinorVersion;
4508 DWORD dwBuildNumber;
4510 CHAR szCSDVersion[128];
4511 unsigned short wServicePackMajor;
4512 unsigned short wServicePackMinor;
4513 unsigned short wSuiteMask;
4519 osver.dwOSVersionInfoSize = sizeof(osver);
4520 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4522 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4523 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4527 if (GIMME_V == G_SCALAR) {
4528 XSRETURN_IV(osver.dwPlatformId);
4530 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4532 XPUSHs(newSViv(osver.dwMajorVersion));
4533 XPUSHs(newSViv(osver.dwMinorVersion));
4534 XPUSHs(newSViv(osver.dwBuildNumber));
4535 XPUSHs(newSViv(osver.dwPlatformId));
4537 XPUSHs(newSViv(osver.wServicePackMajor));
4538 XPUSHs(newSViv(osver.wServicePackMinor));
4539 XPUSHs(newSViv(osver.wSuiteMask));
4540 XPUSHs(newSViv(osver.wProductType));
4550 XSRETURN_IV(IsWinNT());
4558 XSRETURN_IV(IsWin95());
4562 XS(w32_FormatMessage)
4566 char msgbuf[ONE_K_BUFSIZE];
4569 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4571 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4572 &source, SvIV(ST(0)), 0,
4573 msgbuf, sizeof(msgbuf)-1, NULL))
4575 XSRETURN_PV(msgbuf);
4588 PROCESS_INFORMATION stProcInfo;
4589 STARTUPINFO stStartInfo;
4590 BOOL bSuccess = FALSE;
4593 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4595 cmd = SvPV_nolen(ST(0));
4596 args = SvPV_nolen(ST(1));
4598 env = PerlEnv_get_childenv();
4599 dir = PerlEnv_get_childdir();
4601 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4602 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4603 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4604 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4607 cmd, /* Image path */
4608 args, /* Arguments for command line */
4609 NULL, /* Default process security */
4610 NULL, /* Default thread security */
4611 FALSE, /* Must be TRUE to use std handles */
4612 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4613 env, /* Inherit our environment block */
4614 dir, /* Inherit our currrent directory */
4615 &stStartInfo, /* -> Startup info */
4616 &stProcInfo)) /* <- Process info (if OK) */
4618 int pid = (int)stProcInfo.dwProcessId;
4619 if (IsWin95() && pid < 0)
4621 sv_setiv(ST(2), pid);
4622 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4625 PerlEnv_free_childenv(env);
4626 PerlEnv_free_childdir(dir);
4627 XSRETURN_IV(bSuccess);
4631 XS(w32_GetTickCount)
4634 DWORD msec = GetTickCount();
4642 XS(w32_GetShortPathName)
4649 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4651 shortpath = sv_mortalcopy(ST(0));
4652 SvUPGRADE(shortpath, SVt_PV);
4653 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4656 /* src == target is allowed */
4658 len = GetShortPathName(SvPVX(shortpath),
4661 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4663 SvCUR_set(shortpath,len);
4664 *SvEND(shortpath) = '\0';
4672 XS(w32_GetFullPathName)
4679 STRLEN filename_len;
4683 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4686 filename_p = SvPV(filename, filename_len);
4687 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4688 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4692 len = GetFullPathName(SvPVX(filename),
4696 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4698 if (GIMME_V == G_ARRAY) {
4701 XST_mPV(1,filepart);
4702 len = filepart - SvPVX(fullpath);
4709 SvCUR_set(fullpath,len);
4710 *SvEND(fullpath) = '\0';
4718 XS(w32_GetLongPathName)
4722 char tmpbuf[MAX_PATH+1];
4727 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4730 pathstr = SvPV(path,len);
4731 strcpy(tmpbuf, pathstr);
4732 pathstr = win32_longpath(tmpbuf);
4734 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4745 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4755 char szSourceFile[MAX_PATH+1];
4758 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4759 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4760 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4767 Perl_init_os_extras(void)
4770 char *file = __FILE__;
4773 /* these names are Activeware compatible */
4774 newXS("Win32::GetCwd", w32_GetCwd, file);
4775 newXS("Win32::SetCwd", w32_SetCwd, file);
4776 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4777 newXS("Win32::GetLastError", w32_GetLastError, file);
4778 newXS("Win32::SetLastError", w32_SetLastError, file);
4779 newXS("Win32::LoginName", w32_LoginName, file);
4780 newXS("Win32::NodeName", w32_NodeName, file);
4781 newXS("Win32::DomainName", w32_DomainName, file);
4782 newXS("Win32::FsType", w32_FsType, file);
4783 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4784 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4785 newXS("Win32::IsWin95", w32_IsWin95, file);
4786 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4787 newXS("Win32::Spawn", w32_Spawn, file);
4788 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4789 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4790 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4791 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4792 newXS("Win32::CopyFile", w32_CopyFile, file);
4793 newXS("Win32::Sleep", w32_Sleep, file);
4794 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4796 /* XXX Bloat Alert! The following Activeware preloads really
4797 * ought to be part of Win32::Sys::*, so they're not included
4800 /* LookupAccountName
4802 * InitiateSystemShutdown
4803 * AbortSystemShutdown
4804 * ExpandEnvrironmentStrings
4809 win32_signal_context(void)
4814 my_perl = PL_curinterp;
4815 PERL_SET_THX(my_perl);
4819 return PL_curinterp;
4825 win32_ctrlhandler(DWORD dwCtrlType)
4828 dTHXa(PERL_GET_SIG_CONTEXT);
4834 switch(dwCtrlType) {
4835 case CTRL_CLOSE_EVENT:
4836 /* A signal that the system sends to all processes attached to a console when
4837 the user closes the console (either by choosing the Close command from the
4838 console window's System menu, or by choosing the End Task command from the
4841 if (do_raise(aTHX_ 1)) /* SIGHUP */
4842 sig_terminate(aTHX_ 1);
4846 /* A CTRL+c signal was received */
4847 if (do_raise(aTHX_ SIGINT))
4848 sig_terminate(aTHX_ SIGINT);
4851 case CTRL_BREAK_EVENT:
4852 /* A CTRL+BREAK signal was received */
4853 if (do_raise(aTHX_ SIGBREAK))
4854 sig_terminate(aTHX_ SIGBREAK);
4857 case CTRL_LOGOFF_EVENT:
4858 /* A signal that the system sends to all console processes when a user is logging
4859 off. This signal does not indicate which user is logging off, so no
4860 assumptions can be made.
4863 case CTRL_SHUTDOWN_EVENT:
4864 /* A signal that the system sends to all console processes when the system is
4867 if (do_raise(aTHX_ SIGTERM))
4868 sig_terminate(aTHX_ SIGTERM);
4877 #if _MSC_VER >= 1400
4878 # include <crtdbg.h>
4882 Perl_win32_init(int *argcp, char ***argvp)
4884 #if _MSC_VER >= 1400
4885 _invalid_parameter_handler oldHandler, newHandler;
4886 newHandler = my_invalid_parameter_handler;
4887 oldHandler = _set_invalid_parameter_handler(newHandler);
4888 _CrtSetReportMode(_CRT_ASSERT, 0);
4890 /* Disable floating point errors, Perl will trap the ones we
4891 * care about. VC++ RTL defaults to switching these off
4892 * already, but the Borland RTL doesn't. Since we don't
4893 * want to be at the vendor's whim on the default, we set
4894 * it explicitly here.
4896 #if !defined(_ALPHA_) && !defined(__GNUC__)
4897 _control87(MCW_EM, MCW_EM);
4903 Perl_win32_term(void)
4913 win32_get_child_IO(child_IO_table* ptbl)
4915 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4916 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4917 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4921 win32_signal(int sig, Sighandler_t subcode)
4924 if (sig < SIG_SIZE) {
4925 int save_errno = errno;
4926 Sighandler_t result = signal(sig, subcode);
4927 if (result == SIG_ERR) {
4928 result = w32_sighandler[sig];
4931 w32_sighandler[sig] = subcode;
4941 #ifdef HAVE_INTERP_INTERN
4945 win32_csighandler(int sig)
4948 dTHXa(PERL_GET_SIG_CONTEXT);
4949 Perl_warn(aTHX_ "Got signal %d",sig);
4955 win32_create_message_window()
4957 /* "message-only" windows have been implemented in Windows 2000 and later.
4958 * On earlier versions we'll continue to post messages to a specific
4959 * thread and use hwnd==NULL. This is brittle when either an embedding
4960 * application or an XS module is also posting messages to hwnd=NULL
4961 * because once removed from the queue they cannot be delivered to the
4962 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4963 * if there is no window handle.
4965 if (g_osver.dwMajorVersion < 5)
4968 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4971 #if defined(__MINGW32__) && defined(__cplusplus)
4972 #define CAST_HWND__(x) (HWND__*)(x)
4974 #define CAST_HWND__(x) x
4978 Perl_sys_intern_init(pTHX)
4982 if (g_osver.dwOSVersionInfoSize == 0) {
4983 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4984 GetVersionEx(&g_osver);
4987 w32_perlshell_tokens = Nullch;
4988 w32_perlshell_vec = (char**)NULL;
4989 w32_perlshell_items = 0;
4990 w32_fdpid = newAV();
4991 Newx(w32_children, 1, child_tab);
4992 w32_num_children = 0;
4993 # ifdef USE_ITHREADS
4995 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4996 w32_num_pseudo_children = 0;
4999 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5001 for (i=0; i < SIG_SIZE; i++) {
5002 w32_sighandler[i] = SIG_DFL;
5005 if (my_perl == PL_curinterp) {
5009 /* Force C runtime signal stuff to set its console handler */
5010 signal(SIGINT,win32_csighandler);
5011 signal(SIGBREAK,win32_csighandler);
5012 /* Push our handler on top */
5013 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5018 Perl_sys_intern_clear(pTHX)
5020 Safefree(w32_perlshell_tokens);
5021 Safefree(w32_perlshell_vec);
5022 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5023 Safefree(w32_children);
5025 KillTimer(w32_message_hwnd, w32_timerid);
5028 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5029 DestroyWindow(w32_message_hwnd);
5030 # ifdef MULTIPLICITY
5031 if (my_perl == PL_curinterp) {
5035 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5037 # ifdef USE_ITHREADS
5038 Safefree(w32_pseudo_children);
5042 # ifdef USE_ITHREADS
5045 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5047 dst->perlshell_tokens = Nullch;
5048 dst->perlshell_vec = (char**)NULL;
5049 dst->perlshell_items = 0;
5050 dst->fdpid = newAV();
5051 Newxz(dst->children, 1, child_tab);
5053 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5055 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5056 dst->poll_count = 0;
5057 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5059 # endif /* USE_ITHREADS */
5060 #endif /* HAVE_INTERP_INTERN */
5063 win32_free_argvw(pTHX_ void *ptr)
5065 char** argv = (char**)ptr;
5073 win32_argv2utf8(int argc, char** argv)
5078 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5079 if (lpwStr && argc) {
5081 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5082 Newxz(psz, length, char);
5083 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5086 call_atexit(win32_free_argvw, argv);
5088 GlobalFree((HGLOBAL)lpwStr);