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)
139 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
145 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
149 set_w32_module_name(void)
152 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
153 ? GetModuleHandle(NULL)
154 : w32_perldll_handle),
155 w32_module_name, sizeof(w32_module_name));
157 /* remove \\?\ prefix */
158 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
159 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
161 /* try to get full path to binary (which may be mangled when perl is
162 * run from a 16-bit app) */
163 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
164 (void)win32_longpath(w32_module_name);
165 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
167 /* normalize to forward slashes */
168 ptr = w32_module_name;
176 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
178 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
180 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
183 const char *subkey = "Software\\Perl";
187 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
188 if (retval == ERROR_SUCCESS) {
190 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
191 if (retval == ERROR_SUCCESS
192 && (type == REG_SZ || type == REG_EXPAND_SZ))
196 *svp = sv_2mortal(newSVpvn("",0));
197 SvGROW(*svp, datalen);
198 retval = RegQueryValueEx(handle, valuename, 0, NULL,
199 (PBYTE)SvPVX(*svp), &datalen);
200 if (retval == ERROR_SUCCESS) {
202 SvCUR_set(*svp,datalen-1);
210 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
212 get_regstr(const char *valuename, SV **svp)
214 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
216 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
220 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
222 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
226 char mod_name[MAX_PATH+1];
232 va_start(ap, trailing_path);
233 strip = va_arg(ap, char *);
235 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
236 baselen = strlen(base);
238 if (!*w32_module_name) {
239 set_w32_module_name();
241 strcpy(mod_name, w32_module_name);
242 ptr = strrchr(mod_name, '/');
243 while (ptr && strip) {
244 /* look for directories to skip back */
247 ptr = strrchr(mod_name, '/');
248 /* avoid stripping component if there is no slash,
249 * or it doesn't match ... */
250 if (!ptr || stricmp(ptr+1, strip) != 0) {
251 /* ... but not if component matches m|5\.$patchlevel.*| */
252 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
253 && strncmp(strip, base, baselen) == 0
254 && strncmp(ptr+1, base, baselen) == 0))
260 strip = va_arg(ap, char *);
268 strcpy(++ptr, trailing_path);
270 /* only add directory if it exists */
271 if (GetFileAttributes(mod_name) != (DWORD) -1) {
272 /* directory exists */
275 *prev_pathp = sv_2mortal(newSVpvn("",0));
276 else if (SvPVX(*prev_pathp))
277 sv_catpvn(*prev_pathp, ";", 1);
278 sv_catpv(*prev_pathp, mod_name);
279 return SvPVX(*prev_pathp);
286 win32_get_privlib(const char *pl)
289 char *stdlib = "lib";
290 char buffer[MAX_PATH+1];
293 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
294 sprintf(buffer, "%s-%s", stdlib, pl);
295 if (!get_regstr(buffer, &sv))
296 (void)get_regstr(stdlib, &sv);
298 /* $stdlib .= ";$EMD/../../lib" */
299 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
303 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
307 char pathstr[MAX_PATH+1];
311 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
312 sprintf(regstr, "%s-%s", xlib, pl);
313 (void)get_regstr(regstr, &sv1);
316 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
317 sprintf(pathstr, "%s/%s/lib", libname, pl);
318 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
320 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
321 (void)get_regstr(xlib, &sv2);
324 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
325 sprintf(pathstr, "%s/lib", libname);
326 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
335 sv_catpvn(sv1, ";", 1);
342 win32_get_sitelib(const char *pl)
344 return win32_get_xlib(pl, "sitelib", "site");
347 #ifndef PERL_VENDORLIB_NAME
348 # define PERL_VENDORLIB_NAME "vendor"
352 win32_get_vendorlib(const char *pl)
354 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
358 has_shell_metachars(const char *ptr)
364 * Scan string looking for redirection (< or >) or pipe
365 * characters (|) that are not in a quoted string.
366 * Shell variable interpolation (%VAR%) can also happen inside strings.
398 #if !defined(PERL_IMPLICIT_SYS)
399 /* since the current process environment is being updated in util.c
400 * the library functions will get the correct environment
403 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
406 #define fixcmd(x) { \
407 char *pspace = strchr((x),' '); \
410 while (p < pspace) { \
421 PERL_FLUSHALL_FOR_CHILD;
422 return win32_popen(cmd, mode);
426 Perl_my_pclose(pTHX_ PerlIO *fp)
428 return win32_pclose(fp);
432 DllExport unsigned long
435 return (unsigned long)g_osver.dwPlatformId;
445 return -((int)w32_pseudo_id);
448 /* Windows 9x appears to always reports a pid for threads and processes
449 * that has the high bit set. So we treat the lower 31 bits as the
450 * "real" PID for Perl's purposes. */
451 if (IsWin95() && pid < 0)
456 /* Tokenize a string. Words are null-separated, and the list
457 * ends with a doubled null. Any character (except null and
458 * including backslash) may be escaped by preceding it with a
459 * backslash (the backslash will be stripped).
460 * Returns number of words in result buffer.
463 tokenize(const char *str, char **dest, char ***destv)
465 char *retstart = Nullch;
466 char **retvstart = 0;
470 int slen = strlen(str);
472 register char **retv;
473 Newx(ret, slen+2, char);
474 Newx(retv, (slen+3)/2, char*);
482 if (*ret == '\\' && *str)
484 else if (*ret == ' ') {
500 retvstart[items] = Nullch;
513 if (!w32_perlshell_tokens) {
514 /* we don't use COMSPEC here for two reasons:
515 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
516 * uncontrolled unportability of the ensuing scripts.
517 * 2. PERL5SHELL could be set to a shell that may not be fit for
518 * interactive use (which is what most programs look in COMSPEC
521 const char* defaultshell = (IsWinNT()
522 ? "cmd.exe /x/d/c" : "command.com /c");
523 const char *usershell = PerlEnv_getenv("PERL5SHELL");
524 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
525 &w32_perlshell_tokens,
531 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
543 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
545 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
550 while (++mark <= sp) {
551 if (*mark && (str = SvPV_nolen(*mark)))
558 status = win32_spawnvp(flag,
559 (const char*)(really ? SvPV_nolen(really) : argv[0]),
560 (const char* const*)argv);
562 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
563 /* possible shell-builtin, invoke with shell */
565 sh_items = w32_perlshell_items;
567 argv[index+sh_items] = argv[index];
568 while (--sh_items >= 0)
569 argv[sh_items] = w32_perlshell_vec[sh_items];
571 status = win32_spawnvp(flag,
572 (const char*)(really ? SvPV_nolen(really) : argv[0]),
573 (const char* const*)argv);
576 if (flag == P_NOWAIT) {
578 PL_statusvalue = -1; /* >16bits hint for pp_system() */
582 if (ckWARN(WARN_EXEC))
583 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
588 PL_statusvalue = status;
594 /* returns pointer to the next unquoted space or the end of the string */
596 find_next_space(const char *s)
598 bool in_quotes = FALSE;
600 /* ignore doubled backslashes, or backslash+quote */
601 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
604 /* keep track of when we're within quotes */
605 else if (*s == '"') {
607 in_quotes = !in_quotes;
609 /* break it up only at spaces that aren't in quotes */
610 else if (!in_quotes && isSPACE(*s))
619 do_spawn2(pTHX_ const char *cmd, int exectype)
625 BOOL needToTry = TRUE;
628 /* Save an extra exec if possible. See if there are shell
629 * metacharacters in it */
630 if (!has_shell_metachars(cmd)) {
631 Newx(argv, strlen(cmd) / 2 + 2, char*);
632 Newx(cmd2, strlen(cmd) + 1, char);
635 for (s = cmd2; *s;) {
636 while (*s && isSPACE(*s))
640 s = find_next_space(s);
648 status = win32_spawnvp(P_WAIT, argv[0],
649 (const char* const*)argv);
651 case EXECF_SPAWN_NOWAIT:
652 status = win32_spawnvp(P_NOWAIT, argv[0],
653 (const char* const*)argv);
656 status = win32_execvp(argv[0], (const char* const*)argv);
659 if (status != -1 || errno == 0)
669 Newx(argv, w32_perlshell_items + 2, char*);
670 while (++i < w32_perlshell_items)
671 argv[i] = w32_perlshell_vec[i];
672 argv[i++] = (char *)cmd;
676 status = win32_spawnvp(P_WAIT, argv[0],
677 (const char* const*)argv);
679 case EXECF_SPAWN_NOWAIT:
680 status = win32_spawnvp(P_NOWAIT, argv[0],
681 (const char* const*)argv);
684 status = win32_execvp(argv[0], (const char* const*)argv);
690 if (exectype == EXECF_SPAWN_NOWAIT) {
692 PL_statusvalue = -1; /* >16bits hint for pp_system() */
696 if (ckWARN(WARN_EXEC))
697 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
698 (exectype == EXECF_EXEC ? "exec" : "spawn"),
699 cmd, strerror(errno));
704 PL_statusvalue = status;
710 Perl_do_spawn(pTHX_ char *cmd)
712 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
716 Perl_do_spawn_nowait(pTHX_ char *cmd)
718 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
722 Perl_do_exec(pTHX_ const char *cmd)
724 do_spawn2(aTHX_ cmd, EXECF_EXEC);
728 /* The idea here is to read all the directory names into a string table
729 * (separated by nulls) and when one of the other dir functions is called
730 * return the pointer to the current file name.
733 win32_opendir(const char *filename)
739 char scanname[MAX_PATH+3];
741 WIN32_FIND_DATAA aFindData;
743 len = strlen(filename);
747 /* check to see if filename is a directory */
748 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
751 /* Get us a DIR structure */
754 /* Create the search pattern */
755 strcpy(scanname, filename);
757 /* bare drive name means look in cwd for drive */
758 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
759 scanname[len++] = '.';
760 scanname[len++] = '/';
762 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
763 scanname[len++] = '/';
765 scanname[len++] = '*';
766 scanname[len] = '\0';
768 /* do the FindFirstFile call */
769 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
770 if (dirp->handle == INVALID_HANDLE_VALUE) {
771 DWORD err = GetLastError();
772 /* FindFirstFile() fails on empty drives! */
774 case ERROR_FILE_NOT_FOUND:
776 case ERROR_NO_MORE_FILES:
777 case ERROR_PATH_NOT_FOUND:
780 case ERROR_NOT_ENOUGH_MEMORY:
791 /* now allocate the first part of the string table for
792 * the filenames that we find.
794 idx = strlen(aFindData.cFileName)+1;
799 Newx(dirp->start, dirp->size, char);
800 strcpy(dirp->start, aFindData.cFileName);
802 dirp->end = dirp->curr = dirp->start;
808 /* Readdir just returns the current string pointer and bumps the
809 * string pointer to the nDllExport entry.
811 DllExport struct direct *
812 win32_readdir(DIR *dirp)
817 /* first set up the structure to return */
818 len = strlen(dirp->curr);
819 strcpy(dirp->dirstr.d_name, dirp->curr);
820 dirp->dirstr.d_namlen = len;
823 dirp->dirstr.d_ino = dirp->curr - dirp->start;
825 /* Now set up for the next call to readdir */
826 dirp->curr += len + 1;
827 if (dirp->curr >= dirp->end) {
830 WIN32_FIND_DATAA aFindData;
832 /* finding the next file that matches the wildcard
833 * (which should be all of them in this directory!).
835 res = FindNextFileA(dirp->handle, &aFindData);
837 long endpos = dirp->end - dirp->start;
838 long newsize = endpos + strlen(aFindData.cFileName) + 1;
839 /* bump the string table size by enough for the
840 * new name and its null terminator */
841 while (newsize > dirp->size) {
842 long curpos = dirp->curr - dirp->start;
844 Renew(dirp->start, dirp->size, char);
845 dirp->curr = dirp->start + curpos;
847 strcpy(dirp->start + endpos, aFindData.cFileName);
848 dirp->end = dirp->start + newsize;
854 return &(dirp->dirstr);
860 /* Telldir returns the current string pointer position */
862 win32_telldir(DIR *dirp)
864 return (dirp->curr - dirp->start);
868 /* Seekdir moves the string pointer to a previously saved position
869 * (returned by telldir).
872 win32_seekdir(DIR *dirp, long loc)
874 dirp->curr = dirp->start + loc;
877 /* Rewinddir resets the string pointer to the start */
879 win32_rewinddir(DIR *dirp)
881 dirp->curr = dirp->start;
884 /* free the memory allocated by opendir */
886 win32_closedir(DIR *dirp)
889 if (dirp->handle != INVALID_HANDLE_VALUE)
890 FindClose(dirp->handle);
891 Safefree(dirp->start);
904 * Just pretend that everyone is a superuser. NT will let us know if
905 * we don\'t really have permission to do something.
908 #define ROOT_UID ((uid_t)0)
909 #define ROOT_GID ((gid_t)0)
938 return (auid == ROOT_UID ? 0 : -1);
944 return (agid == ROOT_GID ? 0 : -1);
951 char *buf = w32_getlogin_buffer;
952 DWORD size = sizeof(w32_getlogin_buffer);
953 if (GetUserName(buf,&size))
959 chown(const char *path, uid_t owner, gid_t group)
966 * XXX this needs strengthening (for PerlIO)
969 int mkstemp(const char *path)
972 char buf[MAX_PATH+1];
976 if (i++ > 10) { /* give up */
980 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
984 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
994 long child = w32_num_children;
995 while (--child >= 0) {
996 if ((int)w32_child_pids[child] == pid)
1003 remove_dead_process(long child)
1007 CloseHandle(w32_child_handles[child]);
1008 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1009 (w32_num_children-child-1), HANDLE);
1010 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1011 (w32_num_children-child-1), DWORD);
1018 find_pseudo_pid(int pid)
1021 long child = w32_num_pseudo_children;
1022 while (--child >= 0) {
1023 if ((int)w32_pseudo_child_pids[child] == pid)
1030 remove_dead_pseudo_process(long child)
1034 CloseHandle(w32_pseudo_child_handles[child]);
1035 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1036 (w32_num_pseudo_children-child-1), HANDLE);
1037 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1038 (w32_num_pseudo_children-child-1), DWORD);
1039 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1040 (w32_num_pseudo_children-child-1), HWND);
1041 w32_num_pseudo_children--;
1047 win32_kill(int pid, int sig)
1055 /* it is a pseudo-forked child */
1056 child = find_pseudo_pid(-pid);
1058 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1059 hProcess = w32_pseudo_child_handles[child];
1062 /* "Does process exist?" use of kill */
1066 /* kill -9 style un-graceful exit */
1067 if (TerminateThread(hProcess, sig)) {
1068 remove_dead_pseudo_process(child);
1075 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1076 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1077 /* Yield and wait for the other thread to send us its message_hwnd */
1079 win32_async_check(aTHX);
1082 if (hwnd != INVALID_HANDLE_VALUE) {
1083 /* We fake signals to pseudo-processes using Win32
1084 * message queue. In Win9X the pids are negative already. */
1085 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1086 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1088 /* It might be us ... */
1097 else if (IsWin95()) {
1105 child = find_pid(pid);
1107 hProcess = w32_child_handles[child];
1110 /* "Does process exist?" use of kill */
1113 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1118 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1121 default: /* For now be backwards compatible with perl5.6 */
1123 if (TerminateProcess(hProcess, sig)) {
1124 remove_dead_process(child);
1133 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1134 (IsWin95() ? -pid : pid));
1138 /* "Does process exist?" use of kill */
1142 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1147 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1150 default: /* For now be backwards compatible with perl5.6 */
1152 if (TerminateProcess(hProcess, sig))
1157 CloseHandle(hProcess);
1167 win32_stat(const char *path, Stat_t *sbuf)
1170 char buffer[MAX_PATH+1];
1171 int l = strlen(path);
1174 BOOL expect_dir = FALSE;
1176 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1177 GV_NOTQUAL, SVt_PV);
1178 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1181 switch(path[l - 1]) {
1182 /* FindFirstFile() and stat() are buggy with a trailing
1183 * slashes, except for the root directory of a drive */
1186 if (l > sizeof(buffer)) {
1187 errno = ENAMETOOLONG;
1191 strncpy(buffer, path, l);
1192 /* remove additional trailing slashes */
1193 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1195 /* add back slash if we otherwise end up with just a drive letter */
1196 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1203 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1205 if (l == 2 && isALPHA(path[0])) {
1206 buffer[0] = path[0];
1217 path = PerlDir_mapA(path);
1221 /* We must open & close the file once; otherwise file attribute changes */
1222 /* might not yet have propagated to "other" hard links of the same file. */
1223 /* This also gives us an opportunity to determine the number of links. */
1224 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1225 if (handle != INVALID_HANDLE_VALUE) {
1226 BY_HANDLE_FILE_INFORMATION bhi;
1227 if (GetFileInformationByHandle(handle, &bhi))
1228 nlink = bhi.nNumberOfLinks;
1229 CloseHandle(handle);
1233 /* path will be mapped correctly above */
1234 #if defined(WIN64) || defined(USE_LARGE_FILES)
1235 res = _stati64(path, sbuf);
1237 res = stat(path, sbuf);
1239 sbuf->st_nlink = nlink;
1242 /* CRT is buggy on sharenames, so make sure it really isn't.
1243 * XXX using GetFileAttributesEx() will enable us to set
1244 * sbuf->st_*time (but note that's not available on the
1245 * Windows of 1995) */
1246 DWORD r = GetFileAttributesA(path);
1247 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1248 /* sbuf may still contain old garbage since stat() failed */
1249 Zero(sbuf, 1, Stat_t);
1250 sbuf->st_mode = S_IFDIR | S_IREAD;
1252 if (!(r & FILE_ATTRIBUTE_READONLY))
1253 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1258 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1259 && (path[2] == '\\' || path[2] == '/'))
1261 /* The drive can be inaccessible, some _stat()s are buggy */
1262 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1267 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1272 if (S_ISDIR(sbuf->st_mode))
1273 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1274 else if (S_ISREG(sbuf->st_mode)) {
1276 if (l >= 4 && path[l-4] == '.') {
1277 const char *e = path + l - 3;
1278 if (strnicmp(e,"exe",3)
1279 && strnicmp(e,"bat",3)
1280 && strnicmp(e,"com",3)
1281 && (IsWin95() || strnicmp(e,"cmd",3)))
1282 sbuf->st_mode &= ~S_IEXEC;
1284 sbuf->st_mode |= S_IEXEC;
1287 sbuf->st_mode &= ~S_IEXEC;
1288 /* Propagate permissions to _group_ and _others_ */
1289 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1290 sbuf->st_mode |= (perms>>3) | (perms>>6);
1297 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1298 #define SKIP_SLASHES(s) \
1300 while (*(s) && isSLASH(*(s))) \
1303 #define COPY_NONSLASHES(d,s) \
1305 while (*(s) && !isSLASH(*(s))) \
1309 /* Find the longname of a given path. path is destructively modified.
1310 * It should have space for at least MAX_PATH characters. */
1312 win32_longpath(char *path)
1314 WIN32_FIND_DATA fdata;
1316 char tmpbuf[MAX_PATH+1];
1317 char *tmpstart = tmpbuf;
1324 if (isALPHA(path[0]) && path[1] == ':') {
1326 *tmpstart++ = path[0];
1330 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1332 *tmpstart++ = path[0];
1333 *tmpstart++ = path[1];
1334 SKIP_SLASHES(start);
1335 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1337 *tmpstart++ = *start++;
1338 SKIP_SLASHES(start);
1339 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1344 /* copy initial slash, if any */
1345 if (isSLASH(*start)) {
1346 *tmpstart++ = *start++;
1348 SKIP_SLASHES(start);
1351 /* FindFirstFile() expands "." and "..", so we need to pass
1352 * those through unmolested */
1354 && (!start[1] || isSLASH(start[1])
1355 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1357 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1362 /* if this is the end, bust outta here */
1366 /* now we're at a non-slash; walk up to next slash */
1367 while (*start && !isSLASH(*start))
1370 /* stop and find full name of component */
1373 fhand = FindFirstFile(path,&fdata);
1375 if (fhand != INVALID_HANDLE_VALUE) {
1376 STRLEN len = strlen(fdata.cFileName);
1377 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1378 strcpy(tmpstart, fdata.cFileName);
1389 /* failed a step, just return without side effects */
1390 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1395 strcpy(path,tmpbuf);
1400 win32_getenv(const char *name)
1404 SV *curitem = Nullsv;
1406 needlen = GetEnvironmentVariableA(name,NULL,0);
1408 curitem = sv_2mortal(newSVpvn("", 0));
1410 SvGROW(curitem, needlen+1);
1411 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1413 } while (needlen >= SvLEN(curitem));
1414 SvCUR_set(curitem, needlen);
1417 /* allow any environment variables that begin with 'PERL'
1418 to be stored in the registry */
1419 if (strncmp(name, "PERL", 4) == 0)
1420 (void)get_regstr(name, &curitem);
1422 if (curitem && SvCUR(curitem))
1423 return SvPVX(curitem);
1429 win32_putenv(const char *name)
1437 Newx(curitem,strlen(name)+1,char);
1438 strcpy(curitem, name);
1439 val = strchr(curitem, '=');
1441 /* The sane way to deal with the environment.
1442 * Has these advantages over putenv() & co.:
1443 * * enables us to store a truly empty value in the
1444 * environment (like in UNIX).
1445 * * we don't have to deal with RTL globals, bugs and leaks.
1447 * Why you may want to enable USE_WIN32_RTL_ENV:
1448 * * environ[] and RTL functions will not reflect changes,
1449 * which might be an issue if extensions want to access
1450 * the env. via RTL. This cuts both ways, since RTL will
1451 * not see changes made by extensions that call the Win32
1452 * functions directly, either.
1456 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1465 filetime_to_clock(PFILETIME ft)
1467 __int64 qw = ft->dwHighDateTime;
1469 qw |= ft->dwLowDateTime;
1470 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1475 win32_times(struct tms *timebuf)
1480 clock_t process_time_so_far = clock();
1481 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1483 timebuf->tms_utime = filetime_to_clock(&user);
1484 timebuf->tms_stime = filetime_to_clock(&kernel);
1485 timebuf->tms_cutime = 0;
1486 timebuf->tms_cstime = 0;
1488 /* That failed - e.g. Win95 fallback to clock() */
1489 timebuf->tms_utime = process_time_so_far;
1490 timebuf->tms_stime = 0;
1491 timebuf->tms_cutime = 0;
1492 timebuf->tms_cstime = 0;
1494 return process_time_so_far;
1497 /* fix utime() so it works on directories in NT */
1499 filetime_from_time(PFILETIME pFileTime, time_t Time)
1501 struct tm *pTM = localtime(&Time);
1502 SYSTEMTIME SystemTime;
1508 SystemTime.wYear = pTM->tm_year + 1900;
1509 SystemTime.wMonth = pTM->tm_mon + 1;
1510 SystemTime.wDay = pTM->tm_mday;
1511 SystemTime.wHour = pTM->tm_hour;
1512 SystemTime.wMinute = pTM->tm_min;
1513 SystemTime.wSecond = pTM->tm_sec;
1514 SystemTime.wMilliseconds = 0;
1516 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1517 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1521 win32_unlink(const char *filename)
1527 filename = PerlDir_mapA(filename);
1528 attrs = GetFileAttributesA(filename);
1529 if (attrs == 0xFFFFFFFF) {
1533 if (attrs & FILE_ATTRIBUTE_READONLY) {
1534 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1535 ret = unlink(filename);
1537 (void)SetFileAttributesA(filename, attrs);
1540 ret = unlink(filename);
1545 win32_utime(const char *filename, struct utimbuf *times)
1552 struct utimbuf TimeBuffer;
1555 filename = PerlDir_mapA(filename);
1556 rc = utime(filename, times);
1558 /* EACCES: path specifies directory or readonly file */
1559 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1562 if (times == NULL) {
1563 times = &TimeBuffer;
1564 time(×->actime);
1565 times->modtime = times->actime;
1568 /* This will (and should) still fail on readonly files */
1569 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1570 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1571 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1572 if (handle == INVALID_HANDLE_VALUE)
1575 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1576 filetime_from_time(&ftAccess, times->actime) &&
1577 filetime_from_time(&ftWrite, times->modtime) &&
1578 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1583 CloseHandle(handle);
1588 unsigned __int64 ft_i64;
1593 #define Const64(x) x##LL
1595 #define Const64(x) x##i64
1597 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1598 #define EPOCH_BIAS Const64(116444736000000000)
1600 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1601 * and appears to be unsupported even by glibc) */
1603 win32_gettimeofday(struct timeval *tp, void *not_used)
1607 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1608 GetSystemTimeAsFileTime(&ft.ft_val);
1610 /* seconds since epoch */
1611 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1613 /* microseconds remaining */
1614 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1620 win32_uname(struct utsname *name)
1622 struct hostent *hep;
1623 STRLEN nodemax = sizeof(name->nodename)-1;
1626 switch (g_osver.dwPlatformId) {
1627 case VER_PLATFORM_WIN32_WINDOWS:
1628 strcpy(name->sysname, "Windows");
1630 case VER_PLATFORM_WIN32_NT:
1631 strcpy(name->sysname, "Windows NT");
1633 case VER_PLATFORM_WIN32s:
1634 strcpy(name->sysname, "Win32s");
1637 strcpy(name->sysname, "Win32 Unknown");
1642 sprintf(name->release, "%d.%d",
1643 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1646 sprintf(name->version, "Build %d",
1647 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1648 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1649 if (g_osver.szCSDVersion[0]) {
1650 char *buf = name->version + strlen(name->version);
1651 sprintf(buf, " (%s)", g_osver.szCSDVersion);
1655 hep = win32_gethostbyname("localhost");
1657 STRLEN len = strlen(hep->h_name);
1658 if (len <= nodemax) {
1659 strcpy(name->nodename, hep->h_name);
1662 strncpy(name->nodename, hep->h_name, nodemax);
1663 name->nodename[nodemax] = '\0';
1668 if (!GetComputerName(name->nodename, &sz))
1669 *name->nodename = '\0';
1672 /* machine (architecture) */
1677 GetSystemInfo(&info);
1679 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1680 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1681 procarch = info.u.s.wProcessorArchitecture;
1683 procarch = info.wProcessorArchitecture;
1686 case PROCESSOR_ARCHITECTURE_INTEL:
1687 arch = "x86"; break;
1688 case PROCESSOR_ARCHITECTURE_MIPS:
1689 arch = "mips"; break;
1690 case PROCESSOR_ARCHITECTURE_ALPHA:
1691 arch = "alpha"; break;
1692 case PROCESSOR_ARCHITECTURE_PPC:
1693 arch = "ppc"; break;
1694 #ifdef PROCESSOR_ARCHITECTURE_SHX
1695 case PROCESSOR_ARCHITECTURE_SHX:
1696 arch = "shx"; break;
1698 #ifdef PROCESSOR_ARCHITECTURE_ARM
1699 case PROCESSOR_ARCHITECTURE_ARM:
1700 arch = "arm"; break;
1702 #ifdef PROCESSOR_ARCHITECTURE_IA64
1703 case PROCESSOR_ARCHITECTURE_IA64:
1704 arch = "ia64"; break;
1706 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1707 case PROCESSOR_ARCHITECTURE_ALPHA64:
1708 arch = "alpha64"; break;
1710 #ifdef PROCESSOR_ARCHITECTURE_MSIL
1711 case PROCESSOR_ARCHITECTURE_MSIL:
1712 arch = "msil"; break;
1714 #ifdef PROCESSOR_ARCHITECTURE_AMD64
1715 case PROCESSOR_ARCHITECTURE_AMD64:
1716 arch = "amd64"; break;
1718 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1719 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1720 arch = "ia32-64"; break;
1722 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1723 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1724 arch = "unknown"; break;
1727 sprintf(name->machine, "unknown(0x%x)", procarch);
1728 arch = name->machine;
1731 if (name->machine != arch)
1732 strcpy(name->machine, arch);
1737 /* Timing related stuff */
1740 do_raise(pTHX_ int sig)
1742 if (sig < SIG_SIZE) {
1743 Sighandler_t handler = w32_sighandler[sig];
1744 if (handler == SIG_IGN) {
1747 else if (handler != SIG_DFL) {
1752 /* Choose correct default behaviour */
1768 /* Tell caller to exit thread/process as approriate */
1773 sig_terminate(pTHX_ int sig)
1775 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1776 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1783 win32_async_check(pTHX)
1786 HWND hwnd = w32_message_hwnd;
1790 if (hwnd == INVALID_HANDLE_VALUE) {
1791 /* Call PeekMessage() to mark all pending messages in the queue as "old".
1792 * This is necessary when we are being called by win32_msgwait() to
1793 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
1794 * message over and over. An example how this can happen is when
1795 * Perl is calling win32_waitpid() inside a GUI application and the GUI
1796 * is generating messages before the process terminated.
1798 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
1804 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1805 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1810 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
1811 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
1813 switch (msg.message) {
1815 case WM_USER_MESSAGE: {
1816 int child = find_pseudo_pid(msg.wParam);
1818 w32_pseudo_child_message_hwnds[child] = (HWND)msg.lParam;
1823 case WM_USER_KILL: {
1824 /* We use WM_USER to fake kill() with other signals */
1825 int sig = msg.wParam;
1826 if (do_raise(aTHX_ sig))
1827 sig_terminate(aTHX_ sig);
1832 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1833 if (w32_timerid && w32_timerid==msg.wParam) {
1834 KillTimer(w32_message_hwnd, w32_timerid);
1837 /* Now fake a call to signal handler */
1838 if (do_raise(aTHX_ 14))
1839 sig_terminate(aTHX_ 14);
1846 /* Above or other stuff may have set a signal flag */
1847 if (PL_sig_pending) {
1853 /* This function will not return until the timeout has elapsed, or until
1854 * one of the handles is ready. */
1856 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1858 /* We may need several goes at this - so compute when we stop */
1860 if (timeout != INFINITE) {
1861 ticks = GetTickCount();
1865 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1868 if (result == WAIT_TIMEOUT) {
1869 /* Ran out of time - explicit return of zero to avoid -ve if we
1870 have scheduling issues
1874 if (timeout != INFINITE) {
1875 ticks = GetTickCount();
1877 if (result == WAIT_OBJECT_0 + count) {
1878 /* Message has arrived - check it */
1879 (void)win32_async_check(aTHX);
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) {
2020 CloseHandle(hProcess);
2023 else if (waitcode == WAIT_OBJECT_0) {
2024 if (GetExitCodeProcess(hProcess, &waitcode)) {
2025 *status = (int)((waitcode & 0xff) << 8);
2026 CloseHandle(hProcess);
2030 CloseHandle(hProcess);
2036 return retval >= 0 ? pid : retval;
2040 win32_wait(int *status)
2042 return win32_internal_wait(status, INFINITE);
2045 DllExport unsigned int
2046 win32_sleep(unsigned int t)
2049 /* Win32 times are in ms so *1000 in and /1000 out */
2050 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2053 DllExport unsigned int
2054 win32_alarm(unsigned int sec)
2057 * the 'obvious' implentation is SetTimer() with a callback
2058 * which does whatever receiving SIGALRM would do
2059 * we cannot use SIGALRM even via raise() as it is not
2060 * one of the supported codes in <signal.h>
2064 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2065 w32_message_hwnd = win32_create_message_window();
2068 if (w32_message_hwnd == NULL)
2069 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2072 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2077 KillTimer(w32_message_hwnd, w32_timerid);
2084 #ifdef HAVE_DES_FCRYPT
2085 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2089 win32_crypt(const char *txt, const char *salt)
2092 #ifdef HAVE_DES_FCRYPT
2093 return des_fcrypt(txt, salt, w32_crypt_buffer);
2095 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2100 #ifdef USE_FIXED_OSFHANDLE
2102 #define FOPEN 0x01 /* file handle open */
2103 #define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2104 #define FAPPEND 0x20 /* file handle opened O_APPEND */
2105 #define FDEV 0x40 /* file handle refers to device */
2106 #define FTEXT 0x80 /* file handle is in text mode */
2109 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2112 * This function allocates a free C Runtime file handle and associates
2113 * it with the Win32 HANDLE specified by the first parameter. This is a
2114 * temperary fix for WIN95's brain damage GetFileType() error on socket
2115 * we just bypass that call for socket
2117 * This works with MSVC++ 4.0+ or GCC/Mingw32
2120 * intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2121 * int flags - flags to associate with C Runtime file handle.
2124 * returns index of entry in fh, if successful
2125 * return -1, if no free entry is found
2129 *******************************************************************************/
2132 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2133 * this lets sockets work on Win9X with GCC and should fix the problems
2138 /* create an ioinfo entry, kill its handle, and steal the entry */
2143 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2144 int fh = _open_osfhandle((intptr_t)hF, 0);
2148 EnterCriticalSection(&(_pioinfo(fh)->lock));
2153 my_open_osfhandle(intptr_t osfhandle, int flags)
2156 char fileflags; /* _osfile flags */
2158 /* copy relevant flags from second parameter */
2161 if (flags & O_APPEND)
2162 fileflags |= FAPPEND;
2167 if (flags & O_NOINHERIT)
2168 fileflags |= FNOINHERIT;
2170 /* attempt to allocate a C Runtime file handle */
2171 if ((fh = _alloc_osfhnd()) == -1) {
2172 errno = EMFILE; /* too many open files */
2173 _doserrno = 0L; /* not an OS error */
2174 return -1; /* return error to caller */
2177 /* the file is open. now, set the info in _osfhnd array */
2178 _set_osfhnd(fh, osfhandle);
2180 fileflags |= FOPEN; /* mark as open */
2182 _osfile(fh) = fileflags; /* set osfile entry */
2183 LeaveCriticalSection(&_pioinfo(fh)->lock);
2185 return fh; /* return handle */
2188 #endif /* USE_FIXED_OSFHANDLE */
2190 /* simulate flock by locking a range on the file */
2192 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2193 #define LK_LEN 0xffff0000
2196 win32_flock(int fd, int oper)
2204 Perl_croak_nocontext("flock() unimplemented on this platform");
2207 fh = (HANDLE)_get_osfhandle(fd);
2208 memset(&o, 0, sizeof(o));
2211 case LOCK_SH: /* shared lock */
2212 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2214 case LOCK_EX: /* exclusive lock */
2215 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2217 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2218 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2220 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2221 LK_ERR(LockFileEx(fh,
2222 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2223 0, LK_LEN, 0, &o),i);
2225 case LOCK_UN: /* unlock lock */
2226 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2228 default: /* unknown */
2239 * redirected io subsystem for all XS modules
2252 return (&(_environ));
2255 /* the rest are the remapped stdio routines */
2275 win32_ferror(FILE *fp)
2277 return (ferror(fp));
2282 win32_feof(FILE *fp)
2288 * Since the errors returned by the socket error function
2289 * WSAGetLastError() are not known by the library routine strerror
2290 * we have to roll our own.
2294 win32_strerror(int e)
2296 #if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2297 extern int sys_nerr;
2301 if (e < 0 || e > sys_nerr) {
2306 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2307 w32_strerror_buffer,
2308 sizeof(w32_strerror_buffer), NULL) == 0)
2309 strcpy(w32_strerror_buffer, "Unknown Error");
2311 return w32_strerror_buffer;
2317 win32_str_os_error(void *sv, DWORD dwErr)
2321 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2322 |FORMAT_MESSAGE_IGNORE_INSERTS
2323 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2324 dwErr, 0, (char *)&sMsg, 1, NULL);
2325 /* strip trailing whitespace and period */
2328 --dwLen; /* dwLen doesn't include trailing null */
2329 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2330 if ('.' != sMsg[dwLen])
2335 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2337 dwLen = sprintf(sMsg,
2338 "Unknown error #0x%lX (lookup 0x%lX)",
2339 dwErr, GetLastError());
2343 sv_setpvn((SV*)sv, sMsg, dwLen);
2349 win32_fprintf(FILE *fp, const char *format, ...)
2352 va_start(marker, format); /* Initialize variable arguments. */
2354 return (vfprintf(fp, format, marker));
2358 win32_printf(const char *format, ...)
2361 va_start(marker, format); /* Initialize variable arguments. */
2363 return (vprintf(format, marker));
2367 win32_vfprintf(FILE *fp, const char *format, va_list args)
2369 return (vfprintf(fp, format, args));
2373 win32_vprintf(const char *format, va_list args)
2375 return (vprintf(format, args));
2379 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2381 return fread(buf, size, count, fp);
2385 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2387 return fwrite(buf, size, count, fp);
2390 #define MODE_SIZE 10
2393 win32_fopen(const char *filename, const char *mode)
2401 if (stricmp(filename, "/dev/null")==0)
2404 f = fopen(PerlDir_mapA(filename), mode);
2405 /* avoid buffering headaches for child processes */
2406 if (f && *mode == 'a')
2407 win32_fseek(f, 0, SEEK_END);
2411 #ifndef USE_SOCKETS_AS_HANDLES
2413 #define fdopen my_fdopen
2417 win32_fdopen(int handle, const char *mode)
2421 f = fdopen(handle, (char *) mode);
2422 /* avoid buffering headaches for child processes */
2423 if (f && *mode == 'a')
2424 win32_fseek(f, 0, SEEK_END);
2429 win32_freopen(const char *path, const char *mode, FILE *stream)
2432 if (stricmp(path, "/dev/null")==0)
2435 return freopen(PerlDir_mapA(path), mode, stream);
2439 win32_fclose(FILE *pf)
2441 return my_fclose(pf); /* defined in win32sck.c */
2445 win32_fputs(const char *s,FILE *pf)
2447 return fputs(s, pf);
2451 win32_fputc(int c,FILE *pf)
2457 win32_ungetc(int c,FILE *pf)
2459 return ungetc(c,pf);
2463 win32_getc(FILE *pf)
2469 win32_fileno(FILE *pf)
2475 win32_clearerr(FILE *pf)
2482 win32_fflush(FILE *pf)
2488 win32_ftell(FILE *pf)
2490 #if defined(WIN64) || defined(USE_LARGE_FILES)
2491 #if defined(__BORLANDC__) /* buk */
2492 return win32_tell( fileno( pf ) );
2495 if (fgetpos(pf, &pos))
2505 win32_fseek(FILE *pf, Off_t offset,int origin)
2507 #if defined(WIN64) || defined(USE_LARGE_FILES)
2508 #if defined(__BORLANDC__) /* buk */
2518 if (fgetpos(pf, &pos))
2523 fseek(pf, 0, SEEK_END);
2524 pos = _telli64(fileno(pf));
2533 return fsetpos(pf, &offset);
2536 return fseek(pf, (long)offset, origin);
2541 win32_fgetpos(FILE *pf,fpos_t *p)
2543 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2544 if( win32_tell(fileno(pf)) == -1L ) {
2550 return fgetpos(pf, p);
2555 win32_fsetpos(FILE *pf,const fpos_t *p)
2557 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2558 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2560 return fsetpos(pf, p);
2565 win32_rewind(FILE *pf)
2575 char prefix[MAX_PATH+1];
2576 char filename[MAX_PATH+1];
2577 DWORD len = GetTempPath(MAX_PATH, prefix);
2578 if (len && len < MAX_PATH) {
2579 if (GetTempFileName(prefix, "plx", 0, filename)) {
2580 HANDLE fh = CreateFile(filename,
2581 DELETE | GENERIC_READ | GENERIC_WRITE,
2585 FILE_ATTRIBUTE_NORMAL
2586 | FILE_FLAG_DELETE_ON_CLOSE,
2588 if (fh != INVALID_HANDLE_VALUE) {
2589 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2591 #if defined(__BORLANDC__)
2592 setmode(fd,O_BINARY);
2594 DEBUG_p(PerlIO_printf(Perl_debug_log,
2595 "Created tmpfile=%s\n",filename));
2607 int fd = win32_tmpfd();
2609 return win32_fdopen(fd, "w+b");
2621 win32_fstat(int fd, Stat_t *sbufptr)
2624 /* A file designated by filehandle is not shown as accessible
2625 * for write operations, probably because it is opened for reading.
2628 BY_HANDLE_FILE_INFORMATION bhfi;
2629 #if defined(WIN64) || defined(USE_LARGE_FILES)
2630 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2632 int rc = fstat(fd,&tmp);
2634 sbufptr->st_dev = tmp.st_dev;
2635 sbufptr->st_ino = tmp.st_ino;
2636 sbufptr->st_mode = tmp.st_mode;
2637 sbufptr->st_nlink = tmp.st_nlink;
2638 sbufptr->st_uid = tmp.st_uid;
2639 sbufptr->st_gid = tmp.st_gid;
2640 sbufptr->st_rdev = tmp.st_rdev;
2641 sbufptr->st_size = tmp.st_size;
2642 sbufptr->st_atime = tmp.st_atime;
2643 sbufptr->st_mtime = tmp.st_mtime;
2644 sbufptr->st_ctime = tmp.st_ctime;
2646 int rc = fstat(fd,sbufptr);
2649 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2650 #if defined(WIN64) || defined(USE_LARGE_FILES)
2651 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2653 sbufptr->st_mode &= 0xFE00;
2654 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2655 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2657 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2658 + ((S_IREAD|S_IWRITE) >> 6));
2662 return my_fstat(fd,sbufptr);
2667 win32_pipe(int *pfd, unsigned int size, int mode)
2669 return _pipe(pfd, size, mode);
2673 win32_popenlist(const char *mode, IV narg, SV **args)
2676 Perl_croak(aTHX_ "List form of pipe open not implemented");
2681 * a popen() clone that respects PERL5SHELL
2683 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2687 win32_popen(const char *command, const char *mode)
2689 #ifdef USE_RTL_POPEN
2690 return _popen(command, mode);
2702 /* establish which ends read and write */
2703 if (strchr(mode,'w')) {
2704 stdfd = 0; /* stdin */
2707 nhandle = STD_INPUT_HANDLE;
2709 else if (strchr(mode,'r')) {
2710 stdfd = 1; /* stdout */
2713 nhandle = STD_OUTPUT_HANDLE;
2718 /* set the correct mode */
2719 if (strchr(mode,'b'))
2721 else if (strchr(mode,'t'))
2724 ourmode = _fmode & (O_TEXT | O_BINARY);
2726 /* the child doesn't inherit handles */
2727 ourmode |= O_NOINHERIT;
2729 if (win32_pipe(p, 512, ourmode) == -1)
2732 /* save the old std handle (this needs to happen before the
2733 * dup2(), since that might call SetStdHandle() too) */
2736 old_h = GetStdHandle(nhandle);
2738 /* save current stdfd */
2739 if ((oldfd = win32_dup(stdfd)) == -1)
2742 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2743 /* stdfd will be inherited by the child */
2744 if (win32_dup2(p[child], stdfd) == -1)
2747 /* close the child end in parent */
2748 win32_close(p[child]);
2750 /* set the new std handle (in case dup2() above didn't) */
2751 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2753 /* start the child */
2756 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2759 /* revert stdfd to whatever it was before */
2760 if (win32_dup2(oldfd, stdfd) == -1)
2763 /* close saved handle */
2766 /* restore the old std handle (this needs to happen after the
2767 * dup2(), since that might call SetStdHandle() too */
2769 SetStdHandle(nhandle, old_h);
2775 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2778 /* set process id so that it can be returned by perl's open() */
2779 PL_forkprocess = childpid;
2782 /* we have an fd, return a file stream */
2783 return (PerlIO_fdopen(p[parent], (char *)mode));
2786 /* we don't need to check for errors here */
2790 win32_dup2(oldfd, stdfd);
2794 SetStdHandle(nhandle, old_h);
2800 #endif /* USE_RTL_POPEN */
2808 win32_pclose(PerlIO *pf)
2810 #ifdef USE_RTL_POPEN
2814 int childpid, status;
2818 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2821 childpid = SvIVX(sv);
2839 if (win32_waitpid(childpid, &status, 0) == -1)
2844 #endif /* USE_RTL_POPEN */
2850 LPCWSTR lpExistingFileName,
2851 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2854 WCHAR wFullName[MAX_PATH+1];
2855 LPVOID lpContext = NULL;
2856 WIN32_STREAM_ID StreamId;
2857 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2862 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2863 BOOL, BOOL, LPVOID*) =
2864 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2865 BOOL, BOOL, LPVOID*))
2866 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2867 if (pfnBackupWrite == NULL)
2870 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2873 dwLen = (dwLen+1)*sizeof(WCHAR);
2875 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2876 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2877 NULL, OPEN_EXISTING, 0, NULL);
2878 if (handle == INVALID_HANDLE_VALUE)
2881 StreamId.dwStreamId = BACKUP_LINK;
2882 StreamId.dwStreamAttributes = 0;
2883 StreamId.dwStreamNameSize = 0;
2884 #if defined(__BORLANDC__) \
2885 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2886 StreamId.Size.u.HighPart = 0;
2887 StreamId.Size.u.LowPart = dwLen;
2889 StreamId.Size.HighPart = 0;
2890 StreamId.Size.LowPart = dwLen;
2893 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2894 FALSE, FALSE, &lpContext);
2896 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2897 FALSE, FALSE, &lpContext);
2898 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2901 CloseHandle(handle);
2906 win32_link(const char *oldname, const char *newname)
2909 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2910 WCHAR wOldName[MAX_PATH+1];
2911 WCHAR wNewName[MAX_PATH+1];
2914 Perl_croak(aTHX_ PL_no_func, "link");
2916 pfnCreateHardLinkW =
2917 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2918 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2919 if (pfnCreateHardLinkW == NULL)
2920 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2922 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
2923 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
2924 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2925 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2929 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2934 win32_rename(const char *oname, const char *newname)
2936 char szOldName[MAX_PATH+1];
2937 char szNewName[MAX_PATH+1];
2941 /* XXX despite what the documentation says about MoveFileEx(),
2942 * it doesn't work under Windows95!
2945 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2946 if (stricmp(newname, oname))
2947 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2948 strcpy(szOldName, PerlDir_mapA(oname));
2949 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2951 DWORD err = GetLastError();
2953 case ERROR_BAD_NET_NAME:
2954 case ERROR_BAD_NETPATH:
2955 case ERROR_BAD_PATHNAME:
2956 case ERROR_FILE_NOT_FOUND:
2957 case ERROR_FILENAME_EXCED_RANGE:
2958 case ERROR_INVALID_DRIVE:
2959 case ERROR_NO_MORE_FILES:
2960 case ERROR_PATH_NOT_FOUND:
2973 char szTmpName[MAX_PATH+1];
2974 char dname[MAX_PATH+1];
2975 char *endname = Nullch;
2977 DWORD from_attr, to_attr;
2979 strcpy(szOldName, PerlDir_mapA(oname));
2980 strcpy(szNewName, PerlDir_mapA(newname));
2982 /* if oname doesn't exist, do nothing */
2983 from_attr = GetFileAttributes(szOldName);
2984 if (from_attr == 0xFFFFFFFF) {
2989 /* if newname exists, rename it to a temporary name so that we
2990 * don't delete it in case oname happens to be the same file
2991 * (but perhaps accessed via a different path)
2993 to_attr = GetFileAttributes(szNewName);
2994 if (to_attr != 0xFFFFFFFF) {
2995 /* if newname is a directory, we fail
2996 * XXX could overcome this with yet more convoluted logic */
2997 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3001 tmplen = strlen(szNewName);
3002 strcpy(szTmpName,szNewName);
3003 endname = szTmpName+tmplen;
3004 for (; endname > szTmpName ; --endname) {
3005 if (*endname == '/' || *endname == '\\') {
3010 if (endname > szTmpName)
3011 endname = strcpy(dname,szTmpName);
3015 /* get a temporary filename in same directory
3016 * XXX is this really the best we can do? */
3017 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3021 DeleteFile(szTmpName);
3023 retval = rename(szNewName, szTmpName);
3030 /* rename oname to newname */
3031 retval = rename(szOldName, szNewName);
3033 /* if we created a temporary file before ... */
3034 if (endname != Nullch) {
3035 /* ...and rename succeeded, delete temporary file/directory */
3037 DeleteFile(szTmpName);
3038 /* else restore it to what it was */
3040 (void)rename(szTmpName, szNewName);
3047 win32_setmode(int fd, int mode)
3049 return setmode(fd, mode);
3053 win32_chsize(int fd, Off_t size)
3055 #if defined(WIN64) || defined(USE_LARGE_FILES)
3057 Off_t cur, end, extend;
3059 cur = win32_tell(fd);
3062 end = win32_lseek(fd, 0, SEEK_END);
3065 extend = size - end;
3069 else if (extend > 0) {
3070 /* must grow the file, padding with nulls */
3072 int oldmode = win32_setmode(fd, O_BINARY);
3074 memset(b, '\0', sizeof(b));
3076 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3077 count = win32_write(fd, b, count);
3078 if ((int)count < 0) {
3082 } while ((extend -= count) > 0);
3083 win32_setmode(fd, oldmode);
3086 /* shrink the file */
3087 win32_lseek(fd, size, SEEK_SET);
3088 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3094 win32_lseek(fd, cur, SEEK_SET);
3097 return chsize(fd, (long)size);
3102 win32_lseek(int fd, Off_t offset, int origin)
3104 #if defined(WIN64) || defined(USE_LARGE_FILES)
3105 #if defined(__BORLANDC__) /* buk */
3107 pos.QuadPart = offset;
3108 pos.LowPart = SetFilePointer(
3109 (HANDLE)_get_osfhandle(fd),
3114 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3118 return pos.QuadPart;
3120 return _lseeki64(fd, offset, origin);
3123 return lseek(fd, (long)offset, origin);
3130 #if defined(WIN64) || defined(USE_LARGE_FILES)
3131 #if defined(__BORLANDC__) /* buk */
3134 pos.LowPart = SetFilePointer(
3135 (HANDLE)_get_osfhandle(fd),
3140 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3144 return pos.QuadPart;
3145 /* return tell(fd); */
3147 return _telli64(fd);
3155 win32_open(const char *path, int flag, ...)
3162 pmode = va_arg(ap, int);
3165 if (stricmp(path, "/dev/null")==0)
3168 return open(PerlDir_mapA(path), flag, pmode);
3171 /* close() that understands socket */
3172 extern int my_close(int); /* in win32sck.c */
3177 return my_close(fd);
3193 win32_dup2(int fd1,int fd2)
3195 return dup2(fd1,fd2);
3198 #ifdef PERL_MSVCRT_READFIX
3200 #define LF 10 /* line feed */
3201 #define CR 13 /* carriage return */
3202 #define CTRLZ 26 /* ctrl-z means eof for text */
3203 #define FOPEN 0x01 /* file handle open */
3204 #define FEOFLAG 0x02 /* end of file has been encountered */
3205 #define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3206 #define FPIPE 0x08 /* file handle refers to a pipe */
3207 #define FAPPEND 0x20 /* file handle opened O_APPEND */
3208 #define FDEV 0x40 /* file handle refers to device */
3209 #define FTEXT 0x80 /* file handle is in text mode */
3210 #define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3213 _fixed_read(int fh, void *buf, unsigned cnt)
3215 int bytes_read; /* number of bytes read */
3216 char *buffer; /* buffer to read to */
3217 int os_read; /* bytes read on OS call */
3218 char *p, *q; /* pointers into buffer */
3219 char peekchr; /* peek-ahead character */
3220 ULONG filepos; /* file position after seek */
3221 ULONG dosretval; /* o.s. return value */
3223 /* validate handle */
3224 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3225 !(_osfile(fh) & FOPEN))
3227 /* out of range -- return error */
3229 _doserrno = 0; /* not o.s. error */
3234 * If lockinitflag is FALSE, assume fd is device
3235 * lockinitflag is set to TRUE by open.
3237 if (_pioinfo(fh)->lockinitflag)
3238 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3240 bytes_read = 0; /* nothing read yet */
3241 buffer = (char*)buf;
3243 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3244 /* nothing to read or at EOF, so return 0 read */
3248 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3249 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3251 *buffer++ = _pipech(fh);
3254 _pipech(fh) = LF; /* mark as empty */
3259 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3261 /* ReadFile has reported an error. recognize two special cases.
3263 * 1. map ERROR_ACCESS_DENIED to EBADF
3265 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3266 * means the handle is a read-handle on a pipe for which
3267 * all write-handles have been closed and all data has been
3270 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3271 /* wrong read/write mode should return EBADF, not EACCES */
3273 _doserrno = dosretval;
3277 else if (dosretval == ERROR_BROKEN_PIPE) {
3287 bytes_read += os_read; /* update bytes read */
3289 if (_osfile(fh) & FTEXT) {
3290 /* now must translate CR-LFs to LFs in the buffer */
3292 /* set CRLF flag to indicate LF at beginning of buffer */
3293 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3294 /* _osfile(fh) |= FCRLF; */
3296 /* _osfile(fh) &= ~FCRLF; */
3298 _osfile(fh) &= ~FCRLF;
3300 /* convert chars in the buffer: p is src, q is dest */
3302 while (p < (char *)buf + bytes_read) {
3304 /* if fh is not a device, set ctrl-z flag */
3305 if (!(_osfile(fh) & FDEV))
3306 _osfile(fh) |= FEOFLAG;
3307 break; /* stop translating */
3312 /* *p is CR, so must check next char for LF */
3313 if (p < (char *)buf + bytes_read - 1) {
3316 *q++ = LF; /* convert CR-LF to LF */
3319 *q++ = *p++; /* store char normally */
3322 /* This is the hard part. We found a CR at end of
3323 buffer. We must peek ahead to see if next char
3328 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3329 (LPDWORD)&os_read, NULL))
3330 dosretval = GetLastError();
3332 if (dosretval != 0 || os_read == 0) {
3333 /* couldn't read ahead, store CR */
3337 /* peekchr now has the extra character -- we now
3338 have several possibilities:
3339 1. disk file and char is not LF; just seek back
3341 2. disk file and char is LF; store LF, don't seek back
3342 3. pipe/device and char is LF; store LF.
3343 4. pipe/device and char isn't LF, store CR and
3344 put char in pipe lookahead buffer. */
3345 if (_osfile(fh) & (FDEV|FPIPE)) {
3346 /* non-seekable device */
3351 _pipech(fh) = peekchr;
3356 if (peekchr == LF) {
3357 /* nothing read yet; must make some
3360 /* turn on this flag for tell routine */
3361 _osfile(fh) |= FCRLF;
3364 HANDLE osHandle; /* o.s. handle value */
3366 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3368 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3369 dosretval = GetLastError();
3380 /* we now change bytes_read to reflect the true number of chars
3382 bytes_read = q - (char *)buf;
3386 if (_pioinfo(fh)->lockinitflag)
3387 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3392 #endif /* PERL_MSVCRT_READFIX */
3395 win32_read(int fd, void *buf, unsigned int cnt)
3397 #ifdef PERL_MSVCRT_READFIX
3398 return _fixed_read(fd, buf, cnt);
3400 return read(fd, buf, cnt);
3405 win32_write(int fd, const void *buf, unsigned int cnt)
3407 return write(fd, buf, cnt);
3411 win32_mkdir(const char *dir, int mode)
3414 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3418 win32_rmdir(const char *dir)
3421 return rmdir(PerlDir_mapA(dir));
3425 win32_chdir(const char *dir)
3436 win32_access(const char *path, int mode)
3439 return access(PerlDir_mapA(path), mode);
3443 win32_chmod(const char *path, int mode)
3446 return chmod(PerlDir_mapA(path), mode);
3451 create_command_line(char *cname, STRLEN clen, const char * const *args)
3458 bool bat_file = FALSE;
3459 bool cmd_shell = FALSE;
3460 bool dumb_shell = FALSE;
3461 bool extra_quotes = FALSE;
3462 bool quote_next = FALSE;
3465 cname = (char*)args[0];
3467 /* The NT cmd.exe shell has the following peculiarity that needs to be
3468 * worked around. It strips a leading and trailing dquote when any
3469 * of the following is true:
3470 * 1. the /S switch was used
3471 * 2. there are more than two dquotes
3472 * 3. there is a special character from this set: &<>()@^|
3473 * 4. no whitespace characters within the two dquotes
3474 * 5. string between two dquotes isn't an executable file
3475 * To work around this, we always add a leading and trailing dquote
3476 * to the string, if the first argument is either "cmd.exe" or "cmd",
3477 * and there were at least two or more arguments passed to cmd.exe
3478 * (not including switches).
3479 * XXX the above rules (from "cmd /?") don't seem to be applied
3480 * always, making for the convolutions below :-(
3484 clen = strlen(cname);
3487 && (stricmp(&cname[clen-4], ".bat") == 0
3488 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3495 char *exe = strrchr(cname, '/');
3496 char *exe2 = strrchr(cname, '\\');
3503 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3507 else if (stricmp(exe, "command.com") == 0
3508 || stricmp(exe, "command") == 0)
3515 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3516 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3517 STRLEN curlen = strlen(arg);
3518 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3519 len += 2; /* assume quoting needed (worst case) */
3521 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3523 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3526 Newx(cmd, len, char);
3529 if (bat_file && !IsWin95()) {
3531 extra_quotes = TRUE;
3534 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3536 STRLEN curlen = strlen(arg);
3538 /* we want to protect empty arguments and ones with spaces with
3539 * dquotes, but only if they aren't already there */
3544 else if (quote_next) {
3545 /* see if it really is multiple arguments pretending to
3546 * be one and force a set of quotes around it */
3547 if (*find_next_space(arg))
3550 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3552 while (i < curlen) {
3553 if (isSPACE(arg[i])) {
3556 else if (arg[i] == '"') {
3580 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3581 && stricmp(arg+curlen-2, "/c") == 0)
3583 /* is there a next argument? */
3584 if (args[index+1]) {
3585 /* are there two or more next arguments? */
3586 if (args[index+2]) {
3588 extra_quotes = TRUE;
3591 /* single argument, force quoting if it has spaces */
3607 qualified_path(const char *cmd)
3611 char *fullcmd, *curfullcmd;
3617 fullcmd = (char*)cmd;
3619 if (*fullcmd == '/' || *fullcmd == '\\')
3626 pathstr = PerlEnv_getenv("PATH");
3628 /* worst case: PATH is a single directory; we need additional space
3629 * to append "/", ".exe" and trailing "\0" */
3630 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3631 curfullcmd = fullcmd;
3636 /* start by appending the name to the current prefix */
3637 strcpy(curfullcmd, cmd);
3638 curfullcmd += cmdlen;
3640 /* if it doesn't end with '.', or has no extension, try adding
3641 * a trailing .exe first */
3642 if (cmd[cmdlen-1] != '.'
3643 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3645 strcpy(curfullcmd, ".exe");
3646 res = GetFileAttributes(fullcmd);
3647 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3652 /* that failed, try the bare name */
3653 res = GetFileAttributes(fullcmd);
3654 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3657 /* quit if no other path exists, or if cmd already has path */
3658 if (!pathstr || !*pathstr || has_slash)
3661 /* skip leading semis */
3662 while (*pathstr == ';')
3665 /* build a new prefix from scratch */
3666 curfullcmd = fullcmd;
3667 while (*pathstr && *pathstr != ';') {
3668 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3669 pathstr++; /* skip initial '"' */
3670 while (*pathstr && *pathstr != '"') {
3671 *curfullcmd++ = *pathstr++;
3674 pathstr++; /* skip trailing '"' */
3677 *curfullcmd++ = *pathstr++;
3681 pathstr++; /* skip trailing semi */
3682 if (curfullcmd > fullcmd /* append a dir separator */
3683 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3685 *curfullcmd++ = '\\';
3693 /* The following are just place holders.
3694 * Some hosts may provide and environment that the OS is
3695 * not tracking, therefore, these host must provide that
3696 * environment and the current directory to CreateProcess
3700 win32_get_childenv(void)
3706 win32_free_childenv(void* d)
3711 win32_clearenv(void)
3713 char *envv = GetEnvironmentStrings();
3717 char *end = strchr(cur,'=');
3718 if (end && end != cur) {
3720 SetEnvironmentVariable(cur, NULL);
3722 cur = end + strlen(end+1)+2;
3724 else if ((len = strlen(cur)))
3727 FreeEnvironmentStrings(envv);
3731 win32_get_childdir(void)
3735 char szfilename[MAX_PATH+1];
3737 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3738 Newx(ptr, strlen(szfilename)+1, char);
3739 strcpy(ptr, szfilename);
3744 win32_free_childdir(char* d)
3751 /* XXX this needs to be made more compatible with the spawnvp()
3752 * provided by the various RTLs. In particular, searching for
3753 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3754 * This doesn't significantly affect perl itself, because we
3755 * always invoke things using PERL5SHELL if a direct attempt to
3756 * spawn the executable fails.
3758 * XXX splitting and rejoining the commandline between do_aspawn()
3759 * and win32_spawnvp() could also be avoided.
3763 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3765 #ifdef USE_RTL_SPAWNVP
3766 return spawnvp(mode, cmdname, (char * const *)argv);
3773 STARTUPINFO StartupInfo;
3774 PROCESS_INFORMATION ProcessInformation;
3777 char *fullcmd = Nullch;
3778 char *cname = (char *)cmdname;
3782 clen = strlen(cname);
3783 /* if command name contains dquotes, must remove them */
3784 if (strchr(cname, '"')) {
3786 Newx(cname,clen+1,char);
3799 cmd = create_command_line(cname, clen, argv);
3801 env = PerlEnv_get_childenv();
3802 dir = PerlEnv_get_childdir();
3805 case P_NOWAIT: /* asynch + remember result */
3806 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3811 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3814 create |= CREATE_NEW_PROCESS_GROUP;
3817 case P_WAIT: /* synchronous execution */
3819 default: /* invalid mode */
3824 memset(&StartupInfo,0,sizeof(StartupInfo));
3825 StartupInfo.cb = sizeof(StartupInfo);
3826 memset(&tbl,0,sizeof(tbl));
3827 PerlEnv_get_child_IO(&tbl);
3828 StartupInfo.dwFlags = tbl.dwFlags;
3829 StartupInfo.dwX = tbl.dwX;
3830 StartupInfo.dwY = tbl.dwY;
3831 StartupInfo.dwXSize = tbl.dwXSize;
3832 StartupInfo.dwYSize = tbl.dwYSize;
3833 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3834 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3835 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3836 StartupInfo.wShowWindow = tbl.wShowWindow;
3837 StartupInfo.hStdInput = tbl.childStdIn;
3838 StartupInfo.hStdOutput = tbl.childStdOut;
3839 StartupInfo.hStdError = tbl.childStdErr;
3840 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3841 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3842 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3844 create |= CREATE_NEW_CONSOLE;
3847 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3849 if (w32_use_showwindow) {
3850 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3851 StartupInfo.wShowWindow = w32_showwindow;
3854 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3857 if (!CreateProcess(cname, /* search PATH to find executable */
3858 cmd, /* executable, and its arguments */
3859 NULL, /* process attributes */
3860 NULL, /* thread attributes */
3861 TRUE, /* inherit handles */
3862 create, /* creation flags */
3863 (LPVOID)env, /* inherit environment */
3864 dir, /* inherit cwd */
3866 &ProcessInformation))
3868 /* initial NULL argument to CreateProcess() does a PATH
3869 * search, but it always first looks in the directory
3870 * where the current process was started, which behavior
3871 * is undesirable for backward compatibility. So we
3872 * jump through our own hoops by picking out the path
3873 * we really want it to use. */
3875 fullcmd = qualified_path(cname);
3877 if (cname != cmdname)
3880 DEBUG_p(PerlIO_printf(Perl_debug_log,
3881 "Retrying [%s] with same args\n",
3891 if (mode == P_NOWAIT) {
3892 /* asynchronous spawn -- store handle, return PID */
3893 ret = (int)ProcessInformation.dwProcessId;
3894 if (IsWin95() && ret < 0)
3897 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3898 w32_child_pids[w32_num_children] = (DWORD)ret;
3903 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3904 /* FIXME: if msgwait returned due to message perhaps forward the
3905 "signal" to the process
3907 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3909 CloseHandle(ProcessInformation.hProcess);
3912 CloseHandle(ProcessInformation.hThread);
3915 PerlEnv_free_childenv(env);
3916 PerlEnv_free_childdir(dir);
3918 if (cname != cmdname)
3925 win32_execv(const char *cmdname, const char *const *argv)
3929 /* if this is a pseudo-forked child, we just want to spawn
3930 * the new program, and return */
3932 # ifdef __BORLANDC__
3933 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3935 return spawnv(P_WAIT, cmdname, argv);
3939 return execv(cmdname, (char *const *)argv);
3941 return execv(cmdname, argv);
3946 win32_execvp(const char *cmdname, const char *const *argv)
3950 /* if this is a pseudo-forked child, we just want to spawn
3951 * the new program, and return */
3952 if (w32_pseudo_id) {
3953 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3963 return execvp(cmdname, (char *const *)argv);
3965 return execvp(cmdname, argv);
3970 win32_perror(const char *str)
3976 win32_setbuf(FILE *pf, char *buf)
3982 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3984 return setvbuf(pf, buf, type, size);
3988 win32_flushall(void)
3994 win32_fcloseall(void)
4000 win32_fgets(char *s, int n, FILE *pf)
4002 return fgets(s, n, pf);
4012 win32_fgetc(FILE *pf)
4018 win32_putc(int c, FILE *pf)
4024 win32_puts(const char *s)
4036 win32_putchar(int c)
4043 #ifndef USE_PERL_SBRK
4045 static char *committed = NULL; /* XXX threadead */
4046 static char *base = NULL; /* XXX threadead */
4047 static char *reserved = NULL; /* XXX threadead */
4048 static char *brk = NULL; /* XXX threadead */
4049 static DWORD pagesize = 0; /* XXX threadead */
4052 sbrk(ptrdiff_t need)
4057 GetSystemInfo(&info);
4058 /* Pretend page size is larger so we don't perpetually
4059 * call the OS to commit just one page ...
4061 pagesize = info.dwPageSize << 3;
4063 if (brk+need >= reserved)
4065 DWORD size = brk+need-reserved;
4067 char *prev_committed = NULL;
4068 if (committed && reserved && committed < reserved)
4070 /* Commit last of previous chunk cannot span allocations */
4071 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4074 /* Remember where we committed from in case we want to decommit later */
4075 prev_committed = committed;
4076 committed = reserved;
4079 /* Reserve some (more) space
4080 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4081 * this is only address space not memory...
4082 * Note this is a little sneaky, 1st call passes NULL as reserved
4083 * so lets system choose where we start, subsequent calls pass
4084 * the old end address so ask for a contiguous block
4087 if (size < 64*1024*1024)
4088 size = 64*1024*1024;
4089 size = ((size + pagesize - 1) / pagesize) * pagesize;
4090 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4093 reserved = addr+size;
4103 /* The existing block could not be extended far enough, so decommit
4104 * anything that was just committed above and start anew */
4107 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4110 reserved = base = committed = brk = NULL;
4121 if (brk > committed)
4123 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4125 if (committed+size > reserved)
4126 size = reserved-committed;
4127 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4140 win32_malloc(size_t size)
4142 return malloc(size);
4146 win32_calloc(size_t numitems, size_t size)
4148 return calloc(numitems,size);
4152 win32_realloc(void *block, size_t size)
4154 return realloc(block,size);
4158 win32_free(void *block)
4165 win32_open_osfhandle(intptr_t handle, int flags)
4167 #ifdef USE_FIXED_OSFHANDLE
4169 return my_open_osfhandle(handle, flags);
4171 return _open_osfhandle(handle, flags);
4175 win32_get_osfhandle(int fd)
4177 return (intptr_t)_get_osfhandle(fd);
4181 win32_fdupopen(FILE *pf)
4186 int fileno = win32_dup(win32_fileno(pf));
4188 /* open the file in the same mode */
4190 if((pf)->flags & _F_READ) {
4194 else if((pf)->flags & _F_WRIT) {
4198 else if((pf)->flags & _F_RDWR) {
4204 if((pf)->_flag & _IOREAD) {
4208 else if((pf)->_flag & _IOWRT) {
4212 else if((pf)->_flag & _IORW) {
4219 /* it appears that the binmode is attached to the
4220 * file descriptor so binmode files will be handled
4223 pfdup = win32_fdopen(fileno, mode);
4225 /* move the file pointer to the same position */
4226 if (!fgetpos(pf, &pos)) {
4227 fsetpos(pfdup, &pos);
4233 win32_dynaload(const char* filename)
4236 char buf[MAX_PATH+1];
4239 /* LoadLibrary() doesn't recognize forward slashes correctly,
4240 * so turn 'em back. */
4241 first = strchr(filename, '/');
4243 STRLEN len = strlen(filename);
4244 if (len <= MAX_PATH) {
4245 strcpy(buf, filename);
4246 filename = &buf[first - filename];
4248 if (*filename == '/')
4249 *(char*)filename = '\\';
4255 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4263 XS(w32_SetChildShowWindow)
4266 BOOL use_showwindow = w32_use_showwindow;
4267 /* use "unsigned short" because Perl has redefined "WORD" */
4268 unsigned short showwindow = w32_showwindow;
4271 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4273 if (items == 0 || !SvOK(ST(0)))
4274 w32_use_showwindow = FALSE;
4276 w32_use_showwindow = TRUE;
4277 w32_showwindow = (unsigned short)SvIV(ST(0));
4282 ST(0) = sv_2mortal(newSViv(showwindow));
4284 ST(0) = &PL_sv_undef;
4292 /* Make the host for current directory */
4293 char* ptr = PerlEnv_get_childdir();
4296 * then it worked, set PV valid,
4297 * else return 'undef'
4300 SV *sv = sv_newmortal();
4302 PerlEnv_free_childdir(ptr);
4304 #ifndef INCOMPLETE_TAINTS
4321 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4322 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4329 XS(w32_GetNextAvailDrive)
4333 char root[] = "_:\\";
4338 if (GetDriveType(root) == 1) {
4347 XS(w32_GetLastError)
4351 XSRETURN_IV(GetLastError());
4355 XS(w32_SetLastError)
4359 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4360 SetLastError(SvIV(ST(0)));
4368 char *name = w32_getlogin_buffer;
4369 DWORD size = sizeof(w32_getlogin_buffer);
4371 if (GetUserName(name,&size)) {
4372 /* size includes NULL */
4373 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4383 char name[MAX_COMPUTERNAME_LENGTH+1];
4384 DWORD size = sizeof(name);
4386 if (GetComputerName(name,&size)) {
4387 /* size does NOT include NULL :-( */
4388 ST(0) = sv_2mortal(newSVpvn(name,size));
4399 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4400 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4401 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4405 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4406 GetProcAddress(hNetApi32, "NetApiBufferFree");
4407 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4408 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4411 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4412 /* this way is more reliable, in case user has a local account. */
4414 DWORD dnamelen = sizeof(dname);
4416 DWORD wki100_platform_id;
4417 LPWSTR wki100_computername;
4418 LPWSTR wki100_langroup;
4419 DWORD wki100_ver_major;
4420 DWORD wki100_ver_minor;
4422 /* NERR_Success *is* 0*/
4423 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4424 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4425 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4426 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4429 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4430 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4432 pfnNetApiBufferFree(pwi);
4433 FreeLibrary(hNetApi32);
4436 FreeLibrary(hNetApi32);
4439 /* Win95 doesn't have NetWksta*(), so do it the old way */
4441 DWORD size = sizeof(name);
4443 FreeLibrary(hNetApi32);
4444 if (GetUserName(name,&size)) {
4445 char sid[ONE_K_BUFSIZE];
4446 DWORD sidlen = sizeof(sid);
4448 DWORD dnamelen = sizeof(dname);
4450 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4451 dname, &dnamelen, &snu)) {
4452 XSRETURN_PV(dname); /* all that for this */
4464 DWORD flags, filecomplen;
4465 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4466 &flags, fsname, sizeof(fsname))) {
4467 if (GIMME_V == G_ARRAY) {
4468 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4469 XPUSHs(sv_2mortal(newSViv(flags)));
4470 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4475 XSRETURN_PV(fsname);
4481 XS(w32_GetOSVersion)
4484 /* Use explicit struct definition because wSuiteMask and
4485 * wProductType are not defined in the VC++ 6.0 headers.
4486 * WORD type has been replaced by unsigned short because
4487 * WORD is already used by Perl itself.
4490 DWORD dwOSVersionInfoSize;
4491 DWORD dwMajorVersion;
4492 DWORD dwMinorVersion;
4493 DWORD dwBuildNumber;
4495 CHAR szCSDVersion[128];
4496 unsigned short wServicePackMajor;
4497 unsigned short wServicePackMinor;
4498 unsigned short wSuiteMask;
4504 osver.dwOSVersionInfoSize = sizeof(osver);
4505 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4507 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4508 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4512 if (GIMME_V == G_SCALAR) {
4513 XSRETURN_IV(osver.dwPlatformId);
4515 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4517 XPUSHs(newSViv(osver.dwMajorVersion));
4518 XPUSHs(newSViv(osver.dwMinorVersion));
4519 XPUSHs(newSViv(osver.dwBuildNumber));
4520 XPUSHs(newSViv(osver.dwPlatformId));
4522 XPUSHs(newSViv(osver.wServicePackMajor));
4523 XPUSHs(newSViv(osver.wServicePackMinor));
4524 XPUSHs(newSViv(osver.wSuiteMask));
4525 XPUSHs(newSViv(osver.wProductType));
4535 XSRETURN_IV(IsWinNT());
4543 XSRETURN_IV(IsWin95());
4547 XS(w32_FormatMessage)
4551 char msgbuf[ONE_K_BUFSIZE];
4554 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4556 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4557 &source, SvIV(ST(0)), 0,
4558 msgbuf, sizeof(msgbuf)-1, NULL))
4560 XSRETURN_PV(msgbuf);
4573 PROCESS_INFORMATION stProcInfo;
4574 STARTUPINFO stStartInfo;
4575 BOOL bSuccess = FALSE;
4578 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4580 cmd = SvPV_nolen(ST(0));
4581 args = SvPV_nolen(ST(1));
4583 env = PerlEnv_get_childenv();
4584 dir = PerlEnv_get_childdir();
4586 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4587 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4588 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4589 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4592 cmd, /* Image path */
4593 args, /* Arguments for command line */
4594 NULL, /* Default process security */
4595 NULL, /* Default thread security */
4596 FALSE, /* Must be TRUE to use std handles */
4597 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4598 env, /* Inherit our environment block */
4599 dir, /* Inherit our currrent directory */
4600 &stStartInfo, /* -> Startup info */
4601 &stProcInfo)) /* <- Process info (if OK) */
4603 int pid = (int)stProcInfo.dwProcessId;
4604 if (IsWin95() && pid < 0)
4606 sv_setiv(ST(2), pid);
4607 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4610 PerlEnv_free_childenv(env);
4611 PerlEnv_free_childdir(dir);
4612 XSRETURN_IV(bSuccess);
4616 XS(w32_GetTickCount)
4619 DWORD msec = GetTickCount();
4627 XS(w32_GetShortPathName)
4634 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4636 shortpath = sv_mortalcopy(ST(0));
4637 SvUPGRADE(shortpath, SVt_PV);
4638 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4641 /* src == target is allowed */
4643 len = GetShortPathName(SvPVX(shortpath),
4646 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4648 SvCUR_set(shortpath,len);
4649 *SvEND(shortpath) = '\0';
4657 XS(w32_GetFullPathName)
4664 STRLEN filename_len;
4668 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4671 filename_p = SvPV(filename, filename_len);
4672 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4673 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4677 len = GetFullPathName(SvPVX(filename),
4681 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4683 if (GIMME_V == G_ARRAY) {
4686 XST_mPV(1,filepart);
4687 len = filepart - SvPVX(fullpath);
4694 SvCUR_set(fullpath,len);
4695 *SvEND(fullpath) = '\0';
4703 XS(w32_GetLongPathName)
4707 char tmpbuf[MAX_PATH+1];
4712 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4715 pathstr = SvPV(path,len);
4716 strcpy(tmpbuf, pathstr);
4717 pathstr = win32_longpath(tmpbuf);
4719 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4730 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4740 char szSourceFile[MAX_PATH+1];
4743 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4744 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4745 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4752 Perl_init_os_extras(void)
4755 char *file = __FILE__;
4758 /* these names are Activeware compatible */
4759 newXS("Win32::GetCwd", w32_GetCwd, file);
4760 newXS("Win32::SetCwd", w32_SetCwd, file);
4761 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4762 newXS("Win32::GetLastError", w32_GetLastError, file);
4763 newXS("Win32::SetLastError", w32_SetLastError, file);
4764 newXS("Win32::LoginName", w32_LoginName, file);
4765 newXS("Win32::NodeName", w32_NodeName, file);
4766 newXS("Win32::DomainName", w32_DomainName, file);
4767 newXS("Win32::FsType", w32_FsType, file);
4768 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4769 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4770 newXS("Win32::IsWin95", w32_IsWin95, file);
4771 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4772 newXS("Win32::Spawn", w32_Spawn, file);
4773 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4774 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4775 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4776 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4777 newXS("Win32::CopyFile", w32_CopyFile, file);
4778 newXS("Win32::Sleep", w32_Sleep, file);
4779 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4781 /* XXX Bloat Alert! The following Activeware preloads really
4782 * ought to be part of Win32::Sys::*, so they're not included
4785 /* LookupAccountName
4787 * InitiateSystemShutdown
4788 * AbortSystemShutdown
4789 * ExpandEnvrironmentStrings
4794 win32_signal_context(void)
4799 my_perl = PL_curinterp;
4800 PERL_SET_THX(my_perl);
4804 return PL_curinterp;
4810 win32_ctrlhandler(DWORD dwCtrlType)
4813 dTHXa(PERL_GET_SIG_CONTEXT);
4819 switch(dwCtrlType) {
4820 case CTRL_CLOSE_EVENT:
4821 /* A signal that the system sends to all processes attached to a console when
4822 the user closes the console (either by choosing the Close command from the
4823 console window's System menu, or by choosing the End Task command from the
4826 if (do_raise(aTHX_ 1)) /* SIGHUP */
4827 sig_terminate(aTHX_ 1);
4831 /* A CTRL+c signal was received */
4832 if (do_raise(aTHX_ SIGINT))
4833 sig_terminate(aTHX_ SIGINT);
4836 case CTRL_BREAK_EVENT:
4837 /* A CTRL+BREAK signal was received */
4838 if (do_raise(aTHX_ SIGBREAK))
4839 sig_terminate(aTHX_ SIGBREAK);
4842 case CTRL_LOGOFF_EVENT:
4843 /* A signal that the system sends to all console processes when a user is logging
4844 off. This signal does not indicate which user is logging off, so no
4845 assumptions can be made.
4848 case CTRL_SHUTDOWN_EVENT:
4849 /* A signal that the system sends to all console processes when the system is
4852 if (do_raise(aTHX_ SIGTERM))
4853 sig_terminate(aTHX_ SIGTERM);
4863 Perl_win32_init(int *argcp, char ***argvp)
4865 /* Disable floating point errors, Perl will trap the ones we
4866 * care about. VC++ RTL defaults to switching these off
4867 * already, but the Borland RTL doesn't. Since we don't
4868 * want to be at the vendor's whim on the default, we set
4869 * it explicitly here.
4871 #if !defined(_ALPHA_) && !defined(__GNUC__)
4872 _control87(MCW_EM, MCW_EM);
4878 Perl_win32_term(void)
4886 win32_get_child_IO(child_IO_table* ptbl)
4888 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4889 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4890 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4894 win32_signal(int sig, Sighandler_t subcode)
4897 if (sig < SIG_SIZE) {
4898 int save_errno = errno;
4899 Sighandler_t result = signal(sig, subcode);
4900 if (result == SIG_ERR) {
4901 result = w32_sighandler[sig];
4904 w32_sighandler[sig] = subcode;
4914 #ifdef HAVE_INTERP_INTERN
4918 win32_csighandler(int sig)
4921 dTHXa(PERL_GET_SIG_CONTEXT);
4922 Perl_warn(aTHX_ "Got signal %d",sig);
4928 win32_create_message_window()
4930 /* "message-only" windows have been implemented in Windows 2000 and later.
4931 * On earlier versions we'll continue to post messages to a specific
4932 * thread and use hwnd==NULL. This is brittle when either an embedding
4933 * application or an XS module is also posting messages to hwnd=NULL
4934 * because once removed from the queue they cannot be delivered to the
4935 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4936 * if there is no window handle.
4938 if (g_osver.dwMajorVersion < 5)
4941 return CreateWindow("Static", "", 0, 0, 0, 0, 0, HWND_MESSAGE, 0, 0, NULL);
4945 Perl_sys_intern_init(pTHX)
4949 if (g_osver.dwOSVersionInfoSize == 0) {
4950 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4951 GetVersionEx(&g_osver);
4954 w32_perlshell_tokens = Nullch;
4955 w32_perlshell_vec = (char**)NULL;
4956 w32_perlshell_items = 0;
4957 w32_fdpid = newAV();
4958 Newx(w32_children, 1, child_tab);
4959 w32_num_children = 0;
4960 # ifdef USE_ITHREADS
4962 Newx(w32_pseudo_children, 1, pseudo_child_tab);
4963 w32_num_pseudo_children = 0;
4966 w32_message_hwnd = (HWND__*)INVALID_HANDLE_VALUE;
4968 for (i=0; i < SIG_SIZE; i++) {
4969 w32_sighandler[i] = SIG_DFL;
4972 if (my_perl == PL_curinterp) {
4976 /* Force C runtime signal stuff to set its console handler */
4977 signal(SIGINT,win32_csighandler);
4978 signal(SIGBREAK,win32_csighandler);
4979 /* Push our handler on top */
4980 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4985 Perl_sys_intern_clear(pTHX)
4987 Safefree(w32_perlshell_tokens);
4988 Safefree(w32_perlshell_vec);
4989 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4990 Safefree(w32_children);
4992 KillTimer(w32_message_hwnd, w32_timerid);
4995 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4996 DestroyWindow(w32_message_hwnd);
4997 # ifdef MULTIPLICITY
4998 if (my_perl == PL_curinterp) {
5002 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5004 # ifdef USE_ITHREADS
5005 Safefree(w32_pseudo_children);
5009 # ifdef USE_ITHREADS
5012 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5014 dst->perlshell_tokens = Nullch;
5015 dst->perlshell_vec = (char**)NULL;
5016 dst->perlshell_items = 0;
5017 dst->fdpid = newAV();
5018 Newxz(dst->children, 1, child_tab);
5020 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5022 dst->message_hwnd = INVALID_HANDLE_VALUE;
5023 dst->poll_count = 0;
5024 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5026 # endif /* USE_ITHREADS */
5027 #endif /* HAVE_INTERP_INTERN */
5030 win32_free_argvw(pTHX_ void *ptr)
5032 char** argv = (char**)ptr;
5040 win32_argv2utf8(int argc, char** argv)
5045 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5046 if (lpwStr && argc) {
5048 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5049 Newxz(psz, length, char);
5050 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5053 call_atexit(win32_free_argvw, argv);
5055 GlobalFree((HGLOBAL)lpwStr);