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