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