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