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