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