This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
win32: remove support for disabling USE_LARGE_FILES
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745
PP
1/* WIN32.C
2 *
3fadfdf1 3 * (c) 1995 Microsoft Corporation. All rights reserved.
0d130a44 4 * Developed by hip communications inc.
68dc0745
PP
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
PP
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
PP
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
PP
62#include <string.h>
63#include <stdarg.h>
ad2e33dc 64#include <float.h>
ad0751ec 65#include <time.h>
4eab039d 66#include <sys/utime.h>
81a306d4 67#include <wchar.h>
8cbe99e5 68
5b0d9cbe 69#ifdef __GNUC__
3fadfdf1 70/* Mingw32 defaults to globing command line
5b0d9cbe
NIS
71 * So we turn it off like this:
72 */
73int _CRT_glob = 0;
74#endif
75
7c5b6093
AB
76#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
77/* Mingw32-1.1 is missing some prototypes */
d06fc7d4 78START_EXTERN_C
f8fb7c90
GS
79FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
82int _flushall();
83int _fcloseall();
d06fc7d4 84END_EXTERN_C
2b260de0
GS
85#endif
86
6890e559
GS
87#define EXECF_EXEC 1
88#define EXECF_SPAWN 2
89#define EXECF_SPAWN_NOWAIT 3
90
32e30700 91#if defined(PERL_IMPLICIT_SYS)
32e30700
GS
92# undef getlogin
93# define getlogin g_getlogin
94#endif
95
58d049f0
JD
96/* VS2005 (MSC version 14) provides a mechanism to set an invalid
97 * parameter handler. This functionality is not available in the
98 * 64-bit compiler from the Platform SDK, which unfortunately also
99 * believes itself to be MSC version 14.
100 *
101 * There is no #define related to _set_invalid_parameter_handler(),
102 * but we can check for one of the constants defined for
103 * _set_abort_behavior(), which was introduced into stdlib.h at
104 * the same time.
105 */
106
107#if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG)
108# define SET_INVALID_PARAMETER_HANDLER
109#endif
110
111#ifdef SET_INVALID_PARAMETER_HANDLER
d52ca586 112static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
e2cd629f
SH
113static void my_invalid_parameter_handler(const wchar_t* expression,
114 const wchar_t* function, const wchar_t* file,
115 unsigned int line, uintptr_t pReserved);
116#endif
117
6937817d 118#ifndef WIN32_NO_REGISTRY
e2cd629f
SH
119static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
120static char* get_regstr(const char *valuename, SV **svp);
6937817d
DD
121#endif
122
e2cd629f
SH
123static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
124 char *trailing, ...);
6937817d
DD
125static char* win32_get_xlib(const char *pl,
126 WIN32_NO_REGISTRY_M_(const char *xlib)
e2cd629f 127 const char *libname, STRLEN *const len);
6937817d 128
e2cd629f
SH
129static BOOL has_shell_metachars(const char *ptr);
130static long tokenize(const char *str, char **dest, char ***destv);
131static void get_shell(void);
132static char* find_next_space(const char *s);
133static int do_spawn2(pTHX_ const char *cmd, int exectype);
f06c8825
TC
134static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
135 const int *handles);
136static int do_spawnvp_handles(int mode, const char *cmdname,
137 const char * const *argv, const int *handles);
aac983ac
TC
138static PerlIO * do_popen(const char *mode, const char *command, IV narg,
139 SV **args);
04a2c3d9 140static long find_pid(pTHX_ int pid);
e2cd629f
SH
141static void remove_dead_process(long child);
142static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
721b2674 143static int my_killpg(int pid, int sig);
e2cd629f
SH
144static int my_kill(int pid, int sig);
145static void out_of_memory(void);
00a0ae28 146static char* wstr_to_str(const wchar_t* wstr);
e2cd629f
SH
147static long filetime_to_clock(PFILETIME ft);
148static BOOL filetime_from_time(PFILETIME ft, time_t t);
149static char* create_command_line(char *cname, STRLEN clen,
aac983ac 150 const char * const *args);
f5fe1b19 151static char* qualified_path(const char *cmd, bool other_exts);
e2cd629f
SH
152static void ansify_path(void);
153static LRESULT win32_process_message(HWND hwnd, UINT msg,
154 WPARAM wParam, LPARAM lParam);
155
156#ifdef USE_ITHREADS
04a2c3d9 157static long find_pseudo_pid(pTHX_ int pid);
e2cd629f
SH
158static void remove_dead_pseudo_process(long child);
159static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
160#endif
161
162#ifdef HAVE_INTERP_INTERN
163static void win32_csighandler(int sig);
164#endif
165
166START_EXTERN_C
167HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
168char w32_module_name[MAX_PATH+1];
b47a847f
DD
169#ifdef WIN32_DYN_IOINFO_SIZE
170Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */
171#endif
e2cd629f
SH
172END_EXTERN_C
173
174static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
175
6937817d 176#ifndef WIN32_NO_REGISTRY
0517ed38
DD
177/* initialized by Perl_win32_init/PERL_SYS_INIT */
178static HKEY HKCU_Perl_hnd;
179static HKEY HKLM_Perl_hnd;
6937817d 180#endif
0517ed38 181
e2cd629f 182#ifdef SET_INVALID_PARAMETER_HANDLER
d52ca586
SH
183static BOOL silent_invalid_parameter_handler = FALSE;
184
185static BOOL
186set_silent_invalid_parameter_handler(BOOL newvalue)
187{
d52ca586 188 BOOL oldvalue = silent_invalid_parameter_handler;
adb86be5 189# ifdef _DEBUG
d52ca586 190 silent_invalid_parameter_handler = newvalue;
d52ca586 191# endif
adb86be5 192 return oldvalue;
d52ca586
SH
193}
194
e2cd629f
SH
195static void
196my_invalid_parameter_handler(const wchar_t* expression,
0448a0bd
SH
197 const wchar_t* function,
198 const wchar_t* file,
199 unsigned int line,
200 uintptr_t pReserved)
201{
202# ifdef _DEBUG
00a0ae28
SH
203 char* ansi_expression;
204 char* ansi_function;
205 char* ansi_file;
d52ca586
SH
206 if (silent_invalid_parameter_handler)
207 return;
00a0ae28
SH
208 ansi_expression = wstr_to_str(expression);
209 ansi_function = wstr_to_str(function);
210 ansi_file = wstr_to_str(file);
211 fprintf(stderr, "Invalid parameter detected in function %s. "
212 "File: %s, line: %d\n", ansi_function, ansi_file, line);
213 fprintf(stderr, "Expression: %s\n", ansi_expression);
214 free(ansi_expression);
215 free(ansi_function);
216 free(ansi_file);
0448a0bd
SH
217# endif
218}
219#endif
220
2fa86c13
GS
221EXTERN_C void
222set_w32_module_name(void)
223{
aa2b96ec 224 /* this function may be called at DLL_PROCESS_ATTACH time */
2fa86c13 225 char* ptr;
aa2b96ec
JD
226 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
227 ? GetModuleHandle(NULL)
228 : w32_perldll_handle);
2fa86c13 229
0e7b7035
SH
230 WCHAR modulename[MAX_PATH];
231 WCHAR fullname[MAX_PATH];
232 char *ansi;
233
234 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
235 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
236 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
237
238 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
239
240 /* Make sure we get an absolute pathname in case the module was loaded
241 * explicitly by LoadLibrary() with a relative path. */
242 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
243
244 /* Make sure we start with the long path name of the module because we
245 * later scan for pathname components to match "5.xx" to locate
246 * compatible sitelib directories, and the short pathname might mangle
247 * this path segment (e.g. by removing the dot on NTFS to something
248 * like "5xx~1.yy") */
249 if (pfnGetLongPathNameW)
250 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
251
252 /* remove \\?\ prefix */
253 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
254 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
255
256 ansi = win32_ansipath(fullname);
257 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
258 win32_free(ansi);
2fa86c13
GS
259
260 /* normalize to forward slashes */
261 ptr = w32_module_name;
262 while (*ptr) {
263 if (*ptr == '\\')
264 *ptr = '/';
265 ++ptr;
266 }
267}
268
6937817d 269#ifndef WIN32_NO_REGISTRY
c5be433b 270/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 271static char*
0517ed38 272get_regstr_from(HKEY handle, const char *valuename, SV **svp)
349ad1fe
GS
273{
274 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
00dc2f4f 275 DWORD type;
4e205ed6 276 char *str = NULL;
00dc2f4f 277 long retval;
0517ed38 278 DWORD datalen;
00dc2f4f 279
0517ed38
DD
280 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
281 if (retval == ERROR_SUCCESS
282 && (type == REG_SZ || type == REG_EXPAND_SZ))
283 {
284 dTHX;
285 if (!*svp)
286 *svp = sv_2mortal(newSVpvs(""));
287 SvGROW(*svp, datalen);
288 retval = RegQueryValueEx(handle, valuename, 0, NULL,
289 (PBYTE)SvPVX(*svp), &datalen);
290 if (retval == ERROR_SUCCESS) {
291 str = SvPVX(*svp);
292 SvCUR_set(*svp,datalen-1);
00dc2f4f 293 }
00dc2f4f 294 }
349ad1fe 295 return str;
00dc2f4f
GS
296}
297
c5be433b 298/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 299static char*
c5be433b 300get_regstr(const char *valuename, SV **svp)
00dc2f4f 301{
0517ed38
DD
302 char *str;
303 if (HKCU_Perl_hnd) {
304 str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
305 if (!str)
306 goto try_HKLM;
307 }
308 else {
309 try_HKLM:
310 if (HKLM_Perl_hnd)
311 str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
312 else
313 str = NULL;
314 }
349ad1fe 315 return str;
00dc2f4f 316}
6937817d 317#endif /* ifndef WIN32_NO_REGISTRY */
00dc2f4f 318
c5be433b 319/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
e5a95ffb 320static char *
e6a0bbf8 321get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
00dc2f4f 322{
dc9e4912 323 char base[10];
e5a95ffb 324 va_list ap;
e24c7c18 325 char mod_name[MAX_PATH+1];
00dc2f4f 326 char *ptr;
e5a95ffb
GS
327 char *optr;
328 char *strip;
273cf8d1 329 STRLEN baselen;
e5a95ffb
GS
330
331 va_start(ap, trailing_path);
332 strip = va_arg(ap, char *);
333
273cf8d1
GS
334 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
335 baselen = strlen(base);
dc9e4912 336
8ac9c18d 337 if (!*w32_module_name) {
2fa86c13 338 set_w32_module_name();
95140b98 339 }
8ac9c18d 340 strcpy(mod_name, w32_module_name);
95140b98 341 ptr = strrchr(mod_name, '/');
e5a95ffb
GS
342 while (ptr && strip) {
343 /* look for directories to skip back */
344 optr = ptr;
00dc2f4f 345 *ptr = '\0';
95140b98 346 ptr = strrchr(mod_name, '/');
1c39adb2
GS
347 /* avoid stripping component if there is no slash,
348 * or it doesn't match ... */
e5a95ffb 349 if (!ptr || stricmp(ptr+1, strip) != 0) {
273cf8d1 350 /* ... but not if component matches m|5\.$patchlevel.*| */
1c39adb2 351 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
a15aa957
KW
352 && strnEQ(strip, base, baselen)
353 && strnEQ(ptr+1, base, baselen)))
95140b98
GS
354 {
355 *optr = '/';
80252599
GS
356 ptr = optr;
357 }
00dc2f4f 358 }
e5a95ffb 359 strip = va_arg(ap, char *);
00dc2f4f 360 }
e5a95ffb
GS
361 if (!ptr) {
362 ptr = mod_name;
363 *ptr++ = '.';
95140b98 364 *ptr = '/';
00dc2f4f 365 }
e5a95ffb
GS
366 va_end(ap);
367 strcpy(++ptr, trailing_path);
368
dc9e4912 369 /* only add directory if it exists */
349ad1fe 370 if (GetFileAttributes(mod_name) != (DWORD) -1) {
dc9e4912 371 /* directory exists */
acfe0abc 372 dTHX;
c5be433b 373 if (!*prev_pathp)
c2b90b61 374 *prev_pathp = sv_2mortal(newSVpvs(""));
f0c8bec2 375 else if (SvPVX(*prev_pathp))
46e2868e 376 sv_catpvs(*prev_pathp, ";");
c5be433b 377 sv_catpv(*prev_pathp, mod_name);
e6a0bbf8
NC
378 if(len)
379 *len = SvCUR(*prev_pathp);
c5be433b 380 return SvPVX(*prev_pathp);
00dc2f4f 381 }
00dc2f4f 382
4e205ed6 383 return NULL;
00dc2f4f
GS
384}
385
73f2c082 386EXTERN_C char *
6937817d 387win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
00dc2f4f 388{
e5a95ffb 389 char *stdlib = "lib";
4e205ed6 390 SV *sv = NULL;
6937817d
DD
391#ifndef WIN32_NO_REGISTRY
392 char buffer[MAX_PATH+1];
00dc2f4f 393
e5a95ffb
GS
394 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
395 sprintf(buffer, "%s-%s", stdlib, pl);
c5be433b
GS
396 if (!get_regstr(buffer, &sv))
397 (void)get_regstr(stdlib, &sv);
6937817d 398#endif
00dc2f4f 399
e5a95ffb 400 /* $stdlib .= ";$EMD/../../lib" */
e6a0bbf8 401 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
00dc2f4f
GS
402}
403
4ea817c6 404static char *
6937817d
DD
405win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib)
406 const char *libname, STRLEN *const len)
00dc2f4f 407{
6937817d 408#ifndef WIN32_NO_REGISTRY
e5a95ffb 409 char regstr[40];
6937817d 410#endif
e24c7c18 411 char pathstr[MAX_PATH+1];
4e205ed6
SP
412 SV *sv1 = NULL;
413 SV *sv2 = NULL;
00dc2f4f 414
6937817d 415#ifndef WIN32_NO_REGISTRY
4ea817c6
GS
416 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
417 sprintf(regstr, "%s-%s", xlib, pl);
c5be433b 418 (void)get_regstr(regstr, &sv1);
6937817d 419#endif
e5a95ffb 420
4ea817c6
GS
421 /* $xlib .=
422 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
423 sprintf(pathstr, "%s/%s/lib", libname, pl);
e6a0bbf8 424 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
00dc2f4f 425
6937817d 426#ifndef WIN32_NO_REGISTRY
4ea817c6
GS
427 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
428 (void)get_regstr(xlib, &sv2);
6937817d 429#endif
00dc2f4f 430
4ea817c6
GS
431 /* $xlib .=
432 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
433 sprintf(pathstr, "%s/lib", libname);
e6a0bbf8 434 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
e5a95ffb 435
51371543 436 if (!sv1 && !sv2)
4e205ed6 437 return NULL;
e6a0bbf8
NC
438 if (!sv1) {
439 sv1 = sv2;
440 } else if (sv2) {
04a2c3d9 441 dTHX;
f8db7d5b 442 sv_catpvs(sv1, ";");
e6a0bbf8
NC
443 sv_catsv(sv1, sv2);
444 }
e5a95ffb 445
e6a0bbf8
NC
446 if (len)
447 *len = SvCUR(sv1);
349ad1fe 448 return SvPVX(sv1);
68dc0745 449}
0a753a76 450
73f2c082 451EXTERN_C char *
e6a0bbf8 452win32_get_sitelib(const char *pl, STRLEN *const len)
4ea817c6 453{
6937817d 454 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len);
4ea817c6
GS
455}
456
457#ifndef PERL_VENDORLIB_NAME
458# define PERL_VENDORLIB_NAME "vendor"
459#endif
460
73f2c082 461EXTERN_C char *
e6a0bbf8 462win32_get_vendorlib(const char *pl, STRLEN *const len)
4ea817c6 463{
6937817d 464 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len);
4ea817c6 465}
b4793f7f 466
2d7a9237 467static BOOL
08039b81 468has_shell_metachars(const char *ptr)
68dc0745
PP
469{
470 int inquote = 0;
471 char quote = '\0';
472
473 /*
474 * Scan string looking for redirection (< or >) or pipe
e200fe59
JD
475 * characters (|) that are not in a quoted string.
476 * Shell variable interpolation (%VAR%) can also happen inside strings.
68dc0745 477 */
9404a519 478 while (*ptr) {
68dc0745 479 switch(*ptr) {
e200fe59
JD
480 case '%':
481 return TRUE;
68dc0745
PP
482 case '\'':
483 case '\"':
9404a519
GS
484 if (inquote) {
485 if (quote == *ptr) {
68dc0745
PP
486 inquote = 0;
487 quote = '\0';
0a753a76 488 }
68dc0745
PP
489 }
490 else {
491 quote = *ptr;
492 inquote++;
493 }
494 break;
495 case '>':
496 case '<':
497 case '|':
9404a519 498 if (!inquote)
68dc0745
PP
499 return TRUE;
500 default:
501 break;
0a753a76 502 }
68dc0745
PP
503 ++ptr;
504 }
505 return FALSE;
0a753a76
PP
506}
507
32e30700 508#if !defined(PERL_IMPLICIT_SYS)
68dc0745
PP
509/* since the current process environment is being updated in util.c
510 * the library functions will get the correct environment
511 */
512PerlIO *
79d39d80 513Perl_my_popen(pTHX_ const char *cmd, const char *mode)
0a753a76 514{
45bc9206 515 PERL_FLUSHALL_FOR_CHILD;
0a753a76 516 return win32_popen(cmd, mode);
0a753a76
PP
517}
518
68dc0745 519long
4f63d024 520Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76
PP
521{
522 return win32_pclose(fp);
523}
c69f6586 524#endif
0a753a76 525
0cb96387
GS
526DllExport unsigned long
527win32_os_id(void)
0a753a76 528{
aeecf691 529 return (unsigned long)g_osver.dwPlatformId;
0a753a76
PP
530}
531
7766f137
GS
532DllExport int
533win32_getpid(void)
534{
535#ifdef USE_ITHREADS
acfe0abc 536 dTHX;
7766f137
GS
537 if (w32_pseudo_id)
538 return -((int)w32_pseudo_id);
539#endif
8cbe99e5 540 return _getpid();
7766f137
GS
541}
542
ce1da67e
GS
543/* Tokenize a string. Words are null-separated, and the list
544 * ends with a doubled null. Any character (except null and
545 * including backslash) may be escaped by preceding it with a
546 * backslash (the backslash will be stripped).
547 * Returns number of words in result buffer.
548 */
549static long
dff6d3cd 550tokenize(const char *str, char **dest, char ***destv)
ce1da67e 551{
4e205ed6 552 char *retstart = NULL;
ce1da67e
GS
553 char **retvstart = 0;
554 int items = -1;
555 if (str) {
556 int slen = strlen(str);
eb578fdb
KW
557 char *ret;
558 char **retv;
a02a5408
JC
559 Newx(ret, slen+2, char);
560 Newx(retv, (slen+3)/2, char*);
ce1da67e
GS
561
562 retstart = ret;
563 retvstart = retv;
564 *retv = ret;
565 items = 0;
566 while (*str) {
567 *ret = *str++;
568 if (*ret == '\\' && *str)
569 *ret = *str++;
570 else if (*ret == ' ') {
571 while (*str == ' ')
572 str++;
573 if (ret == retstart)
574 ret--;
575 else {
576 *ret = '\0';
577 ++items;
578 if (*str)
579 *++retv = ret+1;
580 }
581 }
582 else if (!*str)
583 ++items;
584 ret++;
585 }
4e205ed6 586 retvstart[items] = NULL;
ce1da67e
GS
587 *ret++ = '\0';
588 *ret = '\0';
589 }
590 *dest = retstart;
591 *destv = retvstart;
592 return items;
593}
594
595static void
2d7a9237 596get_shell(void)
0a753a76 597{
acfe0abc 598 dTHX;
ce1da67e 599 if (!w32_perlshell_tokens) {
174c211a
GS
600 /* we don't use COMSPEC here for two reasons:
601 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
602 * uncontrolled unportability of the ensuing scripts.
603 * 2. PERL5SHELL could be set to a shell that may not be fit for
604 * interactive use (which is what most programs look in COMSPEC
605 * for).
606 */
8cbe99e5 607 const char* defaultshell = "cmd.exe /x/d/c";
2fb9ab56 608 const char *usershell = PerlEnv_getenv("PERL5SHELL");
ce1da67e
GS
609 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
610 &w32_perlshell_tokens,
611 &w32_perlshell_vec);
68dc0745 612 }
0a753a76
PP
613}
614
68dc0745 615int
54725af6 616Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
0a753a76 617{
68dc0745 618 char **argv;
2d7a9237 619 char *str;
68dc0745 620 int status;
2d7a9237 621 int flag = P_WAIT;
68dc0745 622 int index = 0;
69374fe7 623 int eno;
68dc0745 624
7918f24d
NC
625 PERL_ARGS_ASSERT_DO_ASPAWN;
626
2d7a9237
GS
627 if (sp <= mark)
628 return -1;
68dc0745 629
ce1da67e 630 get_shell();
a02a5408 631 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
2d7a9237
GS
632
633 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
634 ++mark;
635 flag = SvIVx(*mark);
68dc0745
PP
636 }
637
9404a519 638 while (++mark <= sp) {
bb897dfc 639 if (*mark && (str = SvPV_nolen(*mark)))
2d7a9237
GS
640 argv[index++] = str;
641 else
642 argv[index++] = "";
68dc0745
PP
643 }
644 argv[index++] = 0;
3fadfdf1 645
2d7a9237 646 status = win32_spawnvp(flag,
bb897dfc 647 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
648 (const char* const*)argv);
649
69374fe7 650 if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) {
2d7a9237 651 /* possible shell-builtin, invoke with shell */
ce1da67e
GS
652 int sh_items;
653 sh_items = w32_perlshell_items;
2d7a9237
GS
654 while (--index >= 0)
655 argv[index+sh_items] = argv[index];
ce1da67e
GS
656 while (--sh_items >= 0)
657 argv[sh_items] = w32_perlshell_vec[sh_items];
3fadfdf1 658
2d7a9237 659 status = win32_spawnvp(flag,
bb897dfc 660 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
661 (const char* const*)argv);
662 }
68dc0745 663
922b1888 664 if (flag == P_NOWAIT) {
40c7cc6d 665 PL_statusvalue = -1; /* >16bits hint for pp_system() */
922b1888
GS
666 }
667 else {
50892819 668 if (status < 0) {
0453d815 669 if (ckWARN(WARN_EXEC))
f98bc0c6 670 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
50892819
GS
671 status = 255 * 256;
672 }
673 else
674 status *= 256;
b28d0864 675 PL_statusvalue = status;
5aabfad6 676 }
ce1da67e 677 Safefree(argv);
50892819 678 return (status);
68dc0745
PP
679}
680
dd7038b3
JH
681/* returns pointer to the next unquoted space or the end of the string */
682static char*
683find_next_space(const char *s)
684{
685 bool in_quotes = FALSE;
686 while (*s) {
687 /* ignore doubled backslashes, or backslash+quote */
688 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
689 s += 2;
690 }
691 /* keep track of when we're within quotes */
692 else if (*s == '"') {
693 s++;
694 in_quotes = !in_quotes;
695 }
696 /* break it up only at spaces that aren't in quotes */
697 else if (!in_quotes && isSPACE(*s))
698 return (char*)s;
699 else
700 s++;
701 }
702 return (char*)s;
703}
704
54725af6 705static int
f06c8825
TC
706do_spawn2(pTHX_ const char *cmd, int exectype) {
707 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
708}
709
710static int
711do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
68dc0745
PP
712{
713 char **a;
714 char *s;
715 char **argv;
716 int status = -1;
717 BOOL needToTry = TRUE;
2d7a9237 718 char *cmd2;
68dc0745 719
2d7a9237
GS
720 /* Save an extra exec if possible. See if there are shell
721 * metacharacters in it */
e200fe59 722 if (!has_shell_metachars(cmd)) {
a02a5408
JC
723 Newx(argv, strlen(cmd) / 2 + 2, char*);
724 Newx(cmd2, strlen(cmd) + 1, char);
68dc0745
PP
725 strcpy(cmd2, cmd);
726 a = argv;
727 for (s = cmd2; *s;) {
de030af3 728 while (*s && isSPACE(*s))
68dc0745
PP
729 s++;
730 if (*s)
731 *(a++) = s;
dd7038b3 732 s = find_next_space(s);
9404a519 733 if (*s)
68dc0745 734 *s++ = '\0';
0a753a76 735 }
4e205ed6 736 *a = NULL;
ce1da67e 737 if (argv[0]) {
6890e559
GS
738 switch (exectype) {
739 case EXECF_SPAWN:
740 status = win32_spawnvp(P_WAIT, argv[0],
741 (const char* const*)argv);
742 break;
743 case EXECF_SPAWN_NOWAIT:
f06c8825
TC
744 status = do_spawnvp_handles(P_NOWAIT, argv[0],
745 (const char* const*)argv, handles);
6890e559
GS
746 break;
747 case EXECF_EXEC:
748 status = win32_execvp(argv[0], (const char* const*)argv);
749 break;
750 }
2d7a9237 751 if (status != -1 || errno == 0)
68dc0745 752 needToTry = FALSE;
0a753a76 753 }
0a753a76 754 Safefree(argv);
68dc0745
PP
755 Safefree(cmd2);
756 }
2d7a9237 757 if (needToTry) {
ce1da67e
GS
758 char **argv;
759 int i = -1;
760 get_shell();
a02a5408 761 Newx(argv, w32_perlshell_items + 2, char*);
ce1da67e
GS
762 while (++i < w32_perlshell_items)
763 argv[i] = w32_perlshell_vec[i];
08039b81 764 argv[i++] = (char *)cmd;
4e205ed6 765 argv[i] = NULL;
6890e559
GS
766 switch (exectype) {
767 case EXECF_SPAWN:
768 status = win32_spawnvp(P_WAIT, argv[0],
769 (const char* const*)argv);
770 break;
771 case EXECF_SPAWN_NOWAIT:
f06c8825
TC
772 status = do_spawnvp_handles(P_NOWAIT, argv[0],
773 (const char* const*)argv, handles);
6890e559
GS
774 break;
775 case EXECF_EXEC:
776 status = win32_execvp(argv[0], (const char* const*)argv);
777 break;
778 }
ce1da67e
GS
779 cmd = argv[0];
780 Safefree(argv);
68dc0745 781 }
922b1888 782 if (exectype == EXECF_SPAWN_NOWAIT) {
40c7cc6d 783 PL_statusvalue = -1; /* >16bits hint for pp_system() */
922b1888
GS
784 }
785 else {
50892819 786 if (status < 0) {
0453d815 787 if (ckWARN(WARN_EXEC))
f98bc0c6 788 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
50892819
GS
789 (exectype == EXECF_EXEC ? "exec" : "spawn"),
790 cmd, strerror(errno));
791 status = 255 * 256;
792 }
793 else
794 status *= 256;
b28d0864 795 PL_statusvalue = status;
5aabfad6 796 }
50892819 797 return (status);
0a753a76
PP
798}
799
6890e559 800int
54725af6 801Perl_do_spawn(pTHX_ char *cmd)
6890e559 802{
7918f24d
NC
803 PERL_ARGS_ASSERT_DO_SPAWN;
804
54725af6 805 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
6890e559
GS
806}
807
2d7a9237 808int
54725af6 809Perl_do_spawn_nowait(pTHX_ char *cmd)
2d7a9237 810{
7918f24d
NC
811 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
812
54725af6 813 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
2d7a9237
GS
814}
815
6890e559 816bool
79d39d80 817Perl_do_exec(pTHX_ const char *cmd)
6890e559 818{
7918f24d
NC
819 PERL_ARGS_ASSERT_DO_EXEC;
820
08039b81 821 do_spawn2(aTHX_ cmd, EXECF_EXEC);
6890e559
GS
822 return FALSE;
823}
824
68dc0745
PP
825/* The idea here is to read all the directory names into a string table
826 * (separated by nulls) and when one of the other dir functions is called
827 * return the pointer to the current file name.
828 */
c5be433b 829DllExport DIR *
0e06f75d 830win32_opendir(const char *filename)
0a753a76 831{
04a2c3d9 832 dTHXa(NULL);
95136add 833 DIR *dirp;
9404a519
GS
834 long len;
835 long idx;
836 char scanname[MAX_PATH+3];
8cbe99e5 837 WCHAR wscanname[sizeof(scanname)];
35cf1ab6 838 WIN32_FIND_DATAW wFindData;
35cf1ab6 839 char buffer[MAX_PATH*2];
8cbe99e5 840 BOOL use_default;
9404a519
GS
841
842 len = strlen(filename);
525f9ba8
AD
843 if (len == 0) {
844 errno = ENOENT;
9404a519 845 return NULL;
525f9ba8
AD
846 }
847 if (len > MAX_PATH) {
848 errno = ENAMETOOLONG;
24caa93f 849 return NULL;
525f9ba8
AD
850 }
851
68dc0745 852 /* Get us a DIR structure */
a02a5408 853 Newxz(dirp, 1, DIR);
68dc0745
PP
854
855 /* Create the search pattern */
856 strcpy(scanname, filename);
23db2e2d
GS
857
858 /* bare drive name means look in cwd for drive */
859 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
860 scanname[len++] = '.';
861 scanname[len++] = '/';
862 }
863 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
9404a519 864 scanname[len++] = '/';
23db2e2d 865 }
9404a519
GS
866 scanname[len++] = '*';
867 scanname[len] = '\0';
68dc0745
PP
868
869 /* do the FindFirstFile call */
8cbe99e5 870 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
04a2c3d9 871 aTHXa(PERL_GET_THX);
8cbe99e5
JD
872 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
873
8c56068e 874 if (dirp->handle == INVALID_HANDLE_VALUE) {
95136add 875 DWORD err = GetLastError();
21e72512 876 /* FindFirstFile() fails on empty drives! */
95136add
GS
877 switch (err) {
878 case ERROR_FILE_NOT_FOUND:
879 return dirp;
880 case ERROR_NO_MORE_FILES:
881 case ERROR_PATH_NOT_FOUND:
882 errno = ENOENT;
883 break;
884 case ERROR_NOT_ENOUGH_MEMORY:
885 errno = ENOMEM;
886 break;
887 default:
888 errno = EINVAL;
889 break;
890 }
891 Safefree(dirp);
68dc0745
PP
892 return NULL;
893 }
894
8cbe99e5
JD
895 use_default = FALSE;
896 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
897 wFindData.cFileName, -1,
898 buffer, sizeof(buffer), NULL, &use_default);
899 if (use_default && *wFindData.cAlternateFileName) {
35cf1ab6 900 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
8cbe99e5
JD
901 wFindData.cAlternateFileName, -1,
902 buffer, sizeof(buffer), NULL, NULL);
35cf1ab6 903 }
8cbe99e5 904
68dc0745
PP
905 /* now allocate the first part of the string table for
906 * the filenames that we find.
907 */
8cbe99e5 908 idx = strlen(buffer)+1;
95136add 909 if (idx < 256)
35cf1ab6 910 dirp->size = 256;
95136add
GS
911 else
912 dirp->size = idx;
a02a5408 913 Newx(dirp->start, dirp->size, char);
8cbe99e5 914 strcpy(dirp->start, buffer);
95136add
GS
915 dirp->nfiles++;
916 dirp->end = dirp->curr = dirp->start;
917 dirp->end += idx;
918 return dirp;
0a753a76
PP
919}
920
921
68dc0745
PP
922/* Readdir just returns the current string pointer and bumps the
923 * string pointer to the nDllExport entry.
924 */
c5be433b 925DllExport struct direct *
ce2e26e5 926win32_readdir(DIR *dirp)
0a753a76 927{
95136add 928 long len;
0a753a76 929
68dc0745
PP
930 if (dirp->curr) {
931 /* first set up the structure to return */
932 len = strlen(dirp->curr);
0f38926b 933 strcpy(dirp->dirstr.d_name, dirp->curr);
68dc0745 934 dirp->dirstr.d_namlen = len;
0a753a76 935
68dc0745 936 /* Fake an inode */
0f38926b 937 dirp->dirstr.d_ino = dirp->curr - dirp->start;
0a753a76 938
95136add 939 /* Now set up for the next call to readdir */
68dc0745 940 dirp->curr += len + 1;
95136add 941 if (dirp->curr >= dirp->end) {
35cf1ab6 942 BOOL res;
35cf1ab6 943 char buffer[MAX_PATH*2];
95136add 944
60b22aca
JD
945 if (dirp->handle == INVALID_HANDLE_VALUE) {
946 res = 0;
947 }
95136add
GS
948 /* finding the next file that matches the wildcard
949 * (which should be all of them in this directory!).
95136add 950 */
8cbe99e5 951 else {
35cf1ab6
JD
952 WIN32_FIND_DATAW wFindData;
953 res = FindNextFileW(dirp->handle, &wFindData);
954 if (res) {
955 BOOL use_default = FALSE;
956 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
957 wFindData.cFileName, -1,
958 buffer, sizeof(buffer), NULL, &use_default);
959 if (use_default && *wFindData.cAlternateFileName) {
960 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
961 wFindData.cAlternateFileName, -1,
962 buffer, sizeof(buffer), NULL, NULL);
963 }
35cf1ab6
JD
964 }
965 }
95136add 966 if (res) {
0f38926b 967 long endpos = dirp->end - dirp->start;
8cbe99e5 968 long newsize = endpos + strlen(buffer) + 1;
95136add 969 /* bump the string table size by enough for the
022735b4 970 * new name and its null terminator */
0f38926b
GS
971 while (newsize > dirp->size) {
972 long curpos = dirp->curr - dirp->start;
35a27ac0 973 Renew(dirp->start, dirp->size * 2, char);
95136add 974 dirp->size *= 2;
0f38926b 975 dirp->curr = dirp->start + curpos;
95136add 976 }
8cbe99e5 977 strcpy(dirp->start + endpos, buffer);
0f38926b 978 dirp->end = dirp->start + newsize;
95136add
GS
979 dirp->nfiles++;
980 }
60b22aca 981 else {
95136add 982 dirp->curr = NULL;
60b22aca
JD
983 if (dirp->handle != INVALID_HANDLE_VALUE) {
984 FindClose(dirp->handle);
985 dirp->handle = INVALID_HANDLE_VALUE;
986 }
987 }
68dc0745 988 }
68dc0745 989 return &(dirp->dirstr);
3fadfdf1 990 }
68dc0745
PP
991 else
992 return NULL;
0a753a76
PP
993}
994
68dc0745 995/* Telldir returns the current string pointer position */
c5be433b 996DllExport long
ce2e26e5 997win32_telldir(DIR *dirp)
0a753a76 998{
60b22aca 999 return dirp->curr ? (dirp->curr - dirp->start) : -1;
0a753a76
PP
1000}
1001
1002
68dc0745 1003/* Seekdir moves the string pointer to a previously saved position
95136add 1004 * (returned by telldir).
68dc0745 1005 */
c5be433b 1006DllExport void
ce2e26e5 1007win32_seekdir(DIR *dirp, long loc)
0a753a76 1008{
60b22aca 1009 dirp->curr = loc == -1 ? NULL : dirp->start + loc;
0a753a76
PP
1010}
1011
68dc0745 1012/* Rewinddir resets the string pointer to the start */
c5be433b 1013DllExport void
ce2e26e5 1014win32_rewinddir(DIR *dirp)
0a753a76
PP
1015{
1016 dirp->curr = dirp->start;
1017}
1018
68dc0745 1019/* free the memory allocated by opendir */
c5be433b 1020DllExport int
ce2e26e5 1021win32_closedir(DIR *dirp)
0a753a76 1022{
95136add 1023 if (dirp->handle != INVALID_HANDLE_VALUE)
0f38926b 1024 FindClose(dirp->handle);
0a753a76
PP
1025 Safefree(dirp->start);
1026 Safefree(dirp);
68dc0745 1027 return 1;
0a753a76
PP
1028}
1029
60b22aca
JD
1030/* duplicate a open DIR* for interpreter cloning */
1031DllExport DIR *
1032win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1033{
60b22aca 1034 PerlInterpreter *const from = param->proto_perl;
f76b679e 1035 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
60b22aca
JD
1036
1037 long pos;
1038 DIR *dup;
1039
1040 /* switch back to original interpreter because win32_readdir()
1041 * might Renew(dirp->start).
1042 */
1043 if (from != to) {
1044 PERL_SET_THX(from);
1045 }
1046
1047 /* mark current position; read all remaining entries into the
1048 * cache, and then restore to current position.
1049 */
1050 pos = win32_telldir(dirp);
1051 while (win32_readdir(dirp)) {
1052 /* read all entries into cache */
1053 }
1054 win32_seekdir(dirp, pos);
1055
1056 /* switch back to new interpreter to allocate new DIR structure */
1057 if (from != to) {
1058 PERL_SET_THX(to);
1059 }
1060
1061 Newx(dup, 1, DIR);
1062 memcpy(dup, dirp, sizeof(DIR));
1063
1064 Newx(dup->start, dirp->size, char);
1065 memcpy(dup->start, dirp->start, dirp->size);
1066
1067 dup->end = dup->start + (dirp->end - dirp->start);
1068 if (dirp->curr)
1069 dup->curr = dup->start + (dirp->curr - dirp->start);
1070
1071 return dup;
1072}
0a753a76 1073
68dc0745
PP
1074/*
1075 * various stubs
1076 */
0a753a76
PP
1077
1078
68dc0745
PP
1079/* Ownership
1080 *
1081 * Just pretend that everyone is a superuser. NT will let us know if
1082 * we don\'t really have permission to do something.
1083 */
0a753a76
PP
1084
1085#define ROOT_UID ((uid_t)0)
1086#define ROOT_GID ((gid_t)0)
1087
68dc0745
PP
1088uid_t
1089getuid(void)
0a753a76 1090{
68dc0745 1091 return ROOT_UID;
0a753a76
PP
1092}
1093
68dc0745
PP
1094uid_t
1095geteuid(void)
0a753a76 1096{
68dc0745 1097 return ROOT_UID;
0a753a76
PP
1098}
1099
68dc0745
PP
1100gid_t
1101getgid(void)
0a753a76 1102{
68dc0745 1103 return ROOT_GID;
0a753a76
PP
1104}
1105
68dc0745
PP
1106gid_t
1107getegid(void)
0a753a76 1108{
68dc0745 1109 return ROOT_GID;
0a753a76
PP
1110}
1111
68dc0745 1112int
22239a37 1113setuid(uid_t auid)
3fadfdf1 1114{
22239a37 1115 return (auid == ROOT_UID ? 0 : -1);
0a753a76
PP
1116}
1117
68dc0745 1118int
22239a37 1119setgid(gid_t agid)
0a753a76 1120{
22239a37 1121 return (agid == ROOT_GID ? 0 : -1);
0a753a76
PP
1122}
1123
73f2c082 1124EXTERN_C char *
e34ffe5a
GS
1125getlogin(void)
1126{
acfe0abc 1127 dTHX;
3352bfcb
GS
1128 char *buf = w32_getlogin_buffer;
1129 DWORD size = sizeof(w32_getlogin_buffer);
e34ffe5a
GS
1130 if (GetUserName(buf,&size))
1131 return buf;
1132 return (char*)NULL;
1133}
1134
b990f8c8
GS
1135int
1136chown(const char *path, uid_t owner, gid_t group)
1137{
1138 /* XXX noop */
1c1c7f20 1139 return 0;
b990f8c8
GS
1140}
1141
00b02797
JH
1142/*
1143 * XXX this needs strengthening (for PerlIO)
1144 * -- BKS, 11-11-200
1145*/
f33b2f58 1146#if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4
00b02797
JH
1147int mkstemp(const char *path)
1148{
1149 dTHX;
1150 char buf[MAX_PATH+1];
1151 int i = 0, fd = -1;
1152
1153retry:
1154 if (i++ > 10) { /* give up */
1155 errno = ENOENT;
1156 return -1;
1157 }
1158 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1159 errno = ENOENT;
1160 return -1;
1161 }
1162 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1163 if (fd == -1)
1164 goto retry;
1165 return fd;
1166}
f33b2f58 1167#endif
00b02797 1168
0aaad0ff 1169static long
04a2c3d9 1170find_pid(pTHX_ int pid)
0a753a76 1171{
7766f137
GS
1172 long child = w32_num_children;
1173 while (--child >= 0) {
eb160463 1174 if ((int)w32_child_pids[child] == pid)
0aaad0ff
GS
1175 return child;
1176 }
1177 return -1;
1178}
1179
1180static void
1181remove_dead_process(long child)
1182{
1183 if (child >= 0) {
acfe0abc 1184 dTHX;
0aaad0ff 1185 CloseHandle(w32_child_handles[child]);
c00206c8 1186 Move(&w32_child_handles[child+1], &w32_child_handles[child],
0aaad0ff 1187 (w32_num_children-child-1), HANDLE);
c00206c8 1188 Move(&w32_child_pids[child+1], &w32_child_pids[child],
0aaad0ff
GS
1189 (w32_num_children-child-1), DWORD);
1190 w32_num_children--;
f55ee38a 1191 }
f55ee38a
GS
1192}
1193
7766f137
GS
1194#ifdef USE_ITHREADS
1195static long
04a2c3d9 1196find_pseudo_pid(pTHX_ int pid)
7766f137 1197{
7766f137
GS
1198 long child = w32_num_pseudo_children;
1199 while (--child >= 0) {
eb160463 1200 if ((int)w32_pseudo_child_pids[child] == pid)
7766f137
GS
1201 return child;
1202 }
1203 return -1;
1204}
1205
1206static void
1207remove_dead_pseudo_process(long child)
1208{
1209 if (child >= 0) {
acfe0abc 1210 dTHX;
7766f137 1211 CloseHandle(w32_pseudo_child_handles[child]);
c00206c8 1212 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
7766f137 1213 (w32_num_pseudo_children-child-1), HANDLE);
c00206c8 1214 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
7766f137 1215 (w32_num_pseudo_children-child-1), DWORD);
aeecf691
JD
1216 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1217 (w32_num_pseudo_children-child-1), HWND);
8a3cb9c6
JD
1218 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1219 (w32_num_pseudo_children-child-1), char);
7766f137
GS
1220 w32_num_pseudo_children--;
1221 }
1222}
8a3cb9c6
JD
1223
1224void
1225win32_wait_for_children(pTHX)
1226{
1227 if (w32_pseudo_children && w32_num_pseudo_children) {
1228 long child = 0;
1229 long count = 0;
1230 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1231
1232 for (child = 0; child < w32_num_pseudo_children; ++child) {
1233 if (!w32_pseudo_child_sigterm[child])
1234 handles[count++] = w32_pseudo_child_handles[child];
1235 }
1236 /* XXX should use MsgWaitForMultipleObjects() to continue
1237 * XXX processing messages while we wait.
1238 */
1239 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1240
1241 while (w32_num_pseudo_children)
1242 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1243 }
1244}
7766f137
GS
1245#endif
1246
542cb85f
JD
1247static int
1248terminate_process(DWORD pid, HANDLE process_handle, int sig)
1249{
1250 switch(sig) {
1251 case 0:
1252 /* "Does process exist?" use of kill */
1253 return 1;
1254 case 2:
1255 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1256 return 1;
1257 break;
1258 case SIGBREAK:
1259 case SIGTERM:
1260 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1261 return 1;
1262 break;
1263 default: /* For now be backwards compatible with perl 5.6 */
1264 case 9:
1265 /* Note that we will only be able to kill processes owned by the
1266 * current process owner, even when we are running as an administrator.
1267 * To kill processes of other owners we would need to set the
1268 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1269 */
1270 if (TerminateProcess(process_handle, sig))
1271 return 1;
1272 break;
1273 }
1274 return 0;
1275}
1276
721b2674
DD
1277/* returns number of processes killed */
1278static int
1279my_killpg(int pid, int sig)
542cb85f
JD
1280{
1281 HANDLE process_handle;
1282 HANDLE snapshot_handle;
1283 int killed = 0;
1284
1285 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
6a4d57af 1286 if (process_handle == NULL)
542cb85f
JD
1287 return 0;
1288
1289 killed += terminate_process(pid, process_handle, sig);
1290
8cbe99e5 1291 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
542cb85f
JD
1292 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1293 PROCESSENTRY32 entry;
1294
1295 entry.dwSize = sizeof(entry);
8cbe99e5 1296 if (Process32First(snapshot_handle, &entry)) {
542cb85f 1297 do {
8cbe99e5 1298 if (entry.th32ParentProcessID == (DWORD)pid)
721b2674 1299 killed += my_killpg(entry.th32ProcessID, sig);
542cb85f
JD
1300 entry.dwSize = sizeof(entry);
1301 }
8cbe99e5 1302 while (Process32Next(snapshot_handle, &entry));
542cb85f
JD
1303 }
1304 CloseHandle(snapshot_handle);
1305 }
1306 CloseHandle(process_handle);
1307 return killed;
1308}
1309
721b2674 1310/* returns number of processes killed */
542cb85f
JD
1311static int
1312my_kill(int pid, int sig)
1313{
1314 int retval = 0;
1315 HANDLE process_handle;
1316
1317 if (sig < 0)
721b2674 1318 return my_killpg(pid, -sig);
542cb85f
JD
1319
1320 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
6a4d57af
JD
1321 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1322 if (process_handle != NULL) {
542cb85f
JD
1323 retval = terminate_process(pid, process_handle, sig);
1324 CloseHandle(process_handle);
1325 }
1326 return retval;
1327}
1328
d903973c 1329#ifdef USE_ITHREADS
17ce47a8
SH
1330/* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1331 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1332 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1333 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1334 * recommended
1335 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1336 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1337 * a HWND in the time period allowed.
1338 */
d903973c 1339static HWND
17ce47a8
SH
1340get_hwnd_delay(pTHX, long child, DWORD tries)
1341{
d903973c 1342 HWND hwnd = w32_pseudo_child_message_hwnds[child];
d903973c 1343 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
17ce47a8
SH
1344
1345 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1346 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1347 * thread 100% of the time since threads are attached to a CPU for NUMA and
1348 * caching reasons, and the child thread was attached to a different CPU
1349 * therefore there is no workload on that CPU and Sleep(0) returns control
1350 * without yielding the time slot.
8034715d 1351 * https://github.com/Perl/perl5/issues/11267
17ce47a8 1352 */
d903973c
DD
1353 Sleep(0);
1354 win32_async_check(aTHX);
17ce47a8 1355 hwnd = w32_pseudo_child_message_hwnds[child];
d903973c 1356 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
17ce47a8 1357
d903973c 1358 {
adb86be5 1359 unsigned int count = 0;
17ce47a8
SH
1360 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1361 while (count++ < tries) {
1362 Sleep(1);
1363 win32_async_check(aTHX);
1364 hwnd = w32_pseudo_child_message_hwnds[child];
1365 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1366 }
d903973c 1367 }
17ce47a8
SH
1368
1369 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
d903973c
DD
1370}
1371#endif
1372
f55ee38a
GS
1373DllExport int
1374win32_kill(int pid, int sig)
1375{
acfe0abc 1376 dTHX;
c66b022d 1377 long child;
7766f137
GS
1378#ifdef USE_ITHREADS
1379 if (pid < 0) {
1380 /* it is a pseudo-forked child */
04a2c3d9 1381 child = find_pseudo_pid(aTHX_ -pid);
7766f137 1382 if (child >= 0) {
85c508c3 1383 HANDLE hProcess = w32_pseudo_child_handles[child];
7e5f34c0 1384 switch (sig) {
17ce47a8
SH
1385 case 0:
1386 /* "Does process exist?" use of kill */
7e5f34c0 1387 return 0;
aeecf691 1388
17ce47a8
SH
1389 case 9: {
1390 /* kill -9 style un-graceful exit */
1391 /* Do a wait to make sure child starts and isn't in DLL
1392 * Loader Lock */
1393 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1394 if (TerminateThread(hProcess, sig)) {
1395 /* Allow the scheduler to finish cleaning up the other
1396 * thread.
1397 * Otherwise, if we ExitProcess() before another context
1398 * switch happens we will end up with a process exit
1399 * code of "sig" instead of our own exit status.
1400 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1401 */
1402 Sleep(0);
1403 remove_dead_pseudo_process(child);
1404 return 0;
1405 }
1406 break;
1407 }
1408
1409 default: {
1410 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1411 /* We fake signals to pseudo-processes using Win32
1412 * message queue. */
1413 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1414 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1415 {
1416 /* Don't wait for child process to terminate after we send a
1417 * SIGTERM because the child may be blocked in a system call
1418 * and never receive the signal.
1419 */
1420 if (sig == SIGTERM) {
1421 Sleep(0);
1422 w32_pseudo_child_sigterm[child] = 1;
1423 }
1424 /* It might be us ... */
1425 PERL_ASYNC_CHECK();
1426 return 0;
1427 }
1428 break;
1429 }
1430 } /* switch */
7766f137 1431 }
68dc0745 1432 }
7766f137
GS
1433 else
1434#endif
1435 {
04a2c3d9 1436 child = find_pid(aTHX_ pid);
7766f137 1437 if (child >= 0) {
542cb85f
JD
1438 if (my_kill(pid, sig)) {
1439 DWORD exitcode = 0;
1440 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1441 exitcode != STILL_ACTIVE)
1442 {
1443 remove_dead_process(child);
1444 }
1445 return 0;
7e5f34c0 1446 }
7766f137
GS
1447 }
1448 else {
8cbe99e5 1449 if (my_kill(pid, sig))
48db714f 1450 return 0;
7766f137
GS
1451 }
1452 }
1453 errno = EINVAL;
1454 return -1;
0a753a76 1455}
fbbbcc48 1456
68dc0745 1457DllExport int
c623ac67 1458win32_stat(const char *path, Stat_t *sbuf)
0a753a76 1459{
3fadfdf1 1460 char buffer[MAX_PATH+1];
68dc0745 1461 int l = strlen(path);
04a2c3d9 1462 dTHX;
67fbe06e 1463 int res;
6b980173 1464 int nlink = 1;
44221b20 1465 BOOL expect_dir = FALSE;
0a753a76 1466
68dc0745
PP
1467 if (l > 1) {
1468 switch(path[l - 1]) {
e1dbac94 1469 /* FindFirstFile() and stat() are buggy with a trailing
44221b20 1470 * slashes, except for the root directory of a drive */
68dc0745 1471 case '\\':
44221b20
JD
1472 case '/':
1473 if (l > sizeof(buffer)) {
0b96339f
JD
1474 errno = ENAMETOOLONG;
1475 return -1;
1476 }
44221b20
JD
1477 --l;
1478 strncpy(buffer, path, l);
1479 /* remove additional trailing slashes */
1480 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\'))
1481 --l;
1482 /* add back slash if we otherwise end up with just a drive letter */
1483 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':')
1484 buffer[l++] = '\\';
1485 buffer[l] = '\0';
1486 path = buffer;
1487 expect_dir = TRUE;
e1dbac94 1488 break;
44221b20 1489
23db2e2d 1490 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS
1491 case ':':
1492 if (l == 2 && isALPHA(path[0])) {
426c1a18
GS
1493 buffer[0] = path[0];
1494 buffer[1] = ':';
1495 buffer[2] = '.';
1496 buffer[3] = '\0';
e1dbac94 1497 l = 3;
426c1a18 1498 path = buffer;
e1dbac94
GS
1499 }
1500 break;
68dc0745
PP
1501 }
1502 }
6b980173 1503
8c56068e
JD
1504 path = PerlDir_mapA(path);
1505 l = strlen(path);
cba61fe1 1506
8ca2a5d6 1507 if (!w32_sloppystat) {
cba61fe1
JD
1508 /* We must open & close the file once; otherwise file attribute changes */
1509 /* might not yet have propagated to "other" hard links of the same file. */
1510 /* This also gives us an opportunity to determine the number of links. */
1511 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1512 if (handle != INVALID_HANDLE_VALUE) {
1513 BY_HANDLE_FILE_INFORMATION bhi;
1514 if (GetFileInformationByHandle(handle, &bhi))
1515 nlink = bhi.nNumberOfLinks;
1516 CloseHandle(handle);
1517 }
d7a7ed74
DD
1518 else {
1519 DWORD err = GetLastError();
1520 /* very common case, skip CRT stat and its also failing syscalls */
1521 if(err == ERROR_FILE_NOT_FOUND) {
1522 errno = ENOENT;
1523 return -1;
1524 }
1525 }
7fac1903 1526 }
6b980173 1527
8c56068e 1528 /* path will be mapped correctly above */
8c56068e 1529 res = _stati64(path, sbuf);
426c1a18 1530 sbuf->st_nlink = nlink;
6b980173 1531
24caa93f
GS
1532 if (res < 0) {
1533 /* CRT is buggy on sharenames, so make sure it really isn't.
1534 * XXX using GetFileAttributesEx() will enable us to set
426c1a18 1535 * sbuf->st_*time (but note that's not available on the
24caa93f 1536 * Windows of 1995) */
8c56068e 1537 DWORD r = GetFileAttributesA(path);
24caa93f 1538 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
426c1a18 1539 /* sbuf may still contain old garbage since stat() failed */
c623ac67 1540 Zero(sbuf, 1, Stat_t);
426c1a18 1541 sbuf->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS
1542 errno = 0;
1543 if (!(r & FILE_ATTRIBUTE_READONLY))
426c1a18 1544 sbuf->st_mode |= S_IWRITE | S_IEXEC;
24caa93f
GS
1545 return 0;
1546 }
1547 }
24caa93f 1548 else {
e1dbac94
GS
1549 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1550 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB
1551 {
1552 /* The drive can be inaccessible, some _stat()s are buggy */
8c56068e 1553 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB
1554 errno = ENOENT;
1555 return -1;
1556 }
1557 }
44221b20
JD
1558 if (expect_dir && !S_ISDIR(sbuf->st_mode)) {
1559 errno = ENOTDIR;
1560 return -1;
1561 }
038ae9a4
SH
1562 if (S_ISDIR(sbuf->st_mode)) {
1563 /* Ensure the "write" bit is switched off in the mode for
378eeda7
SH
1564 * directories with the read-only attribute set. Some compilers
1565 * switch it on for directories, which is technically correct
038ae9a4
SH
1566 * (directories are indeed always writable unless denied by DACLs),
1567 * but we want stat() and -w to reflect the state of the read-only
1568 * attribute for symmetry with chmod(). */
1569 DWORD r = GetFileAttributesA(path);
1570 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) {
1571 sbuf->st_mode &= ~S_IWRITE;
1572 }
1573 }
2293b0e9 1574 }
67fbe06e 1575 return res;
0a753a76
PP
1576}
1577
bb27e7b6
JH
1578#define isSLASH(c) ((c) == '/' || (c) == '\\')
1579#define SKIP_SLASHES(s) \
1580 STMT_START { \
1581 while (*(s) && isSLASH(*(s))) \
1582 ++(s); \
1583 } STMT_END
1584#define COPY_NONSLASHES(d,s) \
1585 STMT_START { \
1586 while (*(s) && !isSLASH(*(s))) \
1587 *(d)++ = *(s)++; \
1588 } STMT_END
1589
8ac9c18d
GS
1590/* Find the longname of a given path. path is destructively modified.
1591 * It should have space for at least MAX_PATH characters. */
1592DllExport char *
1593win32_longpath(char *path)
1594{
1595 WIN32_FIND_DATA fdata;
1596 HANDLE fhand;
1597 char tmpbuf[MAX_PATH+1];
1598 char *tmpstart = tmpbuf;
1599 char *start = path;
1600 char sep;
1601 if (!path)
4e205ed6 1602 return NULL;
8ac9c18d
GS
1603
1604 /* drive prefix */
bb27e7b6 1605 if (isALPHA(path[0]) && path[1] == ':') {
8ac9c18d
GS
1606 start = path + 2;
1607 *tmpstart++ = path[0];
1608 *tmpstart++ = ':';
1609 }
1610 /* UNC prefix */
bb27e7b6 1611 else if (isSLASH(path[0]) && isSLASH(path[1])) {
8ac9c18d 1612 start = path + 2;
52fcf7ee
GS
1613 *tmpstart++ = path[0];
1614 *tmpstart++ = path[1];
bb27e7b6
JH
1615 SKIP_SLASHES(start);
1616 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
8ac9c18d 1617 if (*start) {
bb27e7b6
JH
1618 *tmpstart++ = *start++;
1619 SKIP_SLASHES(start);
1620 COPY_NONSLASHES(tmpstart,start); /* copy share name */
8ac9c18d
GS
1621 }
1622 }
8ac9c18d 1623 *tmpstart = '\0';
bb27e7b6
JH
1624 while (*start) {
1625 /* copy initial slash, if any */
1626 if (isSLASH(*start)) {
1627 *tmpstart++ = *start++;
1628 *tmpstart = '\0';
1629 SKIP_SLASHES(start);
1630 }
1631
1632 /* FindFirstFile() expands "." and "..", so we need to pass
1633 * those through unmolested */
1634 if (*start == '.'
1635 && (!start[1] || isSLASH(start[1])
1636 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1637 {
1638 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1639 *tmpstart = '\0';
1640 continue;
1641 }
1642
1643 /* if this is the end, bust outta here */
1644 if (!*start)
1645 break;
8ac9c18d 1646
bb27e7b6
JH
1647 /* now we're at a non-slash; walk up to next slash */
1648 while (*start && !isSLASH(*start))
8ac9c18d 1649 ++start;
8ac9c18d
GS
1650
1651 /* stop and find full name of component */
bb27e7b6 1652 sep = *start;
8ac9c18d
GS
1653 *start = '\0';
1654 fhand = FindFirstFile(path,&fdata);
bb27e7b6 1655 *start = sep;
8ac9c18d 1656 if (fhand != INVALID_HANDLE_VALUE) {
bb27e7b6
JH
1657 STRLEN len = strlen(fdata.cFileName);
1658 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1659 strcpy(tmpstart, fdata.cFileName);
1660 tmpstart += len;
1661 FindClose(fhand);
1662 }
1663 else {
1664 FindClose(fhand);
1665 errno = ERANGE;
4e205ed6 1666 return NULL;
bb27e7b6 1667 }
8ac9c18d
GS
1668 }
1669 else {
1670 /* failed a step, just return without side effects */
bf49b057 1671 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
bb27e7b6 1672 errno = EINVAL;
4e205ed6 1673 return NULL;
8ac9c18d
GS
1674 }
1675 }
1676 strcpy(path,tmpbuf);
1677 return path;
1678}
1679
aa2b96ec 1680static void
0934c9d9 1681out_of_memory(void)
aa2b96ec 1682{
1565c085 1683
4cbe3a7d
DD
1684 if (PL_curinterp)
1685 croak_no_mem();
ae6198af 1686 exit(1);
aa2b96ec
JD
1687}
1688
073dd035
DD
1689void
1690win32_croak_not_implemented(const char * fname)
1691{
1692 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1693
1694 Perl_croak_nocontext("%s not implemented!\n", fname);
1695}
1696
00a0ae28
SH
1697/* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1698 * potentially using the system's default replacement character for any
1699 * unrepresentable characters. The caller must free() the returned string. */
1700static char*
1701wstr_to_str(const wchar_t* wstr)
1702{
1703 BOOL used_default = FALSE;
1704 size_t wlen = wcslen(wstr) + 1;
1705 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1706 NULL, 0, NULL, NULL);
f76b679e 1707 char* str = (char*)malloc(len);
00a0ae28
SH
1708 if (!str)
1709 out_of_memory();
1710 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1711 str, len, NULL, &used_default);
1712 return str;
1713}
1714
aa2b96ec
JD
1715/* The win32_ansipath() function takes a Unicode filename and converts it
1716 * into the current Windows codepage. If some characters cannot be mapped,
1717 * then it will convert the short name instead.
1718 *
1719 * The buffer to the ansi pathname must be freed with win32_free() when it
a3815e44 1720 * is no longer needed.
aa2b96ec
JD
1721 *
1722 * The argument to win32_ansipath() must exist before this function is
1723 * called; otherwise there is no way to determine the short path name.
1724 *
1725 * Ideas for future refinement:
1726 * - Only convert those segments of the path that are not in the current
1727 * codepage, but leave the other segments in their long form.
1728 * - If the resulting name is longer than MAX_PATH, start converting
1729 * additional path segments into short names until the full name
1730 * is shorter than MAX_PATH. Shorten the filename part last!
1731 */
1732DllExport char *
1733win32_ansipath(const WCHAR *widename)
1734{
1735 char *name;
1736 BOOL use_default = FALSE;
1737 size_t widelen = wcslen(widename)+1;
1738 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1739 NULL, 0, NULL, NULL);
f76b679e 1740 name = (char*)win32_malloc(len);
aa2b96ec
JD
1741 if (!name)
1742 out_of_memory();
1743
1744 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1745 name, len, NULL, &use_default);
1746 if (use_default) {
aa2b96ec 1747 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
ae6198af 1748 if (shortlen) {
f76b679e 1749 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
ae6198af
JD
1750 if (!shortname)
1751 out_of_memory();
1752 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1753
1754 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1755 NULL, 0, NULL, NULL);
f76b679e 1756 name = (char*)win32_realloc(name, len);
ae6198af
JD
1757 if (!name)
1758 out_of_memory();
1759 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1760 name, len, NULL, NULL);
1761 win32_free(shortname);
1762 }
aa2b96ec
JD
1763 }
1764 return name;
1765}
1766
2c8ca683
DD
1767/* the returned string must be freed with win32_freeenvironmentstrings which is
1768 * implemented as a macro
1769 * void win32_freeenvironmentstrings(void* block)
1770 */
0551aaa8 1771DllExport char *
4f46e52b
KR
1772win32_getenvironmentstrings(void)
1773{
1774 LPWSTR lpWStr, lpWTmp;
1775 LPSTR lpStr, lpTmp;
1776 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
1777
1778 /* Get the process environment strings */
1779 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
fa467b9b 1780 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
4f46e52b
KR
1781 env_len = wcslen(lpWTmp);
1782 /* calculate the size of the environment strings */
1783 wenvstrings_len += env_len + 1;
1784 }
1785
fa467b9b 1786 /* Get the number of bytes required to store the ACP encoded string */
4f46e52b 1787 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
fa467b9b 1788 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
4f46e52b
KR
1789 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
1790 if(!lpTmp)
1791 out_of_memory();
1792
1793 /* Convert the string from UTF-16 encoding to ACP encoding */
1794 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
fa467b9b 1795 aenvstrings_len, NULL, NULL);
4f46e52b 1796
a6abe943 1797 FreeEnvironmentStringsW(lpWStr);
90674eaa 1798
4f46e52b
KR
1799 return(lpStr);
1800}
1801
4f46e52b 1802DllExport char *
0551aaa8
GS
1803win32_getenv(const char *name)
1804{
acfe0abc 1805 dTHX;
0551aaa8 1806 DWORD needlen;
4e205ed6 1807 SV *curitem = NULL;
1fcb0052 1808 DWORD last_err;
58a50f62 1809
8c56068e 1810 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1811 if (needlen != 0) {
c2b90b61 1812 curitem = sv_2mortal(newSVpvs(""));
8c56068e
JD
1813 do {
1814 SvGROW(curitem, needlen+1);
1815 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1816 needlen);
1817 } while (needlen >= SvLEN(curitem));
1818 SvCUR_set(curitem, needlen);
0551aaa8 1819 }
c934e9d4 1820 else {
1fcb0052
PM
1821 last_err = GetLastError();
1822 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1823 /* It appears the variable is in the env, but the Win32 API
1824 doesn't have a canned way of getting it. So we fall back to
1825 grabbing the whole env and pulling this value out if possible */
1826 char *envv = GetEnvironmentStrings();
1827 char *cur = envv;
1828 STRLEN len;
1829 while (*cur) {
1830 char *end = strchr(cur,'=');
1831 if (end && end != cur) {
1832 *end = '\0';
083b2a61 1833 if (strEQ(cur,name)) {
1fcb0052
PM
1834 curitem = sv_2mortal(newSVpv(end+1,0));
1835 *end = '=';
1836 break;
1837 }
1838 *end = '=';
1839 cur = end + strlen(end+1)+2;
1840 }
1841 else if ((len = strlen(cur)))
1842 cur += len+1;
1843 }
1844 FreeEnvironmentStrings(envv);
1845 }
6937817d 1846#ifndef WIN32_NO_REGISTRY
1fcb0052
PM
1847 else {
1848 /* last ditch: allow any environment variables that begin with 'PERL'
1849 to be obtained from the registry, if found there */
f55ac4a4 1850 if (strBEGINs(name, "PERL"))
1fcb0052
PM
1851 (void)get_regstr(name, &curitem);
1852 }
6937817d 1853#endif
c69f6586 1854 }
51371543
GS
1855 if (curitem && SvCUR(curitem))
1856 return SvPVX(curitem);
58a50f62 1857
4e205ed6 1858 return NULL;
0551aaa8
GS
1859}
1860
ac5c734f
GS
1861DllExport int
1862win32_putenv(const char *name)
1863{
1864 char* curitem;
1865 char* val;
b813a9c7 1866 int relval = -1;
51371543 1867
73c4f7a1 1868 if (name) {
9399a70c 1869 curitem = (char *) win32_malloc(strlen(name)+1);
8c56068e
JD
1870 strcpy(curitem, name);
1871 val = strchr(curitem, '=');
1872 if (val) {
1873 /* The sane way to deal with the environment.
1874 * Has these advantages over putenv() & co.:
1875 * * enables us to store a truly empty value in the
1876 * environment (like in UNIX).
8d0cd07e
SH
1877 * * we don't have to deal with RTL globals, bugs and leaks
1878 * (specifically, see http://support.microsoft.com/kb/235601).
8c56068e 1879 * * Much faster.
d0fc6d8d
SH
1880 * Why you may want to use the RTL environment handling
1881 * (previously enabled by USE_WIN32_RTL_ENV):
8c56068e
JD
1882 * * environ[] and RTL functions will not reflect changes,
1883 * which might be an issue if extensions want to access
1884 * the env. via RTL. This cuts both ways, since RTL will
1885 * not see changes made by extensions that call the Win32
1886 * functions directly, either.
1887 * GSAR 97-06-07
1888 */
1889 *val++ = '\0';
1890 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1891 relval = 0;
1892 }
9399a70c 1893 win32_free(curitem);
ac5c734f
GS
1894 }
1895 return relval;
1896}
1897
d55594ae 1898static long
2d7a9237 1899filetime_to_clock(PFILETIME ft)
d55594ae 1900{
7766f137
GS
1901 __int64 qw = ft->dwHighDateTime;
1902 qw <<= 32;
1903 qw |= ft->dwLowDateTime;
1904 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1905 return (long) qw;
d55594ae
GS
1906}
1907
f3986ebb
GS
1908DllExport int
1909win32_times(struct tms *timebuf)
0a753a76 1910{
d55594ae
GS
1911 FILETIME user;
1912 FILETIME kernel;
1913 FILETIME dummy;
50ee8e5e 1914 clock_t process_time_so_far = clock();
3fadfdf1 1915 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
d55594ae 1916 &kernel,&user)) {
2d7a9237
GS
1917 timebuf->tms_utime = filetime_to_clock(&user);
1918 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS
1919 timebuf->tms_cutime = 0;
1920 timebuf->tms_cstime = 0;
3fadfdf1 1921 } else {
d55594ae 1922 /* That failed - e.g. Win95 fallback to clock() */
50ee8e5e 1923 timebuf->tms_utime = process_time_so_far;
d55594ae
GS
1924 timebuf->tms_stime = 0;
1925 timebuf->tms_cutime = 0;
1926 timebuf->tms_cstime = 0;
1927 }
50ee8e5e 1928 return process_time_so_far;
0a753a76
PP
1929}
1930
9c51cf4c 1931/* fix utime() so it works on directories in NT */
ad0751ec
GS
1932static BOOL
1933filetime_from_time(PFILETIME pFileTime, time_t Time)
1934{
9c51cf4c 1935 struct tm *pTM = localtime(&Time);
ad0751ec 1936 SYSTEMTIME SystemTime;
9c51cf4c 1937 FILETIME LocalTime;
ad0751ec
GS
1938
1939 if (pTM == NULL)
1940 return FALSE;
1941
1942 SystemTime.wYear = pTM->tm_year + 1900;
1943 SystemTime.wMonth = pTM->tm_mon + 1;
1944 SystemTime.wDay = pTM->tm_mday;
1945 SystemTime.wHour = pTM->tm_hour;
1946 SystemTime.wMinute = pTM->tm_min;
1947 SystemTime.wSecond = pTM->tm_sec;
1948 SystemTime.wMilliseconds = 0;
1949
9c51cf4c
GS
1950 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1951 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS
1952}
1953
1954DllExport int
7766f137
GS
1955win32_unlink(const char *filename)
1956{
acfe0abc 1957 dTHX;
7766f137
GS
1958 int ret;
1959 DWORD attrs;
1960
8c56068e
JD
1961 filename = PerlDir_mapA(filename);
1962 attrs = GetFileAttributesA(filename);
1963 if (attrs == 0xFFFFFFFF) {
1964 errno = ENOENT;
1965 return -1;
7766f137 1966 }
8c56068e
JD
1967 if (attrs & FILE_ATTRIBUTE_READONLY) {
1968 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1969 ret = unlink(filename);
1970 if (ret == -1)
1971 (void)SetFileAttributesA(filename, attrs);
7766f137 1972 }
8c56068e
JD
1973 else
1974 ret = unlink(filename);
7766f137
GS
1975 return ret;
1976}
1977
1978DllExport int
3b405fc5 1979win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1980{
acfe0abc 1981 dTHX;
ad0751ec
GS
1982 HANDLE handle;
1983 FILETIME ftCreate;
1984 FILETIME ftAccess;
1985 FILETIME ftWrite;
1986 struct utimbuf TimeBuffer;
7fac1903 1987 int rc;
8c56068e
JD
1988
1989 filename = PerlDir_mapA(filename);
1990 rc = utime(filename, times);
1991
ad0751ec 1992 /* EACCES: path specifies directory or readonly file */
8cbe99e5 1993 if (rc == 0 || errno != EACCES)
ad0751ec
GS
1994 return rc;
1995
1996 if (times == NULL) {
1997 times = &TimeBuffer;
1998 time(&times->actime);
1999 times->modtime = times->actime;
2000 }
2001
2002 /* This will (and should) still fail on readonly files */
8c56068e
JD
2003 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2004 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
2005 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
ad0751ec
GS
2006 if (handle == INVALID_HANDLE_VALUE)
2007 return rc;
2008
2009 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
2010 filetime_from_time(&ftAccess, times->actime) &&
2011 filetime_from_time(&ftWrite, times->modtime) &&
2012 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
2013 {
2014 rc = 0;
2015 }
2016
2017 CloseHandle(handle);
2018 return rc;
2019}
2020
6e3b076d
JH
2021typedef union {
2022 unsigned __int64 ft_i64;
2023 FILETIME ft_val;
2024} FT_t;
2025
2026#ifdef __GNUC__
2027#define Const64(x) x##LL
2028#else
2029#define Const64(x) x##i64
2030#endif
2031/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2032#define EPOCH_BIAS Const64(116444736000000000)
2033
57ab3dfe
GS
2034/* NOTE: This does not compute the timezone info (doing so can be expensive,
2035 * and appears to be unsupported even by glibc) */
2036DllExport int
2037win32_gettimeofday(struct timeval *tp, void *not_used)
2038{
6e3b076d
JH
2039 FT_t ft;
2040
2041 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2042 GetSystemTimeAsFileTime(&ft.ft_val);
2043
2044 /* seconds since epoch */
2045 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2046
2047 /* microseconds remaining */
2048 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2049
2050 return 0;
57ab3dfe
GS
2051}
2052
2d7a9237 2053DllExport int
b2af26b1
GS
2054win32_uname(struct utsname *name)
2055{
2056 struct hostent *hep;
2057 STRLEN nodemax = sizeof(name->nodename)-1;
b2af26b1 2058
aeecf691
JD
2059 /* sysname */
2060 switch (g_osver.dwPlatformId) {
2061 case VER_PLATFORM_WIN32_WINDOWS:
2062 strcpy(name->sysname, "Windows");
2063 break;
2064 case VER_PLATFORM_WIN32_NT:
2065 strcpy(name->sysname, "Windows NT");
2066 break;
2067 case VER_PLATFORM_WIN32s:
2068 strcpy(name->sysname, "Win32s");
2069 break;
2070 default:
2071 strcpy(name->sysname, "Win32 Unknown");
2072 break;
b2af26b1 2073 }
aeecf691
JD
2074
2075 /* release */
2076 sprintf(name->release, "%d.%d",
2077 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2078
2079 /* version */
2080 sprintf(name->version, "Build %d",
2081 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2082 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2083 if (g_osver.szCSDVersion[0]) {
2084 char *buf = name->version + strlen(name->version);
2085 sprintf(buf, " (%s)", g_osver.szCSDVersion);
b2af26b1
GS
2086 }
2087
2088 /* nodename */
2089 hep = win32_gethostbyname("localhost");
2090 if (hep) {
2091 STRLEN len = strlen(hep->h_name);
2092 if (len <= nodemax) {
2093 strcpy(name->nodename, hep->h_name);
2094 }
2095 else {
2096 strncpy(name->nodename, hep->h_name, nodemax);
2097 name->nodename[nodemax] = '\0';
2098 }
2099 }
2100 else {
2101 DWORD sz = nodemax;
2102 if (!GetComputerName(name->nodename, &sz))
2103 *name->nodename = '\0';
2104 }
2105
2106 /* machine (architecture) */
2107 {
2108 SYSTEM_INFO info;
fe537c65 2109 DWORD procarch;
b2af26b1
GS
2110 char *arch;
2111 GetSystemInfo(&info);
a6c40364 2112
378eeda7 2113#if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
fe537c65 2114 procarch = info.u.s.wProcessorArchitecture;
a6c40364 2115#else
fe537c65 2116 procarch = info.wProcessorArchitecture;
a6c40364 2117#endif
fe537c65 2118 switch (procarch) {
b2af26b1
GS
2119 case PROCESSOR_ARCHITECTURE_INTEL:
2120 arch = "x86"; break;
fe537c65
GS
2121 case PROCESSOR_ARCHITECTURE_IA64:
2122 arch = "ia64"; break;
fe537c65
GS
2123 case PROCESSOR_ARCHITECTURE_AMD64:
2124 arch = "amd64"; break;
fe537c65 2125 case PROCESSOR_ARCHITECTURE_UNKNOWN:
b2af26b1 2126 arch = "unknown"; break;
fe537c65
GS
2127 default:
2128 sprintf(name->machine, "unknown(0x%x)", procarch);
2129 arch = name->machine;
2130 break;
b2af26b1 2131 }
fe537c65
GS
2132 if (name->machine != arch)
2133 strcpy(name->machine, arch);
b2af26b1
GS
2134 }
2135 return 0;
2136}
2137
8fb3fcfb
NIS
2138/* Timing related stuff */
2139
3fadfdf1
NIS
2140int
2141do_raise(pTHX_ int sig)
2142{
2143 if (sig < SIG_SIZE) {
2144 Sighandler_t handler = w32_sighandler[sig];
2145 if (handler == SIG_IGN) {
2146 return 0;
2147 }
2148 else if (handler != SIG_DFL) {
2149 (*handler)(sig);
2150 return 0;
2151 }
2152 else {
2153 /* Choose correct default behaviour */
2154 switch (sig) {
2155#ifdef SIGCLD
2156 case SIGCLD:
2157#endif
2158#ifdef SIGCHLD
2159 case SIGCHLD:
2160#endif
2161 case 0:
2162 return 0;
2163 case SIGTERM:
2164 default:
2165 break;
2166 }
2167 }
2168 }
bb0f0a6a 2169 /* Tell caller to exit thread/process as appropriate */
3fadfdf1
NIS
2170 return 1;
2171}
2172
2173void
2174sig_terminate(pTHX_ int sig)
2175{
2176 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2177 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2178 thread
2179 */
2180 exit(sig);
2181}
2182
8fb3fcfb
NIS
2183DllExport int
2184win32_async_check(pTHX)
2185{
2186 MSG msg;
aeecf691
JD
2187 HWND hwnd = w32_message_hwnd;
2188
099b16d3
RM
2189 /* Reset w32_poll_count before doing anything else, incase we dispatch
2190 * messages that end up calling back into perl */
aeecf691
JD
2191 w32_poll_count = 0;
2192
099b16d3
RM
2193 if (hwnd != INVALID_HANDLE_VALUE) {
2194 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2195 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2196 */
2197 if (hwnd == NULL)
2198 hwnd = (HWND)-1;
2199
2200 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2201 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2202 {
2203 /* re-post a WM_QUIT message (we'll mark it as read later) */
2204 if(msg.message == WM_QUIT) {
2205 PostQuitMessage((int)msg.wParam);
2206 break;
2207 }
8fb3fcfb 2208
099b16d3
RM
2209 if(!CallMsgFilter(&msg, MSGF_USER))
2210 {
2211 TranslateMessage(&msg);
2212 DispatchMessage(&msg);
aeecf691 2213 }
099b16d3 2214 }
8fb3fcfb
NIS
2215 }
2216
099b16d3
RM
2217 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2218 * This is necessary when we are being called by win32_msgwait() to
2219 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2220 * message over and over. An example how this can happen is when
2221 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2222 * is generating messages before the process terminated.
2223 */
4386d69d 2224 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
099b16d3 2225
7e5f34c0 2226 /* Above or other stuff may have set a signal flag */
099b16d3
RM
2227 if (PL_sig_pending)
2228 despatch_signals();
2229
aeecf691 2230 return 1;
8fb3fcfb
NIS
2231}
2232
089197fa
GS
2233/* This function will not return until the timeout has elapsed, or until
2234 * one of the handles is ready. */
8fb3fcfb
NIS
2235DllExport DWORD
2236win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2237{
2238 /* We may need several goes at this - so compute when we stop */
001e9f89
DD
2239 FT_t ticks = {0};
2240 unsigned __int64 endtime = timeout;
8fb3fcfb 2241 if (timeout != INFINITE) {
001e9f89
DD
2242 GetSystemTimeAsFileTime(&ticks.ft_val);
2243 ticks.ft_i64 /= 10000;
2244 endtime += ticks.ft_i64;
2245 }
2246 /* This was a race condition. Do not let a non INFINITE timeout to
2247 * MsgWaitForMultipleObjects roll under 0 creating a near
2248 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2249 * user who did a CORE perl function with a non infinity timeout,
2250 * sleep for example. This is 64 to 32 truncation minefield.
2251 *
2252 * This scenario can only be created if the timespan from the return of
2253 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2254 * generate the scenario, manual breakpoints in a C debugger are required,
bb0f0a6a 2255 * or a context switch occurred in win32_async_check in PeekMessage, or random
001e9f89
DD
2256 * messages are delivered to the *thread* message queue of the Perl thread
2257 * from another process (msctf.dll doing IPC among its instances, VS debugger
2258 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2259 */
81295a42 2260 while (ticks.ft_i64 <= endtime) {
9afd6203
SH
2261 /* if timeout's type is lengthened, remember to split 64b timeout
2262 * into multiple non-infinity runs of MWFMO */
2263 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2264 (DWORD)(endtime - ticks.ft_i64),
2265 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
8fb3fcfb
NIS
2266 if (resultp)
2267 *resultp = result;
2268 if (result == WAIT_TIMEOUT) {
3fadfdf1
NIS
2269 /* Ran out of time - explicit return of zero to avoid -ve if we
2270 have scheduling issues
2271 */
8fb3fcfb
NIS
2272 return 0;
2273 }
2274 if (timeout != INFINITE) {
001e9f89
DD
2275 GetSystemTimeAsFileTime(&ticks.ft_val);
2276 ticks.ft_i64 /= 10000;
2277 }
8fb3fcfb
NIS
2278 if (result == WAIT_OBJECT_0 + count) {
2279 /* Message has arrived - check it */
089197fa 2280 (void)win32_async_check(aTHX);
81295a42
TK
2281
2282 /* retry */
2283 if (ticks.ft_i64 > endtime)
2284 endtime = ticks.ft_i64;
2285
2286 continue;
8fb3fcfb
NIS
2287 }
2288 else {
2289 /* Not timeout or message - one of handles is ready */
2290 break;
2291 }
2292 }
8fb3fcfb 2293 /* If we are past the end say zero */
9afd6203 2294 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
001e9f89
DD
2295 return 0;
2296 /* compute time left to wait */
2297 ticks.ft_i64 = endtime - ticks.ft_i64;
9afd6203
SH
2298 /* if more ms than DWORD, then return max DWORD */
2299 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
8fb3fcfb
NIS
2300}
2301
932b7487 2302int
04a2c3d9 2303win32_internal_wait(pTHX_ int *status, DWORD timeout)
932b7487
RC
2304{
2305 /* XXX this wait emulation only knows about processes
2306 * spawned via win32_spawnvp(P_NOWAIT, ...).
2307 */
932b7487
RC
2308 int i, retval;
2309 DWORD exitcode, waitcode;
2310
2311#ifdef USE_ITHREADS
2312 if (w32_num_pseudo_children) {
8fb3fcfb
NIS
2313 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2314 timeout, &waitcode);
932b7487
RC
2315 /* Time out here if there are no other children to wait for. */
2316 if (waitcode == WAIT_TIMEOUT) {
2317 if (!w32_num_children) {
2318 return 0;
2319 }
2320 }
2321 else if (waitcode != WAIT_FAILED) {
2322 if (waitcode >= WAIT_ABANDONED_0
2323 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2324 i = waitcode - WAIT_ABANDONED_0;
2325 else
2326 i = waitcode - WAIT_OBJECT_0;
2327 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2328 *status = (int)((exitcode & 0xff) << 8);
2329 retval = (int)w32_pseudo_child_pids[i];
2330 remove_dead_pseudo_process(i);
2331 return -retval;
2332 }
2333 }
2334 }
2335#endif
2336
2337 if (!w32_num_children) {
2338 errno = ECHILD;
2339 return -1;
2340 }
2341
2342 /* if a child exists, wait for it to die */
8fb3fcfb 2343 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
932b7487
RC
2344 if (waitcode == WAIT_TIMEOUT) {
2345 return 0;
2346 }
2347 if (waitcode != WAIT_FAILED) {
2348 if (waitcode >= WAIT_ABANDONED_0
2349 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2350 i = waitcode - WAIT_ABANDONED_0;
2351 else
2352 i = waitcode - WAIT_OBJECT_0;
2353 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2354 *status = (int)((exitcode & 0xff) << 8);
2355 retval = (int)w32_child_pids[i];
2356 remove_dead_process(i);
2357 return retval;
2358 }
2359 }
2360
932b7487
RC
2361 errno = GetLastError();
2362 return -1;
2363}
2364
b2af26b1 2365DllExport int
f55ee38a
GS
2366win32_waitpid(int pid, int *status, int flags)
2367{
acfe0abc 2368 dTHX;
922b1888 2369 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
0aaad0ff 2370 int retval = -1;
c66b022d 2371 long child;
7766f137 2372 if (pid == -1) /* XXX threadid == 1 ? */
04a2c3d9 2373 return win32_internal_wait(aTHX_ status, timeout);
7766f137
GS
2374#ifdef USE_ITHREADS
2375 else if (pid < 0) {
04a2c3d9 2376 child = find_pseudo_pid(aTHX_ -pid);
7766f137
GS
2377 if (child >= 0) {
2378 HANDLE hThread = w32_pseudo_child_handles[child];
8fb3fcfb
NIS
2379 DWORD waitcode;
2380 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2f67576d
BC
2381 if (waitcode == WAIT_TIMEOUT) {
2382 return 0;
2383 }
8fb3fcfb 2384 else if (waitcode == WAIT_OBJECT_0) {
7766f137
GS
2385 if (GetExitCodeThread(hThread, &waitcode)) {
2386 *status = (int)((waitcode & 0xff) << 8);
2387 retval = (int)w32_pseudo_child_pids[child];
2388 remove_dead_pseudo_process(child);
68a29c53 2389 return -retval;
7766f137
GS
2390 }
2391 }
2392 else
2393 errno = ECHILD;
2394 }
2395 }
2396#endif
f55ee38a 2397 else {
922b1888
GS
2398 HANDLE hProcess;
2399 DWORD waitcode;
04a2c3d9 2400 child = find_pid(aTHX_ pid);
0aaad0ff 2401 if (child >= 0) {
922b1888 2402 hProcess = w32_child_handles[child];
8fb3fcfb 2403 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
a7867d0a
GS
2404 if (waitcode == WAIT_TIMEOUT) {
2405 return 0;
2406 }
8fb3fcfb 2407 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS
2408 if (GetExitCodeProcess(hProcess, &waitcode)) {
2409 *status = (int)((waitcode & 0xff) << 8);
2410 retval = (int)w32_child_pids[child];
2411 remove_dead_process(child);
2412 return retval;
2413 }
a7867d0a 2414 }
0aaad0ff
GS
2415 else
2416 errno = ECHILD;
2417 }
2418 else {
8cbe99e5 2419 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
922b1888 2420 if (hProcess) {
8fb3fcfb 2421 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
922b1888 2422 if (waitcode == WAIT_TIMEOUT) {
48db714f 2423 CloseHandle(hProcess);
922b1888
GS
2424 return 0;
2425 }
8fb3fcfb 2426 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS
2427 if (GetExitCodeProcess(hProcess, &waitcode)) {
2428 *status = (int)((waitcode & 0xff) << 8);
2429 CloseHandle(hProcess);
2430 return pid;
2431 }
2432 }
2433 CloseHandle(hProcess);
2434 }
2435 else
2436 errno = ECHILD;
0aaad0ff 2437 }
f55ee38a 2438 }
3fadfdf1 2439 return retval >= 0 ? pid : retval;
f55ee38a
GS
2440}
2441
2442DllExport int
2d7a9237
GS
2443win32_wait(int *status)
2444{
04a2c3d9
DD
2445 dTHX;
2446 return win32_internal_wait(aTHX_ status, INFINITE);
2d7a9237 2447}
d55594ae 2448
8fb3fcfb
NIS
2449DllExport unsigned int
2450win32_sleep(unsigned int t)
d55594ae 2451{
acfe0abc 2452 dTHX;
8fb3fcfb 2453 /* Win32 times are in ms so *1000 in and /1000 out */
3b9aea04
SH
2454 if (t > UINT_MAX / 1000) {
2455 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2456 "sleep(%lu) too large", t);
2457 }
2458 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
d55594ae
GS
2459}
2460
bbc9927b
TK
2461DllExport int
2462win32_pause(void)
2463{
2464 dTHX;
2465 win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
2466 return -1;
2467}
2468
f3986ebb
GS
2469DllExport unsigned int
2470win32_alarm(unsigned int sec)
0a753a76 2471{
3fadfdf1 2472 /*
d55594ae 2473 * the 'obvious' implentation is SetTimer() with a callback
3fadfdf1
NIS
2474 * which does whatever receiving SIGALRM would do
2475 * we cannot use SIGALRM even via raise() as it is not
d55594ae 2476 * one of the supported codes in <signal.h>
3fadfdf1 2477 */
acfe0abc 2478 dTHX;
aeecf691
JD
2479
2480 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2481 w32_message_hwnd = win32_create_message_window();
2482
8fb3fcfb 2483 if (sec) {
aeecf691
JD
2484 if (w32_message_hwnd == NULL)
2485 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2486 else {
2487 w32_timerid = 1;
2488 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2489 }
8fb3fcfb
NIS
2490 }
2491 else {
2492 if (w32_timerid) {
aeecf691
JD
2493 KillTimer(w32_message_hwnd, w32_timerid);
2494 w32_timerid = 0;
8fb3fcfb 2495 }
3fadfdf1 2496 }
afe91769 2497 return 0;
0a753a76
PP
2498}
2499
2d77217b 2500extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
26618a56
GS
2501
2502DllExport char *
2503win32_crypt(const char *txt, const char *salt)
2504{
acfe0abc 2505 dTHX;
3352bfcb 2506 return des_fcrypt(txt, salt, w32_crypt_buffer);
26618a56 2507}
26618a56 2508
390b85e7
GS
2509/* simulate flock by locking a range on the file */
2510
390b85e7
GS
2511#define LK_LEN 0xffff0000
2512
f3986ebb
GS
2513DllExport int
2514win32_flock(int fd, int oper)
390b85e7
GS
2515{
2516 OVERLAPPED o;
2517 int i = -1;
2518 HANDLE fh;
2519
2520 fh = (HANDLE)_get_osfhandle(fd);
97b33cac
JD
2521 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
2522 return -1;
2523
390b85e7
GS
2524 memset(&o, 0, sizeof(o));
2525
2526 switch(oper) {
2527 case LOCK_SH: /* shared lock */
97b33cac
JD
2528 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2529 i = 0;
390b85e7
GS
2530 break;
2531 case LOCK_EX: /* exclusive lock */
97b33cac
JD
2532 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2533 i = 0;
390b85e7
GS
2534 break;
2535 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
97b33cac
JD
2536 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2537 i = 0;
390b85e7
GS
2538 break;
2539 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
97b33cac
JD
2540 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2541 0, LK_LEN, 0, &o))
2542 i = 0;
390b85e7
GS
2543 break;
2544 case LOCK_UN: /* unlock lock */
97b33cac
JD
2545 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2546 i = 0;
390b85e7
GS
2547 break;
2548 default: /* unknown */
2549 errno = EINVAL;
97b33cac
JD
2550 return -1;
2551 }
2552 if (i == -1) {
2553 if (GetLastError() == ERROR_LOCK_VIOLATION)
b0ba2190 2554 errno = EWOULDBLOCK;
97b33cac
JD
2555 else
2556 errno = EINVAL;
390b85e7
GS
2557 }
2558 return i;
2559}
2560
390b85e7
GS
2561#undef LK_LEN
2562
cd6a3131
SH
2563extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2564
c9beaf97
SH
2565/* Get the errno value corresponding to the given err. This function is not
2566 * intended to handle conversion of general GetLastError() codes. It only exists
2567 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2568 * used to be assigned to errno/$! in earlier versions of perl; this function is
2569 * used to catch any old Perl code which is still trying to assign such values
2570 * to $! and convert them to errno values instead.
2571 */
2572int
2573win32_get_errno(int err)
2574{
2575 return convert_wsa_error_to_errno(err);
2576}
2577
68dc0745
PP
2578/*
2579 * redirected io subsystem for all XS modules
2580 *
2581 */
0a753a76 2582
68dc0745
PP
2583DllExport int *
2584win32_errno(void)
0a753a76 2585{
390b85e7 2586 return (&errno);
0a753a76
PP
2587}
2588
dcb2879a
GS
2589DllExport char ***
2590win32_environ(void)
2591{
390b85e7 2592 return (&(_environ));
dcb2879a
GS
2593}
2594
68dc0745
PP
2595/* the rest are the remapped stdio routines */
2596DllExport FILE *
2597win32_stderr(void)
0a753a76 2598{
390b85e7 2599 return (stderr);
0a753a76
PP
2600}
2601
68dc0745
PP
2602DllExport FILE *
2603win32_stdin(void)
0a753a76 2604{
390b85e7 2605 return (stdin);
0a753a76
PP
2606}
2607
68dc0745 2608DllExport FILE *
0934c9d9 2609win32_stdout(void)
0a753a76 2610{
390b85e7 2611 return (stdout);
0a753a76
PP
2612}
2613
68dc0745
PP
2614DllExport int
2615win32_ferror(FILE *fp)
0a753a76 2616{
390b85e7 2617 return (ferror(fp));
0a753a76
PP
2618}
2619
2620
68dc0745
PP
2621DllExport int
2622win32_feof(FILE *fp)
0a753a76 2623{
390b85e7 2624 return (feof(fp));
0a753a76
PP
2625}
2626
e85fa3eb 2627#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
cd6a3131 2628extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
e85fa3eb 2629#endif
cd6a3131 2630
68dc0745 2631/*
3fadfdf1 2632 * Since the errors returned by the socket error function
68dc0745 2633 * WSAGetLastError() are not known by the library routine strerror
cd6a3131
SH
2634 * we have to roll our own to cover the case of socket errors
2635 * that could not be converted to regular errno values by
2636 * get_last_socket_error() in win32/win32sck.c.
68dc0745 2637 */
0a753a76 2638
68dc0745 2639DllExport char *
3fadfdf1 2640win32_strerror(int e)
0a753a76 2641{
378eeda7 2642#if !defined __MINGW32__ /* compiler intolerance */
68dc0745 2643 extern int sys_nerr;
3e3baf6d 2644#endif
0a753a76 2645
9404a519 2646 if (e < 0 || e > sys_nerr) {
9399a70c 2647 dTHXa(NULL);
9404a519 2648 if (e < 0)
68dc0745 2649 e = GetLastError();
e85fa3eb 2650#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
4f79e9b1
SH
2651 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2652 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2653 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2654 * We must therefore still roll our own messages for these codes, and
2655 * additionally map them to corresponding Windows (sockets) error codes
2656 * first to avoid getting the wrong system message.
cd6a3131 2657 */
e7e45461 2658 else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) {
cd6a3131
SH
2659 e = convert_errno_to_wsa_error(e);
2660 }
2661#endif
0a753a76 2662
9399a70c 2663 aTHXa(PERL_GET_THX);
364d54ba
JD
2664 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2665 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2666 w32_strerror_buffer, sizeof(w32_strerror_buffer),
2667 NULL) == 0)
2668 {
3352bfcb 2669 strcpy(w32_strerror_buffer, "Unknown Error");
364d54ba 2670 }
3352bfcb 2671 return w32_strerror_buffer;
68dc0745 2672 }
364d54ba 2673#undef strerror
390b85e7 2674 return strerror(e);
364d54ba 2675#define strerror win32_strerror
0a753a76
PP
2676}
2677
22fae026 2678DllExport void
c5be433b 2679win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM
2680{
2681 DWORD dwLen;
2682 char *sMsg;
2683 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2684 |FORMAT_MESSAGE_IGNORE_INSERTS
2685 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2686 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 2687 /* strip trailing whitespace and period */
22fae026 2688 if (0 < dwLen) {
2ce77adf
GS
2689 do {
2690 --dwLen; /* dwLen doesn't include trailing null */
2691 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM
2692 if ('.' != sMsg[dwLen])
2693 dwLen++;
2ce77adf 2694 sMsg[dwLen] = '\0';
22fae026
TM
2695 }
2696 if (0 == dwLen) {
c69f6586 2697 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS
2698 if (sMsg)
2699 dwLen = sprintf(sMsg,
2700 "Unknown error #0x%lX (lookup 0x%lX)",
2701 dwErr, GetLastError());
2702 }
2703 if (sMsg) {
acfe0abc 2704 dTHX;
db7c17d7
GS
2705 sv_setpvn((SV*)sv, sMsg, dwLen);
2706 LocalFree(sMsg);
22fae026 2707 }
22fae026
TM
2708}
2709
68dc0745
PP
2710DllExport int
2711win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2712{
68dc0745
PP
2713 va_list marker;
2714 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2715
390b85e7 2716 return (vfprintf(fp, format, marker));
0a753a76
PP
2717}
2718
68dc0745
PP
2719DllExport int
2720win32_printf(const char *format, ...)
0a753a76 2721{
68dc0745
PP
2722 va_list marker;
2723 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2724
390b85e7 2725 return (vprintf(format, marker));
0a753a76
PP
2726}
2727
68dc0745
PP
2728DllExport int
2729win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2730{
390b85e7 2731 return (vfprintf(fp, format, args));
0a753a76
PP
2732}
2733
96e4d5b1
PP
2734DllExport int
2735win32_vprintf(const char *format, va_list args)
2736{
390b85e7 2737 return (vprintf(format, args));
96e4d5b1
PP
2738}
2739
68dc0745
PP
2740DllExport size_t
2741win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2742{
390b85e7 2743 return fread(buf, size, count, fp);
0a753a76
PP
2744}
2745
68dc0745
PP
2746DllExport size_t
2747win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2748{
390b85e7 2749 return fwrite(buf, size, count, fp);
0a753a76
PP
2750}
2751
7fac1903
GS
2752#define MODE_SIZE 10
2753
68dc0745
PP
2754DllExport FILE *
2755win32_fopen(const char *filename, const char *mode)
0a753a76 2756{
04a2c3d9 2757 dTHXa(NULL);
1c5905c2 2758 FILE *f;
3fadfdf1 2759
c5be433b
GS
2760 if (!*filename)
2761 return NULL;
2762
68dc0745 2763 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS
2764 filename = "NUL";
2765
04a2c3d9 2766 aTHXa(PERL_GET_THX);
8c56068e 2767 f = fopen(PerlDir_mapA(filename), mode);
1c5905c2
GS
2768 /* avoid buffering headaches for child processes */
2769 if (f && *mode == 'a')
2770 win32_fseek(f, 0, SEEK_END);
2771 return f;
0a753a76
PP
2772}
2773
68dc0745 2774DllExport FILE *
7fac1903 2775win32_fdopen(int handle, const char *mode)
0a753a76 2776{
1c5905c2 2777 FILE *f;
8c56068e 2778 f = fdopen(handle, (char *) mode);
1c5905c2
GS
2779 /* avoid buffering headaches for child processes */
2780 if (f && *mode == 'a')
2781 win32_fseek(f, 0, SEEK_END);
2782 return f;
0a753a76
PP
2783}
2784
68dc0745 2785DllExport FILE *
7fac1903 2786win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2787{
04a2c3d9 2788 dTHXa(NULL);
68dc0745 2789 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
2790 path = "NUL";
2791
04a2c3d9 2792 aTHXa(PERL_GET_THX);
7766f137 2793 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76
PP
2794}
2795
68dc0745
PP
2796DllExport int
2797win32_fclose(FILE *pf)
0a753a76 2798{
19253ae6
DD
2799#ifdef WIN32_NO_SOCKETS
2800 return fclose(pf);
2801#else
f3986ebb 2802 return my_fclose(pf); /* defined in win32sck.c */
19253ae6 2803#endif
0a753a76
PP
2804}
2805
68dc0745
PP
2806DllExport int
2807win32_fputs(const char *s,FILE *pf)
0a753a76 2808{
390b85e7 2809 return fputs(s, pf);
0a753a76
PP
2810}
2811
68dc0745
PP
2812DllExport int
2813win32_fputc(int c,FILE *pf)
0a753a76 2814{
390b85e7 2815 return fputc(c,pf);
0a753a76
PP
2816}
2817
68dc0745
PP
2818DllExport int
2819win32_ungetc(int c,FILE *pf)
0a753a76 2820{
390b85e7 2821 return ungetc(c,pf);
0a753a76
PP
2822}
2823
68dc0745
PP
2824DllExport int
2825win32_getc(FILE *pf)
0a753a76 2826{
390b85e7 2827 return getc(pf);
0a753a76
PP
2828}
2829
68dc0745
PP
2830DllExport int
2831win32_fileno(FILE *pf)
0a753a76 2832{
390b85e7 2833 return fileno(pf);
0a753a76
PP
2834}
2835
68dc0745
PP
2836DllExport void
2837win32_clearerr(FILE *pf)
0a753a76 2838{
390b85e7 2839 clearerr(pf);
68dc0745 2840 return;
0a753a76
PP
2841}
2842
68dc0745
PP
2843DllExport int
2844win32_fflush(FILE *pf)
0a753a76 2845{
390b85e7 2846 return fflush(pf);
0a753a76
PP
2847}
2848
c623ac67 2849DllExport Off_t
68dc0745 2850win32_ftell(FILE *pf)
0a753a76 2851{
c623ac67
GS
2852 fpos_t pos;
2853 if (fgetpos(pf, &pos))
2854 return -1;
2855 return (Off_t)pos;
0a753a76
PP
2856}
2857
68dc0745 2858DllExport int
c623ac67 2859win32_fseek(FILE *pf, Off_t offset,int origin)
0a753a76 2860{
c623ac67
GS
2861 fpos_t pos;
2862 switch (origin) {
2863 case SEEK_CUR:
2864 if (fgetpos(pf, &pos))
2865 return -1;
2866 offset += pos;
2867 break;
2868 case SEEK_END:
2869 fseek(pf, 0, SEEK_END);
2870 pos = _telli64(fileno(pf));
2871 offset += pos;
2872 break;
2873 case SEEK_SET:
2874 break;
2875 default:
2876 errno = EINVAL;
2877 return -1;
2878 }
2879 return fsetpos(pf, &offset);
0a753a76
PP
2880}
2881
68dc0745
PP
2882DllExport int
2883win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2884{
390b85e7 2885 return fgetpos(pf, p);
0a753a76
PP
2886}
2887
68dc0745
PP
2888DllExport int
2889win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2890{
390b85e7 2891 return fsetpos(pf, p);
0a753a76
PP
2892}
2893
68dc0745
PP
2894DllExport void
2895win32_rewind(FILE *pf)
0a753a76 2896{
390b85e7 2897 rewind(pf);
68dc0745 2898 return;
0a753a76
PP
2899}
2900
2941a2e1
JH
2901DllExport int
2902win32_tmpfd(void)
0a753a76 2903{
04247234
TC
2904 return win32_tmpfd_mode(0);
2905}
2906
2907DllExport int
2908win32_tmpfd_mode(int mode)
2909{
b3122bc4
JH
2910 char prefix[MAX_PATH+1];
2911 char filename[MAX_PATH+1];
2912 DWORD len = GetTempPath(MAX_PATH, prefix);
04247234
TC
2913 mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
2914 mode |= O_RDWR;
b3122bc4
JH
2915 if (len && len < MAX_PATH) {
2916 if (GetTempFileName(prefix, "plx", 0, filename)) {
2917 HANDLE fh = CreateFile(filename,
2918 DELETE | GENERIC_READ | GENERIC_WRITE,
2919 0,
2920 NULL,
2921 CREATE_ALWAYS,
2922 FILE_ATTRIBUTE_NORMAL
2923 | FILE_FLAG_DELETE_ON_CLOSE,
2924 NULL);
2925 if (fh != INVALID_HANDLE_VALUE) {
04247234 2926 int fd = win32_open_osfhandle((intptr_t)fh, mode);
b3122bc4 2927 if (fd >= 0) {
2b01189b 2928 PERL_DEB(dTHX;)
b3122bc4
JH
2929 DEBUG_p(PerlIO_printf(Perl_debug_log,
2930 "Created tmpfile=%s\n",filename));
2941a2e1 2931 return fd;
b3122bc4
JH
2932 }
2933 }
2934 }
2935 }
2941a2e1
JH
2936 return -1;
2937}
2938
2939DllExport FILE*
2940win32_tmpfile(void)
2941{
2942 int fd = win32_tmpfd();
2943 if (fd >= 0)
2944 return win32_fdopen(fd, "w+b");
b3122bc4 2945 return NULL;
0a753a76
PP
2946}
2947
68dc0745
PP
2948DllExport void
2949win32_abort(void)
0a753a76 2950{
390b85e7 2951 abort();
68dc0745 2952 return;
0a753a76
PP
2953}
2954
68dc0745 2955DllExport int
c623ac67 2956win32_fstat(int fd, Stat_t *sbufptr)
0a753a76 2957{
8cbe99e5 2958 return _fstati64(fd, sbufptr);
0a753a76
PP
2959}
2960
68dc0745
PP
2961DllExport int
2962win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2963{
390b85e7 2964 return _pipe(pfd, size, mode);
0a753a76
PP
2965}
2966
8c0134a8
NIS
2967DllExport PerlIO*
2968win32_popenlist(const char *mode, IV narg, SV **args)
2969{
aac983ac 2970 get_shell();
8c0134a8 2971
aac983ac
TC
2972 return do_popen(mode, NULL, narg, args);
2973}
50892819 2974
aac983ac
TC
2975STATIC PerlIO*
2976do_popen(const char *mode, const char *command, IV narg, SV **args) {
50892819 2977 int p[2];
f06c8825 2978 int handles[3];
50892819 2979 int parent, child;
c161da64 2980 int stdfd;
50892819
GS
2981 int ourmode;
2982 int childpid;
1095be37 2983 DWORD nhandle;
1095be37 2984 int lock_held = 0;
aac983ac 2985 const char **args_pvs = NULL;
50892819
GS
2986
2987 /* establish which ends read and write */
2988 if (strchr(mode,'w')) {
2989 stdfd = 0; /* stdin */
2990 parent = 1;
2991 child = 0;
1095be37 2992 nhandle = STD_INPUT_HANDLE;
50892819
GS
2993 }
2994 else if (strchr(mode,'r')) {
2995 stdfd = 1; /* stdout */
2996 parent = 0;
2997 child = 1;
1095be37 2998 nhandle = STD_OUTPUT_HANDLE;
50892819
GS
2999 }
3000 else
3001 return NULL;
3002
3003 /* set the correct mode */
3004 if (strchr(mode,'b'))
3005 ourmode = O_BINARY;
3006 else if (strchr(mode,'t'))
3007 ourmode = O_TEXT;
3008 else
3009 ourmode = _fmode & (O_TEXT | O_BINARY);
3010
3011 /* the child doesn't inherit handles */
3012 ourmode |= O_NOINHERIT;
3013
1095be37 3014 if (win32_pipe(p, 512, ourmode) == -1)
50892819
GS
3015 return NULL;
3016
f06c8825
TC
3017 /* Previously this code redirected stdin/out temporarily so the
3018 child process inherited those handles, this caused race
3019 conditions when another thread was writing/reading those
3020 handles.
498d7dc4 3021
f06c8825
TC
3022 To avoid that we just feed the handles to CreateProcess() so
3023 the handles are redirected only in the child.
3024 */
3025 handles[child] = p[child];
3026 handles[parent] = -1;
3027 handles[2] = -1;
564914cd 3028
f06c8825 3029 /* CreateProcess() requires inheritable handles */
c161da64 3030 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
f06c8825 3031 HANDLE_FLAG_INHERIT)) {
50892819 3032 goto cleanup;
f06c8825 3033 }
1095be37 3034
50892819 3035 /* start the child */
4f63d024 3036 {
acfe0abc 3037 dTHX;
50892819 3038
aac983ac
TC
3039 if (command) {
3040 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3041 goto cleanup;
3042
3043 }
3044 else {
3045 int i;
f5fe1b19 3046 const char *exe_name;
aac983ac
TC
3047
3048 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3049 SAVEFREEPV(args_pvs);
3050 for (i = 0; i < narg; ++i)
3051 args_pvs[i] = SvPV_nolen(args[i]);
3052 args_pvs[i] = NULL;
f5fe1b19
TC
3053 exe_name = qualified_path(args_pvs[0], TRUE);
3054 if (!exe_name)
3055 /* let CreateProcess() try to find it instead */
3056 exe_name = args_pvs[0];
aac983ac 3057
f5fe1b19
TC
3058 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3059 goto cleanup;
aac983ac
TC
3060 }
3061 }
498d7dc4 3062
f06c8825 3063 win32_close(p[child]);
1095be37 3064
4f63d024 3065 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
d91d68c1
R
3066
3067 /* set process id so that it can be returned by perl's open() */
3068 PL_forkprocess = childpid;
4f63d024 3069 }
50892819
GS
3070
3071 /* we have an fd, return a file stream */
00b02797 3072 return (PerlIO_fdopen(p[parent], (char *)mode));
50892819
GS
3073
3074cleanup:
3075 /* we don't need to check for errors here */
3076 win32_close(p[0]);
3077 win32_close(p[1]);
f06c8825 3078
50892819 3079 return (NULL);
aac983ac
TC
3080}
3081
3082/*
3083 * a popen() clone that respects PERL5SHELL
3084 *
3085 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3086 */
50892819 3087
aac983ac
TC
3088DllExport PerlIO*
3089win32_popen(const char *command, const char *mode)
3090{
3091#ifdef USE_RTL_POPEN
3092 return _popen(command, mode);
3093#else
3094 return do_popen(mode, command, 0, NULL);
4b556e6c 3095#endif /* USE_RTL_POPEN */
0a753a76
PP
3096}
3097
50892819
GS
3098/*
3099 * pclose() clone
3100 */
3101
68dc0745 3102DllExport int
00b02797 3103win32_pclose(PerlIO *pf)
0a753a76 3104{
4b556e6c 3105#ifdef USE_RTL_POPEN
390b85e7 3106 return _pclose(pf);
50892819 3107#else
acfe0abc 3108 dTHX;
e17cb2a9
JD
3109 int childpid, status;
3110 SV *sv;
3111
00b02797 3112 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
4755096e 3113
e17cb2a9
JD
3114 if (SvIOK(sv))
3115 childpid = SvIVX(sv);
3116 else
3117 childpid = 0;
50892819
GS
3118
3119 if (!childpid) {
3120 errno = EBADF;
3121 return -1;
3122 }
3123
00b02797
JH
3124#ifdef USE_PERLIO
3125 PerlIO_close(pf);
3126#else
3127 fclose(pf);
3128#endif
e17cb2a9
JD
3129 SvIVX(sv) = 0;
3130
0aaad0ff
GS
3131 if (win32_waitpid(childpid, &status, 0) == -1)
3132 return -1;
50892819 3133
0aaad0ff 3134 return status;
50892819 3135
4b556e6c 3136#endif /* USE_RTL_POPEN */
0a753a76 3137}
6b980173 3138
6b980173
JD
3139DllExport int
3140win32_link(const char *oldname, const char *newname)
3141{
04a2c3d9 3142 dTHXa(NULL);
82867ecf
GS
3143 WCHAR wOldName[MAX_PATH+1];
3144 WCHAR wNewName[MAX_PATH+1];
6b980173 3145
8c56068e
JD
3146 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3147 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
04a2c3d9 3148 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
8cbe99e5 3149 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD
3150 {
3151 return 0;
3152 }
2b42d7ed
TC
3153 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3154 both permissions errors and if the source is a directory, while
3155 POSIX wants EACCES and EPERM respectively.
3156
3157 Determined by experimentation on Windows 7 x64 SP1, since MS
3158 don't document what error codes are returned.
3159 */
3160 switch (GetLastError()) {
3161 case ERROR_BAD_NET_NAME:
3162 case ERROR_BAD_NETPATH:
3163 case ERROR_BAD_PATHNAME:
3164 case ERROR_FILE_NOT_FOUND:
3165 case ERROR_FILENAME_EXCED_RANGE:
3166 case ERROR_INVALID_DRIVE:
3167 case ERROR_PATH_NOT_FOUND:
3168 errno = ENOENT;
3169 break;
3170 case ERROR_ALREADY_EXISTS:
3171 errno = EEXIST;
3172 break;
3173 case ERROR_ACCESS_DENIED:
3174 errno = EACCES;
3175 break;
3176 case ERROR_NOT_SAME_DEVICE:
3177 errno = EXDEV;
3178 break;
e41416c3
CM
3179 case ERROR_DISK_FULL:
3180 errno = ENOSPC;
3181 break;
3182 case ERROR_NOT_ENOUGH_QUOTA:
3183 errno = EDQUOT;
3184 break;
2b42d7ed
TC
3185 default:
3186 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3187 errno = EINVAL;
3188 break;
3189 }
6b980173
JD
3190 return -1;
3191}
0a753a76 3192
68dc0745 3193DllExport int
8d9b2e3c 3194win32_rename(const char *oname, const char *newname)
e24c7c18 3195{
65cb15a1 3196 char szOldName[MAX_PATH+1];
7fac1903 3197 BOOL bResult;
8cbe99e5 3198 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
acfe0abc 3199 dTHX;
65cb15a1 3200
8cbe99e5
JD
3201 if (stricmp(newname, oname))
3202 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3203 strcpy(szOldName, PerlDir_mapA(oname));
3204
3205 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3206 if (!bResult) {
3207 DWORD err = GetLastError();
3208 switch (err) {
3209 case ERROR_BAD_NET_NAME:
3210 case ERROR_BAD_NETPATH:
3211 case ERROR_BAD_PATHNAME:
3212 case ERROR_FILE_NOT_FOUND:
3213 case ERROR_FILENAME_EXCED_RANGE:
3214 case ERROR_INVALID_DRIVE:
3215 case ERROR_NO_MORE_FILES:
3216 case ERROR_PATH_NOT_FOUND:
3217 errno = ENOENT;
3218 break;
e41416c3
CM
3219 case ERROR_DISK_FULL:
3220 errno = ENOSPC;
3221 break;
3222 case ERROR_NOT_ENOUGH_QUOTA:
3223 errno = EDQUOT;
3224 break;
8cbe99e5
JD
3225 default:
3226 errno = EACCES;
3227 break;
3228 }
3229 return -1;
e24c7c18 3230 }
8cbe99e5 3231 return 0;
e24c7c18
GS
3232}
3233
3234DllExport int
68dc0745 3235win32_setmode(int fd, int mode)
0a753a76 3236{
390b85e7 3237 return setmode(fd, mode);
0a753a76
PP
3238}
3239
4a9d6100
GS
3240DllExport int
3241win32_chsize(int fd, Off_t size)
3242{
4a9d6100
GS
3243 int retval = 0;
3244 Off_t cur, end, extend;
3245
3246 cur = win32_tell(fd);
3247 if (cur < 0)
3248 return -1;
3249 end = win32_lseek(fd, 0, SEEK_END);
3250 if (end < 0)
3251 return -1;
3252 extend = size - end;
3253 if (extend == 0) {
3254 /* do nothing */
3255 }
3256 else if (extend > 0) {
3257 /* must grow the file, padding with nulls */
3258 char b[4096];
3259 int oldmode = win32_setmode(fd, O_BINARY);
3260 size_t count;
3261 memset(b, '\0', sizeof(b));
3262 do {
3263 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3264 count = win32_write(fd, b, count);
21424390 3265 if ((int)count < 0) {
4a9d6100
GS
3266 retval = -1;
3267 break;
3268 }
3269 } while ((extend -= count) > 0);
3270 win32_setmode(fd, oldmode);
3271 }
3272 else {
3273 /* shrink the file */
3274 win32_lseek(fd, size, SEEK_SET);
3275 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3276 errno = EACCES;
3277 retval = -1;
3278 }
3279 }
4a9d6100
GS
3280 win32_lseek(fd, cur, SEEK_SET);
3281 return retval;
4a9d6100
GS
3282}
3283
c623ac67
GS
3284DllExport Off_t
3285win32_lseek(int fd, Off_t offset, int origin)
96e4d5b1 3286{
c623ac67 3287 return _lseeki64(fd, offset, origin);
96e4d5b1
PP
3288}
3289
c623ac67 3290DllExport Off_t
96e4d5b1
PP
3291win32_tell(int fd)
3292{
c623ac67 3293 return _telli64(fd);
96e4d5b1
PP
3294}
3295
68dc0745
PP
3296DllExport int
3297win32_open(const char *path, int flag, ...)
0a753a76 3298{
04a2c3d9 3299 dTHXa(NULL);
68dc0745
PP
3300 va_list ap;
3301 int pmode;
0a753a76
PP
3302
3303 va_start(ap, flag);
3304 pmode = va_arg(ap, int);
3305 va_end(ap);
3306
68dc0745 3307 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
3308 path = "NUL";
3309
04a2c3d9 3310 aTHXa(PERL_GET_THX);
7766f137 3311 return open(PerlDir_mapA(path), flag, pmode);
0a753a76
PP
3312}
3313
00b02797
JH
3314/* close() that understands socket */
3315extern int my_close(int); /* in win32sck.c */
3316
68dc0745
PP
3317DllExport int
3318win32_close(int fd)
0a753a76 3319{
19253ae6
DD
3320#ifdef WIN32_NO_SOCKETS
3321 return close(fd);
3322#else
00b02797 3323 return my_close(fd);
19253ae6 3324#endif
0a753a76
PP
3325}
3326
68dc0745 3327DllExport int
96e4d5b1
PP
3328win32_eof(int fd)
3329{
390b85e7 3330 return eof(fd);
96e4d5b1
PP
3331}
3332
3333DllExport int
4342f4d6
JD
3334win32_isatty(int fd)
3335{
3336 /* The Microsoft isatty() function returns true for *all*
3337 * character mode devices, including "nul". Our implementation
3338 * should only return true if the handle has a console buffer.
3339 */
3340 DWORD mode;
3341 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3342 if (fh == (HANDLE)-1) {
3343 /* errno is already set to EBADF */
3344 return 0;
3345 }
3346
3347 if (GetConsoleMode(fh, &mode))
3348 return 1;
3349
3350 errno = ENOTTY;
3351 return 0;
3352}
3353
3354DllExport int
68dc0745 3355win32_dup(int fd)
0a753a76 3356{
390b85e7 3357 return dup(fd);
0a753a76
PP
3358}
3359
68dc0745
PP
3360DllExport int
3361win32_dup2(int fd1,int fd2)
0a753a76 3362{
390b85e7 3363 return dup2(fd1,fd2);
0a753a76
PP
3364}
3365
68dc0745 3366DllExport int
3e3baf6d 3367win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 3368{
390b85e7 3369 return read(fd, buf, cnt);
0a753a76
PP
3370}
3371
68dc0745 3372DllExport int
3e3baf6d 3373win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 3374{
390b85e7 3375 return write(fd, buf, cnt);
0a753a76
PP
3376}
3377
68dc0745 3378DllExport int
5aabfad6
PP
3379win32_mkdir(const char *dir, int mode)
3380{
acfe0abc 3381 dTHX;
7766f137 3382 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 3383}
96e4d5b1 3384
5aabfad6
PP
3385DllExport int
3386win32_rmdir(const char *dir)
3387{
acfe0abc 3388 dTHX;
7766f137 3389 return rmdir(PerlDir_mapA(dir));
5aabfad6 3390}
96e4d5b1 3391
5aabfad6
PP
3392DllExport int
3393win32_chdir(const char *dir)
3394{
1cdd9224 3395 if (!dir || !*dir) {
9ec3348a
JH
3396 errno = ENOENT;
3397 return -1;
3398 }
390b85e7 3399 return chdir(dir);
5aabfad6 3400}
96e4d5b1 3401
7766f137
GS
3402DllExport int
3403win32_access(const char *path, int mode)
3404{
acfe0abc 3405 dTHX;
7766f137
GS
3406 return access(PerlDir_mapA(path), mode);
3407}
3408
3409DllExport int
3410win32_chmod(const char *path, int mode)
3411{
acfe0abc 3412 dTHX;
7766f137
GS
3413 return chmod(PerlDir_mapA(path), mode);
3414}
3415
3416
0aaad0ff 3417static char *
dd7038b3 3418create_command_line(char *cname, STRLEN clen, const char * const *args)
0aaad0ff 3419{
2b01189b 3420 PERL_DEB(dTHX;)
b309b8ae
JH
3421 int index, argc;
3422 char *cmd, *ptr;
3423 const char *arg;
3424 STRLEN len = 0;
81bc1258 3425 bool bat_file = FALSE;
b309b8ae 3426 bool cmd_shell = FALSE;
7b11e424 3427 bool dumb_shell = FALSE;
b309b8ae 3428 bool extra_quotes = FALSE;
dd7038b3 3429 bool quote_next = FALSE;
81bc1258
JH
3430
3431 if (!cname)
3432 cname = (char*)args[0];
b309b8ae
JH
3433
3434 /* The NT cmd.exe shell has the following peculiarity that needs to be
3435 * worked around. It strips a leading and trailing dquote when any
3436 * of the following is true:
3437 * 1. the /S switch was used
3438 * 2. there are more than two dquotes
3439 * 3. there is a special character from this set: &<>()@^|
3440 * 4. no whitespace characters within the two dquotes
3441 * 5. string between two dquotes isn't an executable file
3442 * To work around this, we always add a leading and trailing dquote
3443 * to the string, if the first argument is either "cmd.exe" or "cmd",
3444 * and there were at least two or more arguments passed to cmd.exe
3445 * (not including switches).
dd7038b3
JH
3446 * XXX the above rules (from "cmd /?") don't seem to be applied
3447 * always, making for the convolutions below :-(
b309b8ae 3448 */
81bc1258 3449 if (cname) {
dd7038b3
JH
3450 if (!clen)
3451 clen = strlen(cname);
3452
81bc1258
JH
3453 if (clen > 4
3454 && (stricmp(&cname[clen-4], ".bat") == 0
8cbe99e5 3455 || (stricmp(&cname[clen-4], ".cmd") == 0)))
81bc1258
JH
3456 {
3457 bat_file = TRUE;
8cbe99e5 3458 len += 3;
81bc1258 3459 }
dd7038b3
JH
3460 else {
3461 char *exe = strrchr(cname, '/');
3462 char *exe2 = strrchr(cname, '\\');
3463 if (exe2 > exe)
3464 exe = exe2;
3465 if (exe)
3466 ++exe;
3467 else
3468 exe = cname;
3469 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3470 cmd_shell = TRUE;
3471 len += 3;
3472 }
7b11e424
JH
3473 else if (stricmp(exe, "command.com") == 0
3474 || stricmp(exe, "command") == 0)
3475 {
3476 dumb_shell = TRUE;
3477 }
81bc1258 3478 }
b309b8ae 3479 }
0aaad0ff 3480
b309b8ae
JH
3481 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3482 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3483 STRLEN curlen = strlen(arg);
3484 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3485 len += 2; /* assume quoting needed (worst case) */
3486 len += curlen + 1;
3487 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3488 }
3489 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
0aaad0ff 3490
b309b8ae 3491 argc = index;
a02a5408 3492 Newx(cmd, len, char);
0aaad0ff 3493 ptr = cmd;
0aaad0ff 3494
8cbe99e5 3495 if (bat_file) {
81bc1258
JH
3496 *ptr++ = '"';
3497 extra_quotes = TRUE;
3498 }
3499
0aaad0ff 3500 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
b309b8ae
JH
3501 bool do_quote = 0;
3502 STRLEN curlen = strlen(arg);
3503
81bc1258
JH
3504 /* we want to protect empty arguments and ones with spaces with
3505 * dquotes, but only if they aren't already there */
7b11e424
JH
3506 if (!dumb_shell) {
3507 if (!curlen) {
3508 do_quote = 1;
3509 }
02ef22d5
JH
3510 else if (quote_next) {
3511 /* see if it really is multiple arguments pretending to
3512 * be one and force a set of quotes around it */
3513 if (*find_next_space(arg))
3514 do_quote = 1;
3515 }
7b11e424
JH
3516 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3517 STRLEN i = 0;
3518 while (i < curlen) {
3519 if (isSPACE(arg[i])) {
3520 do_quote = 1;
02ef22d5
JH
3521 }
3522 else if (arg[i] == '"') {
3523 do_quote = 0;
7b11e424
JH
3524 break;
3525 }
3526 i++;
b309b8ae 3527 }
b309b8ae 3528 }
dd7038b3 3529 }
b309b8ae
JH
3530
3531 if (do_quote)
3532 *ptr++ = '"';
3533
18a945d4 3534 strcpy(ptr, arg);
b309b8ae
JH
3535 ptr += curlen;
3536
3537 if (do_quote)
3538 *ptr++ = '"';
3539
3540 if (args[index+1])
3541 *ptr++ = ' ';
3542
81bc1258
JH
3543 if (!extra_quotes
3544 && cmd_shell