This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
The exit code of make_patchnum.pl is no longer used, so make it return 0.
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745 1/* WIN32.C
2 *
3fadfdf1 3 * (c) 1995 Microsoft Corporation. All rights reserved.
68dc0745 4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
6 *
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.
9 */
3fadfdf1 10#define PERLIO_NOT_STDIO 0
0a753a76 11#define WIN32_LEAN_AND_MEAN
12#define WIN32IO_IS_STDIO
13#include <tchar.h>
a835ef8a
NIS		 14#ifdef __GNUC__
15#define Win32_Winsock
16#endif
0a753a76 17#include <windows.h>
aeecf691
JD		 18#ifndef HWND_MESSAGE
19# define HWND_MESSAGE ((HWND)-3)
20#endif
35cf1ab6 21#ifndef WC_NO_BEST_FIT_CHARS
3839a0fa 22# define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */
35cf1ab6 23#endif
5db10396 24#include <winnt.h>
542cb85f 25#include <tlhelp32.h>
5db10396 26#include <io.h>
c843839f 27#include <signal.h>
0a753a76 28
542cb85f
JD		 29#define SystemProcessesAndThreadsInformation 5
30
31/* Inline some definitions from the DDK */
32typedef struct {
33 USHORT Length;
34 USHORT MaximumLength;
35 PWSTR Buffer;
36} UNICODE_STRING;
37
38typedef struct {
39 ULONG NextEntryDelta;
40 ULONG ThreadCount;
41 ULONG Reserved1[6];
42 LARGE_INTEGER CreateTime;
43 LARGE_INTEGER UserTime;
44 LARGE_INTEGER KernelTime;
45 UNICODE_STRING ProcessName;
46 LONG BasePriority;
47 ULONG ProcessId;
48 ULONG InheritedFromProcessId;
49 /* Remainder of the structure depends on the Windows version,
50 * but we don't need those additional fields anyways... */
51} SYSTEM_PROCESSES;
52
68dc0745 53/* #include "config.h" */
0a753a76 54
0a753a76 55#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
56#define PerlIO FILE
57#endif
58
7a9ec5a3 59#include <sys/stat.h>
0a753a76 60#include "EXTERN.h"
61#include "perl.h"
c69f6586
GS		 62
63#define NO_XSLOCKS
c5be433b 64#define PERL_NO_GET_CONTEXT
ad2e33dc 65#include "XSUB.h"
c69f6586
GS		 66
67#include "Win32iop.h"
0a753a76 68#include <fcntl.h>
5b0d9cbe
NIS		 69#ifndef __GNUC__
70/* assert.h conflicts with #define of assert in perl.h */
0a753a76 71#include <assert.h>
5b0d9cbe 72#endif
0a753a76 73#include <string.h>
74#include <stdarg.h>
ad2e33dc 75#include <float.h>
ad0751ec 76#include <time.h>
3730b96e 77#if defined(_MSC_VER) || defined(__MINGW32__)
ad0751ec
GS		 78#include <sys/utime.h>
79#else
80#include <utime.h>
81#endif
5b0d9cbe 82#ifdef __GNUC__
3fadfdf1 83/* Mingw32 defaults to globing command line
5b0d9cbe
NIS		 84 * So we turn it off like this:
85 */
86int _CRT_glob = 0;
87#endif
88
7c5b6093
AB		 89#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
90/* Mingw32-1.1 is missing some prototypes */
d06fc7d4 91START_EXTERN_C
f8fb7c90
GS		 92FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
93FILE * _wfdopen(int nFd, LPCWSTR wszMode);
94FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
95int _flushall();
96int _fcloseall();
d06fc7d4 97END_EXTERN_C
2b260de0
GS		 98#endif
99
100#if defined(__BORLANDC__)
0b94c7bb
GS		 101# define _stat stat
102# define _utimbuf utimbuf
103#endif
104
6890e559
GS		 105#define EXECF_EXEC 1
106#define EXECF_SPAWN 2
107#define EXECF_SPAWN_NOWAIT 3
108
32e30700
GS		 109#if defined(PERL_IMPLICIT_SYS)
110# undef win32_get_privlib
111# define win32_get_privlib g_win32_get_privlib
112# undef win32_get_sitelib
113# define win32_get_sitelib g_win32_get_sitelib
4ea817c6
GS		 114# undef win32_get_vendorlib
115# define win32_get_vendorlib g_win32_get_vendorlib
32e30700
GS		 116# undef getlogin
117# define getlogin g_getlogin
118#endif
119
ce1da67e 120static void get_shell(void);
dff6d3cd 121static long tokenize(const char *str, char **dest, char ***destv);
08039b81
SH		 122static int do_spawn2(pTHX_ const char *cmd, int exectype);
123static BOOL has_shell_metachars(const char *ptr);
2d7a9237 124static long filetime_to_clock(PFILETIME ft);
ad0751ec 125static BOOL filetime_from_time(PFILETIME ft, time_t t);
c5be433b 126static char * get_emd_part(SV **leading, char *trailing, ...);
0aaad0ff
GS		 127static void remove_dead_process(long deceased);
128static long find_pid(int pid);
129static char * qualified_path(const char *cmd);
4ea817c6
GS		 130static char * win32_get_xlib(const char *pl, const char *xlib,
131 const char *libname);
099b16d3
RM		 132static LRESULT win32_process_message(HWND hwnd, UINT msg,
133 WPARAM wParam, LPARAM lParam);
4ea817c6 134
7766f137
GS		 135#ifdef USE_ITHREADS
136static void remove_dead_pseudo_process(long child);
137static long find_pseudo_pid(int pid);
138#endif
c69f6586 139
7766f137 140START_EXTERN_C
2d7a9237 141HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
8ac9c18d 142char w32_module_name[MAX_PATH+1];
7766f137
GS		 143END_EXTERN_C
144
aeecf691 145static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
50892819 146
542cb85f
JD		 147static HANDLE (WINAPI *pfnCreateToolhelp32Snapshot)(DWORD, DWORD) = NULL;
148static BOOL (WINAPI *pfnProcess32First)(HANDLE, PROCESSENTRY32*) = NULL;
149static BOOL (WINAPI *pfnProcess32Next)(HANDLE, PROCESSENTRY32*) = NULL;
150static LONG (WINAPI *pfnZwQuerySystemInformation)(UINT, PVOID, ULONG, PULONG);
151
3a00b83e
SH		 152#ifdef __BORLANDC__
153/* Silence STDERR grumblings from Borland's math library. */
154DllExport int
155_matherr(struct _exception *a)
156{
157 PERL_UNUSED_VAR(a);
158 return 1;
159}
160#endif
161
58d049f0
JD		 162/* VS2005 (MSC version 14) provides a mechanism to set an invalid
163 * parameter handler. This functionality is not available in the
164 * 64-bit compiler from the Platform SDK, which unfortunately also
165 * believes itself to be MSC version 14.
166 *
167 * There is no #define related to _set_invalid_parameter_handler(),
168 * but we can check for one of the constants defined for
169 * _set_abort_behavior(), which was introduced into stdlib.h at
170 * the same time.
171 */
172
173#if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
174# define SET_INVALID_PARAMETER_HANDLER
175#endif
176
177#ifdef SET_INVALID_PARAMETER_HANDLER
0448a0bd
SH		 178void my_invalid_parameter_handler(const wchar_t* expression,
179 const wchar_t* function,
180 const wchar_t* file,
181 unsigned int line,
182 uintptr_t pReserved)
183{
184# ifdef _DEBUG
185 wprintf(L"Invalid parameter detected in function %s."
186 L" File: %s Line: %d\n", function, file, line);
187 wprintf(L"Expression: %s\n", expression);
188# endif
189}
190#endif
191
3fadfdf1 192int
ba106d47
GS		 193IsWin95(void)
194{
aeecf691 195 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS);
3fe9a6f1 196}
197
198int
ba106d47
GS		 199IsWinNT(void)
200{
aeecf691 201 return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT);
3fe9a6f1 202}
0a753a76 203
3839a0fa
JD		 204int
205IsWin2000(void)
206{
207 return (g_osver.dwMajorVersion > 4);
208}
209
2fa86c13
GS		 210EXTERN_C void
211set_w32_module_name(void)
212{
aa2b96ec 213 /* this function may be called at DLL_PROCESS_ATTACH time */
2fa86c13 214 char* ptr;
aa2b96ec
JD		 215 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
216 ? GetModuleHandle(NULL)
217 : w32_perldll_handle);
2fa86c13 218
aa2b96ec
JD		 219 OSVERSIONINFO osver; /* g_osver may not yet be initialized */
220 osver.dwOSVersionInfoSize = sizeof(osver);
221 GetVersionEx(&osver);
be9da6a9 222
3839a0fa 223 if (osver.dwMajorVersion > 4) {
aa2b96ec
JD		 224 WCHAR modulename[MAX_PATH];
225 WCHAR fullname[MAX_PATH];
226 char *ansi;
227
228 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
229
230 /* Make sure we get an absolute pathname in case the module was loaded
231 * explicitly by LoadLibrary() with a relative path. */
232 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
233
234 /* remove \\?\ prefix */
235 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
236 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
237
238 ansi = win32_ansipath(fullname);
239 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
240 win32_free(ansi);
241 }
242 else {
243 GetModuleFileName(module, w32_module_name, sizeof(w32_module_name));
244
245 /* remove \\?\ prefix */
246 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
247 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
248
249 /* try to get full path to binary (which may be mangled when perl is
250 * run from a 16-bit app) */
251 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
252 win32_longpath(w32_module_name);
253 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
254 }
2fa86c13
GS		 255
256 /* normalize to forward slashes */
257 ptr = w32_module_name;
258 while (*ptr) {
259 if (*ptr == '\\')
260 *ptr = '/';
261 ++ptr;
262 }
263}
264
c5be433b 265/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 266static char*
c5be433b 267get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
349ad1fe
GS		 268{
269 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
00dc2f4f
GS		 270 HKEY handle;
271 DWORD type;
272 const char *subkey = "Software\\Perl";
4e205ed6 273 char *str = NULL;
00dc2f4f
GS		 274 long retval;
275
276 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
349ad1fe 277 if (retval == ERROR_SUCCESS) {
51371543
GS		 278 DWORD datalen;
279 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
1c94caf4
GS		 280 if (retval == ERROR_SUCCESS
281 && (type == REG_SZ || type == REG_EXPAND_SZ))
282 {
acfe0abc 283 dTHX;
c5be433b
GS		 284 if (!*svp)
285 *svp = sv_2mortal(newSVpvn("",0));
286 SvGROW(*svp, datalen);
51371543 287 retval = RegQueryValueEx(handle, valuename, 0, NULL,
c5be433b 288 (PBYTE)SvPVX(*svp), &datalen);
51371543 289 if (retval == ERROR_SUCCESS) {
c5be433b
GS		 290 str = SvPVX(*svp);
291 SvCUR_set(*svp,datalen-1);
51371543 292 }
00dc2f4f
GS		 293 }
294 RegCloseKey(handle);
295 }
349ad1fe 296 return str;
00dc2f4f
GS		 297}
298
c5be433b 299/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 300static char*
c5be433b 301get_regstr(const char *valuename, SV **svp)
00dc2f4f 302{
c5be433b 303 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
349ad1fe 304 if (!str)
c5be433b 305 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
349ad1fe 306 return str;
00dc2f4f
GS		 307}
308
c5be433b 309/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
e5a95ffb 310static char *
c5be433b 311get_emd_part(SV **prev_pathp, char *trailing_path, ...)
00dc2f4f 312{
dc9e4912 313 char base[10];
e5a95ffb 314 va_list ap;
e24c7c18 315 char mod_name[MAX_PATH+1];
00dc2f4f 316 char *ptr;
e5a95ffb
GS		 317 char *optr;
318 char *strip;
273cf8d1 319 STRLEN baselen;
e5a95ffb
GS		 320
321 va_start(ap, trailing_path);
322 strip = va_arg(ap, char *);
323
273cf8d1
GS		 324 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
325 baselen = strlen(base);
dc9e4912 326
8ac9c18d 327 if (!*w32_module_name) {
2fa86c13 328 set_w32_module_name();
95140b98 329 }
8ac9c18d 330 strcpy(mod_name, w32_module_name);
95140b98 331 ptr = strrchr(mod_name, '/');
e5a95ffb
GS		 332 while (ptr && strip) {
333 /* look for directories to skip back */
334 optr = ptr;
00dc2f4f 335 *ptr = '\0';
95140b98 336 ptr = strrchr(mod_name, '/');
1c39adb2
GS		 337 /* avoid stripping component if there is no slash,
338 * or it doesn't match ... */
e5a95ffb 339 if (!ptr || stricmp(ptr+1, strip) != 0) {
273cf8d1 340 /* ... but not if component matches m|5\.$patchlevel.*| */
1c39adb2 341 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
273cf8d1
GS		 342 && strncmp(strip, base, baselen) == 0
343 && strncmp(ptr+1, base, baselen) == 0))
95140b98
GS		 344 {
345 *optr = '/';
80252599
GS		 346 ptr = optr;
347 }
00dc2f4f 348 }
e5a95ffb 349 strip = va_arg(ap, char *);
00dc2f4f 350 }
e5a95ffb
GS		 351 if (!ptr) {
352 ptr = mod_name;
353 *ptr++ = '.';
95140b98 354 *ptr = '/';
00dc2f4f 355 }
e5a95ffb
GS		 356 va_end(ap);
357 strcpy(++ptr, trailing_path);
358
dc9e4912 359 /* only add directory if it exists */
349ad1fe 360 if (GetFileAttributes(mod_name) != (DWORD) -1) {
dc9e4912 361 /* directory exists */
acfe0abc 362 dTHX;
c5be433b
GS		 363 if (!*prev_pathp)
364 *prev_pathp = sv_2mortal(newSVpvn("",0));
f0c8bec2
SH		 365 else if (SvPVX(*prev_pathp))
366 sv_catpvn(*prev_pathp, ";", 1);
c5be433b
GS		 367 sv_catpv(*prev_pathp, mod_name);
368 return SvPVX(*prev_pathp);
00dc2f4f 369 }
00dc2f4f 370
4e205ed6 371 return NULL;
00dc2f4f
GS		 372}
373
374char *
4ea817c6 375win32_get_privlib(const char *pl)
00dc2f4f 376{
acfe0abc 377 dTHX;
e5a95ffb
GS		 378 char *stdlib = "lib";
379 char buffer[MAX_PATH+1];
4e205ed6 380 SV *sv = NULL;
00dc2f4f 381
e5a95ffb
GS		 382 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
383 sprintf(buffer, "%s-%s", stdlib, pl);
c5be433b
GS		 384 if (!get_regstr(buffer, &sv))
385 (void)get_regstr(stdlib, &sv);
00dc2f4f 386
e5a95ffb 387 /* $stdlib .= ";$EMD/../../lib" */
4e205ed6 388 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
00dc2f4f
GS		 389}
390
4ea817c6
GS		 391static char *
392win32_get_xlib(const char *pl, const char *xlib, const char *libname)
00dc2f4f 393{
acfe0abc 394 dTHX;
e5a95ffb 395 char regstr[40];
e24c7c18 396 char pathstr[MAX_PATH+1];
4e205ed6
SP		 397 SV *sv1 = NULL;
398 SV *sv2 = NULL;
00dc2f4f 399
4ea817c6
GS		 400 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
401 sprintf(regstr, "%s-%s", xlib, pl);
c5be433b 402 (void)get_regstr(regstr, &sv1);
e5a95ffb 403
4ea817c6
GS		 404 /* $xlib .=
405 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
406 sprintf(pathstr, "%s/%s/lib", libname, pl);
4e205ed6 407 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
00dc2f4f 408
4ea817c6
GS		 409 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
410 (void)get_regstr(xlib, &sv2);
00dc2f4f 411
4ea817c6
GS		 412 /* $xlib .=
413 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
414 sprintf(pathstr, "%s/lib", libname);
4e205ed6 415 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
e5a95ffb 416
51371543 417 if (!sv1 && !sv2)
4e205ed6 418 return NULL;
51371543
GS		 419 if (!sv1)
420 return SvPVX(sv2);
421 if (!sv2)
422 return SvPVX(sv1);
e5a95ffb 423
349ad1fe
GS		 424 sv_catpvn(sv1, ";", 1);
425 sv_catsv(sv1, sv2);
e5a95ffb 426
349ad1fe 427 return SvPVX(sv1);
68dc0745 428}
0a753a76 429
4ea817c6
GS		 430char *
431win32_get_sitelib(const char *pl)
432{
433 return win32_get_xlib(pl, "sitelib", "site");
434}
435
436#ifndef PERL_VENDORLIB_NAME
437# define PERL_VENDORLIB_NAME "vendor"
438#endif
439
440char *
441win32_get_vendorlib(const char *pl)
442{
443 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
444}
b4793f7f 445
2d7a9237 446static BOOL
08039b81 447has_shell_metachars(const char *ptr)
68dc0745 448{
449 int inquote = 0;
450 char quote = '\0';
451
452 /*
453 * Scan string looking for redirection (< or >) or pipe
e200fe59
JD		 454 * characters (|) that are not in a quoted string.
455 * Shell variable interpolation (%VAR%) can also happen inside strings.
68dc0745 456 */
9404a519 457 while (*ptr) {
68dc0745 458 switch(*ptr) {
e200fe59
JD		 459 case '%':
460 return TRUE;
68dc0745 461 case '\'':
462 case '\"':
9404a519
GS		 463 if (inquote) {
464 if (quote == *ptr) {
68dc0745 465 inquote = 0;
466 quote = '\0';
0a753a76 467 }
68dc0745 468 }
469 else {
470 quote = *ptr;
471 inquote++;
472 }
473 break;
474 case '>':
475 case '<':
476 case '|':
9404a519 477 if (!inquote)
68dc0745 478 return TRUE;
479 default:
480 break;
0a753a76 481 }
68dc0745 482 ++ptr;
483 }
484 return FALSE;
0a753a76 485}
486
32e30700 487#if !defined(PERL_IMPLICIT_SYS)
68dc0745 488/* since the current process environment is being updated in util.c
489 * the library functions will get the correct environment
490 */
491PerlIO *
79d39d80 492Perl_my_popen(pTHX_ const char *cmd, const char *mode)
0a753a76 493{
494#ifdef FIXCMD
7766f137
GS		 495#define fixcmd(x) { \
496 char *pspace = strchr((x),' '); \
497 if (pspace) { \
498 char *p = (x); \
499 while (p < pspace) { \
500 if (*p == '/') \
501 *p = '\\'; \
502 p++; \
503 } \
504 } \
505 }
0a753a76 506#else
507#define fixcmd(x)
508#endif
68dc0745 509 fixcmd(cmd);
45bc9206 510 PERL_FLUSHALL_FOR_CHILD;
0a753a76 511 return win32_popen(cmd, mode);
0a753a76 512}
513
68dc0745 514long
4f63d024 515Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76 516{
517 return win32_pclose(fp);
518}
c69f6586 519#endif
0a753a76 520
0cb96387
GS		 521DllExport unsigned long
522win32_os_id(void)
0a753a76 523{
aeecf691 524 return (unsigned long)g_osver.dwPlatformId;
0a753a76 525}
526
7766f137
GS		 527DllExport int
528win32_getpid(void)
529{
922b1888 530 int pid;
7766f137 531#ifdef USE_ITHREADS
acfe0abc 532 dTHX;
7766f137
GS		 533 if (w32_pseudo_id)
534 return -((int)w32_pseudo_id);
535#endif
922b1888
GS		 536 pid = _getpid();
537 /* Windows 9x appears to always reports a pid for threads and processes
538 * that has the high bit set. So we treat the lower 31 bits as the
539 * "real" PID for Perl's purposes. */
540 if (IsWin95() && pid < 0)
541 pid = -pid;
542 return pid;
7766f137
GS		 543}
544
ce1da67e
GS		 545/* Tokenize a string. Words are null-separated, and the list
546 * ends with a doubled null. Any character (except null and
547 * including backslash) may be escaped by preceding it with a
548 * backslash (the backslash will be stripped).
549 * Returns number of words in result buffer.
550 */
551static long
dff6d3cd 552tokenize(const char *str, char **dest, char ***destv)
ce1da67e 553{
4e205ed6 554 char *retstart = NULL;
ce1da67e
GS		 555 char **retvstart = 0;
556 int items = -1;
557 if (str) {
acfe0abc 558 dTHX;
ce1da67e
GS		 559 int slen = strlen(str);
560 register char *ret;
561 register char **retv;
a02a5408
JC		 562 Newx(ret, slen+2, char);
563 Newx(retv, (slen+3)/2, char*);
ce1da67e
GS		 564
565 retstart = ret;
566 retvstart = retv;
567 *retv = ret;
568 items = 0;
569 while (*str) {
570 *ret = *str++;
571 if (*ret == '\\' && *str)
572 *ret = *str++;
573 else if (*ret == ' ') {
574 while (*str == ' ')
575 str++;
576 if (ret == retstart)
577 ret--;
578 else {
579 *ret = '\0';
580 ++items;
581 if (*str)
582 *++retv = ret+1;
583 }
584 }
585 else if (!*str)
586 ++items;
587 ret++;
588 }
4e205ed6 589 retvstart[items] = NULL;
ce1da67e
GS		 590 *ret++ = '\0';
591 *ret = '\0';
592 }
593 *dest = retstart;
594 *destv = retvstart;
595 return items;
596}
597
598static void
2d7a9237 599get_shell(void)
0a753a76 600{
acfe0abc 601 dTHX;
ce1da67e 602 if (!w32_perlshell_tokens) {
174c211a
GS		 603 /* we don't use COMSPEC here for two reasons:
604 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
605 * uncontrolled unportability of the ensuing scripts.
606 * 2. PERL5SHELL could be set to a shell that may not be fit for
607 * interactive use (which is what most programs look in COMSPEC
608 * for).
609 */
dff6d3cd 610 const char* defaultshell = (IsWinNT()
11998fdb 611 ? "cmd.exe /x/d/c" : "command.com /c");
2fb9ab56 612 const char *usershell = PerlEnv_getenv("PERL5SHELL");
ce1da67e
GS		 613 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
614 &w32_perlshell_tokens,
615 &w32_perlshell_vec);
68dc0745 616 }
0a753a76 617}
618
68dc0745 619int
54725af6 620Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
0a753a76 621{
68dc0745 622 char **argv;
2d7a9237 623 char *str;
68dc0745 624 int status;
2d7a9237 625 int flag = P_WAIT;
68dc0745 626 int index = 0;
68dc0745 627
7918f24d
NC		 628 PERL_ARGS_ASSERT_DO_ASPAWN;
629
2d7a9237
GS		 630 if (sp <= mark)
631 return -1;
68dc0745 632
ce1da67e 633 get_shell();
a02a5408 634 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
2d7a9237
GS		 635
636 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
637 ++mark;
638 flag = SvIVx(*mark);
68dc0745 639 }
640
9404a519 641 while (++mark <= sp) {
bb897dfc 642 if (*mark && (str = SvPV_nolen(*mark)))
2d7a9237
GS		 643 argv[index++] = str;
644 else
645 argv[index++] = "";
68dc0745 646 }
647 argv[index++] = 0;
3fadfdf1 648
2d7a9237 649 status = win32_spawnvp(flag,
bb897dfc 650 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS		 651 (const char* const*)argv);
652
80252599 653 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
2d7a9237 654 /* possible shell-builtin, invoke with shell */
ce1da67e
GS		 655 int sh_items;
656 sh_items = w32_perlshell_items;
2d7a9237
GS		 657 while (--index >= 0)
658 argv[index+sh_items] = argv[index];
ce1da67e
GS		 659 while (--sh_items >= 0)
660 argv[sh_items] = w32_perlshell_vec[sh_items];
3fadfdf1 661
2d7a9237 662 status = win32_spawnvp(flag,
bb897dfc 663 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS		 664 (const char* const*)argv);
665 }
68dc0745 666
922b1888 667 if (flag == P_NOWAIT) {
40c7cc6d 668 PL_statusvalue = -1; /* >16bits hint for pp_system() */
922b1888
GS		 669 }
670 else {
50892819 671 if (status < 0) {
0453d815 672 if (ckWARN(WARN_EXEC))
f98bc0c6 673 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
50892819
GS		 674 status = 255 * 256;
675 }
676 else
677 status *= 256;
b28d0864 678 PL_statusvalue = status;
5aabfad6 679 }
ce1da67e 680 Safefree(argv);
50892819 681 return (status);
68dc0745 682}
683
dd7038b3
JH		 684/* returns pointer to the next unquoted space or the end of the string */
685static char*
686find_next_space(const char *s)
687{
688 bool in_quotes = FALSE;
689 while (*s) {
690 /* ignore doubled backslashes, or backslash+quote */
691 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
692 s += 2;
693 }
694 /* keep track of when we're within quotes */
695 else if (*s == '"') {
696 s++;
697 in_quotes = !in_quotes;
698 }
699 /* break it up only at spaces that aren't in quotes */
700 else if (!in_quotes && isSPACE(*s))
701 return (char*)s;
702 else
703 s++;
704 }
705 return (char*)s;
706}
707
54725af6 708static int
08039b81 709do_spawn2(pTHX_ const char *cmd, int exectype)
68dc0745 710{
711 char **a;
712 char *s;
713 char **argv;
714 int status = -1;
715 BOOL needToTry = TRUE;
2d7a9237 716 char *cmd2;
68dc0745 717
2d7a9237
GS		 718 /* Save an extra exec if possible. See if there are shell
719 * metacharacters in it */
e200fe59 720 if (!has_shell_metachars(cmd)) {
a02a5408
JC		 721 Newx(argv, strlen(cmd) / 2 + 2, char*);
722 Newx(cmd2, strlen(cmd) + 1, char);
68dc0745 723 strcpy(cmd2, cmd);
724 a = argv;
725 for (s = cmd2; *s;) {
de030af3 726 while (*s && isSPACE(*s))
68dc0745 727 s++;
728 if (*s)
729 *(a++) = s;
dd7038b3 730 s = find_next_space(s);
9404a519 731 if (*s)
68dc0745 732 *s++ = '\0';
0a753a76 733 }
4e205ed6 734 *a = NULL;
ce1da67e 735 if (argv[0]) {
6890e559
GS		 736 switch (exectype) {
737 case EXECF_SPAWN:
738 status = win32_spawnvp(P_WAIT, argv[0],
739 (const char* const*)argv);
740 break;
741 case EXECF_SPAWN_NOWAIT:
742 status = win32_spawnvp(P_NOWAIT, argv[0],
743 (const char* const*)argv);
744 break;
745 case EXECF_EXEC:
746 status = win32_execvp(argv[0], (const char* const*)argv);
747 break;
748 }
2d7a9237 749 if (status != -1 || errno == 0)
68dc0745 750 needToTry = FALSE;
0a753a76 751 }
0a753a76 752 Safefree(argv);
68dc0745 753 Safefree(cmd2);
754 }
2d7a9237 755 if (needToTry) {
ce1da67e
GS		 756 char **argv;
757 int i = -1;
758 get_shell();
a02a5408 759 Newx(argv, w32_perlshell_items + 2, char*);
ce1da67e
GS		 760 while (++i < w32_perlshell_items)
761 argv[i] = w32_perlshell_vec[i];
08039b81 762 argv[i++] = (char *)cmd;
4e205ed6 763 argv[i] = NULL;
6890e559
GS		 764 switch (exectype) {
765 case EXECF_SPAWN:
766 status = win32_spawnvp(P_WAIT, argv[0],
767 (const char* const*)argv);
768 break;
769 case EXECF_SPAWN_NOWAIT:
770 status = win32_spawnvp(P_NOWAIT, argv[0],
771 (const char* const*)argv);
772 break;
773 case EXECF_EXEC:
774 status = win32_execvp(argv[0], (const char* const*)argv);
775 break;
776 }
ce1da67e
GS		 777 cmd = argv[0];
778 Safefree(argv);
68dc0745 779 }
922b1888 780 if (exectype == EXECF_SPAWN_NOWAIT) {
40c7cc6d 781 PL_statusvalue = -1; /* >16bits hint for pp_system() */
922b1888
GS		 782 }
783 else {
50892819 784 if (status < 0) {
0453d815 785 if (ckWARN(WARN_EXEC))
f98bc0c6 786 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
50892819
GS		 787 (exectype == EXECF_EXEC ? "exec" : "spawn"),
788 cmd, strerror(errno));
789 status = 255 * 256;
790 }
791 else
792 status *= 256;
b28d0864 793 PL_statusvalue = status;
5aabfad6 794 }
50892819 795 return (status);
0a753a76 796}
797
6890e559 798int
54725af6 799Perl_do_spawn(pTHX_ char *cmd)
6890e559 800{
7918f24d
NC		 801 PERL_ARGS_ASSERT_DO_SPAWN;
802
54725af6 803 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
6890e559
GS		 804}
805
2d7a9237 806int
54725af6 807Perl_do_spawn_nowait(pTHX_ char *cmd)
2d7a9237 808{
7918f24d
NC		 809 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
810
54725af6 811 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
2d7a9237
GS		 812}
813
6890e559 814bool
79d39d80 815Perl_do_exec(pTHX_ const char *cmd)
6890e559 816{
7918f24d
NC		 817 PERL_ARGS_ASSERT_DO_EXEC;
818
08039b81 819 do_spawn2(aTHX_ cmd, EXECF_EXEC);
6890e559
GS		 820 return FALSE;
821}
822
68dc0745 823/* The idea here is to read all the directory names into a string table
824 * (separated by nulls) and when one of the other dir functions is called
825 * return the pointer to the current file name.
826 */
c5be433b 827DllExport DIR *
0e06f75d 828win32_opendir(const char *filename)
0a753a76 829{
acfe0abc 830 dTHX;
95136add 831 DIR *dirp;
9404a519
GS		 832 long len;
833 long idx;
834 char scanname[MAX_PATH+3];
c623ac67 835 Stat_t sbuf;
7fac1903 836 WIN32_FIND_DATAA aFindData;
35cf1ab6
JD		 837 WIN32_FIND_DATAW wFindData;
838 bool using_wide;
839 char buffer[MAX_PATH*2];
840 char *ptr;
9404a519
GS		 841
842 len = strlen(filename);
843 if (len > MAX_PATH)
844 return NULL;
68dc0745 845
846 /* check to see if filename is a directory */
69d3ab13 847 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
24caa93f 848 return NULL;
68dc0745 849
68dc0745 850 /* Get us a DIR structure */
a02a5408 851 Newxz(dirp, 1, DIR);
68dc0745 852
853 /* Create the search pattern */
854 strcpy(scanname, filename);
23db2e2d
GS		 855
856 /* bare drive name means look in cwd for drive */
857 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
858 scanname[len++] = '.';
859 scanname[len++] = '/';
860 }
861 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
9404a519 862 scanname[len++] = '/';
23db2e2d 863 }
9404a519
GS		 864 scanname[len++] = '*';
865 scanname[len] = '\0';
68dc0745 866
867 /* do the FindFirstFile call */
3839a0fa 868 if (IsWin2000()) {
35cf1ab6
JD		 869 WCHAR wscanname[sizeof(scanname)];
870 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
871 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
872 using_wide = TRUE;
873 }
874 else {
875 dirp->handle = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
876 }
8c56068e 877 if (dirp->handle == INVALID_HANDLE_VALUE) {
95136add 878 DWORD err = GetLastError();
21e72512 879 /* FindFirstFile() fails on empty drives! */
95136add
GS		 880 switch (err) {
881 case ERROR_FILE_NOT_FOUND:
882 return dirp;
883 case ERROR_NO_MORE_FILES:
884 case ERROR_PATH_NOT_FOUND:
885 errno = ENOENT;
886 break;
887 case ERROR_NOT_ENOUGH_MEMORY:
888 errno = ENOMEM;
889 break;
890 default:
891 errno = EINVAL;
892 break;
893 }
894 Safefree(dirp);
68dc0745 895 return NULL;
896 }
897
35cf1ab6
JD		 898 if (using_wide) {
899 BOOL use_default = FALSE;
900 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
901 wFindData.cFileName, -1,
902 buffer, sizeof(buffer), NULL, &use_default);
903 if (use_default && *wFindData.cAlternateFileName) {
904 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
905 wFindData.cAlternateFileName, -1,
906 buffer, sizeof(buffer), NULL, NULL);
907 }
908 ptr = buffer;
909 }
910 else {
911 ptr = aFindData.cFileName;
912 }
68dc0745 913 /* now allocate the first part of the string table for
914 * the filenames that we find.
915 */
35cf1ab6 916 idx = strlen(ptr)+1;
95136add 917 if (idx < 256)
35cf1ab6 918 dirp->size = 256;
95136add
GS		 919 else
920 dirp->size = idx;
a02a5408 921 Newx(dirp->start, dirp->size, char);
35cf1ab6 922 strcpy(dirp->start, ptr);
95136add
GS		 923 dirp->nfiles++;
924 dirp->end = dirp->curr = dirp->start;
925 dirp->end += idx;
926 return dirp;
0a753a76 927}
928
929
68dc0745 930/* Readdir just returns the current string pointer and bumps the
931 * string pointer to the nDllExport entry.
932 */
c5be433b 933DllExport struct direct *
ce2e26e5 934win32_readdir(DIR *dirp)
0a753a76 935{
95136add 936 long len;
0a753a76 937
68dc0745 938 if (dirp->curr) {
939 /* first set up the structure to return */
940 len = strlen(dirp->curr);
0f38926b 941 strcpy(dirp->dirstr.d_name, dirp->curr);
68dc0745 942 dirp->dirstr.d_namlen = len;
0a753a76 943
68dc0745 944 /* Fake an inode */
0f38926b 945 dirp->dirstr.d_ino = dirp->curr - dirp->start;
0a753a76 946
95136add 947 /* Now set up for the next call to readdir */
68dc0745 948 dirp->curr += len + 1;
95136add 949 if (dirp->curr >= dirp->end) {
acfe0abc 950 dTHX;
35cf1ab6
JD		 951 BOOL res;
952 WIN32_FIND_DATAA aFindData;
953 char buffer[MAX_PATH*2];
954 char *ptr;
95136add
GS		 955
956 /* finding the next file that matches the wildcard
957 * (which should be all of them in this directory!).
95136add 958 */
3839a0fa 959 if (IsWin2000()) {
35cf1ab6
JD		 960 WIN32_FIND_DATAW wFindData;
961 res = FindNextFileW(dirp->handle, &wFindData);
962 if (res) {
963 BOOL use_default = FALSE;
964 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
965 wFindData.cFileName, -1,
966 buffer, sizeof(buffer), NULL, &use_default);
967 if (use_default && *wFindData.cAlternateFileName) {
968 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
969 wFindData.cAlternateFileName, -1,
970 buffer, sizeof(buffer), NULL, NULL);
971 }
972 ptr = buffer;
973 }
974 }
975 else {
976 res = FindNextFileA(dirp->handle, &aFindData);
977 ptr = aFindData.cFileName;
978 }
95136add 979 if (res) {
0f38926b 980 long endpos = dirp->end - dirp->start;
35cf1ab6 981 long newsize = endpos + strlen(ptr) + 1;
95136add 982 /* bump the string table size by enough for the
022735b4 983 * new name and its null terminator */
0f38926b
GS		 984 while (newsize > dirp->size) {
985 long curpos = dirp->curr - dirp->start;
95136add
GS		 986 dirp->size *= 2;
987 Renew(dirp->start, dirp->size, char);
0f38926b 988 dirp->curr = dirp->start + curpos;
95136add 989 }
35cf1ab6 990 strcpy(dirp->start + endpos, ptr);
0f38926b 991 dirp->end = dirp->start + newsize;
95136add
GS		 992 dirp->nfiles++;
993 }
994 else
995 dirp->curr = NULL;
68dc0745 996 }
68dc0745 997 return &(dirp->dirstr);
3fadfdf1 998 }
68dc0745 999 else
1000 return NULL;
0a753a76 1001}
1002
68dc0745 1003/* Telldir returns the current string pointer position */
c5be433b 1004DllExport long
ce2e26e5 1005win32_telldir(DIR *dirp)
0a753a76 1006{
95136add 1007 return (dirp->curr - dirp->start);
0a753a76 1008}
1009
1010
68dc0745 1011/* Seekdir moves the string pointer to a previously saved position
95136add 1012 * (returned by telldir).
68dc0745 1013 */
c5be433b 1014DllExport void
ce2e26e5 1015win32_seekdir(DIR *dirp, long loc)
0a753a76 1016{
95136add 1017 dirp->curr = dirp->start + loc;
0a753a76 1018}
1019
68dc0745 1020/* Rewinddir resets the string pointer to the start */
c5be433b 1021DllExport void
ce2e26e5 1022win32_rewinddir(DIR *dirp)
0a753a76 1023{
1024 dirp->curr = dirp->start;
1025}
1026
68dc0745 1027/* free the memory allocated by opendir */
c5be433b 1028DllExport int
ce2e26e5 1029win32_closedir(DIR *dirp)
0a753a76 1030{
acfe0abc 1031 dTHX;
95136add 1032 if (dirp->handle != INVALID_HANDLE_VALUE)
0f38926b 1033 FindClose(dirp->handle);
0a753a76 1034 Safefree(dirp->start);
1035 Safefree(dirp);
68dc0745 1036 return 1;
0a753a76 1037}
1038
1039
68dc0745 1040/*
1041 * various stubs
1042 */
0a753a76 1043
1044
68dc0745 1045/* Ownership
1046 *
1047 * Just pretend that everyone is a superuser. NT will let us know if
1048 * we don\'t really have permission to do something.
1049 */
0a753a76 1050
1051#define ROOT_UID ((uid_t)0)
1052#define ROOT_GID ((gid_t)0)
1053
68dc0745 1054uid_t
1055getuid(void)
0a753a76 1056{
68dc0745 1057 return ROOT_UID;
0a753a76 1058}
1059
68dc0745 1060uid_t
1061geteuid(void)
0a753a76 1062{
68dc0745 1063 return ROOT_UID;
0a753a76 1064}
1065
68dc0745 1066gid_t
1067getgid(void)
0a753a76 1068{
68dc0745 1069 return ROOT_GID;
0a753a76 1070}
1071
68dc0745 1072gid_t
1073getegid(void)
0a753a76 1074{
68dc0745 1075 return ROOT_GID;
0a753a76 1076}
1077
68dc0745 1078int
22239a37 1079setuid(uid_t auid)
3fadfdf1 1080{
22239a37 1081 return (auid == ROOT_UID ? 0 : -1);
0a753a76 1082}
1083
68dc0745 1084int
22239a37 1085setgid(gid_t agid)
0a753a76 1086{
22239a37 1087 return (agid == ROOT_GID ? 0 : -1);
0a753a76 1088}
1089
e34ffe5a
GS		 1090char *
1091getlogin(void)
1092{
acfe0abc 1093 dTHX;
3352bfcb
GS		 1094 char *buf = w32_getlogin_buffer;
1095 DWORD size = sizeof(w32_getlogin_buffer);
e34ffe5a
GS		 1096 if (GetUserName(buf,&size))
1097 return buf;
1098 return (char*)NULL;
1099}
1100
b990f8c8
GS		 1101int
1102chown(const char *path, uid_t owner, gid_t group)
1103{
1104 /* XXX noop */
1c1c7f20 1105 return 0;
b990f8c8
GS		 1106}
1107
00b02797
JH		 1108/*
1109 * XXX this needs strengthening (for PerlIO)
1110 * -- BKS, 11-11-200
1111*/
1112int mkstemp(const char *path)
1113{
1114 dTHX;
1115 char buf[MAX_PATH+1];
1116 int i = 0, fd = -1;
1117
1118retry:
1119 if (i++ > 10) { /* give up */
1120 errno = ENOENT;
1121 return -1;
1122 }
1123 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1124 errno = ENOENT;
1125 return -1;
1126 }
1127 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1128 if (fd == -1)
1129 goto retry;
1130 return fd;
1131}
1132
0aaad0ff
GS		 1133static long
1134find_pid(int pid)
0a753a76 1135{
acfe0abc 1136 dTHX;
7766f137
GS		 1137 long child = w32_num_children;
1138 while (--child >= 0) {
eb160463 1139 if ((int)w32_child_pids[child] == pid)
0aaad0ff
GS		 1140 return child;
1141 }
1142 return -1;
1143}
1144
1145static void
1146remove_dead_process(long child)
1147{
1148 if (child >= 0) {
acfe0abc 1149 dTHX;
0aaad0ff 1150 CloseHandle(w32_child_handles[child]);
c00206c8 1151 Move(&w32_child_handles[child+1], &w32_child_handles[child],
0aaad0ff 1152 (w32_num_children-child-1), HANDLE);
c00206c8 1153 Move(&w32_child_pids[child+1], &w32_child_pids[child],
0aaad0ff
GS		 1154 (w32_num_children-child-1), DWORD);
1155 w32_num_children--;
f55ee38a 1156 }
f55ee38a
GS		 1157}
1158
7766f137
GS		 1159#ifdef USE_ITHREADS
1160static long
1161find_pseudo_pid(int pid)
1162{
acfe0abc 1163 dTHX;
7766f137
GS		 1164 long child = w32_num_pseudo_children;
1165 while (--child >= 0) {
eb160463 1166 if ((int)w32_pseudo_child_pids[child] == pid)
7766f137
GS		 1167 return child;
1168 }
1169 return -1;
1170}
1171
1172static void
1173remove_dead_pseudo_process(long child)
1174{
1175 if (child >= 0) {
acfe0abc 1176 dTHX;
7766f137 1177 CloseHandle(w32_pseudo_child_handles[child]);
c00206c8 1178 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
7766f137 1179 (w32_num_pseudo_children-child-1), HANDLE);
c00206c8 1180 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
7766f137 1181 (w32_num_pseudo_children-child-1), DWORD);
aeecf691
JD		 1182 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1183 (w32_num_pseudo_children-child-1), HWND);
7766f137
GS		 1184 w32_num_pseudo_children--;
1185 }
1186}
1187#endif
1188
542cb85f
JD		 1189static int
1190terminate_process(DWORD pid, HANDLE process_handle, int sig)
1191{
1192 switch(sig) {
1193 case 0:
1194 /* "Does process exist?" use of kill */
1195 return 1;
1196 case 2:
1197 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1198 return 1;
1199 break;
1200 case SIGBREAK:
1201 case SIGTERM:
1202 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1203 return 1;
1204 break;
1205 default: /* For now be backwards compatible with perl 5.6 */
1206 case 9:
1207 /* Note that we will only be able to kill processes owned by the
1208 * current process owner, even when we are running as an administrator.
1209 * To kill processes of other owners we would need to set the
1210 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1211 */
1212 if (TerminateProcess(process_handle, sig))
1213 return 1;
1214 break;
1215 }
1216 return 0;
1217}
1218
1219/* Traverse process tree using ToolHelp functions */
1220static int
1221kill_process_tree_toolhelp(DWORD pid, int sig)
1222{
1223 HANDLE process_handle;
1224 HANDLE snapshot_handle;
1225 int killed = 0;
1226
1227 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
6a4d57af 1228 if (process_handle == NULL)
542cb85f
JD		 1229 return 0;
1230
1231 killed += terminate_process(pid, process_handle, sig);
1232
1233 snapshot_handle = pfnCreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1234 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1235 PROCESSENTRY32 entry;
1236
1237 entry.dwSize = sizeof(entry);
1238 if (pfnProcess32First(snapshot_handle, &entry)) {
1239 do {
1240 if (entry.th32ParentProcessID == pid)
1241 killed += kill_process_tree_toolhelp(entry.th32ProcessID, sig);
1242 entry.dwSize = sizeof(entry);
1243 }
1244 while (pfnProcess32Next(snapshot_handle, &entry));
1245 }
1246 CloseHandle(snapshot_handle);
1247 }
1248 CloseHandle(process_handle);
1249 return killed;
1250}
1251
1252/* Traverse process tree using undocumented system information structures.
1253 * This is only necessary on Windows NT, which lacks the ToolHelp functions.
1254 */
1255static int
1256kill_process_tree_sysinfo(SYSTEM_PROCESSES *process_info, DWORD pid, int sig)
1257{
1258 HANDLE process_handle;
1259 SYSTEM_PROCESSES *p = process_info;
1260 int killed = 0;
1261
1262 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
6a4d57af 1263 if (process_handle == NULL)
542cb85f
JD		 1264 return 0;
1265
1266 killed += terminate_process(pid, process_handle, sig);
1267
1268 while (1) {
1269 if (p->InheritedFromProcessId == (DWORD)pid)
1270 killed += kill_process_tree_sysinfo(process_info, p->ProcessId, sig);
1271
1272 if (p->NextEntryDelta == 0)
1273 break;
1274
1275 p = (SYSTEM_PROCESSES*)((char*)p + p->NextEntryDelta);
1276 }
1277
1278 CloseHandle(process_handle);
1279 return killed;
1280}
1281
1282int
1283killpg(int pid, int sig)
1284{
1285 /* Use "documented" method whenever available */
1286 if (pfnCreateToolhelp32Snapshot && pfnProcess32First && pfnProcess32Next) {
1287 return kill_process_tree_toolhelp((DWORD)pid, sig);
1288 }
1289
1290 /* Fall back to undocumented Windows internals on Windows NT */
1291 if (pfnZwQuerySystemInformation) {
1292 dTHX;
1293 char *buffer;
1294 DWORD size = 0;
1295
1296 pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, NULL, 0, &size);
1297 Newx(buffer, size, char);
1298
1299 if (pfnZwQuerySystemInformation(SystemProcessesAndThreadsInformation, buffer, size, NULL) >= 0) {
1300 int killed = kill_process_tree_sysinfo((SYSTEM_PROCESSES*)buffer, (DWORD)pid, sig);
1301 Safefree(buffer);
1302 return killed;
1303 }
1304 }
1305 return 0;
1306}
1307
1308static int
1309my_kill(int pid, int sig)
1310{
1311 int retval = 0;
1312 HANDLE process_handle;
1313
1314 if (sig < 0)
1315 return killpg(pid, -sig);
1316
1317 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
6a4d57af
JD		 1318 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1319 if (process_handle != NULL) {
542cb85f
JD		 1320 retval = terminate_process(pid, process_handle, sig);
1321 CloseHandle(process_handle);
1322 }
1323 return retval;
1324}
1325
f55ee38a
GS		 1326DllExport int
1327win32_kill(int pid, int sig)
1328{
acfe0abc 1329 dTHX;
c66b022d 1330 long child;
7766f137
GS		 1331#ifdef USE_ITHREADS
1332 if (pid < 0) {
1333 /* it is a pseudo-forked child */
c66b022d 1334 child = find_pseudo_pid(-pid);
7766f137 1335 if (child >= 0) {
aeecf691 1336 HWND hwnd = w32_pseudo_child_message_hwnds[child];
85c508c3 1337 HANDLE hProcess = w32_pseudo_child_handles[child];
7e5f34c0
NIS		 1338 switch (sig) {
1339 case 0:
c843839f 1340 /* "Does process exist?" use of kill */
7766f137 1341 return 0;
aeecf691 1342
7e5f34c0
NIS		 1343 case 9:
1344 /* kill -9 style un-graceful exit */
1345 if (TerminateThread(hProcess, sig)) {
1346 remove_dead_pseudo_process(child);
1347 return 0;
1348 }
1349 break;
aeecf691
JD		 1350
1351 default: {
1352 int count = 0;
1353 /* pseudo-process has not yet properly initialized if hwnd isn't set */
1354 while (hwnd == INVALID_HANDLE_VALUE && count < 5) {
1355 /* Yield and wait for the other thread to send us its message_hwnd */
1356 Sleep(0);
1357 win32_async_check(aTHX);
5e162c31 1358 hwnd = w32_pseudo_child_message_hwnds[child];
aeecf691
JD		 1359 ++count;
1360 }
1361 if (hwnd != INVALID_HANDLE_VALUE) {
1362 /* We fake signals to pseudo-processes using Win32
1363 * message queue. In Win9X the pids are negative already. */
1364 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1365 PostThreadMessage(IsWin95() ? pid : -pid, WM_USER_KILL, sig, 0))
1366 {
1367 /* It might be us ... */
1368 PERL_ASYNC_CHECK();
1369 return 0;
1370 }
1371 }
7e5f34c0
NIS		 1372 break;
1373 }
aeecf691 1374 } /* switch */
7766f137 1375 }
922b1888
GS		 1376 else if (IsWin95()) {
1377 pid = -pid;
1378 goto alien_process;
1379 }
68dc0745 1380 }
7766f137
GS		 1381 else
1382#endif
1383 {
c66b022d 1384 child = find_pid(pid);
7766f137 1385 if (child >= 0) {
542cb85f
JD		 1386 if (my_kill(pid, sig)) {
1387 DWORD exitcode = 0;
1388 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1389 exitcode != STILL_ACTIVE)
1390 {
1391 remove_dead_process(child);
1392 }
1393 return 0;
7e5f34c0 1394 }
7766f137
GS		 1395 }
1396 else {
922b1888 1397alien_process:
542cb85f 1398 if (my_kill((IsWin95() ? -pid : pid), sig))
48db714f 1399 return 0;
7766f137
GS		 1400 }
1401 }
1402 errno = EINVAL;
1403 return -1;
0a753a76 1404}
fbbbcc48 1405
68dc0745 1406DllExport int
c623ac67 1407win32_stat(const char *path, Stat_t *sbuf)
0a753a76 1408{
acfe0abc 1409 dTHX;
3fadfdf1 1410 char buffer[MAX_PATH+1];
68dc0745 1411 int l = strlen(path);
67fbe06e 1412 int res;
6b980173 1413 int nlink = 1;
44221b20 1414 BOOL expect_dir = FALSE;
0a753a76 1415
cba61fe1
JD		 1416 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT",
1417 GV_NOTQUAL, SVt_PV);
1418 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy));
1419
68dc0745 1420 if (l > 1) {
1421 switch(path[l - 1]) {
e1dbac94 1422 /* FindFirstFile() and stat() are buggy with a trailing
44221b20 1423 * slashes, except for the root directory of a drive */
68dc0745 1424 case '\\':
44221b20
JD		 1425 case '/':
1426 if (l > sizeof(buffer)) {
0b96339f
JD		 1427 errno = ENAMETOOLONG;
1428 return -1;
1429 }
44221b20
JD		 1430 --l;
1431 strncpy(buffer, path, l);
1432 /* remove additional trailing slashes */
1433 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1434 --l;
1435 /* add back slash if we otherwise end up with just a drive letter */
1436 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1437 buffer[l++] = '\\';
1438 buffer[l] = '\0';
1439 path = buffer;
1440 expect_dir = TRUE;
e1dbac94 1441 break;
44221b20 1442
23db2e2d 1443 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS		 1444 case ':':
1445 if (l == 2 && isALPHA(path[0])) {
426c1a18
GS		 1446 buffer[0] = path[0];
1447 buffer[1] = ':';
1448 buffer[2] = '.';
1449 buffer[3] = '\0';
e1dbac94 1450 l = 3;
426c1a18 1451 path = buffer;
e1dbac94
GS		 1452 }
1453 break;
68dc0745 1454 }
1455 }
6b980173 1456
8c56068e
JD		 1457 path = PerlDir_mapA(path);
1458 l = strlen(path);
cba61fe1
JD		 1459
1460 if (!sloppy) {
1461 /* We must open & close the file once; otherwise file attribute changes */
1462 /* might not yet have propagated to "other" hard links of the same file. */
1463 /* This also gives us an opportunity to determine the number of links. */
1464 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1465 if (handle != INVALID_HANDLE_VALUE) {
1466 BY_HANDLE_FILE_INFORMATION bhi;
1467 if (GetFileInformationByHandle(handle, &bhi))
1468 nlink = bhi.nNumberOfLinks;
1469 CloseHandle(handle);
1470 }
7fac1903 1471 }
6b980173 1472
8c56068e 1473 /* path will be mapped correctly above */
c623ac67 1474#if defined(WIN64) || defined(USE_LARGE_FILES)
8c56068e 1475 res = _stati64(path, sbuf);
c623ac67 1476#else
8c56068e 1477 res = stat(path, sbuf);
c623ac67 1478#endif
426c1a18 1479 sbuf->st_nlink = nlink;
6b980173 1480
24caa93f
GS		 1481 if (res < 0) {
1482 /* CRT is buggy on sharenames, so make sure it really isn't.
1483 * XXX using GetFileAttributesEx() will enable us to set
426c1a18 1484 * sbuf->st_*time (but note that's not available on the
24caa93f 1485 * Windows of 1995) */
8c56068e 1486 DWORD r = GetFileAttributesA(path);
24caa93f 1487 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
426c1a18 1488 /* sbuf may still contain old garbage since stat() failed */
c623ac67 1489 Zero(sbuf, 1, Stat_t);
426c1a18 1490 sbuf->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS		 1491 errno = 0;
1492 if (!(r & FILE_ATTRIBUTE_READONLY))
426c1a18 1493 sbuf->st_mode |= S_IWRITE | S_IEXEC;
24caa93f
GS		 1494 return 0;
1495 }
1496 }
24caa93f 1497 else {
e1dbac94
GS		 1498 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1499 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB		 1500 {
1501 /* The drive can be inaccessible, some _stat()s are buggy */
8c56068e 1502 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB		 1503 errno = ENOENT;
1504 return -1;
1505 }
1506 }
44221b20
JD		 1507 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1508 errno = ENOTDIR;
1509 return -1;
1510 }
038ae9a4
SH		 1511 if (S_ISDIR(sbuf->st_mode)) {
1512 /* Ensure the "write" bit is switched off in the mode for
1513 * directories with the read-only attribute set. Borland (at least)
1514 * switches it on for directories, which is technically correct
1515 * (directories are indeed always writable unless denied by DACLs),
1516 * but we want stat() and -w to reflect the state of the read-only
1517 * attribute for symmetry with chmod(). */
1518 DWORD r = GetFileAttributesA(path);
1519 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1520 sbuf->st_mode &= ~S_IWRITE;
1521 }
1522 }
2293b0e9 1523#ifdef __BORLANDC__
038ae9a4
SH		 1524 if (S_ISDIR(sbuf->st_mode)) {
1525 sbuf->st_mode |= S_IEXEC;
1526 }
426c1a18 1527 else if (S_ISREG(sbuf->st_mode)) {
d0650a05 1528 int perms;
67fbe06e
GS		 1529 if (l >= 4 && path[l-4] == '.') {
1530 const char *e = path + l - 3;
1531 if (strnicmp(e,"exe",3)
1532 && strnicmp(e,"bat",3)
1533 && strnicmp(e,"com",3)
1534 && (IsWin95() || strnicmp(e,"cmd",3)))
426c1a18 1535 sbuf->st_mode &= ~S_IEXEC;
67fbe06e 1536 else
426c1a18 1537 sbuf->st_mode |= S_IEXEC;
67fbe06e
GS		 1538 }
1539 else
426c1a18 1540 sbuf->st_mode &= ~S_IEXEC;
d0650a05
GS		 1541 /* Propagate permissions to _group_ and _others_ */
1542 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1543 sbuf->st_mode |= (perms>>3) | (perms>>6);
67fbe06e 1544 }
67fbe06e 1545#endif
2293b0e9 1546 }
67fbe06e 1547 return res;
0a753a76 1548}
1549
bb27e7b6
JH		 1550#define isSLASH(c) ((c) == '/' || (c) == '\\')
1551#define SKIP_SLASHES(s) \
1552 STMT_START { \
1553 while (*(s) && isSLASH(*(s))) \
1554 ++(s); \
1555 } STMT_END
1556#define COPY_NONSLASHES(d,s) \
1557 STMT_START { \
1558 while (*(s) && !isSLASH(*(s))) \
1559 *(d)++ = *(s)++; \
1560 } STMT_END
1561
8ac9c18d
GS		 1562/* Find the longname of a given path. path is destructively modified.
1563 * It should have space for at least MAX_PATH characters. */
1564DllExport char *
1565win32_longpath(char *path)
1566{
1567 WIN32_FIND_DATA fdata;
1568 HANDLE fhand;
1569 char tmpbuf[MAX_PATH+1];
1570 char *tmpstart = tmpbuf;
1571 char *start = path;
1572 char sep;
1573 if (!path)
4e205ed6 1574 return NULL;
8ac9c18d
GS		 1575
1576 /* drive prefix */
bb27e7b6 1577 if (isALPHA(path[0]) && path[1] == ':') {
8ac9c18d
GS		 1578 start = path + 2;
1579 *tmpstart++ = path[0];
1580 *tmpstart++ = ':';
1581 }
1582 /* UNC prefix */
bb27e7b6 1583 else if (isSLASH(path[0]) && isSLASH(path[1])) {
8ac9c18d 1584 start = path + 2;
52fcf7ee
GS		 1585 *tmpstart++ = path[0];
1586 *tmpstart++ = path[1];
bb27e7b6
JH		 1587 SKIP_SLASHES(start);
1588 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
8ac9c18d 1589 if (*start) {
bb27e7b6
JH		 1590 *tmpstart++ = *start++;
1591 SKIP_SLASHES(start);
1592 COPY_NONSLASHES(tmpstart,start); /* copy share name */
8ac9c18d
GS		 1593 }
1594 }
8ac9c18d 1595 *tmpstart = '\0';
bb27e7b6
JH		 1596 while (*start) {
1597 /* copy initial slash, if any */
1598 if (isSLASH(*start)) {
1599 *tmpstart++ = *start++;
1600 *tmpstart = '\0';
1601 SKIP_SLASHES(start);
1602 }
1603
1604 /* FindFirstFile() expands "." and "..", so we need to pass
1605 * those through unmolested */
1606 if (*start == '.'
1607 && (!start[1] || isSLASH(start[1])
1608 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1609 {
1610 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1611 *tmpstart = '\0';
1612 continue;
1613 }
1614
1615 /* if this is the end, bust outta here */
1616 if (!*start)
1617 break;
8ac9c18d 1618
bb27e7b6
JH		 1619 /* now we're at a non-slash; walk up to next slash */
1620 while (*start && !isSLASH(*start))
8ac9c18d 1621 ++start;
8ac9c18d
GS		 1622
1623 /* stop and find full name of component */
bb27e7b6 1624 sep = *start;
8ac9c18d
GS		 1625 *start = '\0';
1626 fhand = FindFirstFile(path,&fdata);
bb27e7b6 1627 *start = sep;
8ac9c18d 1628 if (fhand != INVALID_HANDLE_VALUE) {
bb27e7b6
JH		 1629 STRLEN len = strlen(fdata.cFileName);
1630 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1631 strcpy(tmpstart, fdata.cFileName);
1632 tmpstart += len;
1633 FindClose(fhand);
1634 }
1635 else {
1636 FindClose(fhand);
1637 errno = ERANGE;
4e205ed6 1638 return NULL;
bb27e7b6 1639 }
8ac9c18d
GS		 1640 }
1641 else {
1642 /* failed a step, just return without side effects */
bf49b057 1643 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
bb27e7b6 1644 errno = EINVAL;
4e205ed6 1645 return NULL;
8ac9c18d
GS		 1646 }
1647 }
1648 strcpy(path,tmpbuf);
1649 return path;
1650}
1651
aa2b96ec 1652static void
0934c9d9 1653out_of_memory(void)
aa2b96ec 1654{
ae6198af
JD		 1655 if (PL_curinterp) {
1656 dTHX;
1657 /* Can't use PerlIO to write as it allocates memory */
1658 PerlLIO_write(PerlIO_fileno(Perl_error_log),
1659 PL_no_mem, strlen(PL_no_mem));
1660 my_exit(1);
1661 }
1662 exit(1);
aa2b96ec
JD		 1663}
1664
1665/* The win32_ansipath() function takes a Unicode filename and converts it
1666 * into the current Windows codepage. If some characters cannot be mapped,
1667 * then it will convert the short name instead.
1668 *
1669 * The buffer to the ansi pathname must be freed with win32_free() when it
1670 * it no longer needed.
1671 *
1672 * The argument to win32_ansipath() must exist before this function is
1673 * called; otherwise there is no way to determine the short path name.
1674 *
1675 * Ideas for future refinement:
1676 * - Only convert those segments of the path that are not in the current
1677 * codepage, but leave the other segments in their long form.
1678 * - If the resulting name is longer than MAX_PATH, start converting
1679 * additional path segments into short names until the full name
1680 * is shorter than MAX_PATH. Shorten the filename part last!
1681 */
1682DllExport char *
1683win32_ansipath(const WCHAR *widename)
1684{
1685 char *name;
1686 BOOL use_default = FALSE;
1687 size_t widelen = wcslen(widename)+1;
1688 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1689 NULL, 0, NULL, NULL);
1690 name = win32_malloc(len);
1691 if (!name)
1692 out_of_memory();
1693
1694 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1695 name, len, NULL, &use_default);
1696 if (use_default) {
aa2b96ec 1697 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
ae6198af
JD		 1698 if (shortlen) {
1699 WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1700 if (!shortname)
1701 out_of_memory();
1702 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1703
1704 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1705 NULL, 0, NULL, NULL);
1706 name = win32_realloc(name, len);
1707 if (!name)
1708 out_of_memory();
1709 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1710 name, len, NULL, NULL);
1711 win32_free(shortname);
1712 }
aa2b96ec
JD		 1713 }
1714 return name;
1715}
1716
0551aaa8
GS		 1717DllExport char *
1718win32_getenv(const char *name)
1719{
acfe0abc 1720 dTHX;
0551aaa8 1721 DWORD needlen;
4e205ed6 1722 SV *curitem = NULL;
58a50f62 1723
8c56068e 1724 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1725 if (needlen != 0) {
51371543 1726 curitem = sv_2mortal(newSVpvn("", 0));
8c56068e
JD		 1727 do {
1728 SvGROW(curitem, needlen+1);
1729 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1730 needlen);
1731 } while (needlen >= SvLEN(curitem));
1732 SvCUR_set(curitem, needlen);
0551aaa8 1733 }
c934e9d4 1734 else {
7a5f8e82 1735 /* allow any environment variables that begin with 'PERL'
c934e9d4 1736 to be stored in the registry */
51371543 1737 if (strncmp(name, "PERL", 4) == 0)
c5be433b 1738 (void)get_regstr(name, &curitem);
c69f6586 1739 }
51371543
GS		 1740 if (curitem && SvCUR(curitem))
1741 return SvPVX(curitem);
58a50f62 1742
4e205ed6 1743 return NULL;
0551aaa8
GS		 1744}
1745
ac5c734f
GS		 1746DllExport int
1747win32_putenv(const char *name)
1748{
acfe0abc 1749 dTHX;
ac5c734f
GS		 1750 char* curitem;
1751 char* val;
b813a9c7 1752 int relval = -1;
51371543 1753
73c4f7a1 1754 if (name) {
8c56068e
JD		 1755 Newx(curitem,strlen(name)+1,char);
1756 strcpy(curitem, name);
1757 val = strchr(curitem, '=');
1758 if (val) {
1759 /* The sane way to deal with the environment.
1760 * Has these advantages over putenv() & co.:
1761 * * enables us to store a truly empty value in the
1762 * environment (like in UNIX).
1763 * * we don't have to deal with RTL globals, bugs and leaks.
1764 * * Much faster.
1765 * Why you may want to enable USE_WIN32_RTL_ENV:
1766 * * environ[] and RTL functions will not reflect changes,
1767 * which might be an issue if extensions want to access
1768 * the env. via RTL. This cuts both ways, since RTL will
1769 * not see changes made by extensions that call the Win32
1770 * functions directly, either.
1771 * GSAR 97-06-07
1772 */
1773 *val++ = '\0';
1774 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1775 relval = 0;
1776 }
1777 Safefree(curitem);
ac5c734f
GS		 1778 }
1779 return relval;
1780}
1781
d55594ae 1782static long
2d7a9237 1783filetime_to_clock(PFILETIME ft)
d55594ae 1784{
7766f137
GS		 1785 __int64 qw = ft->dwHighDateTime;
1786 qw <<= 32;
1787 qw |= ft->dwLowDateTime;
1788 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1789 return (long) qw;
d55594ae
GS		 1790}
1791
f3986ebb
GS		 1792DllExport int
1793win32_times(struct tms *timebuf)
0a753a76 1794{
d55594ae
GS		 1795 FILETIME user;
1796 FILETIME kernel;
1797 FILETIME dummy;
50ee8e5e 1798 clock_t process_time_so_far = clock();
3fadfdf1 1799 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
d55594ae 1800 &kernel,&user)) {
2d7a9237
GS		 1801 timebuf->tms_utime = filetime_to_clock(&user);
1802 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS		 1803 timebuf->tms_cutime = 0;
1804 timebuf->tms_cstime = 0;
3fadfdf1 1805 } else {
d55594ae 1806 /* That failed - e.g. Win95 fallback to clock() */
50ee8e5e 1807 timebuf->tms_utime = process_time_so_far;
d55594ae
GS		 1808 timebuf->tms_stime = 0;
1809 timebuf->tms_cutime = 0;
1810 timebuf->tms_cstime = 0;
1811 }
50ee8e5e 1812 return process_time_so_far;
0a753a76 1813}
1814
9c51cf4c 1815/* fix utime() so it works on directories in NT */
ad0751ec
GS		 1816static BOOL
1817filetime_from_time(PFILETIME pFileTime, time_t Time)
1818{
9c51cf4c 1819 struct tm *pTM = localtime(&Time);
ad0751ec 1820 SYSTEMTIME SystemTime;
9c51cf4c 1821 FILETIME LocalTime;
ad0751ec
GS		 1822
1823 if (pTM == NULL)
1824 return FALSE;
1825
1826 SystemTime.wYear = pTM->tm_year + 1900;
1827 SystemTime.wMonth = pTM->tm_mon + 1;
1828 SystemTime.wDay = pTM->tm_mday;
1829 SystemTime.wHour = pTM->tm_hour;
1830 SystemTime.wMinute = pTM->tm_min;
1831 SystemTime.wSecond = pTM->tm_sec;
1832 SystemTime.wMilliseconds = 0;
1833
9c51cf4c
GS		 1834 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1835 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS		 1836}
1837
1838DllExport int
7766f137
GS		 1839win32_unlink(const char *filename)
1840{
acfe0abc 1841 dTHX;
7766f137
GS		 1842 int ret;
1843 DWORD attrs;
1844
8c56068e
JD		 1845 filename = PerlDir_mapA(filename);
1846 attrs = GetFileAttributesA(filename);
1847 if (attrs == 0xFFFFFFFF) {
1848 errno = ENOENT;
1849 return -1;
7766f137 1850 }
8c56068e
JD		 1851 if (attrs & FILE_ATTRIBUTE_READONLY) {
1852 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1853 ret = unlink(filename);
1854 if (ret == -1)
1855 (void)SetFileAttributesA(filename, attrs);
7766f137 1856 }
8c56068e
JD		 1857 else
1858 ret = unlink(filename);
7766f137
GS		 1859 return ret;
1860}
1861
1862DllExport int
3b405fc5 1863win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1864{
acfe0abc 1865 dTHX;
ad0751ec
GS		 1866 HANDLE handle;
1867 FILETIME ftCreate;
1868 FILETIME ftAccess;
1869 FILETIME ftWrite;
1870 struct utimbuf TimeBuffer;
7fac1903 1871 int rc;
8c56068e
JD		 1872
1873 filename = PerlDir_mapA(filename);
1874 rc = utime(filename, times);
1875
ad0751ec
GS		 1876 /* EACCES: path specifies directory or readonly file */
1877 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1878 return rc;
1879
1880 if (times == NULL) {
1881 times = &TimeBuffer;
1882 time(&times->actime);
1883 times->modtime = times->actime;
1884 }
1885
1886 /* This will (and should) still fail on readonly files */
8c56068e
JD		 1887 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1888 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1889 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
ad0751ec
GS		 1890 if (handle == INVALID_HANDLE_VALUE)
1891 return rc;
1892
1893 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1894 filetime_from_time(&ftAccess, times->actime) &&
1895 filetime_from_time(&ftWrite, times->modtime) &&
1896 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1897 {
1898 rc = 0;
1899 }
1900
1901 CloseHandle(handle);
1902 return rc;
1903}
1904
6e3b076d
JH		 1905typedef union {
1906 unsigned __int64 ft_i64;
1907 FILETIME ft_val;
1908} FT_t;
1909
1910#ifdef __GNUC__
1911#define Const64(x) x##LL
1912#else
1913#define Const64(x) x##i64
1914#endif
1915/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1916#define EPOCH_BIAS Const64(116444736000000000)
1917
57ab3dfe
GS		 1918/* NOTE: This does not compute the timezone info (doing so can be expensive,
1919 * and appears to be unsupported even by glibc) */
1920DllExport int
1921win32_gettimeofday(struct timeval *tp, void *not_used)
1922{
6e3b076d
JH		 1923 FT_t ft;
1924
1925 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1926 GetSystemTimeAsFileTime(&ft.ft_val);
1927
1928 /* seconds since epoch */
1929 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1930
1931 /* microseconds remaining */
1932 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1933
1934 return 0;
57ab3dfe
GS		 1935}
1936
2d7a9237 1937DllExport int
b2af26b1
GS		 1938win32_uname(struct utsname *name)
1939{
1940 struct hostent *hep;
1941 STRLEN nodemax = sizeof(name->nodename)-1;
b2af26b1 1942
aeecf691
JD		 1943 /* sysname */
1944 switch (g_osver.dwPlatformId) {
1945 case VER_PLATFORM_WIN32_WINDOWS:
1946 strcpy(name->sysname, "Windows");
1947 break;
1948 case VER_PLATFORM_WIN32_NT:
1949 strcpy(name->sysname, "Windows NT");
1950 break;
1951 case VER_PLATFORM_WIN32s:
1952 strcpy(name->sysname, "Win32s");
1953 break;
1954 default:
1955 strcpy(name->sysname, "Win32 Unknown");
1956 break;
b2af26b1 1957 }
aeecf691
JD		 1958
1959 /* release */
1960 sprintf(name->release, "%d.%d",
1961 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1962
1963 /* version */
1964 sprintf(name->version, "Build %d",
1965 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1966 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1967 if (g_osver.szCSDVersion[0]) {
1968 char *buf = name->version + strlen(name->version);
1969 sprintf(buf, " (%s)", g_osver.szCSDVersion);
b2af26b1
GS		 1970 }
1971
1972 /* nodename */
1973 hep = win32_gethostbyname("localhost");
1974 if (hep) {
1975 STRLEN len = strlen(hep->h_name);
1976 if (len <= nodemax) {
1977 strcpy(name->nodename, hep->h_name);
1978 }
1979 else {
1980 strncpy(name->nodename, hep->h_name, nodemax);
1981 name->nodename[nodemax] = '\0';
1982 }
1983 }
1984 else {
1985 DWORD sz = nodemax;
1986 if (!GetComputerName(name->nodename, &sz))
1987 *name->nodename = '\0';
1988 }
1989
1990 /* machine (architecture) */
1991 {
1992 SYSTEM_INFO info;
fe537c65 1993 DWORD procarch;
b2af26b1
GS		 1994 char *arch;
1995 GetSystemInfo(&info);
a6c40364 1996
6f24f39d
JK		 1997#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1998 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
fe537c65 1999 procarch = info.u.s.wProcessorArchitecture;
a6c40364 2000#else
fe537c65 2001 procarch = info.wProcessorArchitecture;
a6c40364 2002#endif
fe537c65 2003 switch (procarch) {
b2af26b1
GS		 2004 case PROCESSOR_ARCHITECTURE_INTEL:
2005 arch = "x86"; break;
2006 case PROCESSOR_ARCHITECTURE_MIPS:
2007 arch = "mips"; break;
2008 case PROCESSOR_ARCHITECTURE_ALPHA:
2009 arch = "alpha"; break;
2010 case PROCESSOR_ARCHITECTURE_PPC:
2011 arch = "ppc"; break;
fe537c65
GS		 2012#ifdef PROCESSOR_ARCHITECTURE_SHX
2013 case PROCESSOR_ARCHITECTURE_SHX:
2014 arch = "shx"; break;
2015#endif
2016#ifdef PROCESSOR_ARCHITECTURE_ARM
2017 case PROCESSOR_ARCHITECTURE_ARM:
2018 arch = "arm"; break;
2019#endif
2020#ifdef PROCESSOR_ARCHITECTURE_IA64
2021 case PROCESSOR_ARCHITECTURE_IA64:
2022 arch = "ia64"; break;
2023#endif
2024#ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2025 case PROCESSOR_ARCHITECTURE_ALPHA64:
2026 arch = "alpha64"; break;
2027#endif
2028#ifdef PROCESSOR_ARCHITECTURE_MSIL
2029 case PROCESSOR_ARCHITECTURE_MSIL:
2030 arch = "msil"; break;
2031#endif
2032#ifdef PROCESSOR_ARCHITECTURE_AMD64
2033 case PROCESSOR_ARCHITECTURE_AMD64:
2034 arch = "amd64"; break;
2035#endif
2036#ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2037 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2038 arch = "ia32-64"; break;
2039#endif
2040#ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2041 case PROCESSOR_ARCHITECTURE_UNKNOWN:
b2af26b1 2042 arch = "unknown"; break;
fe537c65
GS		 2043#endif
2044 default:
2045 sprintf(name->machine, "unknown(0x%x)", procarch);
2046 arch = name->machine;
2047 break;
b2af26b1 2048 }
fe537c65
GS		 2049 if (name->machine != arch)
2050 strcpy(name->machine, arch);
b2af26b1
GS		 2051 }
2052 return 0;
2053}
2054
8fb3fcfb
NIS		 2055/* Timing related stuff */
2056
3fadfdf1
NIS		 2057int
2058do_raise(pTHX_ int sig)
2059{
2060 if (sig < SIG_SIZE) {
2061 Sighandler_t handler = w32_sighandler[sig];
2062 if (handler == SIG_IGN) {
2063 return 0;
2064 }
2065 else if (handler != SIG_DFL) {
2066 (*handler)(sig);
2067 return 0;
2068 }
2069 else {
2070 /* Choose correct default behaviour */
2071 switch (sig) {
2072#ifdef SIGCLD
2073 case SIGCLD:
2074#endif
2075#ifdef SIGCHLD
2076 case SIGCHLD:
2077#endif
2078 case 0:
2079 return 0;
2080 case SIGTERM:
2081 default:
2082 break;
2083 }
2084 }
2085 }
2086 /* Tell caller to exit thread/process as approriate */
2087 return 1;
2088}
2089
2090void
2091sig_terminate(pTHX_ int sig)
2092{
2093 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2094 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2095 thread
2096 */
2097 exit(sig);
2098}
2099
8fb3fcfb
NIS		 2100DllExport int
2101win32_async_check(pTHX)
2102{
2103 MSG msg;
aeecf691
JD		 2104 HWND hwnd = w32_message_hwnd;
2105
099b16d3
RM		 2106 /* Reset w32_poll_count before doing anything else, incase we dispatch
2107 * messages that end up calling back into perl */
aeecf691
JD		 2108 w32_poll_count = 0;
2109
099b16d3
RM		 2110 if (hwnd != INVALID_HANDLE_VALUE) {
2111 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2112 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2113 */
2114 if (hwnd == NULL)
2115 hwnd = (HWND)-1;
2116
2117 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2118 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2119 {
2120 /* re-post a WM_QUIT message (we'll mark it as read later) */
2121 if(msg.message == WM_QUIT) {
2122 PostQuitMessage((int)msg.wParam);
2123 break;
2124 }
8fb3fcfb 2125
099b16d3
RM		 2126 if(!CallMsgFilter(&msg, MSGF_USER))
2127 {
2128 TranslateMessage(&msg);
2129 DispatchMessage(&msg);
aeecf691 2130 }
099b16d3 2131 }
8fb3fcfb
NIS		 2132 }
2133
099b16d3
RM		 2134 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2135 * This is necessary when we are being called by win32_msgwait() to
2136 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2137 * message over and over. An example how this can happen is when
2138 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2139 * is generating messages before the process terminated.
2140 */
4386d69d 2141 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
099b16d3 2142
7e5f34c0 2143 /* Above or other stuff may have set a signal flag */
099b16d3
RM		 2144 if (PL_sig_pending)
2145 despatch_signals();
2146
aeecf691 2147 return 1;
8fb3fcfb
NIS		 2148}
2149
089197fa
GS		 2150/* This function will not return until the timeout has elapsed, or until
2151 * one of the handles is ready. */
8fb3fcfb
NIS		 2152DllExport DWORD
2153win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2154{
2155 /* We may need several goes at this - so compute when we stop */
2156 DWORD ticks = 0;
2157 if (timeout != INFINITE) {
2158 ticks = GetTickCount();
2159 timeout += ticks;
2160 }
2161 while (1) {
039698bb 2162 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
8fb3fcfb
NIS		 2163 if (resultp)
2164 *resultp = result;
2165 if (result == WAIT_TIMEOUT) {
3fadfdf1
NIS		 2166 /* Ran out of time - explicit return of zero to avoid -ve if we
2167 have scheduling issues
2168 */
8fb3fcfb
NIS		 2169 return 0;
2170 }
2171 if (timeout != INFINITE) {
2172 ticks = GetTickCount();
2173 }
2174 if (result == WAIT_OBJECT_0 + count) {
2175 /* Message has arrived - check it */
089197fa 2176 (void)win32_async_check(aTHX);
8fb3fcfb
NIS		 2177 }
2178 else {
2179 /* Not timeout or message - one of handles is ready */
2180 break;
2181 }
2182 }
2183 /* compute time left to wait */
2184 ticks = timeout - ticks;
2185 /* If we are past the end say zero */
2186 return (ticks > 0) ? ticks : 0;
2187}
2188
932b7487
RC		 2189int
2190win32_internal_wait(int *status, DWORD timeout)
2191{
2192 /* XXX this wait emulation only knows about processes
2193 * spawned via win32_spawnvp(P_NOWAIT, ...).
2194 */
2195 dTHX;
2196 int i, retval;
2197 DWORD exitcode, waitcode;
2198
2199#ifdef USE_ITHREADS
2200 if (w32_num_pseudo_children) {
8fb3fcfb
NIS		 2201 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2202 timeout, &waitcode);
932b7487
RC		 2203 /* Time out here if there are no other children to wait for. */
2204 if (waitcode == WAIT_TIMEOUT) {
2205 if (!w32_num_children) {
2206 return 0;
2207 }
2208 }
2209 else if (waitcode != WAIT_FAILED) {
2210 if (waitcode >= WAIT_ABANDONED_0
2211 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2212 i = waitcode - WAIT_ABANDONED_0;
2213 else
2214 i = waitcode - WAIT_OBJECT_0;
2215 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2216 *status = (int)((exitcode & 0xff) << 8);
2217 retval = (int)w32_pseudo_child_pids[i];
2218 remove_dead_pseudo_process(i);
2219 return -retval;
2220 }
2221 }
2222 }
2223#endif
2224
2225 if (!w32_num_children) {
2226 errno = ECHILD;
2227 return -1;
2228 }
2229
2230 /* if a child exists, wait for it to die */
8fb3fcfb 2231 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
932b7487
RC		 2232 if (waitcode == WAIT_TIMEOUT) {
2233 return 0;
2234 }
2235 if (waitcode != WAIT_FAILED) {
2236 if (waitcode >= WAIT_ABANDONED_0
2237 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2238 i = waitcode - WAIT_ABANDONED_0;
2239 else
2240 i = waitcode - WAIT_OBJECT_0;
2241 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2242 *status = (int)((exitcode & 0xff) << 8);
2243 retval = (int)w32_child_pids[i];
2244 remove_dead_process(i);
2245 return retval;
2246 }
2247 }
2248
932b7487
RC		 2249 errno = GetLastError();
2250 return -1;
2251}
2252
b2af26b1 2253DllExport int
f55ee38a
GS		 2254win32_waitpid(int pid, int *status, int flags)
2255{
acfe0abc 2256 dTHX;
922b1888 2257 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
0aaad0ff 2258 int retval = -1;
c66b022d 2259 long child;
7766f137 2260 if (pid == -1) /* XXX threadid == 1 ? */
932b7487 2261 return win32_internal_wait(status, timeout);
7766f137
GS		 2262#ifdef USE_ITHREADS
2263 else if (pid < 0) {
c66b022d 2264 child = find_pseudo_pid(-pid);
7766f137
GS		 2265 if (child >= 0) {
2266 HANDLE hThread = w32_pseudo_child_handles[child];
8fb3fcfb
NIS		 2267 DWORD waitcode;
2268 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2f67576d
BC		 2269 if (waitcode == WAIT_TIMEOUT) {
2270 return 0;
2271 }
8fb3fcfb 2272 else if (waitcode == WAIT_OBJECT_0) {
7766f137
GS		 2273 if (GetExitCodeThread(hThread, &waitcode)) {
2274 *status = (int)((waitcode & 0xff) << 8);
2275 retval = (int)w32_pseudo_child_pids[child];
2276 remove_dead_pseudo_process(child);
68a29c53 2277 return -retval;
7766f137
GS		 2278 }
2279 }
2280 else
2281 errno = ECHILD;
2282 }
922b1888
GS		 2283 else if (IsWin95()) {
2284 pid = -pid;
2285 goto alien_process;
2286 }
7766f137
GS		 2287 }
2288#endif
f55ee38a 2289 else {
922b1888
GS		 2290 HANDLE hProcess;
2291 DWORD waitcode;
c66b022d 2292 child = find_pid(pid);
0aaad0ff 2293 if (child >= 0) {
922b1888 2294 hProcess = w32_child_handles[child];
8fb3fcfb 2295 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
a7867d0a
GS		 2296 if (waitcode == WAIT_TIMEOUT) {
2297 return 0;
2298 }
8fb3fcfb 2299 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 2300 if (GetExitCodeProcess(hProcess, &waitcode)) {
2301 *status = (int)((waitcode & 0xff) << 8);
2302 retval = (int)w32_child_pids[child];
2303 remove_dead_process(child);
2304 return retval;
2305 }
a7867d0a 2306 }
0aaad0ff
GS		 2307 else
2308 errno = ECHILD;
2309 }
2310 else {
922b1888
GS		 2311alien_process:
2312 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2313 (IsWin95() ? -pid : pid));
2314 if (hProcess) {
8fb3fcfb 2315 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
922b1888 2316 if (waitcode == WAIT_TIMEOUT) {
48db714f 2317 CloseHandle(hProcess);
922b1888
GS		 2318 return 0;
2319 }
8fb3fcfb 2320 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 2321 if (GetExitCodeProcess(hProcess, &waitcode)) {
2322 *status = (int)((waitcode & 0xff) << 8);
2323 CloseHandle(hProcess);
2324 return pid;
2325 }
2326 }
2327 CloseHandle(hProcess);
2328 }
2329 else
2330 errno = ECHILD;
0aaad0ff 2331 }
f55ee38a 2332 }
3fadfdf1 2333 return retval >= 0 ? pid : retval;
f55ee38a
GS		 2334}
2335
2336DllExport int
2d7a9237
GS		 2337win32_wait(int *status)
2338{
932b7487 2339 return win32_internal_wait(status, INFINITE);
2d7a9237 2340}
d55594ae 2341
8fb3fcfb
NIS		 2342DllExport unsigned int
2343win32_sleep(unsigned int t)
d55594ae 2344{
acfe0abc 2345 dTHX;
8fb3fcfb
NIS		 2346 /* Win32 times are in ms so *1000 in and /1000 out */
2347 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
d55594ae
GS		 2348}
2349
f3986ebb
GS		 2350DllExport unsigned int
2351win32_alarm(unsigned int sec)
0a753a76 2352{
3fadfdf1 2353 /*
d55594ae 2354 * the 'obvious' implentation is SetTimer() with a callback
3fadfdf1
NIS		 2355 * which does whatever receiving SIGALRM would do
2356 * we cannot use SIGALRM even via raise() as it is not
d55594ae 2357 * one of the supported codes in <signal.h>
3fadfdf1 2358 */
acfe0abc 2359 dTHX;
aeecf691
JD		 2360
2361 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2362 w32_message_hwnd = win32_create_message_window();
2363
8fb3fcfb 2364 if (sec) {
aeecf691
JD		 2365 if (w32_message_hwnd == NULL)
2366 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2367 else {
2368 w32_timerid = 1;
2369 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2370 }
8fb3fcfb
NIS		 2371 }
2372 else {
2373 if (w32_timerid) {
aeecf691
JD		 2374 KillTimer(w32_message_hwnd, w32_timerid);
2375 w32_timerid = 0;
8fb3fcfb 2376 }
3fadfdf1 2377 }
afe91769 2378 return 0;
0a753a76 2379}
2380
26618a56 2381#ifdef HAVE_DES_FCRYPT
2d77217b 2382extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
ff95b63e 2383#endif
26618a56
GS		 2384
2385DllExport char *
2386win32_crypt(const char *txt, const char *salt)
2387{
acfe0abc 2388 dTHX;
ff95b63e 2389#ifdef HAVE_DES_FCRYPT
3352bfcb 2390 return des_fcrypt(txt, salt, w32_crypt_buffer);
ff95b63e 2391#else
25dbdbbc 2392 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
4e205ed6 2393 return NULL;
ff95b63e 2394#endif
26618a56 2395}
26618a56 2396
9e5f57de 2397#ifdef USE_FIXED_OSFHANDLE
390b85e7
GS		 2398
2399#define FOPEN 0x01 /* file handle open */
b181b6fb 2400#define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
390b85e7
GS		 2401#define FAPPEND 0x20 /* file handle opened O_APPEND */
2402#define FDEV 0x40 /* file handle refers to device */
2403#define FTEXT 0x80 /* file handle is in text mode */
2404
390b85e7 2405/***
c623ac67 2406*int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
390b85e7
GS		 2407*
2408*Purpose:
2409* This function allocates a free C Runtime file handle and associates
2410* it with the Win32 HANDLE specified by the first parameter. This is a
9e5f57de
GS		 2411* temperary fix for WIN95's brain damage GetFileType() error on socket
2412* we just bypass that call for socket
2413*
2414* This works with MSVC++ 4.0+ or GCC/Mingw32
390b85e7
GS		 2415*
2416*Entry:
c623ac67 2417* intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
390b85e7
GS		 2418* int flags - flags to associate with C Runtime file handle.
2419*
2420*Exit:
2421* returns index of entry in fh, if successful
2422* return -1, if no free entry is found
2423*
2424*Exceptions:
2425*
2426*******************************************************************************/
2427
9e5f57de
GS		 2428/*
2429 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2430 * this lets sockets work on Win9X with GCC and should fix the problems
2431 * with perl95.exe
2432 * -- BKS, 1-23-2000
2433*/
2434
9e5f57de
GS		 2435/* create an ioinfo entry, kill its handle, and steal the entry */
2436
b181b6fb
GS		 2437static int
2438_alloc_osfhnd(void)
9e5f57de
GS		 2439{
2440 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
c623ac67 2441 int fh = _open_osfhandle((intptr_t)hF, 0);
9e5f57de
GS		 2442 CloseHandle(hF);
2443 if (fh == -1)
2444 return fh;
2445 EnterCriticalSection(&(_pioinfo(fh)->lock));
2446 return fh;
2447}
2448
390b85e7 2449static int
c623ac67 2450my_open_osfhandle(intptr_t osfhandle, int flags)
390b85e7
GS		 2451{
2452 int fh;
2453 char fileflags; /* _osfile flags */
2454
2455 /* copy relevant flags from second parameter */
2456 fileflags = FDEV;
2457
9404a519 2458 if (flags & O_APPEND)
390b85e7
GS		 2459 fileflags |= FAPPEND;
2460
9404a519 2461 if (flags & O_TEXT)
390b85e7
GS		 2462 fileflags |= FTEXT;
2463
b181b6fb
GS		 2464 if (flags & O_NOINHERIT)
2465 fileflags |= FNOINHERIT;
2466
390b85e7 2467 /* attempt to allocate a C Runtime file handle */
9404a519 2468 if ((fh = _alloc_osfhnd()) == -1) {
390b85e7
GS		 2469 errno = EMFILE; /* too many open files */
2470 _doserrno = 0L; /* not an OS error */
2471 return -1; /* return error to caller */
2472 }
2473
2474 /* the file is open. now, set the info in _osfhnd array */
2475 _set_osfhnd(fh, osfhandle);
2476
2477 fileflags |= FOPEN; /* mark as open */
2478
390b85e7 2479 _osfile(fh) = fileflags; /* set osfile entry */
dd8f4818 2480 LeaveCriticalSection(&_pioinfo(fh)->lock);
390b85e7
GS		 2481
2482 return fh; /* return handle */
2483}
2484
f3986ebb 2485#endif /* USE_FIXED_OSFHANDLE */
390b85e7
GS		 2486
2487/* simulate flock by locking a range on the file */
2488
2489#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2490#define LK_LEN 0xffff0000
2491
f3986ebb
GS		 2492DllExport int
2493win32_flock(int fd, int oper)
390b85e7
GS		 2494{
2495 OVERLAPPED o;
2496 int i = -1;
2497 HANDLE fh;
2498
f3986ebb 2499 if (!IsWinNT()) {
acfe0abc 2500 dTHX;
4f63d024 2501 Perl_croak_nocontext("flock() unimplemented on this platform");
f3986ebb
GS		 2502 return -1;
2503 }
390b85e7
GS		 2504 fh = (HANDLE)_get_osfhandle(fd);
2505 memset(&o, 0, sizeof(o));
2506
2507 switch(oper) {
2508 case LOCK_SH: /* shared lock */
2509 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2510 break;
2511 case LOCK_EX: /* exclusive lock */
2512 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2513 break;
2514 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2515 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2516 break;
2517 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2518 LK_ERR(LockFileEx(fh,
2519 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2520 0, LK_LEN, 0, &o),i);
2521 break;
2522 case LOCK_UN: /* unlock lock */
2523 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2524 break;
2525 default: /* unknown */
2526 errno = EINVAL;
2527 break;
2528 }
2529 return i;
2530}
2531
2532#undef LK_ERR
2533#undef LK_LEN
2534
68dc0745 2535/*
2536 * redirected io subsystem for all XS modules
2537 *
2538 */
0a753a76 2539
68dc0745 2540DllExport int *
2541win32_errno(void)
0a753a76 2542{
390b85e7 2543 return (&errno);
0a753a76 2544}
2545
dcb2879a
GS		 2546DllExport char ***
2547win32_environ(void)
2548{
390b85e7 2549 return (&(_environ));
dcb2879a
GS		 2550}
2551
68dc0745 2552/* the rest are the remapped stdio routines */
2553DllExport FILE *
2554win32_stderr(void)
0a753a76 2555{
390b85e7 2556 return (stderr);
0a753a76 2557}
2558
68dc0745 2559DllExport FILE *
2560win32_stdin(void)
0a753a76 2561{
390b85e7 2562 return (stdin);
0a753a76 2563}
2564
68dc0745 2565DllExport FILE *
0934c9d9 2566win32_stdout(void)
0a753a76 2567{
390b85e7 2568 return (stdout);
0a753a76 2569}
2570
68dc0745 2571DllExport int
2572win32_ferror(FILE *fp)
0a753a76 2573{
390b85e7 2574 return (ferror(fp));
0a753a76 2575}
2576
2577
68dc0745 2578DllExport int
2579win32_feof(FILE *fp)
0a753a76 2580{
390b85e7 2581 return (feof(fp));
0a753a76 2582}
2583
68dc0745 2584/*
3fadfdf1 2585 * Since the errors returned by the socket error function
68dc0745 2586 * WSAGetLastError() are not known by the library routine strerror
2587 * we have to roll our own.
2588 */
0a753a76 2589
68dc0745 2590DllExport char *
3fadfdf1 2591win32_strerror(int e)
0a753a76 2592{
6f24f39d 2593#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
68dc0745 2594 extern int sys_nerr;
3e3baf6d 2595#endif
68dc0745 2596 DWORD source = 0;
0a753a76 2597
9404a519 2598 if (e < 0 || e > sys_nerr) {
acfe0abc 2599 dTHX;
9404a519 2600 if (e < 0)
68dc0745 2601 e = GetLastError();
0a753a76 2602
9404a519 2603 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
3352bfcb 2604 w32_strerror_buffer,
3fadfdf1 2605 sizeof(w32_strerror_buffer), NULL) == 0)
3352bfcb 2606 strcpy(w32_strerror_buffer, "Unknown Error");
0a753a76 2607
3352bfcb 2608 return w32_strerror_buffer;
68dc0745 2609 }
390b85e7 2610 return strerror(e);
0a753a76 2611}
2612
22fae026 2613DllExport void
c5be433b 2614win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM		 2615{
2616 DWORD dwLen;
2617 char *sMsg;
2618 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2619 |FORMAT_MESSAGE_IGNORE_INSERTS
2620 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2621 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 2622 /* strip trailing whitespace and period */
22fae026 2623 if (0 < dwLen) {
2ce77adf
GS		 2624 do {
2625 --dwLen; /* dwLen doesn't include trailing null */
2626 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM		 2627 if ('.' != sMsg[dwLen])
2628 dwLen++;
2ce77adf 2629 sMsg[dwLen] = '\0';
22fae026
TM		 2630 }
2631 if (0 == dwLen) {
c69f6586 2632 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS		 2633 if (sMsg)
2634 dwLen = sprintf(sMsg,
2635 "Unknown error #0x%lX (lookup 0x%lX)",
2636 dwErr, GetLastError());
2637 }
2638 if (sMsg) {
acfe0abc 2639 dTHX;
db7c17d7
GS		 2640 sv_setpvn((SV*)sv, sMsg, dwLen);
2641 LocalFree(sMsg);
22fae026 2642 }
22fae026
TM		 2643}
2644
68dc0745 2645DllExport int
2646win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2647{
68dc0745 2648 va_list marker;
2649 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2650
390b85e7 2651 return (vfprintf(fp, format, marker));
0a753a76 2652}
2653
68dc0745 2654DllExport int
2655win32_printf(const char *format, ...)
0a753a76 2656{
68dc0745 2657 va_list marker;
2658 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2659
390b85e7 2660 return (vprintf(format, marker));
0a753a76 2661}
2662
68dc0745 2663DllExport int
2664win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2665{
390b85e7 2666 return (vfprintf(fp, format, args));
0a753a76 2667}
2668
96e4d5b1 2669DllExport int
2670win32_vprintf(const char *format, va_list args)
2671{
390b85e7 2672 return (vprintf(format, args));
96e4d5b1 2673}
2674
68dc0745 2675DllExport size_t
2676win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2677{
390b85e7 2678 return fread(buf, size, count, fp);
0a753a76 2679}
2680
68dc0745 2681DllExport size_t
2682win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2683{
390b85e7 2684 return fwrite(buf, size, count, fp);
0a753a76 2685}
2686
7fac1903
GS		 2687#define MODE_SIZE 10
2688
68dc0745 2689DllExport FILE *
2690win32_fopen(const char *filename, const char *mode)
0a753a76 2691{
acfe0abc 2692 dTHX;
1c5905c2 2693 FILE *f;
3fadfdf1 2694
c5be433b
GS		 2695 if (!*filename)
2696 return NULL;
2697
68dc0745 2698 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS		 2699 filename = "NUL";
2700
8c56068e 2701 f = fopen(PerlDir_mapA(filename), mode);
1c5905c2
GS		 2702 /* avoid buffering headaches for child processes */
2703 if (f && *mode == 'a')
2704 win32_fseek(f, 0, SEEK_END);
2705 return f;
0a753a76 2706}
2707
f3986ebb
GS		 2708#ifndef USE_SOCKETS_AS_HANDLES
2709#undef fdopen
2710#define fdopen my_fdopen
2711#endif
2712
68dc0745 2713DllExport FILE *
7fac1903 2714win32_fdopen(int handle, const char *mode)
0a753a76 2715{
acfe0abc 2716 dTHX;
1c5905c2 2717 FILE *f;
8c56068e 2718 f = fdopen(handle, (char *) mode);
1c5905c2
GS		 2719 /* avoid buffering headaches for child processes */
2720 if (f && *mode == 'a')
2721 win32_fseek(f, 0, SEEK_END);
2722 return f;
0a753a76 2723}
2724
68dc0745 2725DllExport FILE *
7fac1903 2726win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2727{
acfe0abc 2728 dTHX;
68dc0745 2729 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 2730 path = "NUL";
2731
7766f137 2732 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76 2733}
2734
68dc0745 2735DllExport int
2736win32_fclose(FILE *pf)
0a753a76 2737{
f3986ebb 2738 return my_fclose(pf); /* defined in win32sck.c */
0a753a76 2739}
2740
68dc0745 2741DllExport int
2742win32_fputs(const char *s,FILE *pf)
0a753a76 2743{
390b85e7 2744 return fputs(s, pf);
0a753a76 2745}
2746
68dc0745 2747DllExport int
2748win32_fputc(int c,FILE *pf)
0a753a76 2749{
390b85e7 2750 return fputc(c,pf);
0a753a76 2751}
2752
68dc0745 2753DllExport int
2754win32_ungetc(int c,FILE *pf)
0a753a76 2755{
390b85e7 2756 return ungetc(c,pf);
0a753a76 2757}
2758
68dc0745 2759DllExport int
2760win32_getc(FILE *pf)
0a753a76 2761{
390b85e7 2762 return getc(pf);
0a753a76 2763}
2764
68dc0745 2765DllExport int
2766win32_fileno(FILE *pf)
0a753a76 2767{
390b85e7 2768 return fileno(pf);
0a753a76 2769}
2770
68dc0745 2771DllExport void
2772win32_clearerr(FILE *pf)
0a753a76 2773{
390b85e7 2774 clearerr(pf);
68dc0745 2775 return;
0a753a76 2776}
2777
68dc0745 2778DllExport int
2779win32_fflush(FILE *pf)
0a753a76 2780{
390b85e7 2781 return fflush(pf);
0a753a76 2782}
2783
c623ac67 2784DllExport Off_t
68dc0745 2785win32_ftell(FILE *pf)
0a753a76 2786{
c623ac67 2787#if defined(WIN64) || defined(USE_LARGE_FILES)
56460430 2788#if defined(__BORLANDC__) /* buk */
a810272a
NS		 2789 return win32_tell( fileno( pf ) );
2790#else
c623ac67
GS		 2791 fpos_t pos;
2792 if (fgetpos(pf, &pos))
2793 return -1;
2794 return (Off_t)pos;
a810272a 2795#endif
c623ac67 2796#else
390b85e7 2797 return ftell(pf);
c623ac67 2798#endif
0a753a76 2799}
2800
68dc0745 2801DllExport int
c623ac67 2802win32_fseek(FILE *pf, Off_t offset,int origin)
0a753a76 2803{
c623ac67 2804#if defined(WIN64) || defined(USE_LARGE_FILES)
a810272a
NS		 2805#if defined(__BORLANDC__) /* buk */
2806 return win32_lseek(
2807 fileno(pf),
2808 offset,
2809 origin
2810 );
2811#else
c623ac67
GS		 2812 fpos_t pos;
2813 switch (origin) {
2814 case SEEK_CUR:
2815 if (fgetpos(pf, &pos))
2816 return -1;
2817 offset += pos;
2818 break;
2819 case SEEK_END:
2820 fseek(pf, 0, SEEK_END);
2821 pos = _telli64(fileno(pf));
2822 offset += pos;
2823 break;
2824 case SEEK_SET:
2825 break;
2826 default:
2827 errno = EINVAL;
2828 return -1;
2829 }
2830 return fsetpos(pf, &offset);
a810272a 2831#endif
c623ac67 2832#else
8859a7a0 2833 return fseek(pf, (long)offset, origin);
c623ac67 2834#endif
0a753a76 2835}
2836
68dc0745 2837DllExport int
2838win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2839{
a810272a
NS		 2840#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2841 if( win32_tell(fileno(pf)) == -1L ) {
2842 errno = EBADF;
2843 return -1;
2844 }
2845 return 0;
2846#else
390b85e7 2847 return fgetpos(pf, p);
a810272a 2848#endif
0a753a76 2849}
2850
68dc0745 2851DllExport int
2852win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2853{
a810272a
NS		 2854#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2855 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2856#else
390b85e7 2857 return fsetpos(pf, p);
a810272a 2858#endif
0a753a76 2859}
2860
68dc0745 2861DllExport void
2862win32_rewind(FILE *pf)
0a753a76 2863{
390b85e7 2864 rewind(pf);
68dc0745 2865 return;
0a753a76 2866}
2867
2941a2e1
JH		 2868DllExport int
2869win32_tmpfd(void)
0a753a76 2870{
b3122bc4
JH		 2871 dTHX;
2872 char prefix[MAX_PATH+1];
2873 char filename[MAX_PATH+1];
2874 DWORD len = GetTempPath(MAX_PATH, prefix);
2875 if (len && len < MAX_PATH) {
2876 if (GetTempFileName(prefix, "plx", 0, filename)) {
2877 HANDLE fh = CreateFile(filename,
2878 DELETE | GENERIC_READ | GENERIC_WRITE,
2879 0,
2880 NULL,
2881 CREATE_ALWAYS,
2882 FILE_ATTRIBUTE_NORMAL
2883 | FILE_FLAG_DELETE_ON_CLOSE,
2884 NULL);
2885 if (fh != INVALID_HANDLE_VALUE) {
c623ac67 2886 int fd = win32_open_osfhandle((intptr_t)fh, 0);
b3122bc4 2887 if (fd >= 0) {
a051bdb4
VK		 2888#if defined(__BORLANDC__)
2889 setmode(fd,O_BINARY);
2890#endif
b3122bc4
JH		 2891 DEBUG_p(PerlIO_printf(Perl_debug_log,
2892 "Created tmpfile=%s\n",filename));
2941a2e1 2893 return fd;
b3122bc4
JH		 2894 }
2895 }
2896 }
2897 }
2941a2e1
JH		 2898 return -1;
2899}
2900
2901DllExport FILE*
2902win32_tmpfile(void)
2903{
2904 int fd = win32_tmpfd();
2905 if (fd >= 0)
2906 return win32_fdopen(fd, "w+b");
b3122bc4 2907 return NULL;
0a753a76 2908}
2909
68dc0745 2910DllExport void
2911win32_abort(void)
0a753a76 2912{
390b85e7 2913 abort();
68dc0745 2914 return;
0a753a76 2915}
2916
68dc0745 2917DllExport int
c623ac67 2918win32_fstat(int fd, Stat_t *sbufptr)
0a753a76 2919{
2a07f407
VK		 2920#ifdef __BORLANDC__
2921 /* A file designated by filehandle is not shown as accessible
2922 * for write operations, probably because it is opened for reading.
2923 * --Vadim Konovalov
3fadfdf1 2924 */
2a07f407 2925 BY_HANDLE_FILE_INFORMATION bhfi;
bda6ed21
PM		 2926#if defined(WIN64) || defined(USE_LARGE_FILES)
2927 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2928 struct stat tmp;
2929 int rc = fstat(fd,&tmp);
2930
2931 sbufptr->st_dev = tmp.st_dev;
2932 sbufptr->st_ino = tmp.st_ino;
2933 sbufptr->st_mode = tmp.st_mode;
2934 sbufptr->st_nlink = tmp.st_nlink;
2935 sbufptr->st_uid = tmp.st_uid;
2936 sbufptr->st_gid = tmp.st_gid;
2937 sbufptr->st_rdev = tmp.st_rdev;
2938 sbufptr->st_size = tmp.st_size;
2939 sbufptr->st_atime = tmp.st_atime;
2940 sbufptr->st_mtime = tmp.st_mtime;
2941 sbufptr->st_ctime = tmp.st_ctime;
2942#else
2943 int rc = fstat(fd,sbufptr);
2944#endif
2945
2a07f407 2946 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
bda6ed21 2947#if defined(WIN64) || defined(USE_LARGE_FILES)
0934c9d9 2948 sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
bda6ed21 2949#endif
2a07f407
VK		 2950 sbufptr->st_mode &= 0xFE00;
2951 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2952 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2953 else
2954 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2955 + ((S_IREAD|S_IWRITE) >> 6));
2956 }
2957 return rc;
2958#else
ed59ec62 2959 return my_fstat(fd,sbufptr);
2a07f407 2960#endif
0a753a76 2961}
2962
68dc0745 2963DllExport int
2964win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2965{
390b85e7 2966 return _pipe(pfd, size, mode);
0a753a76 2967}
2968
8c0134a8
NIS		 2969DllExport PerlIO*
2970win32_popenlist(const char *mode, IV narg, SV **args)
2971{
2972 dTHX;
2973 Perl_croak(aTHX_ "List form of pipe open not implemented");
2974 return NULL;
2975}
2976
50892819
GS		 2977/*
2978 * a popen() clone that respects PERL5SHELL
00b02797
JH		 2979 *
2980 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
50892819
GS		 2981 */
2982
00b02797 2983DllExport PerlIO*
68dc0745 2984win32_popen(const char *command, const char *mode)
0a753a76 2985{
4b556e6c 2986#ifdef USE_RTL_POPEN
390b85e7 2987 return _popen(command, mode);
50892819 2988#else
2cbbe5a1 2989 dTHX;
50892819
GS		 2990 int p[2];
2991 int parent, child;
2992 int stdfd, oldfd;
2993 int ourmode;
2994 int childpid;
1095be37
GS		 2995 DWORD nhandle;
2996 HANDLE old_h;
2997 int lock_held = 0;
50892819
GS		 2998
2999 /* establish which ends read and write */
3000 if (strchr(mode,'w')) {
3001 stdfd = 0; /* stdin */
3002 parent = 1;
3003 child = 0;
1095be37 3004 nhandle = STD_INPUT_HANDLE;
50892819
GS		 3005 }
3006 else if (strchr(mode,'r')) {
3007 stdfd = 1; /* stdout */
3008 parent = 0;
3009 child = 1;
1095be37 3010 nhandle = STD_OUTPUT_HANDLE;
50892819
GS		 3011 }
3012 else
3013 return NULL;
3014
3015 /* set the correct mode */
3016 if (strchr(mode,'b'))
3017 ourmode = O_BINARY;
3018 else if (strchr(mode,'t'))
3019 ourmode = O_TEXT;
3020 else
3021 ourmode = _fmode & (O_TEXT | O_BINARY);
3022
3023 /* the child doesn't inherit handles */
3024 ourmode |= O_NOINHERIT;
3025
1095be37 3026 if (win32_pipe(p, 512, ourmode) == -1)
50892819
GS		 3027 return NULL;
3028
498d7dc4
GS		 3029 /* save the old std handle (this needs to happen before the
3030 * dup2(), since that might call SetStdHandle() too) */
3031 OP_REFCNT_LOCK;
3032 lock_held = 1;
3033 old_h = GetStdHandle(nhandle);
3034
564914cd
AS		 3035 /* save current stdfd */
3036 if ((oldfd = win32_dup(stdfd)) == -1)
3037 goto cleanup;
3038
50892819
GS		 3039 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3040 /* stdfd will be inherited by the child */
3041 if (win32_dup2(p[child], stdfd) == -1)
3042 goto cleanup;
3043
3044 /* close the child end in parent */
3045 win32_close(p[child]);
3046
498d7dc4 3047 /* set the new std handle (in case dup2() above didn't) */
1095be37
GS		 3048 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3049
50892819 3050 /* start the child */
4f63d024 3051 {
acfe0abc 3052 dTHX;
c5be433b 3053 if ((childpid = do_spawn_nowait((char*)command)) == -1)
4f63d024 3054 goto cleanup;
50892819 3055
498d7dc4
GS		 3056 /* revert stdfd to whatever it was before */
3057 if (win32_dup2(oldfd, stdfd) == -1)
3058 goto cleanup;
3059
564914cd
AS		 3060 /* close saved handle */
3061 win32_close(oldfd);
3062
498d7dc4
GS		 3063 /* restore the old std handle (this needs to happen after the
3064 * dup2(), since that might call SetStdHandle() too */
1095be37
GS		 3065 if (lock_held) {
3066 SetStdHandle(nhandle, old_h);
3067 OP_REFCNT_UNLOCK;
3068 lock_held = 0;
3069 }
3070
4755096e 3071 LOCK_FDPID_MUTEX;
4f63d024 3072 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
4755096e 3073 UNLOCK_FDPID_MUTEX;
d91d68c1
RS		 3074
3075 /* set process id so that it can be returned by perl's open() */
3076 PL_forkprocess = childpid;
4f63d024 3077 }
50892819
GS		 3078
3079 /* we have an fd, return a file stream */
00b02797 3080 return (PerlIO_fdopen(p[parent], (char *)mode));
50892819
GS		 3081
3082cleanup:
3083 /* we don't need to check for errors here */
3084 win32_close(p[0]);
3085 win32_close(p[1]);
564914cd
AS		 3086 if (oldfd != -1) {
3087 win32_dup2(oldfd, stdfd);
3088 win32_close(oldfd);
3089 }
1095be37
GS		 3090 if (lock_held) {
3091 SetStdHandle(nhandle, old_h);
3092 OP_REFCNT_UNLOCK;
3093 lock_held = 0;
3094 }
50892819
GS		 3095 return (NULL);
3096
4b556e6c 3097#endif /* USE_RTL_POPEN */
0a753a76 3098}
3099
50892819
GS		 3100/*
3101 * pclose() clone
3102 */
3103
68dc0745 3104DllExport int
00b02797 3105win32_pclose(PerlIO *pf)
0a753a76 3106{
4b556e6c 3107#ifdef USE_RTL_POPEN
390b85e7 3108 return _pclose(pf);
50892819 3109#else
acfe0abc 3110 dTHX;
e17cb2a9
JD		 3111 int childpid, status;
3112 SV *sv;
3113
4755096e 3114 LOCK_FDPID_MUTEX;
00b02797 3115 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
4755096e 3116
e17cb2a9
JD		 3117 if (SvIOK(sv))
3118 childpid = SvIVX(sv);
3119 else
3120 childpid = 0;
50892819
GS		 3121
3122 if (!childpid) {
db2fab48 3123 UNLOCK_FDPID_MUTEX;
50892819
GS		 3124 errno = EBADF;
3125 return -1;
3126 }
3127
00b02797
JH		 3128#ifdef USE_PERLIO
3129 PerlIO_close(pf);
3130#else
3131 fclose(pf);
3132#endif
e17cb2a9 3133 SvIVX(sv) = 0;
4755096e 3134 UNLOCK_FDPID_MUTEX;
e17cb2a9 3135
0aaad0ff
GS		 3136 if (win32_waitpid(childpid, &status, 0) == -1)
3137 return -1;
50892819 3138
0aaad0ff 3139 return status;
50892819 3140
4b556e6c 3141#endif /* USE_RTL_POPEN */
0a753a76 3142}
6b980173
JD		 3143
3144static BOOL WINAPI
3145Nt4CreateHardLinkW(
3146 LPCWSTR lpFileName,
3147 LPCWSTR lpExistingFileName,
3148 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3149{
3150 HANDLE handle;
3151 WCHAR wFullName[MAX_PATH+1];
3152 LPVOID lpContext = NULL;
3153 WIN32_STREAM_ID StreamId;
3154 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3155 DWORD dwWritten;
3156 DWORD dwLen;
3157 BOOL bSuccess;
3158
3159 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3160 BOOL, BOOL, LPVOID*) =
3161 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3162 BOOL, BOOL, LPVOID*))
3163 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3164 if (pfnBackupWrite == NULL)
3165 return 0;
3166
3167 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3168 if (dwLen == 0)
3169 return 0;
3170 dwLen = (dwLen+1)*sizeof(WCHAR);
3171
3172 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3173 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3174 NULL, OPEN_EXISTING, 0, NULL);
3175 if (handle == INVALID_HANDLE_VALUE)
3176 return 0;
3177
3178 StreamId.dwStreamId = BACKUP_LINK;
3179 StreamId.dwStreamAttributes = 0;
3180 StreamId.dwStreamNameSize = 0;
6f24f39d
JK		 3181#if defined(__BORLANDC__) \
3182 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
4ce4f76e
GS		 3183 StreamId.Size.u.HighPart = 0;
3184 StreamId.Size.u.LowPart = dwLen;
3185#else
6b980173
JD		 3186 StreamId.Size.HighPart = 0;
3187 StreamId.Size.LowPart = dwLen;
4ce4f76e 3188#endif
6b980173
JD		 3189
3190 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3191 FALSE, FALSE, &lpContext);
3192 if (bSuccess) {
3193 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3194 FALSE, FALSE, &lpContext);
3195 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3196 }
3197
3198 CloseHandle(handle);
3199 return bSuccess;
3200}
3201
3202DllExport int
3203win32_link(const char *oldname, const char *newname)
3204{
acfe0abc 3205 dTHX;
6b980173 3206 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
82867ecf
GS		 3207 WCHAR wOldName[MAX_PATH+1];
3208 WCHAR wNewName[MAX_PATH+1];
6b980173
JD		 3209
3210 if (IsWin95())
1be9d9c6 3211 Perl_croak(aTHX_ PL_no_func, "link");
6b980173
JD		 3212
3213 pfnCreateHardLinkW =
3214 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3215 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3216 if (pfnCreateHardLinkW == NULL)
3217 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3218
8c56068e
JD		 3219 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3220 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
7766f137 3221 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
8c56068e 3222 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD		 3223 {
3224 return 0;
3225 }
3226 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3227 return -1;
3228}
0a753a76 3229
68dc0745 3230DllExport int
8d9b2e3c 3231win32_rename(const char *oname, const char *newname)
e24c7c18 3232{
65cb15a1
GS		 3233 char szOldName[MAX_PATH+1];
3234 char szNewName[MAX_PATH+1];
7fac1903 3235 BOOL bResult;
acfe0abc 3236 dTHX;
65cb15a1 3237
80252599
GS		 3238 /* XXX despite what the documentation says about MoveFileEx(),
3239 * it doesn't work under Windows95!
3240 */
3241 if (IsWinNT()) {
65cb15a1 3242 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
8c56068e
JD		 3243 if (stricmp(newname, oname))
3244 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3245 strcpy(szOldName, PerlDir_mapA(oname));
3246 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
7fac1903 3247 if (!bResult) {
80252599
GS		 3248 DWORD err = GetLastError();
3249 switch (err) {
3250 case ERROR_BAD_NET_NAME:
3251 case ERROR_BAD_NETPATH:
3252 case ERROR_BAD_PATHNAME:
3253 case ERROR_FILE_NOT_FOUND:
3254 case ERROR_FILENAME_EXCED_RANGE:
3255 case ERROR_INVALID_DRIVE:
3256 case ERROR_NO_MORE_FILES:
3257 case ERROR_PATH_NOT_FOUND:
3258 errno = ENOENT;
3259 break;
3260 default:
3261 errno = EACCES;
3262 break;
3263 }
3264 return -1;
3265 }
3266 return 0;
e24c7c18 3267 }
80252599
GS		 3268 else {
3269 int retval = 0;
65cb15a1 3270 char szTmpName[MAX_PATH+1];
80252599 3271 char dname[MAX_PATH+1];
4e205ed6 3272 char *endname = NULL;
80252599
GS		 3273 STRLEN tmplen = 0;
3274 DWORD from_attr, to_attr;
3275
65cb15a1
GS		 3276 strcpy(szOldName, PerlDir_mapA(oname));
3277 strcpy(szNewName, PerlDir_mapA(newname));
3278
80252599 3279 /* if oname doesn't exist, do nothing */
65cb15a1 3280 from_attr = GetFileAttributes(szOldName);
80252599
GS		 3281 if (from_attr == 0xFFFFFFFF) {
3282 errno = ENOENT;
3283 return -1;
3284 }
3285
3286 /* if newname exists, rename it to a temporary name so that we
3287 * don't delete it in case oname happens to be the same file
3288 * (but perhaps accessed via a different path)
3289 */
65cb15a1 3290 to_attr = GetFileAttributes(szNewName);
80252599
GS		 3291 if (to_attr != 0xFFFFFFFF) {
3292 /* if newname is a directory, we fail
3293 * XXX could overcome this with yet more convoluted logic */
3294 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3295 errno = EACCES;
3296 return -1;
3297 }
65cb15a1
GS		 3298 tmplen = strlen(szNewName);
3299 strcpy(szTmpName,szNewName);
3300 endname = szTmpName+tmplen;
3301 for (; endname > szTmpName ; --endname) {
80252599
GS		 3302 if (*endname == '/' || *endname == '\\') {
3303 *endname = '\0';
3304 break;
3305 }
3306 }
65cb15a1
GS		 3307 if (endname > szTmpName)
3308 endname = strcpy(dname,szTmpName);
e24c7c18 3309 else
80252599
GS		 3310 endname = ".";
3311
3312 /* get a temporary filename in same directory
3313 * XXX is this really the best we can do? */
65cb15a1 3314 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
80252599
GS		 3315 errno = ENOENT;
3316 return -1;
3317 }
65cb15a1 3318 DeleteFile(szTmpName);
80252599 3319
65cb15a1 3320 retval = rename(szNewName, szTmpName);
80252599
GS		 3321 if (retval != 0) {
3322 errno = EACCES;
3323 return retval;
e24c7c18
GS		 3324 }
3325 }
80252599
GS		 3326
3327 /* rename oname to newname */
65cb15a1 3328 retval = rename(szOldName, szNewName);
80252599
GS		 3329
3330 /* if we created a temporary file before ... */
4e205ed6 3331 if (endname != NULL) {
80252599
GS		 3332 /* ...and rename succeeded, delete temporary file/directory */
3333 if (retval == 0)
65cb15a1 3334 DeleteFile(szTmpName);
80252599
GS		 3335 /* else restore it to what it was */
3336 else
65cb15a1 3337 (void)rename(szTmpName, szNewName);
80252599
GS		 3338 }
3339 return retval;
e24c7c18 3340 }
e24c7c18
GS		 3341}
3342
3343DllExport int
68dc0745 3344win32_setmode(int fd, int mode)
0a753a76 3345{
390b85e7 3346 return setmode(fd, mode);
0a753a76 3347}
3348
4a9d6100
GS		 3349DllExport int
3350win32_chsize(int fd, Off_t size)
3351{
3352#if defined(WIN64) || defined(USE_LARGE_FILES)
3353 int retval = 0;
3354 Off_t cur, end, extend;
3355
3356 cur = win32_tell(fd);
3357 if (cur < 0)
3358 return -1;
3359 end = win32_lseek(fd, 0, SEEK_END);
3360 if (end < 0)
3361 return -1;
3362 extend = size - end;
3363 if (extend == 0) {
3364 /* do nothing */
3365 }
3366 else if (extend > 0) {
3367 /* must grow the file, padding with nulls */
3368 char b[4096];
3369 int oldmode = win32_setmode(fd, O_BINARY);
3370 size_t count;
3371 memset(b, '\0', sizeof(b));
3372 do {
3373 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3374 count = win32_write(fd, b, count);
21424390 3375 if ((int)count < 0) {
4a9d6100
GS		 3376 retval = -1;
3377 break;
3378 }
3379 } while ((extend -= count) > 0);
3380 win32_setmode(fd, oldmode);
3381 }
3382 else {
3383 /* shrink the file */
3384 win32_lseek(fd, size, SEEK_SET);
3385 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3386 errno = EACCES;
3387 retval = -1;
3388 }
3389 }
3390finish:
3391 win32_lseek(fd, cur, SEEK_SET);
3392 return retval;
3393#else
8859a7a0 3394 return chsize(fd, (long)size);
4a9d6100
GS		 3395#endif
3396}
3397
c623ac67
GS		 3398DllExport Off_t
3399win32_lseek(int fd, Off_t offset, int origin)
96e4d5b1 3400{
c623ac67 3401#if defined(WIN64) || defined(USE_LARGE_FILES)
a810272a
NS		 3402#if defined(__BORLANDC__) /* buk */
3403 LARGE_INTEGER pos;
3404 pos.QuadPart = offset;
3405 pos.LowPart = SetFilePointer(
3406 (HANDLE)_get_osfhandle(fd),
3407 pos.LowPart,
3408 &pos.HighPart,
3409 origin
3410 );
3411 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3412 pos.QuadPart = -1;
3413 }
3414
3415 return pos.QuadPart;
3416#else
c623ac67 3417 return _lseeki64(fd, offset, origin);
a810272a 3418#endif
c623ac67 3419#else
8859a7a0 3420 return lseek(fd, (long)offset, origin);
c623ac67 3421#endif
96e4d5b1 3422}
3423
c623ac67 3424DllExport Off_t
96e4d5b1 3425win32_tell(int fd)
3426{
c623ac67 3427#if defined(WIN64) || defined(USE_LARGE_FILES)
05e23382 3428#if defined(__BORLANDC__) /* buk */
a810272a
NS		 3429 LARGE_INTEGER pos;
3430 pos.QuadPart = 0;
3431 pos.LowPart = SetFilePointer(
3432 (HANDLE)_get_osfhandle(fd),
3433 pos.LowPart,
3434 &pos.HighPart,
3435 FILE_CURRENT
3436 );
3437 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3438 pos.QuadPart = -1;
3439 }
3440
3441 return pos.QuadPart;
3442 /* return tell(fd); */
3443#else
c623ac67 3444 return _telli64(fd);
a810272a 3445#endif
c623ac67 3446#else
390b85e7 3447 return tell(fd);
c623ac67 3448#endif
96e4d5b1 3449}
3450
68dc0745 3451DllExport int
3452win32_open(const char *path, int flag, ...)
0a753a76 3453{
acfe0abc 3454 dTHX;
68dc0745 3455 va_list ap;
3456 int pmode;
0a753a76 3457
3458 va_start(ap, flag);
3459 pmode = va_arg(ap, int);
3460 va_end(ap);
3461
68dc0745 3462 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 3463 path = "NUL";
3464
7766f137 3465 return open(PerlDir_mapA(path), flag, pmode);
0a753a76 3466}
3467
00b02797
JH		 3468/* close() that understands socket */
3469extern int my_close(int); /* in win32sck.c */
3470
68dc0745 3471DllExport int
3472win32_close(int fd)
0a753a76 3473{
00b02797 3474 return my_close(fd);
0a753a76 3475}
3476
68dc0745 3477DllExport int
96e4d5b1 3478win32_eof(int fd)
3479{
390b85e7 3480 return eof(fd);
96e4d5b1 3481}
3482
3483DllExport int
68dc0745 3484win32_dup(int fd)
0a753a76 3485{
390b85e7 3486 return dup(fd);
0a753a76 3487}
3488
68dc0745 3489DllExport int
3490win32_dup2(int fd1,int fd2)
0a753a76 3491{
390b85e7 3492 return dup2(fd1,fd2);
0a753a76 3493}
3494
f7aeb604
GS		 3495#ifdef PERL_MSVCRT_READFIX
3496
3497#define LF 10 /* line feed */
3498#define CR 13 /* carriage return */
3499#define CTRLZ 26 /* ctrl-z means eof for text */
3500#define FOPEN 0x01 /* file handle open */
3501#define FEOFLAG 0x02 /* end of file has been encountered */
3502#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3503#define FPIPE 0x08 /* file handle refers to a pipe */
3504#define FAPPEND 0x20 /* file handle opened O_APPEND */
3505#define FDEV 0x40 /* file handle refers to device */
3506#define FTEXT 0x80 /* file handle is in text mode */
3507#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3508
b181b6fb
GS		 3509int __cdecl
3510_fixed_read(int fh, void *buf, unsigned cnt)
f7aeb604
GS		 3511{
3512 int bytes_read; /* number of bytes read */
3513 char *buffer; /* buffer to read to */
3514 int os_read; /* bytes read on OS call */
3515 char *p, *q; /* pointers into buffer */
3516 char peekchr; /* peek-ahead character */
3517 ULONG filepos; /* file position after seek */
3518 ULONG dosretval; /* o.s. return value */
3519
3520 /* validate handle */
3521 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3522 !(_osfile(fh) & FOPEN))
3523 {
3524 /* out of range -- return error */
3525 errno = EBADF;
3526 _doserrno = 0; /* not o.s. error */
3527 return -1;
3528 }
3529
635bbe87
GS		 3530 /*
3531 * If lockinitflag is FALSE, assume fd is device
3532 * lockinitflag is set to TRUE by open.
3533 */
3534 if (_pioinfo(fh)->lockinitflag)
3535 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
f7aeb604
GS		 3536
3537 bytes_read = 0; /* nothing read yet */
3538 buffer = (char*)buf;
3539
3540 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3541 /* nothing to read or at EOF, so return 0 read */
3542 goto functionexit;
3543 }
3544
3545 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3546 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3547 * char */
3548 *buffer++ = _pipech(fh);
3549 ++bytes_read;
3550 --cnt;
3551 _pipech(fh) = LF; /* mark as empty */
3552 }
3553
3554 /* read the data */
3555
3556 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3557 {
3558 /* ReadFile has reported an error. recognize two special cases.
3559 *
3560 * 1. map ERROR_ACCESS_DENIED to EBADF
3561 *
3562 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3563 * means the handle is a read-handle on a pipe for which
3564 * all write-handles have been closed and all data has been
3565 * read. */
3566
3567 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3568 /* wrong read/write mode should return EBADF, not EACCES */
3569 errno = EBADF;
3570 _doserrno = dosretval;
3571 bytes_read = -1;
3572 goto functionexit;
3573 }
3574 else if (dosretval == ERROR_BROKEN_PIPE) {
3575 bytes_read = 0;
3576 goto functionexit;
3577 }
3578 else {
3579 bytes_read = -1;
3580 goto functionexit;
3581 }
3582 }
3583
3584 bytes_read += os_read; /* update bytes read */
3585
3586 if (_osfile(fh) & FTEXT) {
3587 /* now must translate CR-LFs to LFs in the buffer */
3588
3589 /* set CRLF flag to indicate LF at beginning of buffer */
3590 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3591 /* _osfile(fh) |= FCRLF; */
3592 /* else */
3593 /* _osfile(fh) &= ~FCRLF; */
3594
3595 _osfile(fh) &= ~FCRLF;
3596
3597 /* convert chars in the buffer: p is src, q is dest */
3598 p = q = (char*)buf;
3599 while (p < (char *)buf + bytes_read) {
3600 if (*p == CTRLZ) {
3601 /* if fh is not a device, set ctrl-z flag */
3602 if (!(_osfile(fh) & FDEV))
3603 _osfile(fh) |= FEOFLAG;
3604 break; /* stop translating */
3605 }
3606 else if (*p != CR)
3607 *q++ = *p++;
3608 else {
3609 /* *p is CR, so must check next char for LF */
3610 if (p < (char *)buf + bytes_read - 1) {
3611 if (*(p+1) == LF) {
3612 p += 2;
3613 *q++ = LF; /* convert CR-LF to LF */
3614 }
3615 else
3616 *q++ = *p++; /* store char normally */
3617 }
3618 else {
3619 /* This is the hard part. We found a CR at end of
3620 buffer. We must peek ahead to see if next char
3621 is an LF. */
3622 ++p;
3623
3624 dosretval = 0;
3625 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3626 (LPDWORD)&os_read, NULL))
3627 dosretval = GetLastError();
3628
3629 if (dosretval != 0 || os_read == 0) {
3630 /* couldn't read ahead, store CR */
3631 *q++ = CR;
3632 }
3633 else {
3634 /* peekchr now has the extra character -- we now
3635 have several possibilities:
3636 1. disk file and char is not LF; just seek back
3637 and copy CR
3638 2. disk file and char is LF; store LF, don't seek back
3639 3. pipe/device and char is LF; store LF.
3640 4. pipe/device and char isn't LF, store CR and
3641 put char in pipe lookahead buffer. */
3642 if (_osfile(fh) & (FDEV|FPIPE)) {
3643 /* non-seekable device */
3644 if (peekchr == LF)
3645 *q++ = LF;
3646 else {
3647 *q++ = CR;
3648 _pipech(fh) = peekchr;
3649 }
3650 }
3651 else {
3652 /* disk file */
3653 if (peekchr == LF) {
3654 /* nothing read yet; must make some
3655 progress */
3656 *q++ = LF;
3657 /* turn on this flag for tell routine */
3658 _osfile(fh) |= FCRLF;
3659 }
3660 else {
3661 HANDLE osHandle; /* o.s. handle value */
3662 /* seek back */
3663 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3664 {
3665 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3666 dosretval = GetLastError();
3667 }
3668 if (peekchr != LF)
3669 *q++ = CR;
3670 }
3671 }
3672 }
3673 }
3674 }
3675 }
3676
3677 /* we now change bytes_read to reflect the true number of chars
3678 in the buffer */
3679 bytes_read = q - (char *)buf;
3680 }
3681
3fadfdf1 3682functionexit:
635bbe87
GS		 3683 if (_pioinfo(fh)->lockinitflag)
3684 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
f7aeb604
GS		 3685
3686 return bytes_read;
3687}
3688
3689#endif /* PERL_MSVCRT_READFIX */
3690
68dc0745 3691DllExport int
3e3baf6d 3692win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 3693{
f7aeb604
GS		 3694#ifdef PERL_MSVCRT_READFIX
3695 return _fixed_read(fd, buf, cnt);
3696#else
390b85e7 3697 return read(fd, buf, cnt);
f7aeb604 3698#endif
0a753a76 3699}
3700
68dc0745 3701DllExport int
3e3baf6d 3702win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 3703{
390b85e7 3704 return write(fd, buf, cnt);
0a753a76 3705}
3706
68dc0745 3707DllExport int
5aabfad6 3708win32_mkdir(const char *dir, int mode)
3709{
acfe0abc 3710 dTHX;
7766f137 3711 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 3712}
96e4d5b1 3713
5aabfad6 3714DllExport int
3715win32_rmdir(const char *dir)
3716{
acfe0abc 3717 dTHX;
7766f137 3718 return rmdir(PerlDir_mapA(dir));
5aabfad6 3719}
96e4d5b1 3720
5aabfad6 3721DllExport int
3722win32_chdir(const char *dir)
3723{
4ae93879 3724 dTHX;
9ec3348a
JH		 3725 if (!dir) {
3726 errno = ENOENT;
3727 return -1;
3728 }
390b85e7 3729 return chdir(dir);
5aabfad6 3730}
96e4d5b1 3731
7766f137
GS		 3732DllExport int
3733win32_access(const char *path, int mode)
3734{
acfe0abc 3735 dTHX;
7766f137
GS		 3736 return access(PerlDir_mapA(path), mode);
3737}
3738
3739DllExport int
3740win32_chmod(const char *path, int mode)
3741{
acfe0abc 3742 dTHX;
7766f137
GS		 3743 return chmod(PerlDir_mapA(path), mode);
3744}
3745
3746
0aaad0ff 3747static char *
dd7038b3 3748create_command_line(char *cname, STRLEN clen, const char * const *args)
0aaad0ff 3749{
acfe0abc 3750 dTHX;
b309b8ae
JH		 3751 int index, argc;
3752 char *cmd, *ptr;
3753 const char *arg;
3754 STRLEN len = 0;
81bc1258 3755 bool bat_file = FALSE;
b309b8ae 3756 bool cmd_shell = FALSE;
7b11e424 3757 bool dumb_shell = FALSE;
b309b8ae 3758 bool extra_quotes = FALSE;
dd7038b3 3759 bool quote_next = FALSE;
81bc1258
JH		 3760
3761 if (!cname)
3762 cname = (char*)args[0];
b309b8ae
JH		 3763
3764 /* The NT cmd.exe shell has the following peculiarity that needs to be
3765 * worked around. It strips a leading and trailing dquote when any
3766 * of the following is true:
3767 * 1. the /S switch was used
3768 * 2. there are more than two dquotes
3769 * 3. there is a special character from this set: &<>()@^|
3770 * 4. no whitespace characters within the two dquotes
3771 * 5. string between two dquotes isn't an executable file
3772 * To work around this, we always add a leading and trailing dquote
3773 * to the string, if the first argument is either "cmd.exe" or "cmd",
3774 * and there were at least two or more arguments passed to cmd.exe
3775 * (not including switches).
dd7038b3
JH		 3776 * XXX the above rules (from "cmd /?") don't seem to be applied
3777 * always, making for the convolutions below :-(
b309b8ae 3778 */
81bc1258 3779 if (cname) {
dd7038b3
JH		 3780 if (!clen)
3781 clen = strlen(cname);
3782
81bc1258
JH		 3783 if (clen > 4
3784 && (stricmp(&cname[clen-4], ".bat") == 0
3785 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3786 {
3787 bat_file = TRUE;
96090bfd
B		 3788 if (!IsWin95())
3789 len += 3;
81bc1258 3790 }
dd7038b3
JH		 3791 else {
3792 char *exe = strrchr(cname, '/');
3793 char *exe2 = strrchr(cname, '\\');
3794 if (exe2 > exe)
3795 exe = exe2;
3796 if (exe)
3797 ++exe;
3798 else
3799 exe = cname;
3800 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3801 cmd_shell = TRUE;
3802 len += 3;
3803 }
7b11e424
JH		 3804 else if (stricmp(exe, "command.com") == 0
3805 || stricmp(exe, "command") == 0)
3806 {
3807 dumb_shell = TRUE;
3808 }
81bc1258 3809 }
b309b8ae 3810 }
0aaad0ff 3811
b309b8ae
JH		 3812 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3813 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3814 STRLEN curlen = strlen(arg);
3815 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3816 len += 2; /* assume quoting needed (worst case) */
3817 len += curlen + 1;
3818 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3819 }
3820 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
0aaad0ff 3821
b309b8ae 3822 argc = index;
a02a5408 3823 Newx(cmd, len, char);
0aaad0ff 3824 ptr = cmd;
0aaad0ff 3825
96090bfd 3826 if (bat_file && !IsWin95()) {
81bc1258
JH		 3827 *ptr++ = '"';
3828 extra_quotes = TRUE;
3829 }
3830
0aaad0ff 3831 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
b309b8ae
JH		 3832 bool do_quote = 0;
3833 STRLEN curlen = strlen(arg);
3834
81bc1258
JH		 3835 /* we want to protect empty arguments and ones with spaces with
3836 * dquotes, but only if they aren't already there */
7b11e424
JH		 3837 if (!dumb_shell) {
3838 if (!curlen) {
3839 do_quote = 1;
3840 }
02ef22d5
JH		 3841 else if (quote_next) {
3842 /* see if it really is multiple arguments pretending to
3843 * be one and force a set of quotes around it */
3844 if (*find_next_space(arg))
3845 do_quote = 1;
3846 }
7b11e424
JH		 3847 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3848 STRLEN i = 0;
3849 while (i < curlen) {
3850 if (isSPACE(arg[i])) {
3851 do_quote = 1;
02ef22d5
JH		 3852 }
3853 else if (arg[i] == '"') {
3854 do_quote = 0;
7b11e424
JH		 3855 break;
3856 }
3857 i++;
b309b8ae 3858 }
b309b8ae 3859 }
dd7038b3 3860 }
b309b8ae
JH		 3861
3862 if (do_quote)
3863 *ptr++ = '"';
3864
18a945d4 3865 strcpy(ptr, arg);
b309b8ae
JH		 3866 ptr += curlen;
3867
3868 if (do_quote)
3869 *ptr++ = '"';
3870
3871 if (args[index+1])
3872 *ptr++ = ' ';
3873
81bc1258
JH		 3874 if (!extra_quotes
3875 && cmd_shell
11998fdb
GS		 3876 && curlen >= 2
3877 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3878 && stricmp(arg+curlen-2, "/c") == 0)
b309b8ae 3879 {
dd7038b3
JH		 3880 /* is there a next argument? */
3881 if (args[index+1]) {
3882 /* are there two or more next arguments? */
3883 if (args[index+2]) {
3884 *ptr++ = '"';
3885 extra_quotes = TRUE;
3886 }
3887 else {
02ef22d5 3888 /* single argument, force quoting if it has spaces */
dd7038b3
JH		 3889 quote_next = TRUE;
3890 }
3891 }
b309b8ae 3892 }
0aaad0ff
GS		 3893 }
3894
b309b8ae
JH		 3895 if (extra_quotes)
3896 *ptr++ = '"';
3897
3898 *ptr = '\0';
3899
0aaad0ff
GS		 3900 return cmd;
3901}
3902
3903static char *
3904qualified_path(const char *cmd)
3905{
acfe0abc 3906 dTHX;
0aaad0ff
GS		 3907 char *pathstr;
3908 char *fullcmd, *curfullcmd;
3909 STRLEN cmdlen = 0;
3910 int has_slash = 0;
3911
3912 if (!cmd)
4e205ed6 3913 return NULL;
0aaad0ff
GS		 3914 fullcmd = (char*)cmd;
3915 while (*fullcmd) {
3916 if (*fullcmd == '/' || *fullcmd == '\\')
3917 has_slash++;
3918 fullcmd++;
3919 cmdlen++;
3920 }
3921
3922 /* look in PATH */
2fb9ab56 3923 pathstr = PerlEnv_getenv("PATH");
1928965c
JD		 3924
3925 /* worst case: PATH is a single directory; we need additional space
3926 * to append "/", ".exe" and trailing "\0" */
a02a5408 3927 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
0aaad0ff
GS		 3928 curfullcmd = fullcmd;
3929
3930 while (1) {
3931 DWORD res;
3932
3933 /* start by appending the name to the current prefix */
3934 strcpy(curfullcmd, cmd);
3935 curfullcmd += cmdlen;
3936
3937 /* if it doesn't end with '.', or has no extension, try adding
3938 * a trailing .exe first */
3939 if (cmd[cmdlen-1] != '.'
3940 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3941 {
3942 strcpy(curfullcmd, ".exe");
3943 res = GetFileAttributes(fullcmd);
3944 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3945 return fullcmd;
3946 *curfullcmd = '\0';
3947 }
3948
3949 /* that failed, try the bare name */
3950 res = GetFileAttributes(fullcmd);
3951 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3952 return fullcmd;
3953
3954 /* quit if no other path exists, or if cmd already has path */
3955 if (!pathstr || !*pathstr || has_slash)
3956 break;
3957
3958 /* skip leading semis */
3959 while (*pathstr == ';')
3960 pathstr++;
3961
3962 /* build a new prefix from scratch */
3963 curfullcmd = fullcmd;
3964 while (*pathstr && *pathstr != ';') {
3965 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3966 pathstr++; /* skip initial '"' */
3967 while (*pathstr && *pathstr != '"') {
1928965c 3968 *curfullcmd++ = *pathstr++;
0aaad0ff
GS		 3969 }
3970 if (*pathstr)
3971 pathstr++; /* skip trailing '"' */
3972 }
3973 else {
1928965c 3974 *curfullcmd++ = *pathstr++;
0aaad0ff
GS		 3975 }
3976 }
3977 if (*pathstr)
3978 pathstr++; /* skip trailing semi */
3979 if (curfullcmd > fullcmd /* append a dir separator */
3980 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3981 {
3982 *curfullcmd++ = '\\';
3983 }
3984 }
eb160463 3985
0aaad0ff 3986 Safefree(fullcmd);
4e205ed6 3987 return NULL;
0aaad0ff
GS		 3988}
3989
3075ddba
GS		 3990/* The following are just place holders.
3991 * Some hosts may provide and environment that the OS is
3992 * not tracking, therefore, these host must provide that
3993 * environment and the current directory to CreateProcess
3994 */
3995
df3728a2
JH		 3996DllExport void*
3997win32_get_childenv(void)
3075ddba
GS		 3998{
3999 return NULL;
4000}
4001
df3728a2
JH		 4002DllExport void
4003win32_free_childenv(void* d)
3075ddba
GS		 4004{
4005}
4006
df3728a2
JH		 4007DllExport void
4008win32_clearenv(void)
4009{
4010 char *envv = GetEnvironmentStrings();
4011 char *cur = envv;
4012 STRLEN len;
4013 while (*cur) {
4014 char *end = strchr(cur,'=');
4015 if (end && end != cur) {
4016 *end = '\0';
4017 SetEnvironmentVariable(cur, NULL);
4018 *end = '=';
4019 cur = end + strlen(end+1)+2;
4020 }
4021 else if ((len = strlen(cur)))
4022 cur += len+1;
4023 }
4024 FreeEnvironmentStrings(envv);
4025}
4026
4027DllExport char*
4028win32_get_childdir(void)
3075ddba 4029{
acfe0abc 4030 dTHX;
7766f137 4031 char* ptr;
8c56068e 4032 char szfilename[MAX_PATH+1];
7766f137 4033
8c56068e 4034 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
a02a5408 4035 Newx(ptr, strlen(szfilename)+1, char);
7766f137
GS		 4036 strcpy(ptr, szfilename);
4037 return ptr;
3075ddba
GS		 4038}
4039
df3728a2
JH		 4040DllExport void
4041win32_free_childdir(char* d)
3075ddba 4042{
acfe0abc 4043 dTHX;
7766f137 4044 Safefree(d);
3075ddba
GS		 4045}
4046
4047
0aaad0ff
GS		 4048/* XXX this needs to be made more compatible with the spawnvp()
4049 * provided by the various RTLs. In particular, searching for
4050 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4051 * This doesn't significantly affect perl itself, because we
4052 * always invoke things using PERL5SHELL if a direct attempt to
4053 * spawn the executable fails.
3fadfdf1 4054 *
0aaad0ff
GS		 4055 * XXX splitting and rejoining the commandline between do_aspawn()
4056 * and win32_spawnvp() could also be avoided.
4057 */
4058
5aabfad6 4059DllExport int
3e3baf6d 4060win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
0a753a76 4061{
0aaad0ff
GS		 4062#ifdef USE_RTL_SPAWNVP
4063 return spawnvp(mode, cmdname, (char * const *)argv);
4064#else
acfe0abc 4065 dTHX;
2b260de0 4066 int ret;
3075ddba
GS		 4067 void* env;
4068 char* dir;
635bbe87 4069 child_IO_table tbl;
0aaad0ff
GS		 4070 STARTUPINFO StartupInfo;
4071 PROCESS_INFORMATION ProcessInformation;
4072 DWORD create = 0;
dd7038b3 4073 char *cmd;
4e205ed6 4074 char *fullcmd = NULL;
dd7038b3
JH		 4075 char *cname = (char *)cmdname;
4076 STRLEN clen = 0;
4077
4078 if (cname) {
4079 clen = strlen(cname);
4080 /* if command name contains dquotes, must remove them */
4081 if (strchr(cname, '"')) {
4082 cmd = cname;
a02a5408 4083 Newx(cname,clen+1,char);
dd7038b3
JH		 4084 clen = 0;
4085 while (*cmd) {
4086 if (*cmd != '"') {
4087 cname[clen] = *cmd;
4088 ++clen;
4089 }
4090 ++cmd;
4091 }
4092 cname[clen] = '\0';
4093 }
4094 }
4095
4096 cmd = create_command_line(cname, clen, argv);
0aaad0ff 4097
3075ddba
GS		 4098 env = PerlEnv_get_childenv();
4099 dir = PerlEnv_get_childdir();
4100
0aaad0ff
GS		 4101 switch(mode) {
4102 case P_NOWAIT: /* asynch + remember result */
4103 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4104 errno = EAGAIN;
4105 ret = -1;
4106 goto RETVAL;
4107 }
3fadfdf1 4108 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
7e5f34c0
NIS		 4109 * in win32_kill()
4110 */
3fadfdf1 4111 create |= CREATE_NEW_PROCESS_GROUP;
0aaad0ff 4112 /* FALL THROUGH */
7e5f34c0 4113
0aaad0ff
GS		 4114 case P_WAIT: /* synchronous execution */
4115 break;
4116 default: /* invalid mode */
4117 errno = EINVAL;
4118 ret = -1;
4119 goto RETVAL;
4120 }
4121 memset(&StartupInfo,0,sizeof(StartupInfo));
4122 StartupInfo.cb = sizeof(StartupInfo);
f83751a7 4123 memset(&tbl,0,sizeof(tbl));
635bbe87 4124 PerlEnv_get_child_IO(&tbl);
f83751a7 4125 StartupInfo.dwFlags = tbl.dwFlags;
3fadfdf1
NIS		 4126 StartupInfo.dwX = tbl.dwX;
4127 StartupInfo.dwY = tbl.dwY;
4128 StartupInfo.dwXSize = tbl.dwXSize;
4129 StartupInfo.dwYSize = tbl.dwYSize;
4130 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4131 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4132 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4133 StartupInfo.wShowWindow = tbl.wShowWindow;
f83751a7
GS		 4134 StartupInfo.hStdInput = tbl.childStdIn;
4135 StartupInfo.hStdOutput = tbl.childStdOut;
4136 StartupInfo.hStdError = tbl.childStdErr;
139cf11b
GS		 4137 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4138 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4139 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3ffaa937 4140 {
139cf11b 4141 create |= CREATE_NEW_CONSOLE;
3ffaa937
GS		 4142 }
4143 else {
139cf11b 4144 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3ffaa937 4145 }
02637f4c
JD		 4146 if (w32_use_showwindow) {
4147 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4148 StartupInfo.wShowWindow = w32_showwindow;
4149 }
3ffaa937 4150
b309b8ae 4151 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
dd7038b3 4152 cname,cmd));
0aaad0ff 4153RETRY:
dd7038b3 4154 if (!CreateProcess(cname, /* search PATH to find executable */
0aaad0ff
GS		 4155 cmd, /* executable, and its arguments */
4156 NULL, /* process attributes */
4157 NULL, /* thread attributes */
4158 TRUE, /* inherit handles */
4159 create, /* creation flags */
3075ddba
GS		 4160 (LPVOID)env, /* inherit environment */
4161 dir, /* inherit cwd */
0aaad0ff
GS		 4162 &StartupInfo,
4163 &ProcessInformation))
4164 {
4165 /* initial NULL argument to CreateProcess() does a PATH
4166 * search, but it always first looks in the directory
4167 * where the current process was started, which behavior
4168 * is undesirable for backward compatibility. So we
4169 * jump through our own hoops by picking out the path
4170 * we really want it to use. */
4171 if (!fullcmd) {
dd7038b3 4172 fullcmd = qualified_path(cname);
0aaad0ff 4173 if (fullcmd) {
dd7038b3
JH		 4174 if (cname != cmdname)
4175 Safefree(cname);
4176 cname = fullcmd;
b309b8ae
JH		 4177 DEBUG_p(PerlIO_printf(Perl_debug_log,
4178 "Retrying [%s] with same args\n",
dd7038b3 4179 cname));
0aaad0ff
GS		 4180 goto RETRY;
4181 }
4182 }
4183 errno = ENOENT;
4184 ret = -1;
4185 goto RETVAL;
4186 }
2d7a9237 4187
0aaad0ff
GS		 4188 if (mode == P_NOWAIT) {
4189 /* asynchronous spawn -- store handle, return PID */
2b260de0 4190 ret = (int)ProcessInformation.dwProcessId;
922b1888
GS		 4191 if (IsWin95() && ret < 0)
4192 ret = -ret;
4193
4194 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4195 w32_child_pids[w32_num_children] = (DWORD)ret;
0aaad0ff
GS		 4196 ++w32_num_children;
4197 }
4198 else {
2b260de0 4199 DWORD status;
8fb3fcfb 4200 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
7e5f34c0
NIS		 4201 /* FIXME: if msgwait returned due to message perhaps forward the
4202 "signal" to the process
4203 */
2b260de0
GS		 4204 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4205 ret = (int)status;
0aaad0ff
GS		 4206 CloseHandle(ProcessInformation.hProcess);
4207 }
e17cb2a9 4208
0aaad0ff 4209 CloseHandle(ProcessInformation.hThread);
3075ddba 4210
0aaad0ff 4211RETVAL:
3075ddba
GS		 4212 PerlEnv_free_childenv(env);
4213 PerlEnv_free_childdir(dir);
0aaad0ff 4214 Safefree(cmd);
dd7038b3
JH		 4215 if (cname != cmdname)
4216 Safefree(cname);
2b260de0 4217 return ret;
2d7a9237 4218#endif
0a753a76 4219}
4220
6890e559 4221DllExport int
eb62e965
JD		 4222win32_execv(const char *cmdname, const char *const *argv)
4223{
7766f137 4224#ifdef USE_ITHREADS
acfe0abc 4225 dTHX;
7766f137
GS		 4226 /* if this is a pseudo-forked child, we just want to spawn
4227 * the new program, and return */
4228 if (w32_pseudo_id)
a51a97d8 4229# ifdef __BORLANDC__
7766f137 4230 return spawnv(P_WAIT, cmdname, (char *const *)argv);
a51a97d8
SH		 4231# else
4232 return spawnv(P_WAIT, cmdname, argv);
4233# endif
7766f137 4234#endif
a51a97d8 4235#ifdef __BORLANDC__
eb62e965 4236 return execv(cmdname, (char *const *)argv);
a51a97d8
SH		 4237#else
4238 return execv(cmdname, argv);
4239#endif
eb62e965
JD		 4240}
4241
4242DllExport int
6890e559
GS		 4243win32_execvp(const char *cmdname, const char *const *argv)
4244{
7766f137 4245#ifdef USE_ITHREADS
acfe0abc 4246 dTHX;
7766f137
GS		 4247 /* if this is a pseudo-forked child, we just want to spawn
4248 * the new program, and return */
190e4ad0 4249 if (w32_pseudo_id) {
f026e7c6 4250 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
ba6ce41c
GS		 4251 if (status != -1) {
4252 my_exit(status);
4253 return 0;
4254 }
4255 else
4256 return status;
190e4ad0 4257 }
7766f137 4258#endif
a51a97d8 4259#ifdef __BORLANDC__
390b85e7 4260 return execvp(cmdname, (char *const *)argv);
a51a97d8
SH		 4261#else
4262 return execvp(cmdname, argv);
4263#endif
6890e559
GS		 4264}
4265
84902520
TB		 4266DllExport void
4267win32_perror(const char *str)
4268{
390b85e7 4269 perror(str);
84902520
TB		 4270}
4271
4272DllExport void
4273win32_setbuf(FILE *pf, char *buf)
4274{
390b85e7 4275 setbuf(pf, buf);
84902520
TB		 4276}
4277
4278DllExport int
4279win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4280{
390b85e7 4281 return setvbuf(pf, buf, type, size);
84902520
TB		 4282}
4283
4284DllExport int
4285win32_flushall(void)
4286{
390b85e7 4287 return flushall();
84902520
TB		 4288}
4289
4290DllExport int
4291win32_fcloseall(void)
4292{
390b85e7 4293 return fcloseall();
84902520
TB		 4294}
4295
4296DllExport char*
4297win32_fgets(char *s, int n, FILE *pf)
4298{
390b85e7 4299 return fgets(s, n, pf);
84902520
TB		 4300}
4301
4302DllExport char*
4303win32_gets(char *s)
4304{
390b85e7 4305 return gets(s);
84902520
TB		 4306}
4307
4308DllExport int
4309win32_fgetc(FILE *pf)
4310{
390b85e7 4311 return fgetc(pf);
84902520
TB		 4312}
4313
4314DllExport int
4315win32_putc(int c, FILE *pf)
4316{
390b85e7 4317 return putc(c,pf);
84902520
TB		 4318}
4319
4320DllExport int
4321win32_puts(const char *s)
4322{
390b85e7 4323 return puts(s);
84902520
TB		 4324}
4325
4326DllExport int
4327win32_getchar(void)
4328{
390b85e7 4329 return getchar();
84902520
TB		 4330}
4331
4332DllExport int
4333win32_putchar(int c)
4334{
390b85e7 4335 return putchar(c);
84902520
TB		 4336}
4337
bbc8f9de
NIS		 4338#ifdef MYMALLOC
4339
4340#ifndef USE_PERL_SBRK
4341
df3728a2
JH		 4342static char *committed = NULL; /* XXX threadead */
4343static char *base = NULL; /* XXX threadead */
4344static char *reserved = NULL; /* XXX threadead */
4345static char *brk = NULL; /* XXX threadead */
4346static DWORD pagesize = 0; /* XXX threadead */
bbc8f9de
NIS		 4347
4348void *
c623ac67 4349sbrk(ptrdiff_t need)
bbc8f9de
NIS		 4350{
4351 void *result;
4352 if (!pagesize)
4353 {SYSTEM_INFO info;
4354 GetSystemInfo(&info);
4355 /* Pretend page size is larger so we don't perpetually
4356 * call the OS to commit just one page ...
4357 */
4358 pagesize = info.dwPageSize << 3;
bbc8f9de 4359 }
bbc8f9de
NIS		 4360 if (brk+need >= reserved)
4361 {
b2d41e21 4362 DWORD size = brk+need-reserved;
bbc8f9de 4363 char *addr;
b2d41e21 4364 char *prev_committed = NULL;
bbc8f9de
NIS		 4365 if (committed && reserved && committed < reserved)
4366 {
4367 /* Commit last of previous chunk cannot span allocations */
161b471a 4368 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de 4369 if (addr)
b2d41e21
SH		 4370 {
4371 /* Remember where we committed from in case we want to decommit later */
4372 prev_committed = committed;
bbc8f9de 4373 committed = reserved;
b2d41e21 4374 }
bbc8f9de 4375 }
3fadfdf1 4376 /* Reserve some (more) space
b2d41e21
SH		 4377 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4378 * this is only address space not memory...
bbc8f9de
NIS		 4379 * Note this is a little sneaky, 1st call passes NULL as reserved
4380 * so lets system choose where we start, subsequent calls pass
4381 * the old end address so ask for a contiguous block
4382 */
b2d41e21
SH		 4383sbrk_reserve:
4384 if (size < 64*1024*1024)
4385 size = 64*1024*1024;
4386 size = ((size + pagesize - 1) / pagesize) * pagesize;
161b471a 4387 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
bbc8f9de
NIS		 4388 if (addr)
4389 {
4390 reserved = addr+size;
4391 if (!base)
4392 base = addr;
4393 if (!committed)
4394 committed = base;
4395 if (!brk)
4396 brk = committed;
4397 }
b2d41e21
SH		 4398 else if (reserved)
4399 {
4400 /* The existing block could not be extended far enough, so decommit
4401 * anything that was just committed above and start anew */
4402 if (prev_committed)
4403 {
4404 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4405 return (void *) -1;
4406 }
4407 reserved = base = committed = brk = NULL;
4408 size = need;
4409 goto sbrk_reserve;
4410 }
bbc8f9de
NIS		 4411 else
4412 {
4413 return (void *) -1;
4414 }
4415 }
4416 result = brk;
4417 brk += need;
4418 if (brk > committed)
4419 {
4420 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
b2d41e21
SH		 4421 char *addr;
4422 if (committed+size > reserved)
4423 size = reserved-committed;
4424 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de 4425 if (addr)
b2d41e21 4426 committed += size;
bbc8f9de
NIS		 4427 else
4428 return (void *) -1;
4429 }
4430 return result;
4431}
4432
4433#endif
4434#endif
4435
84902520
TB		 4436DllExport void*
4437win32_malloc(size_t size)
4438{
390b85e7 4439 return malloc(size);
84902520
TB		 4440}
4441
4442DllExport void*
4443win32_calloc(size_t numitems, size_t size)
4444{
390b85e7 4445 return calloc(numitems,size);
84902520
TB		 4446}
4447
4448DllExport void*
4449win32_realloc(void *block, size_t size)
4450{
390b85e7 4451 return realloc(block,size);
84902520
TB		 4452}
4453
4454DllExport void
4455win32_free(void *block)
4456{
390b85e7 4457 free(block);
84902520
TB		 4458}
4459
bbc8f9de 4460
6e21dc91 4461DllExport int
c623ac67 4462win32_open_osfhandle(intptr_t handle, int flags)
0a753a76 4463{
9e5f57de
GS		 4464#ifdef USE_FIXED_OSFHANDLE
4465 if (IsWin95())
4466 return my_open_osfhandle(handle, flags);
4467#endif
390b85e7 4468 return _open_osfhandle(handle, flags);
0a753a76 4469}
4470
6e21dc91 4471DllExport intptr_t
65e48ea9 4472win32_get_osfhandle(int fd)
0a753a76 4473{
c623ac67 4474 return (intptr_t)_get_osfhandle(fd);
0a753a76 4475}
7bac28a0 4476
6e21dc91 4477DllExport FILE *
30753f56
NIS		 4478win32_fdupopen(FILE *pf)
4479{
4480 FILE* pfdup;
4481 fpos_t pos;
4482 char mode[3];
4483 int fileno = win32_dup(win32_fileno(pf));
4484
4485 /* open the file in the same mode */
4486#ifdef __BORLANDC__
4487 if((pf)->flags & _F_READ) {
4488 mode[0] = 'r';
4489 mode[1] = 0;
4490 }
4491 else if((pf)->flags & _F_WRIT) {
4492 mode[0] = 'a';
4493 mode[1] = 0;
4494 }
4495 else if((pf)->flags & _F_RDWR) {
4496 mode[0] = 'r';
4497 mode[1] = '+';
4498 mode[2] = 0;
4499 }
4500#else
4501 if((pf)->_flag & _IOREAD) {
4502 mode[0] = 'r';
4503 mode[1] = 0;
4504 }
4505 else if((pf)->_flag & _IOWRT) {
4506 mode[0] = 'a';
4507 mode[1] = 0;
4508 }
4509 else if((pf)->_flag & _IORW) {
4510 mode[0] = 'r';
4511 mode[1] = '+';
4512 mode[2] = 0;
4513 }
4514#endif
4515
4516 /* it appears that the binmode is attached to the
4517 * file descriptor so binmode files will be handled
4518 * correctly
4519 */
4520 pfdup = win32_fdopen(fileno, mode);
4521
4522 /* move the file pointer to the same position */
4523 if (!fgetpos(pf, &pos)) {
4524 fsetpos(pfdup, &pos);
4525 }
4526 return pfdup;
4527}
4528
0cb96387 4529DllExport void*
c5be433b 4530win32_dynaload(const char* filename)
0cb96387 4531{
acfe0abc 4532 dTHX;
32f99636
GS		 4533 char buf[MAX_PATH+1];
4534 char *first;
4535
4536 /* LoadLibrary() doesn't recognize forward slashes correctly,
4537 * so turn 'em back. */
4538 first = strchr(filename, '/');
4539 if (first) {
4540 STRLEN len = strlen(filename);
4541 if (len <= MAX_PATH) {
4542 strcpy(buf, filename);
4543 filename = &buf[first - filename];
4544 while (*filename) {
4545 if (*filename == '/')
4546 *(char*)filename = '\\';
4547 ++filename;
4548 }
4549 filename = buf;
4550 }
4551 }
8c56068e 4552 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS		 4553}
4554
5bd7e777
JD		 4555XS(w32_SetChildShowWindow)
4556{
4557 dXSARGS;
4558 BOOL use_showwindow = w32_use_showwindow;
4559 /* use "unsigned short" because Perl has redefined "WORD" */
4560 unsigned short showwindow = w32_showwindow;
4561
4562 if (items > 1)
4563 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4564
4565 if (items == 0 || !SvOK(ST(0)))
4566 w32_use_showwindow = FALSE;
4567 else {
4568 w32_use_showwindow = TRUE;
4569 w32_showwindow = (unsigned short)SvIV(ST(0));
4570 }
4571
4572 EXTEND(SP, 1);
4573 if (use_showwindow)
4574 ST(0) = sv_2mortal(newSViv(showwindow));
4575 else
4576 ST(0) = &PL_sv_undef;
4577 XSRETURN(1);
4578}
4579
ad2e33dc 4580void
c5be433b 4581Perl_init_os_extras(void)
ad2e33dc 4582{
acfe0abc 4583 dTHX;
ad2e33dc 4584 char *file = __FILE__;
ad2e33dc 4585
9fb265f7
JD		 4586 /* Initialize Win32CORE if it has been statically linked. */
4587 void (*pfn_init)(pTHX);
4588#if defined(__BORLANDC__)
4589 /* makedef.pl seems to have given up on fixing this issue in the .def file */
4590 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4591#else
4592 pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4593#endif
4594 if (pfn_init)
4595 pfn_init(aTHX);
78ff2d7b 4596
02637f4c 4597 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
ad2e33dc
GS		 4598}
4599
f4958739 4600void *
1018e26f 4601win32_signal_context(void)
c843839f
NIS		 4602{
4603 dTHX;
f4958739 4604#ifdef MULTIPLICITY
c843839f 4605 if (!my_perl) {
1018e26f 4606 my_perl = PL_curinterp;
c843839f 4607 PERL_SET_THX(my_perl);
3fadfdf1 4608 }
1018e26f 4609 return my_perl;
f4958739 4610#else
d9a047f6
GS		 4611 return PL_curinterp;
4612#endif
1018e26f
NIS		 4613}
4614
96116d93 4615
3fadfdf1 4616BOOL WINAPI
1018e26f
NIS		 4617win32_ctrlhandler(DWORD dwCtrlType)
4618{
96116d93 4619#ifdef MULTIPLICITY
1018e26f
NIS		 4620 dTHXa(PERL_GET_SIG_CONTEXT);
4621
4622 if (!my_perl)
4623 return FALSE;
96116d93 4624#endif
c843839f
NIS		 4625
4626 switch(dwCtrlType) {
4627 case CTRL_CLOSE_EVENT:
3fadfdf1
NIS		 4628 /* A signal that the system sends to all processes attached to a console when
4629 the user closes the console (either by choosing the Close command from the
4630 console window's System menu, or by choosing the End Task command from the
c843839f
NIS		 4631 Task List
4632 */
3fadfdf1
NIS		 4633 if (do_raise(aTHX_ 1)) /* SIGHUP */
4634 sig_terminate(aTHX_ 1);
4635 return TRUE;
c843839f
NIS		 4636
4637 case CTRL_C_EVENT:
4638 /* A CTRL+c signal was received */
3fadfdf1
NIS		 4639 if (do_raise(aTHX_ SIGINT))
4640 sig_terminate(aTHX_ SIGINT);
4641 return TRUE;
c843839f
NIS		 4642
4643 case CTRL_BREAK_EVENT:
4644 /* A CTRL+BREAK signal was received */
3fadfdf1
NIS		 4645 if (do_raise(aTHX_ SIGBREAK))
4646 sig_terminate(aTHX_ SIGBREAK);
4647 return TRUE;
c843839f
NIS		 4648
4649 case CTRL_LOGOFF_EVENT:
3fadfdf1
NIS		 4650 /* A signal that the system sends to all console processes when a user is logging
4651 off. This signal does not indicate which user is logging off, so no
4652 assumptions can be made.
c843839f 4653 */
3fadfdf1 4654 break;
c843839f 4655 case CTRL_SHUTDOWN_EVENT:
3fadfdf1
NIS		 4656 /* A signal that the system sends to all console processes when the system is
4657 shutting down.
c843839f 4658 */
3fadfdf1
NIS		 4659 if (do_raise(aTHX_ SIGTERM))
4660 sig_terminate(aTHX_ SIGTERM);
4661 return TRUE;
c843839f 4662 default:
3fadfdf1 4663 break;
c843839f
NIS		 4664 }
4665 return FALSE;
4666}
c843839f
NIS		 4667
4668
58d049f0 4669#ifdef SET_INVALID_PARAMETER_HANDLER
0448a0bd
SH		 4670# include <crtdbg.h>
4671#endif
4672
dc0472e9
JD		 4673static void
4674ansify_path(void)
4675{
dc0472e9
JD		 4676 size_t len;
4677 char *ansi_path;
4678 WCHAR *wide_path;
4679 WCHAR *wide_dir;
4680
3839a0fa
JD		 4681 /* win32_ansipath() requires Windows 2000 or later */
4682 if (!IsWin2000())
dc0472e9
JD		 4683 return;
4684
4685 /* fetch Unicode version of PATH */
4686 len = 2000;
4687 wide_path = win32_malloc(len*sizeof(WCHAR));
4688 while (wide_path) {
4689 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4690 if (newlen < len)
4691 break;
4692 len = newlen;
4693 wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4694 }
4695 if (!wide_path)
4696 return;
4697
4698 /* convert to ANSI pathnames */
4699 wide_dir = wide_path;
4700 ansi_path = NULL;
4701 while (wide_dir) {
4702 WCHAR *sep = wcschr(wide_dir, ';');
4703 char *ansi_dir;
4704 size_t ansi_len;
4705 size_t wide_len;
4706
4707 if (sep)
4708 *sep++ = '\0';
4709
4710 /* remove quotes around pathname */
4711 if (*wide_dir == '"')
4712 ++wide_dir;
4713 wide_len = wcslen(wide_dir);
4714 if (wide_len && wide_dir[wide_len-1] == '"')
4715 wide_dir[wide_len-1] = '\0';
4716
4717 /* append ansi_dir to ansi_path */
4718 ansi_dir = win32_ansipath(wide_dir);
4719 ansi_len = strlen(ansi_dir);
4720 if (ansi_path) {
4721 size_t newlen = len + 1 + ansi_len;
4722 ansi_path = win32_realloc(ansi_path, newlen+1);
4723 if (!ansi_path)
4724 break;
4725 ansi_path[len] = ';';
4726 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4727 len = newlen;
4728 }
4729 else {
4730 len = ansi_len;
4731 ansi_path = win32_malloc(5+len+1);
4732 if (!ansi_path)
4733 break;
4734 memcpy(ansi_path, "PATH=", 5);
4735 memcpy(ansi_path+5, ansi_dir, len+1);
4736 len += 5;
4737 }
4738 win32_free(ansi_dir);
4739 wide_dir = sep;
4740 }
4741
4742 if (ansi_path) {
4743 /* Update C RTL environ array. This will only have full effect if
4744 * perl_parse() is later called with `environ` as the `env` argument.
4745 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4746 *
4747 * We do have to ansify() the PATH before Perl has been fully
4748 * initialized because S_find_script() uses the PATH when perl
4749 * is being invoked with the -S option. This happens before %ENV
4750 * is initialized in S_init_postdump_symbols().
4751 *
4752 * XXX Is this a bug? Should S_find_script() use the environment
4753 * XXX passed in the `env` arg to parse_perl()?
4754 */
4755 putenv(ansi_path);
4756 /* Keep system environment in sync because S_init_postdump_symbols()
4757 * will not call mg_set() if it initializes %ENV from `environ`.
4758 */
4759 SetEnvironmentVariableA("PATH", ansi_path+5);
3e5d884e
JD		 4760 /* We are intentionally leaking the ansi_path string here because
4761 * the Borland runtime library puts it directly into the environ
4762 * array. The Microsoft runtime library seems to make a copy,
4763 * but will leak the copy should it be replaced again later.
4764 * Since this code is only called once during PERL_SYS_INIT this
4765 * shouldn't really matter.
4766 */
dc0472e9
JD		 4767 }
4768 win32_free(wide_path);
4769}
c843839f 4770
3e5d884e
JD		 4771void
4772Perl_win32_init(int *argcp, char ***argvp)
4773{
4774 HMODULE module;
4775
58d049f0 4776#ifdef SET_INVALID_PARAMETER_HANDLER
3e5d884e
JD		 4777 _invalid_parameter_handler oldHandler, newHandler;
4778 newHandler = my_invalid_parameter_handler;
4779 oldHandler = _set_invalid_parameter_handler(newHandler);
4780 _CrtSetReportMode(_CRT_ASSERT, 0);
4781#endif
4782 /* Disable floating point errors, Perl will trap the ones we
4783 * care about. VC++ RTL defaults to switching these off
4784 * already, but the Borland RTL doesn't. Since we don't
4785 * want to be at the vendor's whim on the default, we set
4786 * it explicitly here.
4787 */
4788#if !defined(_ALPHA_) && !defined(__GNUC__)
4789 _control87(MCW_EM, MCW_EM);
4790#endif
4791 MALLOC_INIT;
4792
4793 module = GetModuleHandle("ntdll.dll");
4794 if (module) {
4795 *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4796 }
4797
4798 module = GetModuleHandle("kernel32.dll");
4799 if (module) {
4800 *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4801 *(FARPROC*)&pfnProcess32First = GetProcAddress(module, "Process32First");
4802 *(FARPROC*)&pfnProcess32Next = GetProcAddress(module, "Process32Next");
4803 }
4804
4805 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4806 GetVersionEx(&g_osver);
4807
4808 ansify_path();
4809}
4810
4811void
4812Perl_win32_term(void)
4813{
4814 dTHX;
4815 HINTS_REFCNT_TERM;
4816 OP_REFCNT_TERM;
4817 PERLIO_TERM;
4818 MALLOC_TERM;
4819}
4820
4821void
4822win32_get_child_IO(child_IO_table* ptbl)
4823{
4824 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4825 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4826 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4827}
4828
4829Sighandler_t
4830win32_signal(int sig, Sighandler_t subcode)
4831{
4832 dTHX;
4833 if (sig < SIG_SIZE) {
4834 int save_errno = errno;
4835 Sighandler_t result = signal(sig, subcode);
4836 if (result == SIG_ERR) {
4837 result = w32_sighandler[sig];
4838 errno = save_errno;
4839 }
4840 w32_sighandler[sig] = subcode;
4841 return result;
4842 }
4843 else {
4844 errno = EINVAL;
4845 return SIG_ERR;
4846 }
4847}
4848
099b16d3
RM		 4849/* The PerlMessageWindowClass's WindowProc */
4850LRESULT CALLBACK
4851win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4852{
4853 return win32_process_message(hwnd, msg, wParam, lParam) ?
4854 0 : DefWindowProc(hwnd, msg, wParam, lParam);
4855}
4856
4857/* we use a message filter hook to process thread messages, passing any
4858 * messages that we don't process on to the rest of the hook chain
4859 * Anyone else writing a message loop that wants to play nicely with perl
4860 * should do
4861 * CallMsgFilter(&msg, MSGF_***);
4862 * between their GetMessage and DispatchMessage calls. */
4863LRESULT CALLBACK
4864win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4865 LPMSG pmsg = (LPMSG)lParam;
4866
4867 /* we'll process it if code says we're allowed, and it's a thread message */
4868 if (code >= 0 && pmsg->hwnd == NULL
4869 && win32_process_message(pmsg->hwnd, pmsg->message,
4870 pmsg->wParam, pmsg->lParam))
4871 {
4872 return TRUE;
4873 }
4874
4875 /* XXX: MSDN says that hhk is ignored, but we should really use the
4876 * return value from SetWindowsHookEx() in win32_create_message_window(). */
4877 return CallNextHookEx(NULL, code, wParam, lParam);
4878}
4879
4880/* The real message handler. Can be called with
4881 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4882 * that it processes */
4883static LRESULT
4884win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4885{
4886 /* BEWARE. The context retrieved using dTHX; is the context of the
4887 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4888 * up to and including WM_CREATE. If it ever happens that you need the
4889 * 'child' context before this, then it needs to be passed into
4890 * win32_create_message_window(), and passed to the WM_NCCREATE handler
4891 * from the lparam of CreateWindow(). It could then be stored/retrieved
4892 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4893 * the dTHX calls here. */
4894 /* XXX For now it is assumed that the overhead of the dTHX; for what
4895 * are relativley infrequent code-paths, is better than the added
4896 * complexity of getting the correct context passed into
4897 * win32_create_message_window() */
4898
4899 switch(msg) {
4900
4901#ifdef USE_ITHREADS
4902 case WM_USER_MESSAGE: {
4903 long child = find_pseudo_pid((int)wParam);
4904 if (child >= 0) {
4905 dTHX;
4906 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4907 return 1;
4908 }
4909 break;
4910 }
4911#endif
4912
4913 case WM_USER_KILL: {
4914 dTHX;
4915 /* We use WM_USER_KILL to fake kill() with other signals */
4916 int sig = (int)wParam;
4917 if (do_raise(aTHX_ sig))
4918 sig_terminate(aTHX_ sig);
4919
4920 return 1;
4921 }
4922
4923 case WM_TIMER: {
4924 dTHX;
4925 /* alarm() is a one-shot but SetTimer() repeats so kill it */
4926 if (w32_timerid && w32_timerid==(UINT)wParam) {
4927 KillTimer(w32_message_hwnd, w32_timerid);
4928 w32_timerid=0;
4929
4930 /* Now fake a call to signal handler */
4931 if (do_raise(aTHX_ 14))
4932 sig_terminate(aTHX_ 14);
4933
4934 return 1;
4935 }
4936 break;
4937 }
4938
4939 default:
4940 break;
4941
4942 } /* switch */
4943
4944 /* Above or other stuff may have set a signal flag, and we may not have
4945 * been called from win32_async_check() (e.g. some other GUI's message
4946 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
4947 * handler that die's, and the message loop that calls here is wrapped
4948 * in an eval, then you may well end up with orphaned windows - signals
4949 * are dispatched by win32_async_check() */
4950
4951 return 0;
4952}
4953
4954void
0934c9d9 4955win32_create_message_window_class(void)
099b16d3
RM		 4956{
4957 /* create the window class for "message only" windows */
4958 WNDCLASS wc;
4959
4960 Zero(&wc, 1, wc);
4961 wc.lpfnWndProc = win32_message_window_proc;
4962 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4963 wc.lpszClassName = "PerlMessageWindowClass";
4964
4965 /* second and subsequent calls will fail, but class
4966 * will already be registered */
4967 RegisterClass(&wc);
4968}
4969
aeecf691 4970HWND
0934c9d9 4971win32_create_message_window(void)
aeecf691 4972{
099b16d3
RM		 4973 HWND hwnd = NULL;
4974
aeecf691
JD		 4975 /* "message-only" windows have been implemented in Windows 2000 and later.
4976 * On earlier versions we'll continue to post messages to a specific
4977 * thread and use hwnd==NULL. This is brittle when either an embedding
4978 * application or an XS module is also posting messages to hwnd=NULL
4979 * because once removed from the queue they cannot be delivered to the
4980 * "right" place with DispatchMessage() anymore, as there is no WindowProc
4981 * if there is no window handle.
4982 */
099b16d3
RM		 4983 /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4984 * documentation to the contrary, however, there is some evidence that
4985 * there may be problems with the implementation on Win98. As it is not
4986 * officially supported we take the cautious route and stick with thread
4987 * messages (hwnd == NULL) on platforms prior to Win2k.
4988 */
4989 if (IsWin2000()) {
4990 win32_create_message_window_class();
aeecf691 4991
099b16d3
RM		 4992 hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4993 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4994 }
4995
4996 /* If we din't create a window for any reason, then we'll use thread
4997 * messages for our signalling, so we install a hook which
4998 * is called by CallMsgFilter in win32_async_check(), or any other
4999 * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5000 * that use OLE, etc. */
5001 if(!hwnd) {
5002 SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5003 NULL, GetCurrentThreadId());
5004 }
5005
5006 return hwnd;
aeecf691
JD		 5007}
5008
a33ef3f0
SH		 5009#ifdef HAVE_INTERP_INTERN
5010
5011static void
5012win32_csighandler(int sig)
5013{
5014#if 0
5015 dTHXa(PERL_GET_SIG_CONTEXT);
5016 Perl_warn(aTHX_ "Got signal %d",sig);
5017#endif
5018 /* Does nothing */
5019}
5020
edb113cf 5021#if defined(__MINGW32__) && defined(__cplusplus)
beeded0b
YO		 5022#define CAST_HWND__(x) (HWND__*)(x)
5023#else
5024#define CAST_HWND__(x) x
5025#endif
5026
7766f137 5027void
52853b95
GS		 5028Perl_sys_intern_init(pTHX)
5029{
3fadfdf1 5030 int i;
aeecf691 5031
4e205ed6 5032 w32_perlshell_tokens = NULL;
52853b95
GS		 5033 w32_perlshell_vec = (char**)NULL;
5034 w32_perlshell_items = 0;
5035 w32_fdpid = newAV();
a02a5408 5036 Newx(w32_children, 1, child_tab);
52853b95
GS		 5037 w32_num_children = 0;
5038# ifdef USE_ITHREADS
5039 w32_pseudo_id = 0;
aeecf691 5040 Newx(w32_pseudo_children, 1, pseudo_child_tab);
52853b95
GS		 5041 w32_num_pseudo_children = 0;
5042# endif
222c300a 5043 w32_timerid = 0;
beeded0b 5044 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
05ec9bb3 5045 w32_poll_count = 0;
3fadfdf1
NIS		 5046 for (i=0; i < SIG_SIZE; i++) {
5047 w32_sighandler[i] = SIG_DFL;
5048 }
00967642 5049# ifdef MULTIPLICITY
1018e26f 5050 if (my_perl == PL_curinterp) {
96116d93
MB		 5051# else
5052 {
5053# endif
3fadfdf1 5054 /* Force C runtime signal stuff to set its console handler */
1c127fab
SH		 5055 signal(SIGINT,win32_csighandler);
5056 signal(SIGBREAK,win32_csighandler);
0a311364
JD		 5057
5058 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5059 * flag. This has the side-effect of disabling Ctrl-C events in all
5060 * processes in this group. At least on Windows NT and later we
5061 * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5062 * with a NULL handler. This is not valid on Windows 9X.
5063 */
5064 if (IsWinNT())
5065 SetConsoleCtrlHandler(NULL,FALSE);
5066
3fadfdf1 5067 /* Push our handler on top */
c843839f
NIS		 5068 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5069 }
52853b95
GS		 5070}
5071
3dbbd0f5
GS		 5072void
5073Perl_sys_intern_clear(pTHX)
5074{
5075 Safefree(w32_perlshell_tokens);
5076 Safefree(w32_perlshell_vec);
5077 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5078 Safefree(w32_children);
222c300a 5079 if (w32_timerid) {
aeecf691
JD		 5080 KillTimer(w32_message_hwnd, w32_timerid);
5081 w32_timerid = 0;
222c300a 5082 }
aeecf691
JD		 5083 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5084 DestroyWindow(w32_message_hwnd);
96116d93 5085# ifdef MULTIPLICITY
1018e26f 5086 if (my_perl == PL_curinterp) {
96116d93
MB		 5087# else
5088 {
5089# endif
c843839f 5090 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
c843839f 5091 }
3dbbd0f5
GS		 5092# ifdef USE_ITHREADS
5093 Safefree(w32_pseudo_children);
5094# endif
5095}
5096
52853b95
GS		 5097# ifdef USE_ITHREADS
5098
5099void
7766f137
GS		 5100Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5101{
7918f24d
NC		 5102 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5103
4e205ed6 5104 dst->perlshell_tokens = NULL;
7766f137
GS		 5105 dst->perlshell_vec = (char**)NULL;
5106 dst->perlshell_items = 0;
5107 dst->fdpid = newAV();
a02a5408 5108 Newxz(dst->children, 1, child_tab);
7766f137 5109 dst->pseudo_id = 0;
aeecf691
JD		 5110 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5111 dst->timerid = 0;
beeded0b 5112 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
aeecf691 5113 dst->poll_count = 0;
3fadfdf1 5114 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
7766f137 5115}
52853b95
GS		 5116# endif /* USE_ITHREADS */
5117#endif /* HAVE_INTERP_INTERN */
Unnamed repository; edit this file 'description' to name the repository.