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