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