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