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