This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
new perldelta
[perl5.git] / win32 / win32.c
... / ...
CommitLineData
1/* WIN32.C
2 *
3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc.
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 */
10#define PERLIO_NOT_STDIO 0
11#define WIN32_LEAN_AND_MEAN
12#define WIN32IO_IS_STDIO
13/* for CreateSymbolicLinkA() etc */
14#define _WIN32_WINNT 0x0601
15#include <tchar.h>
16
17#ifdef __GNUC__
18# define Win32_Winsock
19#endif
20
21#include <windows.h>
22
23#ifndef HWND_MESSAGE
24# define HWND_MESSAGE ((HWND)-3)
25#endif
26
27#ifndef PROCESSOR_ARCHITECTURE_AMD64
28# define PROCESSOR_ARCHITECTURE_AMD64 9
29#endif
30
31#ifndef WC_NO_BEST_FIT_CHARS
32# define WC_NO_BEST_FIT_CHARS 0x00000400
33#endif
34
35#include <winnt.h>
36#include <commctrl.h>
37#include <tlhelp32.h>
38#include <io.h>
39#include <signal.h>
40#include <winioctl.h>
41#include <winternl.h>
42
43/* #include "config.h" */
44
45
46#define PerlIO FILE
47
48#include <sys/stat.h>
49#include "EXTERN.h"
50#include "perl.h"
51
52#define NO_XSLOCKS
53#define PERL_NO_GET_CONTEXT
54#include "XSUB.h"
55
56#include <fcntl.h>
57#ifndef __GNUC__
58/* assert.h conflicts with #define of assert in perl.h */
59# include <assert.h>
60#endif
61
62#include <string.h>
63#include <stdarg.h>
64#include <float.h>
65#include <time.h>
66#include <sys/utime.h>
67#include <wchar.h>
68
69#ifdef __GNUC__
70/* Mingw32 defaults to globing command line
71 * So we turn it off like this:
72 */
73int _CRT_glob = 0;
74#endif
75
76#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
77/* Mingw32-1.1 is missing some prototypes */
78START_EXTERN_C
79FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
80FILE * _wfdopen(int nFd, LPCWSTR wszMode);
81FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
82int _flushall();
83int _fcloseall();
84END_EXTERN_C
85#endif
86
87#define EXECF_EXEC 1
88#define EXECF_SPAWN 2
89#define EXECF_SPAWN_NOWAIT 3
90
91#if defined(PERL_IMPLICIT_SYS)
92# undef getlogin
93# define getlogin g_getlogin
94#endif
95
96#ifdef _MSC_VER
97# define SET_INVALID_PARAMETER_HANDLER
98#endif
99
100#ifdef SET_INVALID_PARAMETER_HANDLER
101static BOOL set_silent_invalid_parameter_handler(BOOL newvalue);
102static void my_invalid_parameter_handler(const wchar_t* expression,
103 const wchar_t* function, const wchar_t* file,
104 unsigned int line, uintptr_t pReserved);
105#endif
106
107#ifndef WIN32_NO_REGISTRY
108static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp);
109static char* get_regstr(const char *valuename, SV **svp);
110#endif
111
112static char* get_emd_part(SV **prev_pathp, STRLEN *const len,
113 const char *trailing, ...);
114static char* win32_get_xlib(const char *pl,
115 WIN32_NO_REGISTRY_M_(const char *xlib)
116 const char *libname, STRLEN *const len);
117
118static BOOL has_shell_metachars(const char *ptr);
119static long tokenize(const char *str, char **dest, char ***destv);
120static int get_shell(void);
121static char* find_next_space(const char *s);
122static int do_spawn2(pTHX_ const char *cmd, int exectype);
123static int do_spawn2_handles(pTHX_ const char *cmd, int exectype,
124 const int *handles);
125static int do_spawnvp_handles(int mode, const char *cmdname,
126 const char * const *argv, const int *handles);
127static PerlIO * do_popen(const char *mode, const char *command, IV narg,
128 SV **args);
129static long find_pid(pTHX_ int pid);
130static void remove_dead_process(long child);
131static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
132static int my_killpg(int pid, int sig);
133static int my_kill(int pid, int sig);
134static void out_of_memory(const char *context, STRLEN len);
135static char* wstr_to_str(const wchar_t* wstr);
136static long filetime_to_clock(PFILETIME ft);
137static BOOL filetime_from_time(PFILETIME ft, time_t t);
138static char* create_command_line(char *cname, STRLEN clen,
139 const char * const *args);
140static char* qualified_path(const char *cmd, bool other_exts);
141static void ansify_path(void);
142static LRESULT win32_process_message(HWND hwnd, UINT msg,
143 WPARAM wParam, LPARAM lParam);
144
145#ifdef USE_ITHREADS
146static long find_pseudo_pid(pTHX_ int pid);
147static void remove_dead_pseudo_process(long child);
148static HWND get_hwnd_delay(pTHX, long child, DWORD tries);
149#endif
150
151#ifdef HAVE_INTERP_INTERN
152static void win32_csighandler(int sig);
153#endif
154
155static void translate_to_errno(void);
156
157START_EXTERN_C
158HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
159char w32_module_name[MAX_PATH+1];
160END_EXTERN_C
161
162static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""};
163
164#ifndef WIN32_NO_REGISTRY
165/* initialized by Perl_win32_init/PERL_SYS_INIT */
166static HKEY HKCU_Perl_hnd;
167static HKEY HKLM_Perl_hnd;
168#endif
169
170/* the time_t epoch start time as a filetime expressed as a large integer */
171static ULARGE_INTEGER time_t_epoch_base_filetime;
172
173static const SYSTEMTIME time_t_epoch_base_systemtime = {
174 1970, /* wYear */
175 1, /* wMonth */
176 0, /* wDayOfWeek */
177 1, /* wDay */
178 0, /* wHour */
179 0, /* wMinute */
180 0, /* wSecond */
181 0 /* wMilliseconds */
182};
183
184#define FILETIME_CHUNKS_PER_SECOND (10000000UL)
185
186#ifdef USE_ITHREADS
187static perl_mutex win32_read_console_mutex;
188#endif
189
190#ifdef SET_INVALID_PARAMETER_HANDLER
191static BOOL silent_invalid_parameter_handler = FALSE;
192
193static BOOL
194set_silent_invalid_parameter_handler(BOOL newvalue)
195{
196 BOOL oldvalue = silent_invalid_parameter_handler;
197# ifdef _DEBUG
198 silent_invalid_parameter_handler = newvalue;
199# endif
200 return oldvalue;
201}
202
203static void
204my_invalid_parameter_handler(const wchar_t* expression,
205 const wchar_t* function,
206 const wchar_t* file,
207 unsigned int line,
208 uintptr_t pReserved)
209{
210# ifdef _DEBUG
211 char* ansi_expression;
212 char* ansi_function;
213 char* ansi_file;
214 if (silent_invalid_parameter_handler)
215 return;
216 ansi_expression = wstr_to_str(expression);
217 ansi_function = wstr_to_str(function);
218 ansi_file = wstr_to_str(file);
219 fprintf(stderr, "Invalid parameter detected in function %s. "
220 "File: %s, line: %d\n", ansi_function, ansi_file, line);
221 fprintf(stderr, "Expression: %s\n", ansi_expression);
222 free(ansi_expression);
223 free(ansi_function);
224 free(ansi_file);
225# endif
226}
227#endif
228
229EXTERN_C void
230set_w32_module_name(void)
231{
232 /* this function may be called at DLL_PROCESS_ATTACH time */
233 char* ptr;
234 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
235 ? GetModuleHandle(NULL)
236 : w32_perldll_handle);
237
238 WCHAR modulename[MAX_PATH];
239 WCHAR fullname[MAX_PATH];
240 char *ansi;
241
242 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) =
243 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD))
244 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW");
245
246 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR));
247
248 /* Make sure we get an absolute pathname in case the module was loaded
249 * explicitly by LoadLibrary() with a relative path. */
250 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL);
251
252 /* Make sure we start with the long path name of the module because we
253 * later scan for pathname components to match "5.xx" to locate
254 * compatible sitelib directories, and the short pathname might mangle
255 * this path segment (e.g. by removing the dot on NTFS to something
256 * like "5xx~1.yy") */
257 if (pfnGetLongPathNameW)
258 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR));
259
260 /* remove \\?\ prefix */
261 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0)
262 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR));
263
264 ansi = win32_ansipath(fullname);
265 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name));
266 win32_free(ansi);
267
268 /* normalize to forward slashes */
269 ptr = w32_module_name;
270 while (*ptr) {
271 if (*ptr == '\\')
272 *ptr = '/';
273 ++ptr;
274 }
275}
276
277#ifndef WIN32_NO_REGISTRY
278/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
279static char*
280get_regstr_from(HKEY handle, const char *valuename, SV **svp)
281{
282 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
283 DWORD type;
284 char *str = NULL;
285 long retval;
286 DWORD datalen;
287
288 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
289 if (retval == ERROR_SUCCESS
290 && (type == REG_SZ || type == REG_EXPAND_SZ))
291 {
292 dTHX;
293 if (!*svp)
294 *svp = sv_2mortal(newSVpvs(""));
295 SvGROW(*svp, datalen);
296 retval = RegQueryValueEx(handle, valuename, 0, NULL,
297 (PBYTE)SvPVX(*svp), &datalen);
298 if (retval == ERROR_SUCCESS) {
299 str = SvPVX(*svp);
300 SvCUR_set(*svp,datalen-1);
301 }
302 }
303 return str;
304}
305
306/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
307static char*
308get_regstr(const char *valuename, SV **svp)
309{
310 char *str;
311 if (HKCU_Perl_hnd) {
312 str = get_regstr_from(HKCU_Perl_hnd, valuename, svp);
313 if (!str)
314 goto try_HKLM;
315 }
316 else {
317 try_HKLM:
318 if (HKLM_Perl_hnd)
319 str = get_regstr_from(HKLM_Perl_hnd, valuename, svp);
320 else
321 str = NULL;
322 }
323 return str;
324}
325#endif /* ifndef WIN32_NO_REGISTRY */
326
327/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
328static char *
329get_emd_part(SV **prev_pathp, STRLEN *const len, const char *trailing_path, ...)
330{
331 char base[10];
332 va_list ap;
333 char mod_name[MAX_PATH+1];
334 char *ptr;
335 char *optr;
336 char *strip;
337 STRLEN baselen;
338
339 va_start(ap, trailing_path);
340 strip = va_arg(ap, char *);
341
342 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
343 baselen = strlen(base);
344
345 if (!*w32_module_name) {
346 set_w32_module_name();
347 }
348 strcpy(mod_name, w32_module_name);
349 ptr = strrchr(mod_name, '/');
350 while (ptr && strip) {
351 /* look for directories to skip back */
352 optr = ptr;
353 *ptr = '\0';
354 ptr = strrchr(mod_name, '/');
355 /* avoid stripping component if there is no slash,
356 * or it doesn't match ... */
357 if (!ptr || stricmp(ptr+1, strip) != 0) {
358 /* ... but not if component matches m|5\.$patchlevel.*| */
359 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
360 && strnEQ(strip, base, baselen)
361 && strnEQ(ptr+1, base, baselen)))
362 {
363 *optr = '/';
364 ptr = optr;
365 }
366 }
367 strip = va_arg(ap, char *);
368 }
369 if (!ptr) {
370 ptr = mod_name;
371 *ptr++ = '.';
372 *ptr = '/';
373 }
374 va_end(ap);
375 strcpy(++ptr, trailing_path);
376
377 /* only add directory if it exists */
378 if (GetFileAttributes(mod_name) != (DWORD) -1) {
379 /* directory exists */
380 dTHX;
381 if (!*prev_pathp)
382 *prev_pathp = sv_2mortal(newSVpvs(""));
383 else if (SvPVX(*prev_pathp))
384 sv_catpvs(*prev_pathp, ";");
385 sv_catpv(*prev_pathp, mod_name);
386 if(len)
387 *len = SvCUR(*prev_pathp);
388 return SvPVX(*prev_pathp);
389 }
390
391 return NULL;
392}
393
394EXTERN_C char *
395win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len)
396{
397 const char *stdlib = "lib";
398 SV *sv = NULL;
399#ifndef WIN32_NO_REGISTRY
400 char buffer[MAX_PATH+1];
401
402 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
403 sprintf(buffer, "%s-%s", stdlib, pl);
404 if (!get_regstr(buffer, &sv))
405 (void)get_regstr(stdlib, &sv);
406#endif
407
408 /* $stdlib .= ";$EMD/../../lib" */
409 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
410}
411
412static char *
413win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib)
414 const char *libname, STRLEN *const len)
415{
416#ifndef WIN32_NO_REGISTRY
417 char regstr[40];
418#endif
419 char pathstr[MAX_PATH+1];
420 SV *sv1 = NULL;
421 SV *sv2 = NULL;
422
423#ifndef WIN32_NO_REGISTRY
424 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
425 sprintf(regstr, "%s-%s", xlib, pl);
426 (void)get_regstr(regstr, &sv1);
427#endif
428
429 /* $xlib .=
430 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
431 sprintf(pathstr, "%s/%s/lib", libname, pl);
432 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
433
434#ifndef WIN32_NO_REGISTRY
435 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
436 (void)get_regstr(xlib, &sv2);
437#endif
438
439 /* $xlib .=
440 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
441 sprintf(pathstr, "%s/lib", libname);
442 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
443
444 if (!sv1 && !sv2)
445 return NULL;
446 if (!sv1) {
447 sv1 = sv2;
448 } else if (sv2) {
449 dTHX;
450 sv_catpvs(sv1, ";");
451 sv_catsv(sv1, sv2);
452 }
453
454 if (len)
455 *len = SvCUR(sv1);
456 return SvPVX(sv1);
457}
458
459EXTERN_C char *
460win32_get_sitelib(const char *pl, STRLEN *const len)
461{
462 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len);
463}
464
465#ifndef PERL_VENDORLIB_NAME
466# define PERL_VENDORLIB_NAME "vendor"
467#endif
468
469EXTERN_C char *
470win32_get_vendorlib(const char *pl, STRLEN *const len)
471{
472 return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len);
473}
474
475static BOOL
476has_shell_metachars(const char *ptr)
477{
478 int inquote = 0;
479 char quote = '\0';
480
481 /*
482 * Scan string looking for redirection (< or >) or pipe
483 * characters (|) that are not in a quoted string.
484 * Shell variable interpolation (%VAR%) can also happen inside strings.
485 */
486 while (*ptr) {
487 switch(*ptr) {
488 case '%':
489 return TRUE;
490 case '\'':
491 case '\"':
492 if (inquote) {
493 if (quote == *ptr) {
494 inquote = 0;
495 quote = '\0';
496 }
497 }
498 else {
499 quote = *ptr;
500 inquote++;
501 }
502 break;
503 case '>':
504 case '<':
505 case '|':
506 if (!inquote)
507 return TRUE;
508 default:
509 break;
510 }
511 ++ptr;
512 }
513 return FALSE;
514}
515
516#if !defined(PERL_IMPLICIT_SYS)
517/* since the current process environment is being updated in util.c
518 * the library functions will get the correct environment
519 */
520PerlIO *
521Perl_my_popen(pTHX_ const char *cmd, const char *mode)
522{
523 PERL_FLUSHALL_FOR_CHILD;
524 return win32_popen(cmd, mode);
525}
526
527long
528Perl_my_pclose(pTHX_ PerlIO *fp)
529{
530 return win32_pclose(fp);
531}
532#endif
533
534DllExport unsigned long
535win32_os_id(void)
536{
537 return (unsigned long)g_osver.dwPlatformId;
538}
539
540DllExport int
541win32_getpid(void)
542{
543#ifdef USE_ITHREADS
544 dTHX;
545 if (w32_pseudo_id)
546 return -((int)w32_pseudo_id);
547#endif
548 return _getpid();
549}
550
551/* Tokenize a string. Words are null-separated, and the list
552 * ends with a doubled null. Any character (except null and
553 * including backslash) may be escaped by preceding it with a
554 * backslash (the backslash will be stripped).
555 * Returns number of words in result buffer.
556 */
557static long
558tokenize(const char *str, char **dest, char ***destv)
559{
560 char *retstart = NULL;
561 char **retvstart = 0;
562 int items = -1;
563 if (str) {
564 int slen = strlen(str);
565 char *ret;
566 char **retv;
567 Newx(ret, slen+2, char);
568 Newx(retv, (slen+3)/2, char*);
569
570 retstart = ret;
571 retvstart = retv;
572 *retv = ret;
573 items = 0;
574 while (*str) {
575 *ret = *str++;
576 if (*ret == '\\' && *str)
577 *ret = *str++;
578 else if (*ret == ' ') {
579 while (*str == ' ')
580 str++;
581 if (ret == retstart)
582 ret--;
583 else {
584 *ret = '\0';
585 ++items;
586 if (*str)
587 *++retv = ret+1;
588 }
589 }
590 else if (!*str)
591 ++items;
592 ret++;
593 }
594 retvstart[items] = NULL;
595 *ret++ = '\0';
596 *ret = '\0';
597 }
598 *dest = retstart;
599 *destv = retvstart;
600 return items;
601}
602
603static const char
604cmd_opts[] = "/x/d/c";
605
606static const char
607shell_cmd[] = "cmd.exe";
608
609static int
610get_shell(void)
611{
612 dTHX;
613 if (!w32_perlshell_tokens) {
614 /* we don't use COMSPEC here for two reasons:
615 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
616 * uncontrolled unportability of the ensuing scripts.
617 * 2. PERL5SHELL could be set to a shell that may not be fit for
618 * interactive use (which is what most programs look in COMSPEC
619 * for).
620 */
621 const char *shell = PerlEnv_getenv("PERL5SHELL");
622 if (shell) {
623 w32_perlshell_items = tokenize(shell,
624 &w32_perlshell_tokens,
625 &w32_perlshell_vec);
626 }
627 else {
628 /* tokenize does some Unix-ish like things like
629 \\ escaping that don't work well here
630 */
631 char shellbuf[MAX_PATH];
632 UINT len = GetSystemDirectoryA(shellbuf, sizeof(shellbuf));
633 if (len == 0) {
634 translate_to_errno();
635 return -1;
636 }
637 else if (len >= MAX_PATH) {
638 /* buffer too small */
639 errno = E2BIG;
640 return -1;
641 }
642 if (shellbuf[len-1] != '\\') {
643 my_strlcat(shellbuf, "\\", sizeof(shellbuf));
644 ++len;
645 }
646 if (len + sizeof(shell_cmd) > sizeof(shellbuf)) {
647 errno = E2BIG;
648 return -1;
649 }
650 my_strlcat(shellbuf, shell_cmd, sizeof(shellbuf));
651 len += sizeof(shell_cmd)-1;
652
653 Newx(w32_perlshell_vec, 3, char *);
654 Newx(w32_perlshell_tokens, len + 1 + sizeof(cmd_opts), char);
655
656 my_strlcpy(w32_perlshell_tokens, shellbuf, len+1);
657 my_strlcpy(w32_perlshell_tokens + len +1, cmd_opts,
658 sizeof(cmd_opts));
659
660 w32_perlshell_vec[0] = w32_perlshell_tokens;
661 w32_perlshell_vec[1] = w32_perlshell_tokens + len + 1;
662 w32_perlshell_vec[2] = NULL;
663
664 w32_perlshell_items = 2;
665 }
666 }
667 return 0;
668}
669
670int
671Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
672{
673 const char **argv;
674 char *str;
675 int status;
676 int flag = P_WAIT;
677 int index = 0;
678 int eno;
679
680 PERL_ARGS_ASSERT_DO_ASPAWN;
681
682 if (sp <= mark)
683 return -1;
684
685 if (get_shell() < 0)
686 return -1;
687
688 Newx(argv, (sp - mark) + w32_perlshell_items + 2, const char*);
689
690 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
691 ++mark;
692 flag = SvIVx(*mark);
693 }
694
695 while (++mark <= sp) {
696 if (*mark && (str = SvPV_nolen(*mark)))
697 argv[index++] = str;
698 else
699 argv[index++] = "";
700 }
701 argv[index++] = 0;
702
703 status = win32_spawnvp(flag,
704 (const char*)(really ? SvPV_nolen(really) : argv[0]),
705 (const char* const*)argv);
706
707 if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) {
708 /* possible shell-builtin, invoke with shell */
709 int sh_items;
710 sh_items = w32_perlshell_items;
711 while (--index >= 0)
712 argv[index+sh_items] = argv[index];
713 while (--sh_items >= 0)
714 argv[sh_items] = w32_perlshell_vec[sh_items];
715
716 status = win32_spawnvp(flag,
717 (const char*)(really ? SvPV_nolen(really) : argv[0]),
718 (const char* const*)argv);
719 }
720
721 if (flag == P_NOWAIT) {
722 PL_statusvalue = -1; /* >16bits hint for pp_system() */
723 }
724 else {
725 if (status < 0) {
726 if (ckWARN(WARN_EXEC))
727 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
728 status = 255 * 256;
729 }
730 else
731 status *= 256;
732 PL_statusvalue = status;
733 }
734 Safefree(argv);
735 return (status);
736}
737
738/* returns pointer to the next unquoted space or the end of the string */
739static char*
740find_next_space(const char *s)
741{
742 bool in_quotes = FALSE;
743 while (*s) {
744 /* ignore doubled backslashes, or backslash+quote */
745 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
746 s += 2;
747 }
748 /* keep track of when we're within quotes */
749 else if (*s == '"') {
750 s++;
751 in_quotes = !in_quotes;
752 }
753 /* break it up only at spaces that aren't in quotes */
754 else if (!in_quotes && isSPACE(*s))
755 return (char*)s;
756 else
757 s++;
758 }
759 return (char*)s;
760}
761
762static int
763do_spawn2(pTHX_ const char *cmd, int exectype) {
764 return do_spawn2_handles(aTHX_ cmd, exectype, NULL);
765}
766
767static int
768do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
769{
770 char **a;
771 char *s;
772 char **argv;
773 int status = -1;
774 BOOL needToTry = TRUE;
775 char *cmd2;
776
777 /* Save an extra exec if possible. See if there are shell
778 * metacharacters in it */
779 if (!has_shell_metachars(cmd)) {
780 Newx(argv, strlen(cmd) / 2 + 2, char*);
781 Newx(cmd2, strlen(cmd) + 1, char);
782 strcpy(cmd2, cmd);
783 a = argv;
784 for (s = cmd2; *s;) {
785 while (*s && isSPACE(*s))
786 s++;
787 if (*s)
788 *(a++) = s;
789 s = find_next_space(s);
790 if (*s)
791 *s++ = '\0';
792 }
793 *a = NULL;
794 if (argv[0]) {
795 switch (exectype) {
796 case EXECF_SPAWN:
797 status = win32_spawnvp(P_WAIT, argv[0],
798 (const char* const*)argv);
799 break;
800 case EXECF_SPAWN_NOWAIT:
801 status = do_spawnvp_handles(P_NOWAIT, argv[0],
802 (const char* const*)argv, handles);
803 break;
804 case EXECF_EXEC:
805 status = win32_execvp(argv[0], (const char* const*)argv);
806 break;
807 }
808 if (status != -1 || errno == 0)
809 needToTry = FALSE;
810 }
811 Safefree(argv);
812 Safefree(cmd2);
813 }
814 if (needToTry) {
815 char **argv;
816 int i = -1;
817 if (get_shell() < 0)
818 return -1;
819 Newx(argv, w32_perlshell_items + 2, char*);
820 while (++i < w32_perlshell_items)
821 argv[i] = w32_perlshell_vec[i];
822 argv[i++] = (char *)cmd;
823 argv[i] = NULL;
824 switch (exectype) {
825 case EXECF_SPAWN:
826 status = win32_spawnvp(P_WAIT, argv[0],
827 (const char* const*)argv);
828 break;
829 case EXECF_SPAWN_NOWAIT:
830 status = do_spawnvp_handles(P_NOWAIT, argv[0],
831 (const char* const*)argv, handles);
832 break;
833 case EXECF_EXEC:
834 status = win32_execvp(argv[0], (const char* const*)argv);
835 break;
836 }
837 cmd = argv[0];
838 Safefree(argv);
839 }
840 if (exectype == EXECF_SPAWN_NOWAIT) {
841 PL_statusvalue = -1; /* >16bits hint for pp_system() */
842 }
843 else {
844 if (status < 0) {
845 if (ckWARN(WARN_EXEC))
846 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
847 (exectype == EXECF_EXEC ? "exec" : "spawn"),
848 cmd, strerror(errno));
849 status = 255 * 256;
850 }
851 else
852 status *= 256;
853 PL_statusvalue = status;
854 }
855 return (status);
856}
857
858int
859Perl_do_spawn(pTHX_ char *cmd)
860{
861 PERL_ARGS_ASSERT_DO_SPAWN;
862
863 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
864}
865
866int
867Perl_do_spawn_nowait(pTHX_ char *cmd)
868{
869 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
870
871 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
872}
873
874bool
875Perl_do_exec(pTHX_ const char *cmd)
876{
877 PERL_ARGS_ASSERT_DO_EXEC;
878
879 do_spawn2(aTHX_ cmd, EXECF_EXEC);
880 return FALSE;
881}
882
883/* The idea here is to read all the directory names into a string table
884 * (separated by nulls) and when one of the other dir functions is called
885 * return the pointer to the current file name.
886 */
887DllExport DIR *
888win32_opendir(const char *filename)
889{
890 dTHXa(NULL);
891 DIR *dirp;
892 long len;
893 long idx;
894 char scanname[MAX_PATH+3];
895 WCHAR wscanname[sizeof(scanname)];
896 WIN32_FIND_DATAW wFindData;
897 char buffer[MAX_PATH*2];
898 BOOL use_default;
899
900 len = strlen(filename);
901 if (len == 0) {
902 errno = ENOENT;
903 return NULL;
904 }
905 if (len > MAX_PATH) {
906 errno = ENAMETOOLONG;
907 return NULL;
908 }
909
910 /* Get us a DIR structure */
911 Newxz(dirp, 1, DIR);
912
913 /* Create the search pattern */
914 strcpy(scanname, filename);
915
916 /* bare drive name means look in cwd for drive */
917 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
918 scanname[len++] = '.';
919 scanname[len++] = '/';
920 }
921 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
922 scanname[len++] = '/';
923 }
924 scanname[len++] = '*';
925 scanname[len] = '\0';
926
927 /* do the FindFirstFile call */
928 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR));
929 aTHXa(PERL_GET_THX);
930 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData);
931
932 if (dirp->handle == INVALID_HANDLE_VALUE) {
933 DWORD err = GetLastError();
934 /* FindFirstFile() fails on empty drives! */
935 switch (err) {
936 case ERROR_FILE_NOT_FOUND:
937 return dirp;
938 case ERROR_NO_MORE_FILES:
939 case ERROR_PATH_NOT_FOUND:
940 errno = ENOENT;
941 break;
942 case ERROR_NOT_ENOUGH_MEMORY:
943 errno = ENOMEM;
944 break;
945 default:
946 errno = EINVAL;
947 break;
948 }
949 Safefree(dirp);
950 return NULL;
951 }
952
953 use_default = FALSE;
954 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
955 wFindData.cFileName, -1,
956 buffer, sizeof(buffer), NULL, &use_default);
957 if (use_default && *wFindData.cAlternateFileName) {
958 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
959 wFindData.cAlternateFileName, -1,
960 buffer, sizeof(buffer), NULL, NULL);
961 }
962
963 /* now allocate the first part of the string table for
964 * the filenames that we find.
965 */
966 idx = strlen(buffer)+1;
967 if (idx < 256)
968 dirp->size = 256;
969 else
970 dirp->size = idx;
971 Newx(dirp->start, dirp->size, char);
972 strcpy(dirp->start, buffer);
973 dirp->nfiles++;
974 dirp->end = dirp->curr = dirp->start;
975 dirp->end += idx;
976 return dirp;
977}
978
979
980/* Readdir just returns the current string pointer and bumps the
981 * string pointer to the nDllExport entry.
982 */
983DllExport struct direct *
984win32_readdir(DIR *dirp)
985{
986 long len;
987
988 if (dirp->curr) {
989 /* first set up the structure to return */
990 len = strlen(dirp->curr);
991 strcpy(dirp->dirstr.d_name, dirp->curr);
992 dirp->dirstr.d_namlen = len;
993
994 /* Fake an inode */
995 dirp->dirstr.d_ino = dirp->curr - dirp->start;
996
997 /* Now set up for the next call to readdir */
998 dirp->curr += len + 1;
999 if (dirp->curr >= dirp->end) {
1000 BOOL res;
1001 char buffer[MAX_PATH*2];
1002
1003 if (dirp->handle == INVALID_HANDLE_VALUE) {
1004 res = 0;
1005 }
1006 /* finding the next file that matches the wildcard
1007 * (which should be all of them in this directory!).
1008 */
1009 else {
1010 WIN32_FIND_DATAW wFindData;
1011 res = FindNextFileW(dirp->handle, &wFindData);
1012 if (res) {
1013 BOOL use_default = FALSE;
1014 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1015 wFindData.cFileName, -1,
1016 buffer, sizeof(buffer), NULL, &use_default);
1017 if (use_default && *wFindData.cAlternateFileName) {
1018 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1019 wFindData.cAlternateFileName, -1,
1020 buffer, sizeof(buffer), NULL, NULL);
1021 }
1022 }
1023 }
1024 if (res) {
1025 long endpos = dirp->end - dirp->start;
1026 long newsize = endpos + strlen(buffer) + 1;
1027 /* bump the string table size by enough for the
1028 * new name and its null terminator */
1029 while (newsize > dirp->size) {
1030 long curpos = dirp->curr - dirp->start;
1031 Renew(dirp->start, dirp->size * 2, char);
1032 dirp->size *= 2;
1033 dirp->curr = dirp->start + curpos;
1034 }
1035 strcpy(dirp->start + endpos, buffer);
1036 dirp->end = dirp->start + newsize;
1037 dirp->nfiles++;
1038 }
1039 else {
1040 dirp->curr = NULL;
1041 if (dirp->handle != INVALID_HANDLE_VALUE) {
1042 FindClose(dirp->handle);
1043 dirp->handle = INVALID_HANDLE_VALUE;
1044 }
1045 }
1046 }
1047 return &(dirp->dirstr);
1048 }
1049 else
1050 return NULL;
1051}
1052
1053/* Telldir returns the current string pointer position */
1054DllExport long
1055win32_telldir(DIR *dirp)
1056{
1057 return dirp->curr ? (dirp->curr - dirp->start) : -1;
1058}
1059
1060
1061/* Seekdir moves the string pointer to a previously saved position
1062 * (returned by telldir).
1063 */
1064DllExport void
1065win32_seekdir(DIR *dirp, long loc)
1066{
1067 /* Ensure dirp->curr remains within `dirp->start` buffer. */
1068 if (loc >= 0 && dirp->end - dirp->start > (ptrdiff_t) loc) {
1069 dirp->curr = dirp->start + loc;
1070 } else {
1071 dirp->curr = NULL;
1072 }
1073}
1074
1075/* Rewinddir resets the string pointer to the start */
1076DllExport void
1077win32_rewinddir(DIR *dirp)
1078{
1079 dirp->curr = dirp->start;
1080}
1081
1082/* free the memory allocated by opendir */
1083DllExport int
1084win32_closedir(DIR *dirp)
1085{
1086 if (dirp->handle != INVALID_HANDLE_VALUE)
1087 FindClose(dirp->handle);
1088 Safefree(dirp->start);
1089 Safefree(dirp);
1090 return 1;
1091}
1092
1093/* duplicate a open DIR* for interpreter cloning */
1094DllExport DIR *
1095win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param)
1096{
1097 PerlInterpreter *const from = param->proto_perl;
1098 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX;
1099
1100 long pos;
1101 DIR *dup;
1102
1103 /* switch back to original interpreter because win32_readdir()
1104 * might Renew(dirp->start).
1105 */
1106 if (from != to) {
1107 PERL_SET_THX(from);
1108 }
1109
1110 /* mark current position; read all remaining entries into the
1111 * cache, and then restore to current position.
1112 */
1113 pos = win32_telldir(dirp);
1114 while (win32_readdir(dirp)) {
1115 /* read all entries into cache */
1116 }
1117 win32_seekdir(dirp, pos);
1118
1119 /* switch back to new interpreter to allocate new DIR structure */
1120 if (from != to) {
1121 PERL_SET_THX(to);
1122 }
1123
1124 Newx(dup, 1, DIR);
1125 memcpy(dup, dirp, sizeof(DIR));
1126
1127 Newx(dup->start, dirp->size, char);
1128 memcpy(dup->start, dirp->start, dirp->size);
1129
1130 dup->end = dup->start + (dirp->end - dirp->start);
1131 if (dirp->curr)
1132 dup->curr = dup->start + (dirp->curr - dirp->start);
1133
1134 return dup;
1135}
1136
1137/*
1138 * various stubs
1139 */
1140
1141
1142/* Ownership
1143 *
1144 * Just pretend that everyone is a superuser. NT will let us know if
1145 * we don\'t really have permission to do something.
1146 */
1147
1148#define ROOT_UID ((uid_t)0)
1149#define ROOT_GID ((gid_t)0)
1150
1151uid_t
1152getuid(void)
1153{
1154 return ROOT_UID;
1155}
1156
1157uid_t
1158geteuid(void)
1159{
1160 return ROOT_UID;
1161}
1162
1163gid_t
1164getgid(void)
1165{
1166 return ROOT_GID;
1167}
1168
1169gid_t
1170getegid(void)
1171{
1172 return ROOT_GID;
1173}
1174
1175int
1176setuid(uid_t auid)
1177{
1178 return (auid == ROOT_UID ? 0 : -1);
1179}
1180
1181int
1182setgid(gid_t agid)
1183{
1184 return (agid == ROOT_GID ? 0 : -1);
1185}
1186
1187EXTERN_C char *
1188getlogin(void)
1189{
1190 dTHX;
1191 char *buf = w32_getlogin_buffer;
1192 DWORD size = sizeof(w32_getlogin_buffer);
1193 if (GetUserName(buf,&size))
1194 return buf;
1195 return (char*)NULL;
1196}
1197
1198int
1199chown(const char *path, uid_t owner, gid_t group)
1200{
1201 /* XXX noop */
1202 return 0;
1203}
1204
1205/*
1206 * XXX this needs strengthening (for PerlIO)
1207 * -- BKS, 11-11-200
1208*/
1209#if((!defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4) && \
1210 (!defined(__MINGW32_MAJOR_VERSION) || __MINGW32_MAJOR_VERSION < 3 || \
1211 (__MINGW32_MAJOR_VERSION == 3 && __MINGW32_MINOR_VERSION < 21)))
1212int mkstemp(const char *path)
1213{
1214 dTHX;
1215 char buf[MAX_PATH+1];
1216 int i = 0, fd = -1;
1217
1218retry:
1219 if (i++ > 10) { /* give up */
1220 errno = ENOENT;
1221 return -1;
1222 }
1223 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1224 errno = ENOENT;
1225 return -1;
1226 }
1227 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1228 if (fd == -1)
1229 goto retry;
1230 return fd;
1231}
1232#endif
1233
1234static long
1235find_pid(pTHX_ int pid)
1236{
1237 long child = w32_num_children;
1238 while (--child >= 0) {
1239 if ((int)w32_child_pids[child] == pid)
1240 return child;
1241 }
1242 return -1;
1243}
1244
1245static void
1246remove_dead_process(long child)
1247{
1248 if (child >= 0) {
1249 dTHX;
1250 CloseHandle(w32_child_handles[child]);
1251 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1252 (w32_num_children-child-1), HANDLE);
1253 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1254 (w32_num_children-child-1), DWORD);
1255 w32_num_children--;
1256 }
1257}
1258
1259#ifdef USE_ITHREADS
1260static long
1261find_pseudo_pid(pTHX_ int pid)
1262{
1263 long child = w32_num_pseudo_children;
1264 while (--child >= 0) {
1265 if ((int)w32_pseudo_child_pids[child] == pid)
1266 return child;
1267 }
1268 return -1;
1269}
1270
1271static void
1272remove_dead_pseudo_process(long child)
1273{
1274 if (child >= 0) {
1275 dTHX;
1276 CloseHandle(w32_pseudo_child_handles[child]);
1277 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1278 (w32_num_pseudo_children-child-1), HANDLE);
1279 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1280 (w32_num_pseudo_children-child-1), DWORD);
1281 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child],
1282 (w32_num_pseudo_children-child-1), HWND);
1283 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child],
1284 (w32_num_pseudo_children-child-1), char);
1285 w32_num_pseudo_children--;
1286 }
1287}
1288
1289void
1290win32_wait_for_children(pTHX)
1291{
1292 if (w32_pseudo_children && w32_num_pseudo_children) {
1293 long child = 0;
1294 long count = 0;
1295 HANDLE handles[MAXIMUM_WAIT_OBJECTS];
1296
1297 for (child = 0; child < w32_num_pseudo_children; ++child) {
1298 if (!w32_pseudo_child_sigterm[child])
1299 handles[count++] = w32_pseudo_child_handles[child];
1300 }
1301 /* XXX should use MsgWaitForMultipleObjects() to continue
1302 * XXX processing messages while we wait.
1303 */
1304 WaitForMultipleObjects(count, handles, TRUE, INFINITE);
1305
1306 while (w32_num_pseudo_children)
1307 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]);
1308 }
1309}
1310#endif
1311
1312static int
1313terminate_process(DWORD pid, HANDLE process_handle, int sig)
1314{
1315 switch(sig) {
1316 case 0:
1317 /* "Does process exist?" use of kill */
1318 return 1;
1319 case 2:
1320 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid))
1321 return 1;
1322 break;
1323 case SIGBREAK:
1324 case SIGTERM:
1325 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid))
1326 return 1;
1327 break;
1328 default: /* For now be backwards compatible with perl 5.6 */
1329 case 9:
1330 /* Note that we will only be able to kill processes owned by the
1331 * current process owner, even when we are running as an administrator.
1332 * To kill processes of other owners we would need to set the
1333 * 'SeDebugPrivilege' privilege before obtaining the process handle.
1334 */
1335 if (TerminateProcess(process_handle, sig))
1336 return 1;
1337 break;
1338 }
1339 return 0;
1340}
1341
1342/* returns number of processes killed */
1343static int
1344my_killpg(int pid, int sig)
1345{
1346 HANDLE process_handle;
1347 HANDLE snapshot_handle;
1348 int killed = 0;
1349
1350 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1351 if (process_handle == NULL)
1352 return 0;
1353
1354 killed += terminate_process(pid, process_handle, sig);
1355
1356 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1357 if (snapshot_handle != INVALID_HANDLE_VALUE) {
1358 PROCESSENTRY32 entry;
1359
1360 entry.dwSize = sizeof(entry);
1361 if (Process32First(snapshot_handle, &entry)) {
1362 do {
1363 if (entry.th32ParentProcessID == (DWORD)pid)
1364 killed += my_killpg(entry.th32ProcessID, sig);
1365 entry.dwSize = sizeof(entry);
1366 }
1367 while (Process32Next(snapshot_handle, &entry));
1368 }
1369 CloseHandle(snapshot_handle);
1370 }
1371 CloseHandle(process_handle);
1372 return killed;
1373}
1374
1375/* returns number of processes killed */
1376static int
1377my_kill(int pid, int sig)
1378{
1379 int retval = 0;
1380 HANDLE process_handle;
1381
1382 if (sig < 0)
1383 return my_killpg(pid, -sig);
1384
1385 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid);
1386 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */
1387 if (process_handle != NULL) {
1388 retval = terminate_process(pid, process_handle, sig);
1389 CloseHandle(process_handle);
1390 }
1391 return retval;
1392}
1393
1394#ifdef USE_ITHREADS
1395/* Get a child pseudo-process HWND, with retrying and delaying/yielding.
1396 * The "tries" parameter is the number of retries to make, with a Sleep(1)
1397 * (waiting and yielding the time slot) between each try. Specifying 0 causes
1398 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not
1399 * recommended
1400 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be
1401 * returned) or croaks if the child pseudo-process doesn't schedule and deliver
1402 * a HWND in the time period allowed.
1403 */
1404static HWND
1405get_hwnd_delay(pTHX, long child, DWORD tries)
1406{
1407 HWND hwnd = w32_pseudo_child_message_hwnds[child];
1408 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1409
1410 /* Pseudo-process has not yet properly initialized since hwnd isn't set.
1411 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a
1412 * thread 100% of the time since threads are attached to a CPU for NUMA and
1413 * caching reasons, and the child thread was attached to a different CPU
1414 * therefore there is no workload on that CPU and Sleep(0) returns control
1415 * without yielding the time slot.
1416 * https://github.com/Perl/perl5/issues/11267
1417 */
1418 Sleep(0);
1419 win32_async_check(aTHX);
1420 hwnd = w32_pseudo_child_message_hwnds[child];
1421 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1422
1423 {
1424 unsigned int count = 0;
1425 /* No Sleep(1) if tries==0, just fail instead if we get this far. */
1426 while (count++ < tries) {
1427 Sleep(1);
1428 win32_async_check(aTHX);
1429 hwnd = w32_pseudo_child_message_hwnds[child];
1430 if (hwnd != INVALID_HANDLE_VALUE) return hwnd;
1431 }
1432 }
1433
1434 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled");
1435}
1436#endif
1437
1438DllExport int
1439win32_kill(int pid, int sig)
1440{
1441 dTHX;
1442 long child;
1443#ifdef USE_ITHREADS
1444 if (pid < 0) {
1445 /* it is a pseudo-forked child */
1446 child = find_pseudo_pid(aTHX_ -pid);
1447 if (child >= 0) {
1448 HANDLE hProcess = w32_pseudo_child_handles[child];
1449 switch (sig) {
1450 case 0:
1451 /* "Does process exist?" use of kill */
1452 return 0;
1453
1454 case 9: {
1455 /* kill -9 style un-graceful exit */
1456 /* Do a wait to make sure child starts and isn't in DLL
1457 * Loader Lock */
1458 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1459 if (TerminateThread(hProcess, sig)) {
1460 /* Allow the scheduler to finish cleaning up the other
1461 * thread.
1462 * Otherwise, if we ExitProcess() before another context
1463 * switch happens we will end up with a process exit
1464 * code of "sig" instead of our own exit status.
1465 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976
1466 */
1467 Sleep(0);
1468 remove_dead_pseudo_process(child);
1469 return 0;
1470 }
1471 break;
1472 }
1473
1474 default: {
1475 HWND hwnd = get_hwnd_delay(aTHX, child, 5);
1476 /* We fake signals to pseudo-processes using Win32
1477 * message queue. */
1478 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) ||
1479 PostThreadMessage(-pid, WM_USER_KILL, sig, 0))
1480 {
1481 /* Don't wait for child process to terminate after we send a
1482 * SIGTERM because the child may be blocked in a system call
1483 * and never receive the signal.
1484 */
1485 if (sig == SIGTERM) {
1486 Sleep(0);
1487 w32_pseudo_child_sigterm[child] = 1;
1488 }
1489 /* It might be us ... */
1490 PERL_ASYNC_CHECK();
1491 return 0;
1492 }
1493 break;
1494 }
1495 } /* switch */
1496 }
1497 }
1498 else
1499#endif
1500 {
1501 child = find_pid(aTHX_ pid);
1502 if (child >= 0) {
1503 if (my_kill(pid, sig)) {
1504 DWORD exitcode = 0;
1505 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) &&
1506 exitcode != STILL_ACTIVE)
1507 {
1508 remove_dead_process(child);
1509 }
1510 return 0;
1511 }
1512 }
1513 else {
1514 if (my_kill(pid, sig))
1515 return 0;
1516 }
1517 }
1518 errno = EINVAL;
1519 return -1;
1520}
1521
1522PERL_STATIC_INLINE
1523time_t
1524translate_ft_to_time_t(FILETIME ft) {
1525 SYSTEMTIME st;
1526 struct tm pt;
1527 time_t retval;
1528 dTHX;
1529
1530 if (!FileTimeToSystemTime(&ft, &st))
1531 return -1;
1532
1533 Zero(&pt, 1, struct tm);
1534 pt.tm_year = st.wYear - 1900;
1535 pt.tm_mon = st.wMonth - 1;
1536 pt.tm_mday = st.wDay;
1537 pt.tm_hour = st.wHour;
1538 pt.tm_min = st.wMinute;
1539 pt.tm_sec = st.wSecond;
1540
1541 MKTIME_LOCK;
1542 retval = _mkgmtime(&pt);
1543 MKTIME_UNLOCK;
1544
1545 return retval;
1546}
1547
1548typedef DWORD (__stdcall *pGetFinalPathNameByHandleA_t)(HANDLE, LPSTR, DWORD, DWORD);
1549
1550/* Adapted from:
1551
1552https://docs.microsoft.com/en-us/windows-hardware/drivers/ddi/ntifs/ns-ntifs-_reparse_data_buffer
1553
1554Renamed to avoid conflicts, apparently some SDKs define this
1555structure.
1556
1557Hoisted the symlink and mount point data into a new type to allow us
1558to make a pointer to it, and to avoid C++ scoping issues.
1559
1560*/
1561
1562typedef struct {
1563 USHORT SubstituteNameOffset;
1564 USHORT SubstituteNameLength;
1565 USHORT PrintNameOffset;
1566 USHORT PrintNameLength;
1567 ULONG Flags;
1568 WCHAR PathBuffer[MAX_PATH*3];
1569} MY_SYMLINK_REPARSE_BUFFER, *PMY_SYMLINK_REPARSE_BUFFER;
1570
1571typedef struct {
1572 USHORT SubstituteNameOffset;
1573 USHORT SubstituteNameLength;
1574 USHORT PrintNameOffset;
1575 USHORT PrintNameLength;
1576 WCHAR PathBuffer[MAX_PATH*3];
1577} MY_MOUNT_POINT_REPARSE_BUFFER;
1578
1579typedef struct {
1580 ULONG ReparseTag;
1581 USHORT ReparseDataLength;
1582 USHORT Reserved;
1583 union {
1584 MY_SYMLINK_REPARSE_BUFFER SymbolicLinkReparseBuffer;
1585 MY_MOUNT_POINT_REPARSE_BUFFER MountPointReparseBuffer;
1586 struct {
1587 UCHAR DataBuffer[1];
1588 } GenericReparseBuffer;
1589 } Data;
1590} MY_REPARSE_DATA_BUFFER, *PMY_REPARSE_DATA_BUFFER;
1591
1592#ifndef IO_REPARSE_TAG_SYMLINK
1593# define IO_REPARSE_TAG_SYMLINK (0xA000000CL)
1594#endif
1595#ifndef IO_REPARSE_TAG_AF_UNIX
1596# define IO_REPARSE_TAG_AF_UNIX 0x80000023
1597#endif
1598#ifndef IO_REPARSE_TAG_LX_FIFO
1599# define IO_REPARSE_TAG_LX_FIFO 0x80000024
1600#endif
1601#ifndef IO_REPARSE_TAG_LX_CHR
1602# define IO_REPARSE_TAG_LX_CHR 0x80000025
1603#endif
1604#ifndef IO_REPARSE_TAG_LX_BLK
1605# define IO_REPARSE_TAG_LX_BLK 0x80000026
1606#endif
1607
1608static int
1609win32_stat_low(HANDLE handle, const char *path, STRLEN len, Stat_t *sbuf,
1610 DWORD reparse_type) {
1611 DWORD type = GetFileType(handle);
1612 BY_HANDLE_FILE_INFORMATION bhi;
1613
1614 Zero(sbuf, 1, Stat_t);
1615
1616 if (reparse_type) {
1617 /* Lie to get to the right place */
1618 type = FILE_TYPE_DISK;
1619 }
1620
1621 type &= ~FILE_TYPE_REMOTE;
1622
1623 switch (type) {
1624 case FILE_TYPE_DISK:
1625 if (GetFileInformationByHandle(handle, &bhi)) {
1626 sbuf->st_dev = bhi.dwVolumeSerialNumber;
1627 sbuf->st_ino = bhi.nFileIndexHigh;
1628 sbuf->st_ino <<= 32;
1629 sbuf->st_ino |= bhi.nFileIndexLow;
1630 sbuf->st_nlink = bhi.nNumberOfLinks;
1631 sbuf->st_uid = 0;
1632 sbuf->st_gid = 0;
1633 /* ucrt sets this to the drive letter for
1634 stat(), lets not reproduce that mistake */
1635 sbuf->st_rdev = 0;
1636 sbuf->st_size = bhi.nFileSizeHigh;
1637 sbuf->st_size <<= 32;
1638 sbuf->st_size |= bhi.nFileSizeLow;
1639
1640 sbuf->st_atime = translate_ft_to_time_t(bhi.ftLastAccessTime);
1641 sbuf->st_mtime = translate_ft_to_time_t(bhi.ftLastWriteTime);
1642 sbuf->st_ctime = translate_ft_to_time_t(bhi.ftCreationTime);
1643
1644 if (reparse_type) {
1645 /* https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-fscc/c8e77b37-3909-4fe6-a4ea-2b9d423b1ee4
1646 describes all of these as WSL only, but the AF_UNIX tag
1647 is known to be used for AF_UNIX sockets without WSL.
1648 */
1649 switch (reparse_type) {
1650 case IO_REPARSE_TAG_AF_UNIX:
1651 sbuf->st_mode = _S_IFSOCK;
1652 break;
1653
1654 case IO_REPARSE_TAG_LX_FIFO:
1655 sbuf->st_mode = _S_IFIFO;
1656 break;
1657
1658 case IO_REPARSE_TAG_LX_CHR:
1659 sbuf->st_mode = _S_IFCHR;
1660 break;
1661
1662 case IO_REPARSE_TAG_LX_BLK:
1663 sbuf->st_mode = _S_IFBLK;
1664 break;
1665
1666 default:
1667 /* Is there anything else we can do here? */
1668 errno = EINVAL;
1669 return -1;
1670 }
1671 }
1672 else if (bhi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
1673 sbuf->st_mode = _S_IFDIR | _S_IREAD | _S_IEXEC;
1674 /* duplicate the logic from the end of the old win32_stat() */
1675 if (!(bhi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) {
1676 sbuf->st_mode |= S_IWRITE;
1677 }
1678 }
1679 else {
1680 char path_buf[MAX_PATH+1];
1681 sbuf->st_mode = _S_IFREG;
1682
1683 if (!path) {
1684 pGetFinalPathNameByHandleA_t pGetFinalPathNameByHandleA =
1685 (pGetFinalPathNameByHandleA_t)GetProcAddress(GetModuleHandle("kernel32.dll"), "GetFinalPathNameByHandleA");
1686 if (pGetFinalPathNameByHandleA) {
1687 len = pGetFinalPathNameByHandleA(handle, path_buf, sizeof(path_buf), 0);
1688 }
1689 else {
1690 len = 0;
1691 }
1692
1693 /* < to ensure there's space for the \0 */
1694 if (len && len < sizeof(path_buf)) {
1695 path = path_buf;
1696 }
1697 }
1698
1699 if (path && len > 4 &&
1700 (_stricmp(path + len - 4, ".exe") == 0 ||
1701 _stricmp(path + len - 4, ".bat") == 0 ||
1702 _stricmp(path + len - 4, ".cmd") == 0 ||
1703 _stricmp(path + len - 4, ".com") == 0)) {
1704 sbuf->st_mode |= _S_IEXEC;
1705 }
1706 if (!(bhi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) {
1707 sbuf->st_mode |= _S_IWRITE;
1708 }
1709 sbuf->st_mode |= _S_IREAD;
1710 }
1711 }
1712 else {
1713 translate_to_errno();
1714 return -1;
1715 }
1716 break;
1717
1718 case FILE_TYPE_CHAR:
1719 case FILE_TYPE_PIPE:
1720 sbuf->st_mode = (type == FILE_TYPE_CHAR) ? _S_IFCHR : _S_IFIFO;
1721 if (handle == GetStdHandle(STD_INPUT_HANDLE) ||
1722 handle == GetStdHandle(STD_OUTPUT_HANDLE) ||
1723 handle == GetStdHandle(STD_ERROR_HANDLE)) {
1724 sbuf->st_mode |= _S_IWRITE | _S_IREAD;
1725 }
1726 break;
1727
1728 default:
1729 return -1;
1730 }
1731
1732 /* owner == user == group */
1733 sbuf->st_mode |= (sbuf->st_mode & 0700) >> 3;
1734 sbuf->st_mode |= (sbuf->st_mode & 0700) >> 6;
1735
1736 return 0;
1737}
1738
1739/* https://docs.microsoft.com/en-us/windows/win32/fileio/reparse-points */
1740#define SYMLINK_FOLLOW_LIMIT 63
1741
1742/*
1743
1744Given a pathname, required to be a symlink, follow it until we find a
1745non-symlink path.
1746
1747This should only be called when the symlink() chain doesn't lead to a
1748normal file, which should have been caught earlier.
1749
1750On success, returns a HANDLE to the target and sets *reparse_type to
1751the ReparseTag of the target.
1752
1753Returns INVALID_HANDLE_VALUE on error, which might be that the symlink
1754chain is broken, or requires too many links to resolve.
1755
1756*/
1757
1758static HANDLE
1759S_follow_symlinks_to(pTHX_ const char *pathname, DWORD *reparse_type) {
1760 char link_target[MAX_PATH];
1761 SV *work_path = newSVpvn(pathname, strlen(pathname));
1762 int link_count = 0;
1763 int link_len;
1764 HANDLE handle;
1765
1766 *reparse_type = 0;
1767
1768 while ((link_len = win32_readlink(SvPVX(work_path), link_target,
1769 sizeof(link_target))) > 0) {
1770 if (link_count++ >= SYMLINK_FOLLOW_LIMIT) {
1771 /* Windows doesn't appear to ever return ELOOP,
1772 let's do better ourselves
1773 */
1774 SvREFCNT_dec(work_path);
1775 errno = ELOOP;
1776 return INVALID_HANDLE_VALUE;
1777 }
1778 /* Adjust the linktarget based on the link source or current
1779 directory as needed.
1780 */
1781 if (link_target[0] == '\\'
1782 || link_target[0] == '/'
1783 || (link_len >=2 && link_target[1] == ':')) {
1784 /* link is absolute */
1785 sv_setpvn(work_path, link_target, link_len);
1786 }
1787 else {
1788 STRLEN work_len;
1789 const char *workp = SvPV(work_path, work_len);
1790 const char *final_bslash =
1791 (const char *)my_memrchr(workp, '\\', work_len);
1792 const char *final_slash =
1793 (const char *)my_memrchr(workp, '/', work_len);
1794 const char *path_sep = NULL;
1795 if (final_bslash && final_slash)
1796 path_sep = final_bslash > final_slash ? final_bslash : final_slash;
1797 else if (final_bslash)
1798 path_sep = final_bslash;
1799 else if (final_slash)
1800 path_sep = final_slash;
1801
1802 if (path_sep) {
1803 SV *new_path = newSVpv(workp, path_sep - workp + 1);
1804 sv_catpvn(new_path, link_target, link_len);
1805 SvREFCNT_dec(work_path);
1806 work_path = new_path;
1807 }
1808 else {
1809 /* should only get here the first time around */
1810 assert(link_count == 1);
1811 char path_temp[MAX_PATH];
1812 DWORD path_len = GetCurrentDirectoryA(sizeof(path_temp), path_temp);
1813 if (!path_len || path_len > sizeof(path_temp)) {
1814 SvREFCNT_dec(work_path);
1815 errno = EINVAL;
1816 return INVALID_HANDLE_VALUE;
1817 }
1818
1819 SV *new_path = newSVpvn(path_temp, path_len);
1820 if (path_temp[path_len-1] != '\\') {
1821 sv_catpvs(new_path, "\\");
1822 }
1823 sv_catpvn(new_path, link_target, link_len);
1824 SvREFCNT_dec(work_path);
1825 work_path = new_path;
1826 }
1827 }
1828 }
1829
1830 handle =
1831 CreateFileA(SvPVX(work_path), GENERIC_READ, 0, NULL, OPEN_EXISTING,
1832 FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
1833 SvREFCNT_dec(work_path);
1834 if (handle != INVALID_HANDLE_VALUE) {
1835 MY_REPARSE_DATA_BUFFER linkdata;
1836 DWORD linkdata_returned;
1837
1838 if (!DeviceIoControl(handle, FSCTL_GET_REPARSE_POINT, NULL, 0,
1839 &linkdata, sizeof(linkdata),
1840 &linkdata_returned, NULL)) {
1841 translate_to_errno();
1842 CloseHandle(handle);
1843 return INVALID_HANDLE_VALUE;
1844 }
1845 *reparse_type = linkdata.ReparseTag;
1846 return handle;
1847 }
1848 else {
1849 translate_to_errno();
1850 }
1851
1852 return handle;
1853}
1854
1855DllExport int
1856win32_stat(const char *path, Stat_t *sbuf)
1857{
1858 dTHX;
1859 BOOL expect_dir = FALSE;
1860 int result;
1861 HANDLE handle;
1862 DWORD reparse_type = 0;
1863
1864 path = PerlDir_mapA(path);
1865
1866 handle =
1867 CreateFileA(path, FILE_READ_ATTRIBUTES,
1868 FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
1869 NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1870 if (handle == INVALID_HANDLE_VALUE) {
1871 /* AF_UNIX sockets need to be opened as a reparse point, but
1872 that will also open symlinks rather than following them.
1873
1874 There may be other reparse points that need similar
1875 treatment.
1876 */
1877 handle = S_follow_symlinks_to(aTHX_ path, &reparse_type);
1878 if (handle == INVALID_HANDLE_VALUE) {
1879 /* S_follow_symlinks_to() will set errno */
1880 return -1;
1881 }
1882 }
1883 if (handle != INVALID_HANDLE_VALUE) {
1884 result = win32_stat_low(handle, path, strlen(path), sbuf, reparse_type);
1885 CloseHandle(handle);
1886 }
1887 else {
1888 translate_to_errno();
1889 result = -1;
1890 }
1891
1892 return result;
1893}
1894
1895static void
1896translate_to_errno(void)
1897{
1898 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
1899 both permissions errors and if the source is a directory, while
1900 POSIX wants EACCES and EPERM respectively.
1901 */
1902 switch (GetLastError()) {
1903 case ERROR_BAD_NET_NAME:
1904 case ERROR_BAD_NETPATH:
1905 case ERROR_BAD_PATHNAME:
1906 case ERROR_FILE_NOT_FOUND:
1907 case ERROR_FILENAME_EXCED_RANGE:
1908 case ERROR_INVALID_DRIVE:
1909 case ERROR_PATH_NOT_FOUND:
1910 errno = ENOENT;
1911 break;
1912 case ERROR_ALREADY_EXISTS:
1913 errno = EEXIST;
1914 break;
1915 case ERROR_ACCESS_DENIED:
1916 errno = EACCES;
1917 break;
1918 case ERROR_PRIVILEGE_NOT_HELD:
1919 errno = EPERM;
1920 break;
1921 case ERROR_NOT_SAME_DEVICE:
1922 errno = EXDEV;
1923 break;
1924 case ERROR_DISK_FULL:
1925 errno = ENOSPC;
1926 break;
1927 case ERROR_NOT_ENOUGH_QUOTA:
1928 errno = EDQUOT;
1929 break;
1930 default:
1931 /* ERROR_INVALID_FUNCTION - eg. symlink on a FAT volume */
1932 errno = EINVAL;
1933 break;
1934 }
1935}
1936
1937static BOOL
1938is_symlink(HANDLE h) {
1939 MY_REPARSE_DATA_BUFFER linkdata;
1940 const MY_SYMLINK_REPARSE_BUFFER * const sd =
1941 &linkdata.Data.SymbolicLinkReparseBuffer;
1942 DWORD linkdata_returned;
1943
1944 if (!DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, &linkdata, sizeof(linkdata), &linkdata_returned, NULL)) {
1945 return FALSE;
1946 }
1947
1948 if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.SymbolicLinkReparseBuffer.PathBuffer)
1949 || (linkdata.ReparseTag != IO_REPARSE_TAG_SYMLINK
1950 && linkdata.ReparseTag != IO_REPARSE_TAG_MOUNT_POINT)) {
1951 /* some other type of reparse point */
1952 return FALSE;
1953 }
1954
1955 return TRUE;
1956}
1957
1958static BOOL
1959is_symlink_name(const char *name) {
1960 HANDLE f = CreateFileA(name, GENERIC_READ, 0, NULL, OPEN_EXISTING,
1961 FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
1962 BOOL result;
1963
1964 if (f == INVALID_HANDLE_VALUE) {
1965 return FALSE;
1966 }
1967 result = is_symlink(f);
1968 CloseHandle(f);
1969
1970 return result;
1971}
1972
1973static int
1974do_readlink_handle(HANDLE hlink, char *buf, size_t bufsiz, bool *is_symlink) {
1975 MY_REPARSE_DATA_BUFFER linkdata;
1976 DWORD linkdata_returned;
1977
1978 if (is_symlink)
1979 *is_symlink = FALSE;
1980
1981 if (!DeviceIoControl(hlink, FSCTL_GET_REPARSE_POINT, NULL, 0, &linkdata, sizeof(linkdata), &linkdata_returned, NULL)) {
1982 translate_to_errno();
1983 return -1;
1984 }
1985
1986 int bytes_out;
1987 BOOL used_default;
1988 switch (linkdata.ReparseTag) {
1989 case IO_REPARSE_TAG_SYMLINK:
1990 {
1991 const MY_SYMLINK_REPARSE_BUFFER * const sd =
1992 &linkdata.Data.SymbolicLinkReparseBuffer;
1993 if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.SymbolicLinkReparseBuffer.PathBuffer)) {
1994 errno = EINVAL;
1995 return -1;
1996 }
1997 bytes_out =
1998 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1999 sd->PathBuffer + sd->PrintNameOffset/2,
2000 sd->PrintNameLength/2,
2001 buf, (int)bufsiz, NULL, &used_default);
2002 if (is_symlink)
2003 *is_symlink = TRUE;
2004 }
2005 break;
2006 case IO_REPARSE_TAG_MOUNT_POINT:
2007 {
2008 const MY_MOUNT_POINT_REPARSE_BUFFER * const rd =
2009 &linkdata.Data.MountPointReparseBuffer;
2010 if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.MountPointReparseBuffer.PathBuffer)) {
2011 errno = EINVAL;
2012 return -1;
2013 }
2014 bytes_out =
2015 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
2016 rd->PathBuffer + rd->PrintNameOffset/2,
2017 rd->PrintNameLength/2,
2018 buf, (int)bufsiz, NULL, &used_default);
2019 if (is_symlink)
2020 *is_symlink = TRUE;
2021 }
2022 break;
2023
2024 default:
2025 errno = EINVAL;
2026 return -1;
2027 }
2028
2029 if (bytes_out == 0 || used_default) {
2030 /* failed conversion from unicode to ANSI or otherwise failed */
2031 errno = EINVAL;
2032 return -1;
2033 }
2034
2035 return bytes_out;
2036}
2037
2038DllExport int
2039win32_readlink(const char *pathname, char *buf, size_t bufsiz) {
2040 if (pathname == NULL || buf == NULL) {
2041 errno = EFAULT;
2042 return -1;
2043 }
2044 if (bufsiz <= 0) {
2045 errno = EINVAL;
2046 return -1;
2047 }
2048
2049 DWORD fileattr = GetFileAttributes(pathname);
2050 if (fileattr == INVALID_FILE_ATTRIBUTES) {
2051 translate_to_errno();
2052 return -1;
2053 }
2054
2055 if (!(fileattr & FILE_ATTRIBUTE_REPARSE_POINT)) {
2056 /* not a symbolic link */
2057 errno = EINVAL;
2058 return -1;
2059 }
2060
2061 HANDLE hlink =
2062 CreateFileA(pathname, GENERIC_READ, 0, NULL, OPEN_EXISTING,
2063 FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
2064 if (hlink == INVALID_HANDLE_VALUE) {
2065 translate_to_errno();
2066 return -1;
2067 }
2068 int bytes_out = do_readlink_handle(hlink, buf, bufsiz, NULL);
2069 CloseHandle(hlink);
2070 if (bytes_out < 0) {
2071 /* errno already set */
2072 return -1;
2073 }
2074
2075 if ((size_t)bytes_out > bufsiz) {
2076 errno = EINVAL;
2077 return -1;
2078 }
2079
2080 return bytes_out;
2081}
2082
2083DllExport int
2084win32_lstat(const char *path, Stat_t *sbuf)
2085{
2086 HANDLE f;
2087 int result;
2088 DWORD attr = GetFileAttributes(path); /* doesn't follow symlinks */
2089
2090 if (attr == INVALID_FILE_ATTRIBUTES) {
2091 translate_to_errno();
2092 return -1;
2093 }
2094
2095 if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
2096 return win32_stat(path, sbuf);
2097 }
2098
2099 f = CreateFileA(path, GENERIC_READ, 0, NULL, OPEN_EXISTING,
2100 FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
2101 if (f == INVALID_HANDLE_VALUE) {
2102 translate_to_errno();
2103 return -1;
2104 }
2105 bool is_symlink;
2106 int size = do_readlink_handle(f, NULL, 0, &is_symlink);
2107 if (!is_symlink) {
2108 /* it isn't a symlink, fallback to normal stat */
2109 CloseHandle(f);
2110 return win32_stat(path, sbuf);
2111 }
2112 else if (size < 0) {
2113 /* some other error, errno already set */
2114 CloseHandle(f);
2115 return -1;
2116 }
2117 result = win32_stat_low(f, NULL, 0, sbuf, 0);
2118
2119 if (result != -1){
2120 sbuf->st_mode = (sbuf->st_mode & ~_S_IFMT) | _S_IFLNK;
2121 sbuf->st_size = size;
2122 }
2123 CloseHandle(f);
2124
2125 return result;
2126}
2127
2128#define isSLASH(c) ((c) == '/' || (c) == '\\')
2129#define SKIP_SLASHES(s) \
2130 STMT_START { \
2131 while (*(s) && isSLASH(*(s))) \
2132 ++(s); \
2133 } STMT_END
2134#define COPY_NONSLASHES(d,s) \
2135 STMT_START { \
2136 while (*(s) && !isSLASH(*(s))) \
2137 *(d)++ = *(s)++; \
2138 } STMT_END
2139
2140/* Find the longname of a given path. path is destructively modified.
2141 * It should have space for at least MAX_PATH characters. */
2142DllExport char *
2143win32_longpath(char *path)
2144{
2145 WIN32_FIND_DATA fdata;
2146 HANDLE fhand;
2147 char tmpbuf[MAX_PATH+1];
2148 char *tmpstart = tmpbuf;
2149 char *start = path;
2150 char sep;
2151 if (!path)
2152 return NULL;
2153
2154 /* drive prefix */
2155 if (isALPHA(path[0]) && path[1] == ':') {
2156 start = path + 2;
2157 *tmpstart++ = path[0];
2158 *tmpstart++ = ':';
2159 }
2160 /* UNC prefix */
2161 else if (isSLASH(path[0]) && isSLASH(path[1])) {
2162 start = path + 2;
2163 *tmpstart++ = path[0];
2164 *tmpstart++ = path[1];
2165 SKIP_SLASHES(start);
2166 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
2167 if (*start) {
2168 *tmpstart++ = *start++;
2169 SKIP_SLASHES(start);
2170 COPY_NONSLASHES(tmpstart,start); /* copy share name */
2171 }
2172 }
2173 *tmpstart = '\0';
2174 while (*start) {
2175 /* copy initial slash, if any */
2176 if (isSLASH(*start)) {
2177 *tmpstart++ = *start++;
2178 *tmpstart = '\0';
2179 SKIP_SLASHES(start);
2180 }
2181
2182 /* FindFirstFile() expands "." and "..", so we need to pass
2183 * those through unmolested */
2184 if (*start == '.'
2185 && (!start[1] || isSLASH(start[1])
2186 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
2187 {
2188 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
2189 *tmpstart = '\0';
2190 continue;
2191 }
2192
2193 /* if this is the end, bust outta here */
2194 if (!*start)
2195 break;
2196
2197 /* now we're at a non-slash; walk up to next slash */
2198 while (*start && !isSLASH(*start))
2199 ++start;
2200
2201 /* stop and find full name of component */
2202 sep = *start;
2203 *start = '\0';
2204 fhand = FindFirstFile(path,&fdata);
2205 *start = sep;
2206 if (fhand != INVALID_HANDLE_VALUE) {
2207 STRLEN len = strlen(fdata.cFileName);
2208 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
2209 strcpy(tmpstart, fdata.cFileName);
2210 tmpstart += len;
2211 FindClose(fhand);
2212 }
2213 else {
2214 FindClose(fhand);
2215 errno = ERANGE;
2216 return NULL;
2217 }
2218 }
2219 else {
2220 /* failed a step, just return without side effects */
2221 errno = EINVAL;
2222 return NULL;
2223 }
2224 }
2225 strcpy(path,tmpbuf);
2226 return path;
2227}
2228
2229static void
2230out_of_memory(const char *context, STRLEN len)
2231{
2232
2233 if (PL_curinterp)
2234 croak_no_mem_ext(context, len);
2235 exit(1);
2236}
2237
2238void
2239win32_croak_not_implemented(const char * fname)
2240{
2241 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
2242
2243 Perl_croak_nocontext("%s not implemented!\n", fname);
2244}
2245
2246/* Converts a wide character (UTF-16) string to the Windows ANSI code page,
2247 * potentially using the system's default replacement character for any
2248 * unrepresentable characters. The caller must free() the returned string. */
2249static char*
2250wstr_to_str(const wchar_t* wstr)
2251{
2252 BOOL used_default = FALSE;
2253 size_t wlen = wcslen(wstr) + 1;
2254 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
2255 NULL, 0, NULL, NULL);
2256 char* str = (char*)malloc(len);
2257 if (!str)
2258 out_of_memory(STR_WITH_LEN("win32:wstr_to_str"));
2259 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
2260 str, len, NULL, &used_default);
2261 return str;
2262}
2263
2264/* The win32_ansipath() function takes a Unicode filename and converts it
2265 * into the current Windows codepage. If some characters cannot be mapped,
2266 * then it will convert the short name instead.
2267 *
2268 * The buffer to the ansi pathname must be freed with win32_free() when it
2269 * is no longer needed.
2270 *
2271 * The argument to win32_ansipath() must exist before this function is
2272 * called; otherwise there is no way to determine the short path name.
2273 *
2274 * Ideas for future refinement:
2275 * - Only convert those segments of the path that are not in the current
2276 * codepage, but leave the other segments in their long form.
2277 * - If the resulting name is longer than MAX_PATH, start converting
2278 * additional path segments into short names until the full name
2279 * is shorter than MAX_PATH. Shorten the filename part last!
2280 */
2281DllExport char *
2282win32_ansipath(const WCHAR *widename)
2283{
2284 char *name;
2285 BOOL use_default = FALSE;
2286 size_t widelen = wcslen(widename)+1;
2287 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
2288 NULL, 0, NULL, NULL);
2289 name = (char*)win32_malloc(len);
2290 if (!name)
2291 out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
2292
2293 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
2294 name, len, NULL, &use_default);
2295 if (use_default) {
2296 DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
2297 if (shortlen) {
2298 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
2299 if (!shortname)
2300 out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
2301 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
2302
2303 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
2304 NULL, 0, NULL, NULL);
2305 name = (char*)win32_realloc(name, len);
2306 if (!name)
2307 out_of_memory(STR_WITH_LEN("win32:win32_ansipath"));
2308 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
2309 name, len, NULL, NULL);
2310 win32_free(shortname);
2311 }
2312 }
2313 return name;
2314}
2315
2316/* the returned string must be freed with win32_freeenvironmentstrings which is
2317 * implemented as a macro
2318 * void win32_freeenvironmentstrings(void* block)
2319 */
2320DllExport char *
2321win32_getenvironmentstrings(void)
2322{
2323 LPWSTR lpWStr, lpWTmp;
2324 LPSTR lpStr, lpTmp;
2325 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
2326
2327 /* Get the process environment strings */
2328 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
2329 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
2330 env_len = wcslen(lpWTmp);
2331 /* calculate the size of the environment strings */
2332 wenvstrings_len += env_len + 1;
2333 }
2334
2335 /* Get the number of bytes required to store the ACP encoded string */
2336 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
2337 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
2338 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
2339 if(!lpTmp)
2340 out_of_memory(STR_WITH_LEN("win32:win32_getenvironmentstrings"));
2341
2342 /* Convert the string from UTF-16 encoding to ACP encoding */
2343 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
2344 aenvstrings_len, NULL, NULL);
2345
2346 FreeEnvironmentStringsW(lpWStr);
2347
2348 return(lpStr);
2349}
2350
2351DllExport char *
2352win32_getenv(const char *name)
2353{
2354 dTHX;
2355 DWORD needlen;
2356 SV *curitem = NULL;
2357 DWORD last_err;
2358
2359 needlen = GetEnvironmentVariableA(name,NULL,0);
2360 if (needlen != 0) {
2361 curitem = sv_2mortal(newSVpvs(""));
2362 do {
2363 SvGROW(curitem, needlen+1);
2364 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
2365 needlen);
2366 } while (needlen >= SvLEN(curitem));
2367 SvCUR_set(curitem, needlen);
2368 }
2369 else {
2370 last_err = GetLastError();
2371 if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
2372 /* It appears the variable is in the env, but the Win32 API
2373 doesn't have a canned way of getting it. So we fall back to
2374 grabbing the whole env and pulling this value out if possible */
2375 char *envv = GetEnvironmentStrings();
2376 char *cur = envv;
2377 STRLEN len;
2378 while (*cur) {
2379 char *end = strchr(cur,'=');
2380 if (end && end != cur) {
2381 *end = '\0';
2382 if (strEQ(cur,name)) {
2383 curitem = sv_2mortal(newSVpv(end+1,0));
2384 *end = '=';
2385 break;
2386 }
2387 *end = '=';
2388 cur = end + strlen(end+1)+2;
2389 }
2390 else if ((len = strlen(cur)))
2391 cur += len+1;
2392 }
2393 FreeEnvironmentStrings(envv);
2394 }
2395#ifndef WIN32_NO_REGISTRY
2396 else {
2397 /* last ditch: allow any environment variables that begin with 'PERL'
2398 to be obtained from the registry, if found there */
2399 if (strBEGINs(name, "PERL"))
2400 (void)get_regstr(name, &curitem);
2401 }
2402#endif
2403 }
2404 if (curitem && SvCUR(curitem))
2405 return SvPVX(curitem);
2406
2407 return NULL;
2408}
2409
2410DllExport int
2411win32_putenv(const char *name)
2412{
2413 char* curitem;
2414 char* val;
2415 int relval = -1;
2416
2417 if (name) {
2418 curitem = (char *) win32_malloc(strlen(name)+1);
2419 strcpy(curitem, name);
2420 val = strchr(curitem, '=');
2421 if (val) {
2422 /* The sane way to deal with the environment.
2423 * Has these advantages over putenv() & co.:
2424 * * enables us to store a truly empty value in the
2425 * environment (like in UNIX).
2426 * * we don't have to deal with RTL globals, bugs and leaks
2427 * (specifically, see http://support.microsoft.com/kb/235601).
2428 * * Much faster.
2429 * Why you may want to use the RTL environment handling
2430 * (previously enabled by USE_WIN32_RTL_ENV):
2431 * * environ[] and RTL functions will not reflect changes,
2432 * which might be an issue if extensions want to access
2433 * the env. via RTL. This cuts both ways, since RTL will
2434 * not see changes made by extensions that call the Win32
2435 * functions directly, either.
2436 * GSAR 97-06-07
2437 */
2438 *val++ = '\0';
2439 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
2440 relval = 0;
2441 }
2442 win32_free(curitem);
2443 }
2444 return relval;
2445}
2446
2447static long
2448filetime_to_clock(PFILETIME ft)
2449{
2450 __int64 qw = ft->dwHighDateTime;
2451 qw <<= 32;
2452 qw |= ft->dwLowDateTime;
2453 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
2454 return (long) qw;
2455}
2456
2457DllExport int
2458win32_times(struct tms *timebuf)
2459{
2460 FILETIME user;
2461 FILETIME kernel;
2462 FILETIME dummy;
2463 clock_t process_time_so_far = clock();
2464 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
2465 &kernel,&user)) {
2466 timebuf->tms_utime = filetime_to_clock(&user);
2467 timebuf->tms_stime = filetime_to_clock(&kernel);
2468 timebuf->tms_cutime = 0;
2469 timebuf->tms_cstime = 0;
2470 } else {
2471 /* That failed - e.g. Win95 fallback to clock() */
2472 timebuf->tms_utime = process_time_so_far;
2473 timebuf->tms_stime = 0;
2474 timebuf->tms_cutime = 0;
2475 timebuf->tms_cstime = 0;
2476 }
2477 return process_time_so_far;
2478}
2479
2480static BOOL
2481filetime_from_time(PFILETIME pFileTime, time_t Time)
2482{
2483 struct tm *pt;
2484 SYSTEMTIME st;
2485 dTHX;
2486
2487 GMTIME_LOCK;
2488 pt = gmtime(&Time);
2489 if (!pt) {
2490 GMTIME_UNLOCK;
2491 pFileTime->dwLowDateTime = 0;
2492 pFileTime->dwHighDateTime = 0;
2493 return FALSE;
2494 }
2495
2496 st.wYear = pt->tm_year + 1900;
2497 st.wMonth = pt->tm_mon + 1;
2498 st.wDay = pt->tm_mday;
2499 st.wHour = pt->tm_hour;
2500 st.wMinute = pt->tm_min;
2501 st.wSecond = pt->tm_sec;
2502 st.wMilliseconds = 0;
2503
2504 GMTIME_UNLOCK;
2505
2506 if (!SystemTimeToFileTime(&st, pFileTime)) {
2507 pFileTime->dwLowDateTime = 0;
2508 pFileTime->dwHighDateTime = 0;
2509 return FALSE;
2510 }
2511
2512 return TRUE;
2513}
2514
2515DllExport int
2516win32_unlink(const char *filename)
2517{
2518 dTHX;
2519 int ret;
2520 DWORD attrs;
2521
2522 filename = PerlDir_mapA(filename);
2523 attrs = GetFileAttributesA(filename);
2524 if (attrs == 0xFFFFFFFF) {
2525 errno = ENOENT;
2526 return -1;
2527 }
2528 if (attrs & FILE_ATTRIBUTE_READONLY) {
2529 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
2530 ret = unlink(filename);
2531 if (ret == -1)
2532 (void)SetFileAttributesA(filename, attrs);
2533 }
2534 else if ((attrs & (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY))
2535 == (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY)
2536 && is_symlink_name(filename)) {
2537 ret = rmdir(filename);
2538 }
2539 else {
2540 ret = unlink(filename);
2541 }
2542 return ret;
2543}
2544
2545DllExport int
2546win32_utime(const char *filename, struct utimbuf *times)
2547{
2548 dTHX;
2549 HANDLE handle;
2550 FILETIME ftAccess;
2551 FILETIME ftWrite;
2552 struct utimbuf TimeBuffer;
2553 int rc = -1;
2554
2555 filename = PerlDir_mapA(filename);
2556 /* This will (and should) still fail on readonly files */
2557 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2558 FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
2559 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2560 if (handle == INVALID_HANDLE_VALUE) {
2561 translate_to_errno();
2562 return -1;
2563 }
2564
2565 if (times == NULL) {
2566 times = &TimeBuffer;
2567 time(&times->actime);
2568 times->modtime = times->actime;
2569 }
2570
2571 if (filetime_from_time(&ftAccess, times->actime) &&
2572 filetime_from_time(&ftWrite, times->modtime)) {
2573 if (SetFileTime(handle, NULL, &ftAccess, &ftWrite)) {
2574 rc = 0;
2575 }
2576 else {
2577 translate_to_errno();
2578 }
2579 }
2580 else {
2581 errno = EINVAL; /* bad time? */
2582 }
2583
2584 CloseHandle(handle);
2585 return rc;
2586}
2587
2588typedef union {
2589 unsigned __int64 ft_i64;
2590 FILETIME ft_val;
2591} FT_t;
2592
2593#ifdef __GNUC__
2594#define Const64(x) x##LL
2595#else
2596#define Const64(x) x##i64
2597#endif
2598/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2599#define EPOCH_BIAS Const64(116444736000000000)
2600
2601/* NOTE: This does not compute the timezone info (doing so can be expensive,
2602 * and appears to be unsupported even by glibc) */
2603DllExport int
2604win32_gettimeofday(struct timeval *tp, void *not_used)
2605{
2606 FT_t ft;
2607
2608 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
2609 GetSystemTimeAsFileTime(&ft.ft_val);
2610
2611 /* seconds since epoch */
2612 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2613
2614 /* microseconds remaining */
2615 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2616
2617 return 0;
2618}
2619
2620DllExport int
2621win32_uname(struct utsname *name)
2622{
2623 struct hostent *hep;
2624 STRLEN nodemax = sizeof(name->nodename)-1;
2625
2626 /* sysname */
2627 switch (g_osver.dwPlatformId) {
2628 case VER_PLATFORM_WIN32_WINDOWS:
2629 strcpy(name->sysname, "Windows");
2630 break;
2631 case VER_PLATFORM_WIN32_NT:
2632 strcpy(name->sysname, "Windows NT");
2633 break;
2634 case VER_PLATFORM_WIN32s:
2635 strcpy(name->sysname, "Win32s");
2636 break;
2637 default:
2638 strcpy(name->sysname, "Win32 Unknown");
2639 break;
2640 }
2641
2642 /* release */
2643 sprintf(name->release, "%d.%d",
2644 g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2645
2646 /* version */
2647 sprintf(name->version, "Build %d",
2648 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2649 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2650 if (g_osver.szCSDVersion[0]) {
2651 char *buf = name->version + strlen(name->version);
2652 sprintf(buf, " (%s)", g_osver.szCSDVersion);
2653 }
2654
2655 /* nodename */
2656 hep = win32_gethostbyname("localhost");
2657 if (hep) {
2658 STRLEN len = strlen(hep->h_name);
2659 if (len <= nodemax) {
2660 strcpy(name->nodename, hep->h_name);
2661 }
2662 else {
2663 strncpy(name->nodename, hep->h_name, nodemax);
2664 name->nodename[nodemax] = '\0';
2665 }
2666 }
2667 else {
2668 DWORD sz = nodemax;
2669 if (!GetComputerName(name->nodename, &sz))
2670 *name->nodename = '\0';
2671 }
2672
2673 /* machine (architecture) */
2674 {
2675 SYSTEM_INFO info;
2676 DWORD procarch;
2677 const char *arch;
2678 GetSystemInfo(&info);
2679
2680#if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2681 procarch = info.u.s.wProcessorArchitecture;
2682#else
2683 procarch = info.wProcessorArchitecture;
2684#endif
2685 switch (procarch) {
2686 case PROCESSOR_ARCHITECTURE_INTEL:
2687 arch = "x86"; break;
2688 case PROCESSOR_ARCHITECTURE_IA64:
2689 arch = "ia64"; break;
2690 case PROCESSOR_ARCHITECTURE_AMD64:
2691 arch = "amd64"; break;
2692 case PROCESSOR_ARCHITECTURE_UNKNOWN:
2693 arch = "unknown"; break;
2694 default:
2695 sprintf(name->machine, "unknown(0x%x)", procarch);
2696 arch = name->machine;
2697 break;
2698 }
2699 if (name->machine != arch)
2700 strcpy(name->machine, arch);
2701 }
2702 return 0;
2703}
2704
2705/* Timing related stuff */
2706
2707int
2708do_raise(pTHX_ int sig)
2709{
2710 if (sig < SIG_SIZE) {
2711 Sighandler_t handler = w32_sighandler[sig];
2712 if (handler == SIG_IGN) {
2713 return 0;
2714 }
2715 else if (handler != SIG_DFL) {
2716 (*handler)(sig);
2717 return 0;
2718 }
2719 else {
2720 /* Choose correct default behaviour */
2721 switch (sig) {
2722#ifdef SIGCLD
2723 case SIGCLD:
2724#endif
2725#ifdef SIGCHLD
2726 case SIGCHLD:
2727#endif
2728 case 0:
2729 return 0;
2730 case SIGTERM:
2731 default:
2732 break;
2733 }
2734 }
2735 }
2736 /* Tell caller to exit thread/process as appropriate */
2737 return 1;
2738}
2739
2740void
2741sig_terminate(pTHX_ int sig)
2742{
2743 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2744 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2745 thread
2746 */
2747 exit(sig);
2748}
2749
2750DllExport int
2751win32_async_check(pTHX)
2752{
2753 MSG msg;
2754 HWND hwnd = w32_message_hwnd;
2755
2756 /* Reset w32_poll_count before doing anything else, in case we dispatch
2757 * messages that end up calling back into perl */
2758 w32_poll_count = 0;
2759
2760 if (hwnd != INVALID_HANDLE_VALUE) {
2761 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2762 * and ignores window messages - should co-exist better with windows apps e.g. Tk
2763 */
2764 if (hwnd == NULL)
2765 hwnd = (HWND)-1;
2766
2767 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) ||
2768 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2769 {
2770 /* re-post a WM_QUIT message (we'll mark it as read later) */
2771 if(msg.message == WM_QUIT) {
2772 PostQuitMessage((int)msg.wParam);
2773 break;
2774 }
2775
2776 if(!CallMsgFilter(&msg, MSGF_USER))
2777 {
2778 TranslateMessage(&msg);
2779 DispatchMessage(&msg);
2780 }
2781 }
2782 }
2783
2784 /* Call PeekMessage() to mark all pending messages in the queue as "old".
2785 * This is necessary when we are being called by win32_msgwait() to
2786 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2787 * message over and over. An example how this can happen is when
2788 * Perl is calling win32_waitpid() inside a GUI application and the GUI
2789 * is generating messages before the process terminated.
2790 */
2791 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2792
2793 /* Above or other stuff may have set a signal flag */
2794 if (PL_sig_pending)
2795 despatch_signals();
2796
2797 return 1;
2798}
2799
2800/* This function will not return until the timeout has elapsed, or until
2801 * one of the handles is ready. */
2802DllExport DWORD
2803win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2804{
2805 /* We may need several goes at this - so compute when we stop */
2806 FT_t ticks = {0};
2807 unsigned __int64 endtime = timeout;
2808 if (timeout != INFINITE) {
2809 GetSystemTimeAsFileTime(&ticks.ft_val);
2810 ticks.ft_i64 /= 10000;
2811 endtime += ticks.ft_i64;
2812 }
2813 /* This was a race condition. Do not let a non INFINITE timeout to
2814 * MsgWaitForMultipleObjects roll under 0 creating a near
2815 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2816 * user who did a CORE perl function with a non infinity timeout,
2817 * sleep for example. This is 64 to 32 truncation minefield.
2818 *
2819 * This scenario can only be created if the timespan from the return of
2820 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2821 * generate the scenario, manual breakpoints in a C debugger are required,
2822 * or a context switch occurred in win32_async_check in PeekMessage, or random
2823 * messages are delivered to the *thread* message queue of the Perl thread
2824 * from another process (msctf.dll doing IPC among its instances, VS debugger
2825 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2826 */
2827 while (ticks.ft_i64 <= endtime) {
2828 /* if timeout's type is lengthened, remember to split 64b timeout
2829 * into multiple non-infinity runs of MWFMO */
2830 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2831 (DWORD)(endtime - ticks.ft_i64),
2832 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2833 if (resultp)
2834 *resultp = result;
2835 if (result == WAIT_TIMEOUT) {
2836 /* Ran out of time - explicit return of zero to avoid -ve if we
2837 have scheduling issues
2838 */
2839 return 0;
2840 }
2841 if (timeout != INFINITE) {
2842 GetSystemTimeAsFileTime(&ticks.ft_val);
2843 ticks.ft_i64 /= 10000;
2844 }
2845 if (result == WAIT_OBJECT_0 + count) {
2846 /* Message has arrived - check it */
2847 (void)win32_async_check(aTHX);
2848
2849 /* retry */
2850 if (ticks.ft_i64 > endtime)
2851 endtime = ticks.ft_i64;
2852
2853 continue;
2854 }
2855 else {
2856 /* Not timeout or message - one of handles is ready */
2857 break;
2858 }
2859 }
2860 /* If we are past the end say zero */
2861 if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2862 return 0;
2863 /* compute time left to wait */
2864 ticks.ft_i64 = endtime - ticks.ft_i64;
2865 /* if more ms than DWORD, then return max DWORD */
2866 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2867}
2868
2869int
2870win32_internal_wait(pTHX_ int *status, DWORD timeout)
2871{
2872 /* XXX this wait emulation only knows about processes
2873 * spawned via win32_spawnvp(P_NOWAIT, ...).
2874 */
2875 int i, retval;
2876 DWORD exitcode, waitcode;
2877
2878#ifdef USE_ITHREADS
2879 if (w32_num_pseudo_children) {
2880 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2881 timeout, &waitcode);
2882 /* Time out here if there are no other children to wait for. */
2883 if (waitcode == WAIT_TIMEOUT) {
2884 if (!w32_num_children) {
2885 return 0;
2886 }
2887 }
2888 else if (waitcode != WAIT_FAILED) {
2889 if (waitcode >= WAIT_ABANDONED_0
2890 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2891 i = waitcode - WAIT_ABANDONED_0;
2892 else
2893 i = waitcode - WAIT_OBJECT_0;
2894 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2895 *status = (int)(((U8) exitcode) << 8);
2896 retval = (int)w32_pseudo_child_pids[i];
2897 remove_dead_pseudo_process(i);
2898 return -retval;
2899 }
2900 }
2901 }
2902#endif
2903
2904 if (!w32_num_children) {
2905 errno = ECHILD;
2906 return -1;
2907 }
2908
2909 /* if a child exists, wait for it to die */
2910 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2911 if (waitcode == WAIT_TIMEOUT) {
2912 return 0;
2913 }
2914 if (waitcode != WAIT_FAILED) {
2915 if (waitcode >= WAIT_ABANDONED_0
2916 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2917 i = waitcode - WAIT_ABANDONED_0;
2918 else
2919 i = waitcode - WAIT_OBJECT_0;
2920 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2921 *status = (int)(((U8) exitcode) << 8);
2922 retval = (int)w32_child_pids[i];
2923 remove_dead_process(i);
2924 return retval;
2925 }
2926 }
2927
2928 errno = GetLastError();
2929 return -1;
2930}
2931
2932DllExport int
2933win32_waitpid(int pid, int *status, int flags)
2934{
2935 dTHX;
2936 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2937 int retval = -1;
2938 long child;
2939 if (pid == -1) /* XXX threadid == 1 ? */
2940 return win32_internal_wait(aTHX_ status, timeout);
2941#ifdef USE_ITHREADS
2942 else if (pid < 0) {
2943 child = find_pseudo_pid(aTHX_ -pid);
2944 if (child >= 0) {
2945 HANDLE hThread = w32_pseudo_child_handles[child];
2946 DWORD waitcode;
2947 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2948 if (waitcode == WAIT_TIMEOUT) {
2949 return 0;
2950 }
2951 else if (waitcode == WAIT_OBJECT_0) {
2952 if (GetExitCodeThread(hThread, &waitcode)) {
2953 *status = (int)(((U8) waitcode) << 8);
2954 retval = (int)w32_pseudo_child_pids[child];
2955 remove_dead_pseudo_process(child);
2956 return -retval;
2957 }
2958 }
2959 else
2960 errno = ECHILD;
2961 }
2962 }
2963#endif
2964 else {
2965 HANDLE hProcess;
2966 DWORD waitcode;
2967 child = find_pid(aTHX_ pid);
2968 if (child >= 0) {
2969 hProcess = w32_child_handles[child];
2970 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2971 if (waitcode == WAIT_TIMEOUT) {
2972 return 0;
2973 }
2974 else if (waitcode == WAIT_OBJECT_0) {
2975 if (GetExitCodeProcess(hProcess, &waitcode)) {
2976 *status = (int)(((U8) waitcode) << 8);
2977 retval = (int)w32_child_pids[child];
2978 remove_dead_process(child);
2979 return retval;
2980 }
2981 }
2982 else
2983 errno = ECHILD;
2984 }
2985 else {
2986 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2987 if (hProcess) {
2988 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2989 if (waitcode == WAIT_TIMEOUT) {
2990 CloseHandle(hProcess);
2991 return 0;
2992 }
2993 else if (waitcode == WAIT_OBJECT_0) {
2994 if (GetExitCodeProcess(hProcess, &waitcode)) {
2995 *status = (int)(((U8) waitcode) << 8);
2996 CloseHandle(hProcess);
2997 return pid;
2998 }
2999 }
3000 CloseHandle(hProcess);
3001 }
3002 else
3003 errno = ECHILD;
3004 }
3005 }
3006 return retval >= 0 ? pid : retval;
3007}
3008
3009DllExport int
3010win32_wait(int *status)
3011{
3012 dTHX;
3013 return win32_internal_wait(aTHX_ status, INFINITE);
3014}
3015
3016DllExport unsigned int
3017win32_sleep(unsigned int t)
3018{
3019 dTHX;
3020 /* Win32 times are in ms so *1000 in and /1000 out */
3021 if (t > UINT_MAX / 1000) {
3022 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
3023 "sleep(%lu) too large", t);
3024 }
3025 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
3026}
3027
3028DllExport int
3029win32_pause(void)
3030{
3031 dTHX;
3032 win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
3033 return -1;
3034}
3035
3036DllExport unsigned int
3037win32_alarm(unsigned int sec)
3038{
3039 /*
3040 * the 'obvious' implementation is SetTimer() with a callback
3041 * which does whatever receiving SIGALRM would do
3042 * we cannot use SIGALRM even via raise() as it is not
3043 * one of the supported codes in <signal.h>
3044 */
3045 dTHX;
3046
3047 if (w32_message_hwnd == INVALID_HANDLE_VALUE)
3048 w32_message_hwnd = win32_create_message_window();
3049
3050 if (sec) {
3051 if (w32_message_hwnd == NULL)
3052 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
3053 else {
3054 w32_timerid = 1;
3055 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
3056 }
3057 }
3058 else {
3059 if (w32_timerid) {
3060 KillTimer(w32_message_hwnd, w32_timerid);
3061 w32_timerid = 0;
3062 }
3063 }
3064 return 0;
3065}
3066
3067extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
3068
3069DllExport char *
3070win32_crypt(const char *txt, const char *salt)
3071{
3072 dTHX;
3073 return des_fcrypt(txt, salt, w32_crypt_buffer);
3074}
3075
3076/* simulate flock by locking a range on the file */
3077
3078#define LK_LEN 0xffff0000
3079
3080DllExport int
3081win32_flock(int fd, int oper)
3082{
3083 OVERLAPPED o;
3084 int i = -1;
3085 HANDLE fh;
3086
3087 fh = (HANDLE)_get_osfhandle(fd);
3088 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */
3089 return -1;
3090
3091 memset(&o, 0, sizeof(o));
3092
3093 switch(oper) {
3094 case LOCK_SH: /* shared lock */
3095 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
3096 i = 0;
3097 break;
3098 case LOCK_EX: /* exclusive lock */
3099 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
3100 i = 0;
3101 break;
3102 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
3103 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
3104 i = 0;
3105 break;
3106 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
3107 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
3108 0, LK_LEN, 0, &o))
3109 i = 0;
3110 break;
3111 case LOCK_UN: /* unlock lock */
3112 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
3113 i = 0;
3114 break;
3115 default: /* unknown */
3116 errno = EINVAL;
3117 return -1;
3118 }
3119 if (i == -1) {
3120 if (GetLastError() == ERROR_LOCK_VIOLATION)
3121 errno = EWOULDBLOCK;
3122 else
3123 errno = EINVAL;
3124 }
3125 return i;
3126}
3127
3128#undef LK_LEN
3129
3130extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
3131
3132/* Get the errno value corresponding to the given err. This function is not
3133 * intended to handle conversion of general GetLastError() codes. It only exists
3134 * to translate Windows sockets error codes from WSAGetLastError(). Such codes
3135 * used to be assigned to errno/$! in earlier versions of perl; this function is
3136 * used to catch any old Perl code which is still trying to assign such values
3137 * to $! and convert them to errno values instead.
3138 */
3139int
3140win32_get_errno(int err)
3141{
3142 return convert_wsa_error_to_errno(err);
3143}
3144
3145/*
3146 * redirected io subsystem for all XS modules
3147 *
3148 */
3149
3150DllExport int *
3151win32_errno(void)
3152{
3153 return (&errno);
3154}
3155
3156DllExport char ***
3157win32_environ(void)
3158{
3159 return (&(_environ));
3160}
3161
3162/* the rest are the remapped stdio routines */
3163DllExport FILE *
3164win32_stderr(void)
3165{
3166 return (stderr);
3167}
3168
3169DllExport FILE *
3170win32_stdin(void)
3171{
3172 return (stdin);
3173}
3174
3175DllExport FILE *
3176win32_stdout(void)
3177{
3178 return (stdout);
3179}
3180
3181DllExport int
3182win32_ferror(FILE *fp)
3183{
3184 return (ferror(fp));
3185}
3186
3187
3188DllExport int
3189win32_feof(FILE *fp)
3190{
3191 return (feof(fp));
3192}
3193
3194#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
3195extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
3196#endif
3197
3198/*
3199 * Since the errors returned by the socket error function
3200 * WSAGetLastError() are not known by the library routine strerror
3201 * we have to roll our own to cover the case of socket errors
3202 * that could not be converted to regular errno values by
3203 * get_last_socket_error() in win32/win32sck.c.
3204 */
3205
3206DllExport char *
3207win32_strerror(int e)
3208{
3209#if !defined __MINGW32__ /* compiler intolerance */
3210 extern int sys_nerr;
3211#endif
3212
3213 if (e < 0 || e > sys_nerr) {
3214 dTHXa(NULL);
3215 if (e < 0)
3216 e = GetLastError();
3217#ifdef ERRNO_HAS_POSIX_SUPPLEMENT
3218 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
3219 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
3220 * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
3221 * We must therefore still roll our own messages for these codes, and
3222 * additionally map them to corresponding Windows (sockets) error codes
3223 * first to avoid getting the wrong system message.
3224 */
3225 else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) {
3226 e = convert_errno_to_wsa_error(e);
3227 }
3228#endif
3229
3230 aTHXa(PERL_GET_THX);
3231 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
3232 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
3233 w32_strerror_buffer, sizeof(w32_strerror_buffer),
3234 NULL) == 0)
3235 {
3236 strcpy(w32_strerror_buffer, "Unknown Error");
3237 }
3238 return w32_strerror_buffer;
3239 }
3240#undef strerror
3241 return strerror(e);
3242#define strerror win32_strerror
3243}
3244
3245DllExport void
3246win32_str_os_error(void *sv, DWORD dwErr)
3247{
3248 DWORD dwLen;
3249 char *sMsg;
3250 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
3251 |FORMAT_MESSAGE_IGNORE_INSERTS
3252 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
3253 dwErr, 0, (char *)&sMsg, 1, NULL);
3254 /* strip trailing whitespace and period */
3255 if (0 < dwLen) {
3256 do {
3257 --dwLen; /* dwLen doesn't include trailing null */
3258 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
3259 if ('.' != sMsg[dwLen])
3260 dwLen++;
3261 sMsg[dwLen] = '\0';
3262 }
3263 if (0 == dwLen) {
3264 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
3265 if (sMsg)
3266 dwLen = sprintf(sMsg,
3267 "Unknown error #0x%lX (lookup 0x%lX)",
3268 dwErr, GetLastError());
3269 }
3270 if (sMsg) {
3271 dTHX;
3272 sv_setpvn((SV*)sv, sMsg, dwLen);
3273 LocalFree(sMsg);
3274 }
3275}
3276
3277DllExport int
3278win32_fprintf(FILE *fp, const char *format, ...)
3279{
3280 va_list marker;
3281 va_start(marker, format); /* Initialize variable arguments. */
3282
3283 return (vfprintf(fp, format, marker));
3284}
3285
3286DllExport int
3287win32_printf(const char *format, ...)
3288{
3289 va_list marker;
3290 va_start(marker, format); /* Initialize variable arguments. */
3291
3292 return (vprintf(format, marker));
3293}
3294
3295DllExport int
3296win32_vfprintf(FILE *fp, const char *format, va_list args)
3297{
3298 return (vfprintf(fp, format, args));
3299}
3300
3301DllExport int
3302win32_vprintf(const char *format, va_list args)
3303{
3304 return (vprintf(format, args));
3305}
3306
3307DllExport size_t
3308win32_fread(void *buf, size_t size, size_t count, FILE *fp)
3309{
3310 return fread(buf, size, count, fp);
3311}
3312
3313DllExport size_t
3314win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
3315{
3316 return fwrite(buf, size, count, fp);
3317}
3318
3319#define MODE_SIZE 10
3320
3321DllExport FILE *
3322win32_fopen(const char *filename, const char *mode)
3323{
3324 dTHXa(NULL);
3325 FILE *f;
3326
3327 if (!*filename)
3328 return NULL;
3329
3330 if (stricmp(filename, "/dev/null")==0)
3331 filename = "NUL";
3332
3333 aTHXa(PERL_GET_THX);
3334 f = fopen(PerlDir_mapA(filename), mode);
3335 /* avoid buffering headaches for child processes */
3336 if (f && *mode == 'a')
3337 win32_fseek(f, 0, SEEK_END);
3338 return f;
3339}
3340
3341DllExport FILE *
3342win32_fdopen(int handle, const char *mode)
3343{
3344 FILE *f;
3345 f = fdopen(handle, (char *) mode);
3346 /* avoid buffering headaches for child processes */
3347 if (f && *mode == 'a')
3348 win32_fseek(f, 0, SEEK_END);
3349 return f;
3350}
3351
3352DllExport FILE *
3353win32_freopen(const char *path, const char *mode, FILE *stream)
3354{
3355 dTHXa(NULL);
3356 if (stricmp(path, "/dev/null")==0)
3357 path = "NUL";
3358
3359 aTHXa(PERL_GET_THX);
3360 return freopen(PerlDir_mapA(path), mode, stream);
3361}
3362
3363DllExport int
3364win32_fclose(FILE *pf)
3365{
3366 return fclose(pf);
3367}
3368
3369DllExport int
3370win32_fputs(const char *s,FILE *pf)
3371{
3372 return fputs(s, pf);
3373}
3374
3375DllExport int
3376win32_fputc(int c,FILE *pf)
3377{
3378 return fputc(c,pf);
3379}
3380
3381DllExport int
3382win32_ungetc(int c,FILE *pf)
3383{
3384 return ungetc(c,pf);
3385}
3386
3387DllExport int
3388win32_getc(FILE *pf)
3389{
3390 return getc(pf);
3391}
3392
3393DllExport int
3394win32_fileno(FILE *pf)
3395{
3396 return fileno(pf);
3397}
3398
3399DllExport void
3400win32_clearerr(FILE *pf)
3401{
3402 clearerr(pf);
3403 return;
3404}
3405
3406DllExport int
3407win32_fflush(FILE *pf)
3408{
3409 return fflush(pf);
3410}
3411
3412DllExport Off_t
3413win32_ftell(FILE *pf)
3414{
3415 fpos_t pos;
3416 if (fgetpos(pf, &pos))
3417 return -1;
3418 return (Off_t)pos;
3419}
3420
3421DllExport int
3422win32_fseek(FILE *pf, Off_t offset,int origin)
3423{
3424 fpos_t pos;
3425 switch (origin) {
3426 case SEEK_CUR:
3427 if (fgetpos(pf, &pos))
3428 return -1;
3429 offset += pos;
3430 break;
3431 case SEEK_END:
3432 fseek(pf, 0, SEEK_END);
3433 pos = _telli64(fileno(pf));
3434 offset += pos;
3435 break;
3436 case SEEK_SET:
3437 break;
3438 default:
3439 errno = EINVAL;
3440 return -1;
3441 }
3442 return fsetpos(pf, &offset);
3443}
3444
3445DllExport int
3446win32_fgetpos(FILE *pf,fpos_t *p)
3447{
3448 return fgetpos(pf, p);
3449}
3450
3451DllExport int
3452win32_fsetpos(FILE *pf,const fpos_t *p)
3453{
3454 return fsetpos(pf, p);
3455}
3456
3457DllExport void
3458win32_rewind(FILE *pf)
3459{
3460 rewind(pf);
3461 return;
3462}
3463
3464DllExport int
3465win32_tmpfd(void)
3466{
3467 return win32_tmpfd_mode(0);
3468}
3469
3470DllExport int
3471win32_tmpfd_mode(int mode)
3472{
3473 char prefix[MAX_PATH+1];
3474 char filename[MAX_PATH+1];
3475 DWORD len = GetTempPath(MAX_PATH, prefix);
3476 mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
3477 mode |= O_RDWR;
3478 if (len && len < MAX_PATH) {
3479 if (GetTempFileName(prefix, "plx", 0, filename)) {
3480 HANDLE fh = CreateFile(filename,
3481 DELETE | GENERIC_READ | GENERIC_WRITE,
3482 0,
3483 NULL,
3484 CREATE_ALWAYS,
3485 FILE_ATTRIBUTE_NORMAL
3486 | FILE_FLAG_DELETE_ON_CLOSE,
3487 NULL);
3488 if (fh != INVALID_HANDLE_VALUE) {
3489 int fd = win32_open_osfhandle((intptr_t)fh, mode);
3490 if (fd >= 0) {
3491 PERL_DEB(dTHX;)
3492 DEBUG_p(PerlIO_printf(Perl_debug_log,
3493 "Created tmpfile=%s\n",filename));
3494 return fd;
3495 }
3496 }
3497 }
3498 }
3499 return -1;
3500}
3501
3502DllExport FILE*
3503win32_tmpfile(void)
3504{
3505 int fd = win32_tmpfd();
3506 if (fd >= 0)
3507 return win32_fdopen(fd, "w+b");
3508 return NULL;
3509}
3510
3511DllExport void
3512win32_abort(void)
3513{
3514 abort();
3515 return;
3516}
3517
3518DllExport int
3519win32_fstat(int fd, Stat_t *sbufptr)
3520{
3521 HANDLE handle = (HANDLE)win32_get_osfhandle(fd);
3522
3523 return win32_stat_low(handle, NULL, 0, sbufptr, 0);
3524}
3525
3526DllExport int
3527win32_pipe(int *pfd, unsigned int size, int mode)
3528{
3529 return _pipe(pfd, size, mode);
3530}
3531
3532DllExport PerlIO*
3533win32_popenlist(const char *mode, IV narg, SV **args)
3534{
3535 if (get_shell() < 0)
3536 return NULL;
3537
3538 return do_popen(mode, NULL, narg, args);
3539}
3540
3541STATIC PerlIO*
3542do_popen(const char *mode, const char *command, IV narg, SV **args) {
3543 int p[2];
3544 int handles[3];
3545 int parent, child;
3546 int stdfd;
3547 int ourmode;
3548 int childpid;
3549 DWORD nhandle;
3550 int lock_held = 0;
3551 const char **args_pvs = NULL;
3552
3553 /* establish which ends read and write */
3554 if (strchr(mode,'w')) {
3555 stdfd = 0; /* stdin */
3556 parent = 1;
3557 child = 0;
3558 nhandle = STD_INPUT_HANDLE;
3559 }
3560 else if (strchr(mode,'r')) {
3561 stdfd = 1; /* stdout */
3562 parent = 0;
3563 child = 1;
3564 nhandle = STD_OUTPUT_HANDLE;
3565 }
3566 else
3567 return NULL;
3568
3569 /* set the correct mode */
3570 if (strchr(mode,'b'))
3571 ourmode = O_BINARY;
3572 else if (strchr(mode,'t'))
3573 ourmode = O_TEXT;
3574 else
3575 ourmode = _fmode & (O_TEXT | O_BINARY);
3576
3577 /* the child doesn't inherit handles */
3578 ourmode |= O_NOINHERIT;
3579
3580 if (win32_pipe(p, 512, ourmode) == -1)
3581 return NULL;
3582
3583 /* Previously this code redirected stdin/out temporarily so the
3584 child process inherited those handles, this caused race
3585 conditions when another thread was writing/reading those
3586 handles.
3587
3588 To avoid that we just feed the handles to CreateProcess() so
3589 the handles are redirected only in the child.
3590 */
3591 handles[child] = p[child];
3592 handles[parent] = -1;
3593 handles[2] = -1;
3594
3595 /* CreateProcess() requires inheritable handles */
3596 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3597 HANDLE_FLAG_INHERIT)) {
3598 goto cleanup;
3599 }
3600
3601 /* start the child */
3602 {
3603 dTHX;
3604
3605 if (command) {
3606 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3607 goto cleanup;
3608
3609 }
3610 else {
3611 int i;
3612 const char *exe_name;
3613
3614 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3615 SAVEFREEPV(args_pvs);
3616 for (i = 0; i < narg; ++i)
3617 args_pvs[i] = SvPV_nolen(args[i]);
3618 args_pvs[i] = NULL;
3619 exe_name = qualified_path(args_pvs[0], TRUE);
3620 if (!exe_name)
3621 /* let CreateProcess() try to find it instead */
3622 exe_name = args_pvs[0];
3623
3624 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3625 goto cleanup;
3626 }
3627 }
3628
3629 win32_close(p[child]);
3630
3631 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3632
3633 /* set process id so that it can be returned by perl's open() */
3634 PL_forkprocess = childpid;
3635 }
3636
3637 /* we have an fd, return a file stream */
3638 return (PerlIO_fdopen(p[parent], (char *)mode));
3639
3640cleanup:
3641 /* we don't need to check for errors here */
3642 win32_close(p[0]);
3643 win32_close(p[1]);
3644
3645 return (NULL);
3646}
3647
3648/*
3649 * a popen() clone that respects PERL5SHELL
3650 *
3651 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3652 */
3653
3654DllExport PerlIO*
3655win32_popen(const char *command, const char *mode)
3656{
3657#ifdef USE_RTL_POPEN
3658 return _popen(command, mode);
3659#else
3660 return do_popen(mode, command, 0, NULL);
3661#endif /* USE_RTL_POPEN */
3662}
3663
3664/*
3665 * pclose() clone
3666 */
3667
3668DllExport int
3669win32_pclose(PerlIO *pf)
3670{
3671#ifdef USE_RTL_POPEN
3672 return _pclose(pf);
3673#else
3674 dTHX;
3675 int childpid, status;
3676 SV *sv;
3677
3678 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3679
3680 if (SvIOK(sv))
3681 childpid = SvIVX(sv);
3682 else
3683 childpid = 0;
3684
3685 if (!childpid) {
3686 errno = EBADF;
3687 return -1;
3688 }
3689
3690#ifdef USE_PERLIO
3691 PerlIO_close(pf);
3692#else
3693 fclose(pf);
3694#endif
3695 SvIVX(sv) = 0;
3696
3697 if (win32_waitpid(childpid, &status, 0) == -1)
3698 return -1;
3699
3700 return status;
3701
3702#endif /* USE_RTL_POPEN */
3703}
3704
3705DllExport int
3706win32_link(const char *oldname, const char *newname)
3707{
3708 dTHXa(NULL);
3709 WCHAR wOldName[MAX_PATH+1];
3710 WCHAR wNewName[MAX_PATH+1];
3711
3712 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3713 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3714 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3715 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3716 {
3717 return 0;
3718 }
3719 translate_to_errno();
3720 return -1;
3721}
3722
3723typedef BOOLEAN (__stdcall *pCreateSymbolicLinkA_t)(LPCSTR, LPCSTR, DWORD);
3724
3725#ifndef SYMBOLIC_LINK_FLAG_DIRECTORY
3726# define SYMBOLIC_LINK_FLAG_DIRECTORY 0x1
3727#endif
3728
3729#ifndef SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
3730# define SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 0x2
3731#endif
3732
3733DllExport int
3734win32_symlink(const char *oldfile, const char *newfile)
3735{
3736 dTHX;
3737 size_t oldfile_len = strlen(oldfile);
3738 pCreateSymbolicLinkA_t pCreateSymbolicLinkA =
3739 (pCreateSymbolicLinkA_t)GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateSymbolicLinkA");
3740 DWORD create_flags = 0;
3741
3742 /* this flag can be used only on Windows 10 1703 or newer */
3743 if (g_osver.dwMajorVersion > 10 ||
3744 (g_osver.dwMajorVersion == 10 &&
3745 (g_osver.dwMinorVersion > 0 || g_osver.dwBuildNumber > 15063)))
3746 {
3747 create_flags |= SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE;
3748 }
3749
3750 if (!pCreateSymbolicLinkA) {
3751 errno = ENOSYS;
3752 return -1;
3753 }
3754
3755 /* oldfile might be relative and we don't want to change that,
3756 so don't map that.
3757 */
3758 newfile = PerlDir_mapA(newfile);
3759
3760 if (strchr(oldfile, '/')) {
3761 /* Win32 (or perhaps NTFS) won't follow symlinks containing
3762 /, so replace any with \\
3763 */
3764 char *temp = savepv(oldfile);
3765 SAVEFREEPV(temp);
3766 char *p = temp;
3767 while (*p) {
3768 if (*p == '/') {
3769 *p = '\\';
3770 }
3771 ++p;
3772 }
3773 *p = 0;
3774 oldfile = temp;
3775 oldfile_len = p - temp;
3776 }
3777
3778 /* are we linking to a directory?
3779 CreateSymlinkA() needs to know if the target is a directory,
3780 If it looks like a directory name:
3781 - ends in slash
3782 - is just . or ..
3783 - ends in /. or /.. (with either slash)
3784 - is a simple drive letter
3785 assume it's a directory.
3786
3787 Otherwise if the oldfile is relative we need to make a relative path
3788 based on the newfile to check if the target is a directory.
3789 */
3790 if ((oldfile_len >= 1 && isSLASH(oldfile[oldfile_len-1])) ||
3791 strEQ(oldfile, "..") ||
3792 strEQ(oldfile, ".") ||
3793 (isSLASH(oldfile[oldfile_len-2]) && oldfile[oldfile_len-1] == '.') ||
3794 strEQ(oldfile+oldfile_len-3, "\\..") ||
3795 (oldfile_len == 2 && oldfile[1] == ':')) {
3796 create_flags |= SYMBOLIC_LINK_FLAG_DIRECTORY;
3797 }
3798 else {
3799 DWORD dest_attr;
3800 const char *dest_path = oldfile;
3801 char szTargetName[MAX_PATH+1];
3802
3803 if (oldfile_len >= 3 && oldfile[1] == ':') {
3804 /* relative to current directory on a drive, or absolute */
3805 /* dest_path = oldfile; already done */
3806 }
3807 else if (oldfile[0] != '\\') {
3808 size_t newfile_len = strlen(newfile);
3809 const char *last_slash = strrchr(newfile, '/');
3810 const char *last_bslash = strrchr(newfile, '\\');
3811 const char *end_dir = last_slash && last_bslash
3812 ? ( last_slash > last_bslash ? last_slash : last_bslash)
3813 : last_slash ? last_slash : last_bslash ? last_bslash : NULL;
3814
3815 if (end_dir) {
3816 if ((end_dir - newfile + 1) + oldfile_len > MAX_PATH) {
3817 /* too long */
3818 errno = EINVAL;
3819 return -1;
3820 }
3821
3822 memcpy(szTargetName, newfile, end_dir - newfile + 1);
3823 strcpy(szTargetName + (end_dir - newfile + 1), oldfile);
3824 dest_path = szTargetName;
3825 }
3826 else {
3827 /* newpath is just a filename */
3828 /* dest_path = oldfile; */
3829 }
3830 }
3831
3832 dest_attr = GetFileAttributes(dest_path);
3833 if (dest_attr != (DWORD)-1 && (dest_attr & FILE_ATTRIBUTE_DIRECTORY)) {
3834 create_flags |= SYMBOLIC_LINK_FLAG_DIRECTORY;
3835 }
3836 }
3837
3838 if (!pCreateSymbolicLinkA(newfile, oldfile, create_flags)) {
3839 translate_to_errno();
3840 return -1;
3841 }
3842
3843 return 0;
3844}
3845
3846DllExport int
3847win32_rename(const char *oname, const char *newname)
3848{
3849 char szOldName[MAX_PATH+1];
3850 BOOL bResult;
3851 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3852 dTHX;
3853
3854 if (stricmp(newname, oname))
3855 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3856 strcpy(szOldName, PerlDir_mapA(oname));
3857
3858 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3859 if (!bResult) {
3860 DWORD err = GetLastError();
3861 switch (err) {
3862 case ERROR_BAD_NET_NAME:
3863 case ERROR_BAD_NETPATH:
3864 case ERROR_BAD_PATHNAME:
3865 case ERROR_FILE_NOT_FOUND:
3866 case ERROR_FILENAME_EXCED_RANGE:
3867 case ERROR_INVALID_DRIVE:
3868 case ERROR_NO_MORE_FILES:
3869 case ERROR_PATH_NOT_FOUND:
3870 errno = ENOENT;
3871 break;
3872 case ERROR_DISK_FULL:
3873 errno = ENOSPC;
3874 break;
3875 case ERROR_NOT_ENOUGH_QUOTA:
3876 errno = EDQUOT;
3877 break;
3878 default:
3879 errno = EACCES;
3880 break;
3881 }
3882 return -1;
3883 }
3884 return 0;
3885}
3886
3887DllExport int
3888win32_setmode(int fd, int mode)
3889{
3890 return setmode(fd, mode);
3891}
3892
3893DllExport int
3894win32_chsize(int fd, Off_t size)
3895{
3896 int retval = 0;
3897 Off_t cur, end, extend;
3898
3899 cur = win32_tell(fd);
3900 if (cur < 0)
3901 return -1;
3902 end = win32_lseek(fd, 0, SEEK_END);
3903 if (end < 0)
3904 return -1;
3905 extend = size - end;
3906 if (extend == 0) {
3907 /* do nothing */
3908 }
3909 else if (extend > 0) {
3910 /* must grow the file, padding with nulls */
3911 char b[4096];
3912 int oldmode = win32_setmode(fd, O_BINARY);
3913 size_t count;
3914 memset(b, '\0', sizeof(b));
3915 do {
3916 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3917 count = win32_write(fd, b, count);
3918 if ((int)count < 0) {
3919 retval = -1;
3920 break;
3921 }
3922 } while ((extend -= count) > 0);
3923 win32_setmode(fd, oldmode);
3924 }
3925 else {
3926 /* shrink the file */
3927 win32_lseek(fd, size, SEEK_SET);
3928 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3929 errno = EACCES;
3930 retval = -1;
3931 }
3932 }
3933 win32_lseek(fd, cur, SEEK_SET);
3934 return retval;
3935}
3936
3937DllExport Off_t
3938win32_lseek(int fd, Off_t offset, int origin)
3939{
3940 return _lseeki64(fd, offset, origin);
3941}
3942
3943DllExport Off_t
3944win32_tell(int fd)
3945{
3946 return _telli64(fd);
3947}
3948
3949DllExport int
3950win32_open(const char *path, int flag, ...)
3951{
3952 dTHXa(NULL);
3953 va_list ap;
3954 int pmode;
3955
3956 va_start(ap, flag);
3957 pmode = va_arg(ap, int);
3958 va_end(ap);
3959
3960 if (stricmp(path, "/dev/null")==0)
3961 path = "NUL";
3962
3963 aTHXa(PERL_GET_THX);
3964 return open(PerlDir_mapA(path), flag, pmode);
3965}
3966
3967DllExport int
3968win32_close(int fd)
3969{
3970 return _close(fd);
3971}
3972
3973DllExport int
3974win32_eof(int fd)
3975{
3976 return eof(fd);
3977}
3978
3979DllExport int
3980win32_isatty(int fd)
3981{
3982 /* The Microsoft isatty() function returns true for *all*
3983 * character mode devices, including "nul". Our implementation
3984 * should only return true if the handle has a console buffer.
3985 */
3986 DWORD mode;
3987 HANDLE fh = (HANDLE)_get_osfhandle(fd);
3988 if (fh == (HANDLE)-1) {
3989 /* errno is already set to EBADF */
3990 return 0;
3991 }
3992
3993 if (GetConsoleMode(fh, &mode))
3994 return 1;
3995
3996 errno = ENOTTY;
3997 return 0;
3998}
3999
4000DllExport int
4001win32_dup(int fd)
4002{
4003 return dup(fd);
4004}
4005
4006DllExport int
4007win32_dup2(int fd1,int fd2)
4008{
4009 return dup2(fd1,fd2);
4010}
4011
4012static int
4013win32_read_console(int fd, U8 *buf, unsigned int cnt)
4014{
4015 /* This function is a workaround for a bug in Windows:
4016 * https://github.com/microsoft/terminal/issues/4551
4017 * tl;dr: ReadFile() and ReadConsoleA() return garbage when reading
4018 * non-ASCII characters from the console with the 65001 codepage.
4019 */
4020 HANDLE h = (HANDLE)_get_osfhandle(fd);
4021 size_t left_to_read = cnt;
4022 DWORD mode;
4023
4024 if (h == INVALID_HANDLE_VALUE) {
4025 errno = EBADF;
4026 return -1;
4027 }
4028
4029 if (!GetConsoleMode(h, &mode)) {
4030 translate_to_errno();
4031 return -1;
4032 }
4033
4034 while (left_to_read) {
4035 /* The purpose of converted_buf is to preserve partial UTF-8 (or of any
4036 * other multibyte encoding) code points between read() calls. Since
4037 * there's only one console, the buffer is global. It's needed because
4038 * ReadConsoleW() returns a string of UTF-16 code units and its result,
4039 * after conversion to the current console codepage, may not fit in the
4040 * return buffer.
4041 *
4042 * The buffer's size is 8 because it will contain at most two UTF-8 code
4043 * points.
4044 */
4045 static char converted_buf[8];
4046 static size_t converted_buf_len = 0;
4047 WCHAR wbuf[2];
4048 DWORD wbuf_len = 0, chars_read;
4049
4050 if (converted_buf_len) {
4051 bool newline = 0;
4052 size_t to_write = MIN(converted_buf_len, left_to_read);
4053
4054 /* Don't read anything if the *first* character is ^Z and
4055 * ENABLE_PROCESSED_INPUT is enabled. On some versions of Windows,
4056 * ReadFile() ignores ENABLE_PROCESSED_INPUT, but apparently it's a
4057 * bug: https://github.com/microsoft/terminal/issues/4958
4058 */
4059 if (left_to_read == cnt && (mode & ENABLE_PROCESSED_INPUT) &&
4060 converted_buf[0] == 0x1a)
4061 break;
4062
4063 /* Are we returning a newline? */
4064 if (memchr(converted_buf, '\n', to_write))
4065 newline = 1;
4066
4067 memcpy(buf, converted_buf, to_write);
4068 buf += to_write;
4069
4070 /* If there's anything left in converted_buf, move it to the
4071 * beginning of the buffer. */
4072 converted_buf_len -= to_write;
4073 if (converted_buf_len)
4074 memmove(
4075 converted_buf, converted_buf + to_write, converted_buf_len
4076 );
4077
4078 left_to_read -= to_write;
4079
4080 /* With ENABLE_LINE_INPUT enabled, we stop reading after the first
4081 * newline, otherwise we stop reading after the first character. */
4082 if (!left_to_read || newline || (mode & ENABLE_LINE_INPUT) == 0)
4083 break;
4084 }
4085
4086 /* Reading one code unit at a time is inefficient, but since this code
4087 * is used only for the interactive console, that shouldn't matter. */
4088 if (!ReadConsoleW(h, wbuf, 1, &chars_read, 0)) {
4089 translate_to_errno();
4090 return -1;
4091 }
4092 if (!chars_read)
4093 break;
4094
4095 ++wbuf_len;
4096
4097 if (wbuf[0] >= 0xD800 && wbuf[0] <= 0xDBFF) {
4098 /* High surrogate, read one more code unit. */
4099 if (!ReadConsoleW(h, wbuf + 1, 1, &chars_read, 0)) {
4100 translate_to_errno();
4101 return -1;
4102 }
4103 if (chars_read)
4104 ++wbuf_len;
4105 }
4106
4107 converted_buf_len = WideCharToMultiByte(
4108 GetConsoleCP(), 0, wbuf, wbuf_len, converted_buf,
4109 sizeof(converted_buf), NULL, NULL
4110 );
4111 if (!converted_buf_len) {
4112 translate_to_errno();
4113 return -1;
4114 }
4115 }
4116
4117 return cnt - left_to_read;
4118}
4119
4120
4121DllExport int
4122win32_read(int fd, void *buf, unsigned int cnt)
4123{
4124 int ret;
4125 if (UNLIKELY(win32_isatty(fd) && GetConsoleCP() == 65001)) {
4126 MUTEX_LOCK(&win32_read_console_mutex);
4127 ret = win32_read_console(fd, (U8 *)buf, cnt);
4128 MUTEX_UNLOCK(&win32_read_console_mutex);
4129 }
4130 else
4131 ret = read(fd, buf, cnt);
4132
4133 return ret;
4134}
4135
4136DllExport int
4137win32_write(int fd, const void *buf, unsigned int cnt)
4138{
4139 return write(fd, buf, cnt);
4140}
4141
4142DllExport int
4143win32_mkdir(const char *dir, int mode)
4144{
4145 dTHX;
4146 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
4147}
4148
4149DllExport int
4150win32_rmdir(const char *dir)
4151{
4152 dTHX;
4153 return rmdir(PerlDir_mapA(dir));
4154}
4155
4156DllExport int
4157win32_chdir(const char *dir)
4158{
4159 if (!dir || !*dir) {
4160 errno = ENOENT;
4161 return -1;
4162 }
4163 return chdir(dir);
4164}
4165
4166DllExport int
4167win32_access(const char *path, int mode)
4168{
4169 dTHX;
4170 return access(PerlDir_mapA(path), mode);
4171}
4172
4173DllExport int
4174win32_chmod(const char *path, int mode)
4175{
4176 dTHX;
4177 return chmod(PerlDir_mapA(path), mode);
4178}
4179
4180
4181static char *
4182create_command_line(char *cname, STRLEN clen, const char * const *args)
4183{
4184 PERL_DEB(dTHX;)
4185 int index, argc;
4186 char *cmd, *ptr;
4187 const char *arg;
4188 STRLEN len = 0;
4189 bool bat_file = FALSE;
4190 bool cmd_shell = FALSE;
4191 bool dumb_shell = FALSE;
4192 bool extra_quotes = FALSE;
4193 bool quote_next = FALSE;
4194
4195 if (!cname)
4196 cname = (char*)args[0];
4197
4198 /* The NT cmd.exe shell has the following peculiarity that needs to be
4199 * worked around. It strips a leading and trailing dquote when any
4200 * of the following is true:
4201 * 1. the /S switch was used
4202 * 2. there are more than two dquotes
4203 * 3. there is a special character from this set: &<>()@^|
4204 * 4. no whitespace characters within the two dquotes
4205 * 5. string between two dquotes isn't an executable file
4206 * To work around this, we always add a leading and trailing dquote
4207 * to the string, if the first argument is either "cmd.exe" or "cmd",
4208 * and there were at least two or more arguments passed to cmd.exe
4209 * (not including switches).
4210 * XXX the above rules (from "cmd /?") don't seem to be applied
4211 * always, making for the convolutions below :-(
4212 */
4213 if (cname) {
4214 if (!clen)
4215 clen = strlen(cname);
4216
4217 if (clen > 4
4218 && (stricmp(&cname[clen-4], ".bat") == 0
4219 || (stricmp(&cname[clen-4], ".cmd") == 0)))
4220 {
4221 bat_file = TRUE;
4222 len += 3;
4223 }
4224 else {
4225 char *exe = strrchr(cname, '/');
4226 char *exe2 = strrchr(cname, '\\');
4227 if (exe2 > exe)
4228 exe = exe2;
4229 if (exe)
4230 ++exe;
4231 else
4232 exe = cname;
4233 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
4234 cmd_shell = TRUE;
4235 len += 3;
4236 }
4237 else if (stricmp(exe, "command.com") == 0
4238 || stricmp(exe, "command") == 0)
4239 {
4240 dumb_shell = TRUE;
4241 }
4242 }
4243 }
4244
4245 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
4246 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
4247 STRLEN curlen = strlen(arg);
4248 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
4249 len += 2; /* assume quoting needed (worst case) */
4250 len += curlen + 1;
4251 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
4252 }
4253 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
4254
4255 argc = index;
4256 Newx(cmd, len, char);
4257 ptr = cmd;
4258
4259 if (bat_file) {
4260 *ptr++ = '"';
4261 extra_quotes = TRUE;
4262 }
4263
4264 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
4265 bool do_quote = 0;
4266 STRLEN curlen = strlen(arg);
4267
4268 /* we want to protect empty arguments and ones with spaces with
4269 * dquotes, but only if they aren't already there */
4270 if (!dumb_shell) {
4271 if (!curlen) {
4272 do_quote = 1;
4273 }
4274 else if (quote_next) {
4275 /* see if it really is multiple arguments pretending to
4276 * be one and force a set of quotes around it */
4277 if (*find_next_space(arg))
4278 do_quote = 1;
4279 }
4280 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
4281 STRLEN i = 0;
4282 while (i < curlen) {
4283 if (isSPACE(arg[i])) {
4284 do_quote = 1;
4285 }
4286 else if (arg[i] == '"') {
4287 do_quote = 0;
4288 break;
4289 }
4290 i++;
4291 }
4292 }
4293 }
4294
4295 if (do_quote)
4296 *ptr++ = '"';
4297
4298 strcpy(ptr, arg);
4299 ptr += curlen;
4300
4301 if (do_quote)
4302 *ptr++ = '"';
4303
4304 if (args[index+1])
4305 *ptr++ = ' ';
4306
4307 if (!extra_quotes
4308 && cmd_shell
4309 && curlen >= 2
4310 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
4311 && stricmp(arg+curlen-2, "/c") == 0)
4312 {
4313 /* is there a next argument? */
4314 if (args[index+1]) {
4315 /* are there two or more next arguments? */
4316 if (args[index+2]) {
4317 *ptr++ = '"';
4318 extra_quotes = TRUE;
4319 }
4320 else {
4321 /* single argument, force quoting if it has spaces */
4322 quote_next = TRUE;
4323 }
4324 }
4325 }
4326 }
4327
4328 if (extra_quotes)
4329 *ptr++ = '"';
4330
4331 *ptr = '\0';
4332
4333 return cmd;
4334}
4335
4336static const char *exe_extensions[] =
4337 {
4338 ".exe", /* this must be first */
4339 ".cmd",
4340 ".bat"
4341 };
4342
4343static char *
4344qualified_path(const char *cmd, bool other_exts)
4345{
4346 char *pathstr;
4347 char *fullcmd, *curfullcmd;
4348 STRLEN cmdlen = 0;
4349 int has_slash = 0;
4350
4351 if (!cmd)
4352 return NULL;
4353 fullcmd = (char*)cmd;
4354 while (*fullcmd) {
4355 if (*fullcmd == '/' || *fullcmd == '\\')
4356 has_slash++;
4357 fullcmd++;
4358 cmdlen++;
4359 }
4360
4361 /* look in PATH */
4362 {
4363 dTHX;
4364 pathstr = PerlEnv_getenv("PATH");
4365 }
4366 /* worst case: PATH is a single directory; we need additional space
4367 * to append "/", ".exe" and trailing "\0" */
4368 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
4369 curfullcmd = fullcmd;
4370
4371 while (1) {
4372 DWORD res;
4373
4374 /* start by appending the name to the current prefix */
4375 strcpy(curfullcmd, cmd);
4376 curfullcmd += cmdlen;
4377
4378 /* if it doesn't end with '.', or has no extension, try adding
4379 * a trailing .exe first */
4380 if (cmd[cmdlen-1] != '.'
4381 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
4382 {
4383 int i;
4384 /* first extension is .exe */
4385 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
4386 for (i = 0; i < ext_limit; ++i) {
4387 strcpy(curfullcmd, exe_extensions[i]);
4388 res = GetFileAttributes(fullcmd);
4389 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
4390 return fullcmd;
4391 }
4392
4393 *curfullcmd = '\0';
4394 }
4395
4396 /* that failed, try the bare name */
4397 res = GetFileAttributes(fullcmd);
4398 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
4399 return fullcmd;
4400
4401 /* quit if no other path exists, or if cmd already has path */
4402 if (!pathstr || !*pathstr || has_slash)
4403 break;
4404
4405 /* skip leading semis */
4406 while (*pathstr == ';')
4407 pathstr++;
4408
4409 /* build a new prefix from scratch */
4410 curfullcmd = fullcmd;
4411 while (*pathstr && *pathstr != ';') {
4412 if (*pathstr == '"') { /* foo;"baz;etc";bar */
4413 pathstr++; /* skip initial '"' */
4414 while (*pathstr && *pathstr != '"') {
4415 *curfullcmd++ = *pathstr++;
4416 }
4417 if (*pathstr)
4418 pathstr++; /* skip trailing '"' */
4419 }
4420 else {
4421 *curfullcmd++ = *pathstr++;
4422 }
4423 }
4424 if (*pathstr)
4425 pathstr++; /* skip trailing semi */
4426 if (curfullcmd > fullcmd /* append a dir separator */
4427 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
4428 {
4429 *curfullcmd++ = '\\';
4430 }
4431 }
4432
4433 Safefree(fullcmd);
4434 return NULL;
4435}
4436
4437/* The following are just place holders.
4438 * Some hosts may provide and environment that the OS is
4439 * not tracking, therefore, these host must provide that
4440 * environment and the current directory to CreateProcess
4441 */
4442
4443DllExport void*
4444win32_get_childenv(void)
4445{
4446 return NULL;
4447}
4448
4449DllExport void
4450win32_free_childenv(void* d)
4451{
4452}
4453
4454DllExport void
4455win32_clearenv(void)
4456{
4457 char *envv = GetEnvironmentStrings();
4458 char *cur = envv;
4459 STRLEN len;
4460 while (*cur) {
4461 char *end = strchr(cur,'=');
4462 if (end && end != cur) {
4463 *end = '\0';
4464 SetEnvironmentVariable(cur, NULL);
4465 *end = '=';
4466 cur = end + strlen(end+1)+2;
4467 }
4468 else if ((len = strlen(cur)))
4469 cur += len+1;
4470 }
4471 FreeEnvironmentStrings(envv);
4472}
4473
4474DllExport char*
4475win32_get_childdir(void)
4476{
4477 char* ptr;
4478 char szfilename[MAX_PATH+1];
4479
4480 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4481 Newx(ptr, strlen(szfilename)+1, char);
4482 strcpy(ptr, szfilename);
4483 return ptr;
4484}
4485
4486DllExport void
4487win32_free_childdir(char* d)
4488{
4489 Safefree(d);
4490}
4491
4492
4493/* XXX this needs to be made more compatible with the spawnvp()
4494 * provided by the various RTLs. In particular, searching for
4495 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4496 * This doesn't significantly affect perl itself, because we
4497 * always invoke things using PERL5SHELL if a direct attempt to
4498 * spawn the executable fails.
4499 *
4500 * XXX splitting and rejoining the commandline between do_aspawn()
4501 * and win32_spawnvp() could also be avoided.
4502 */
4503
4504DllExport int
4505win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4506{
4507#ifdef USE_RTL_SPAWNVP
4508 return _spawnvp(mode, cmdname, (char * const *)argv);
4509#else
4510 return do_spawnvp_handles(mode, cmdname, argv, NULL);
4511#endif
4512}
4513
4514static int
4515do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
4516 const int *handles) {
4517 dTHXa(NULL);
4518 int ret;
4519 void* env;
4520 char* dir;
4521 child_IO_table tbl;
4522 STARTUPINFO StartupInfo;
4523 PROCESS_INFORMATION ProcessInformation;
4524 DWORD create = 0;
4525 char *cmd;
4526 char *fullcmd = NULL;
4527 char *cname = (char *)cmdname;
4528 STRLEN clen = 0;
4529
4530 if (cname) {
4531 clen = strlen(cname);
4532 /* if command name contains dquotes, must remove them */
4533 if (strchr(cname, '"')) {
4534 cmd = cname;
4535 Newx(cname,clen+1,char);
4536 clen = 0;
4537 while (*cmd) {
4538 if (*cmd != '"') {
4539 cname[clen] = *cmd;
4540 ++clen;
4541 }
4542 ++cmd;
4543 }
4544 cname[clen] = '\0';
4545 }
4546 }
4547
4548 cmd = create_command_line(cname, clen, argv);
4549
4550 aTHXa(PERL_GET_THX);
4551 env = PerlEnv_get_childenv();
4552 dir = PerlEnv_get_childdir();
4553
4554 switch(mode) {
4555 case P_NOWAIT: /* asynch + remember result */
4556 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4557 errno = EAGAIN;
4558 ret = -1;
4559 goto RETVAL;
4560 }
4561 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4562 * in win32_kill()
4563 */
4564 create |= CREATE_NEW_PROCESS_GROUP;
4565 /* FALL THROUGH */
4566
4567 case P_WAIT: /* synchronous execution */
4568 break;
4569 default: /* invalid mode */
4570 errno = EINVAL;
4571 ret = -1;
4572 goto RETVAL;
4573 }
4574
4575 memset(&StartupInfo,0,sizeof(StartupInfo));
4576 StartupInfo.cb = sizeof(StartupInfo);
4577 memset(&tbl,0,sizeof(tbl));
4578 PerlEnv_get_child_IO(&tbl);
4579 StartupInfo.dwFlags = tbl.dwFlags;
4580 StartupInfo.dwX = tbl.dwX;
4581 StartupInfo.dwY = tbl.dwY;
4582 StartupInfo.dwXSize = tbl.dwXSize;
4583 StartupInfo.dwYSize = tbl.dwYSize;
4584 StartupInfo.dwXCountChars = tbl.dwXCountChars;
4585 StartupInfo.dwYCountChars = tbl.dwYCountChars;
4586 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4587 StartupInfo.wShowWindow = tbl.wShowWindow;
4588 StartupInfo.hStdInput = handles && handles[0] != -1 ?
4589 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
4590 StartupInfo.hStdOutput = handles && handles[1] != -1 ?
4591 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
4592 StartupInfo.hStdError = handles && handles[2] != -1 ?
4593 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
4594 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4595 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4596 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4597 {
4598 create |= CREATE_NEW_CONSOLE;
4599 }
4600 else {
4601 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4602 }
4603 if (w32_use_showwindow) {
4604 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4605 StartupInfo.wShowWindow = w32_showwindow;
4606 }
4607
4608 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4609 cname,cmd));
4610RETRY:
4611 if (!CreateProcess(cname, /* search PATH to find executable */
4612 cmd, /* executable, and its arguments */
4613 NULL, /* process attributes */
4614 NULL, /* thread attributes */
4615 TRUE, /* inherit handles */
4616 create, /* creation flags */
4617 (LPVOID)env, /* inherit environment */
4618 dir, /* inherit cwd */
4619 &StartupInfo,
4620 &ProcessInformation))
4621 {
4622 /* initial NULL argument to CreateProcess() does a PATH
4623 * search, but it always first looks in the directory
4624 * where the current process was started, which behavior
4625 * is undesirable for backward compatibility. So we
4626 * jump through our own hoops by picking out the path
4627 * we really want it to use. */
4628 if (!fullcmd) {
4629 fullcmd = qualified_path(cname, FALSE);
4630 if (fullcmd) {
4631 if (cname != cmdname)
4632 Safefree(cname);
4633 cname = fullcmd;
4634 DEBUG_p(PerlIO_printf(Perl_debug_log,
4635 "Retrying [%s] with same args\n",
4636 cname));
4637 goto RETRY;
4638 }
4639 }
4640 errno = ENOENT;
4641 ret = -1;
4642 goto RETVAL;
4643 }
4644
4645 if (mode == P_NOWAIT) {
4646 /* asynchronous spawn -- store handle, return PID */
4647 ret = (int)ProcessInformation.dwProcessId;
4648
4649 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4650 w32_child_pids[w32_num_children] = (DWORD)ret;
4651 ++w32_num_children;
4652 }
4653 else {
4654 DWORD status;
4655 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4656 /* FIXME: if msgwait returned due to message perhaps forward the
4657 "signal" to the process
4658 */
4659 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4660 ret = (int)status;
4661 CloseHandle(ProcessInformation.hProcess);
4662 }
4663
4664 CloseHandle(ProcessInformation.hThread);
4665
4666RETVAL:
4667 PerlEnv_free_childenv(env);
4668 PerlEnv_free_childdir(dir);
4669 Safefree(cmd);
4670 if (cname != cmdname)
4671 Safefree(cname);
4672 return ret;
4673}
4674
4675DllExport int
4676win32_execv(const char *cmdname, const char *const *argv)
4677{
4678#ifdef USE_ITHREADS
4679 dTHX;
4680 /* if this is a pseudo-forked child, we just want to spawn
4681 * the new program, and return */
4682 if (w32_pseudo_id)
4683 return _spawnv(P_WAIT, cmdname, argv);
4684#endif
4685 return _execv(cmdname, argv);
4686}
4687
4688DllExport int
4689win32_execvp(const char *cmdname, const char *const *argv)
4690{
4691#ifdef USE_ITHREADS
4692 dTHX;
4693 /* if this is a pseudo-forked child, we just want to spawn
4694 * the new program, and return */
4695 if (w32_pseudo_id) {
4696 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4697 if (status != -1) {
4698 my_exit(status);
4699 return 0;
4700 }
4701 else
4702 return status;
4703 }
4704#endif
4705 return _execvp(cmdname, argv);
4706}
4707
4708DllExport void
4709win32_perror(const char *str)
4710{
4711 perror(str);
4712}
4713
4714DllExport void
4715win32_setbuf(FILE *pf, char *buf)
4716{
4717 setbuf(pf, buf);
4718}
4719
4720DllExport int
4721win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4722{
4723 return setvbuf(pf, buf, type, size);
4724}
4725
4726DllExport int
4727win32_flushall(void)
4728{
4729 return flushall();
4730}
4731
4732DllExport int
4733win32_fcloseall(void)
4734{
4735 return fcloseall();
4736}
4737
4738DllExport char*
4739win32_fgets(char *s, int n, FILE *pf)
4740{
4741 return fgets(s, n, pf);
4742}
4743
4744DllExport char*
4745win32_gets(char *s)
4746{
4747 return gets(s);
4748}
4749
4750DllExport int
4751win32_fgetc(FILE *pf)
4752{
4753 return fgetc(pf);
4754}
4755
4756DllExport int
4757win32_putc(int c, FILE *pf)
4758{
4759 return putc(c,pf);
4760}
4761
4762DllExport int
4763win32_puts(const char *s)
4764{
4765 return puts(s);
4766}
4767
4768DllExport int
4769win32_getchar(void)
4770{
4771 return getchar();
4772}
4773
4774DllExport int
4775win32_putchar(int c)
4776{
4777 return putchar(c);
4778}
4779
4780#ifdef MYMALLOC
4781
4782#ifndef USE_PERL_SBRK
4783
4784static char *committed = NULL; /* XXX threadead */
4785static char *base = NULL; /* XXX threadead */
4786static char *reserved = NULL; /* XXX threadead */
4787static char *brk = NULL; /* XXX threadead */
4788static DWORD pagesize = 0; /* XXX threadead */
4789
4790void *
4791sbrk(ptrdiff_t need)
4792{
4793 void *result;
4794 if (!pagesize)
4795 {SYSTEM_INFO info;
4796 GetSystemInfo(&info);
4797 /* Pretend page size is larger so we don't perpetually
4798 * call the OS to commit just one page ...
4799 */
4800 pagesize = info.dwPageSize << 3;
4801 }
4802 if (brk+need >= reserved)
4803 {
4804 DWORD size = brk+need-reserved;
4805 char *addr;
4806 char *prev_committed = NULL;
4807 if (committed && reserved && committed < reserved)
4808 {
4809 /* Commit last of previous chunk cannot span allocations */
4810 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4811 if (addr)
4812 {
4813 /* Remember where we committed from in case we want to decommit later */
4814 prev_committed = committed;
4815 committed = reserved;
4816 }
4817 }
4818 /* Reserve some (more) space
4819 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4820 * this is only address space not memory...
4821 * Note this is a little sneaky, 1st call passes NULL as reserved
4822 * so lets system choose where we start, subsequent calls pass
4823 * the old end address so ask for a contiguous block
4824 */
4825sbrk_reserve:
4826 if (size < 64*1024*1024)
4827 size = 64*1024*1024;
4828 size = ((size + pagesize - 1) / pagesize) * pagesize;
4829 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4830 if (addr)
4831 {
4832 reserved = addr+size;
4833 if (!base)
4834 base = addr;
4835 if (!committed)
4836 committed = base;
4837 if (!brk)
4838 brk = committed;
4839 }
4840 else if (reserved)
4841 {
4842 /* The existing block could not be extended far enough, so decommit
4843 * anything that was just committed above and start anew */
4844 if (prev_committed)
4845 {
4846 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4847 return (void *) -1;
4848 }
4849 reserved = base = committed = brk = NULL;
4850 size = need;
4851 goto sbrk_reserve;
4852 }
4853 else
4854 {
4855 return (void *) -1;
4856 }
4857 }
4858 result = brk;
4859 brk += need;
4860 if (brk > committed)
4861 {
4862 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4863 char *addr;
4864 if (committed+size > reserved)
4865 size = reserved-committed;
4866 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4867 if (addr)
4868 committed += size;
4869 else
4870 return (void *) -1;
4871 }
4872 return result;
4873}
4874
4875#endif
4876#endif
4877
4878DllExport void*
4879win32_malloc(size_t size)
4880{
4881 return malloc(size);
4882}
4883
4884DllExport void*
4885win32_calloc(size_t numitems, size_t size)
4886{
4887 return calloc(numitems,size);
4888}
4889
4890DllExport void*
4891win32_realloc(void *block, size_t size)
4892{
4893 return realloc(block,size);
4894}
4895
4896DllExport void
4897win32_free(void *block)
4898{
4899 free(block);
4900}
4901
4902
4903DllExport int
4904win32_open_osfhandle(intptr_t handle, int flags)
4905{
4906 return _open_osfhandle(handle, flags);
4907}
4908
4909DllExport intptr_t
4910win32_get_osfhandle(int fd)
4911{
4912 return (intptr_t)_get_osfhandle(fd);
4913}
4914
4915DllExport FILE *
4916win32_fdupopen(FILE *pf)
4917{
4918 FILE* pfdup;
4919 fpos_t pos;
4920 char mode[3];
4921 int fileno = win32_dup(win32_fileno(pf));
4922
4923 /* open the file in the same mode */
4924 if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
4925 mode[0] = 'r';
4926 mode[1] = 0;
4927 }
4928 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
4929 mode[0] = 'a';
4930 mode[1] = 0;
4931 }
4932 else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
4933 mode[0] = 'r';
4934 mode[1] = '+';
4935 mode[2] = 0;
4936 }
4937
4938 /* it appears that the binmode is attached to the
4939 * file descriptor so binmode files will be handled
4940 * correctly
4941 */
4942 pfdup = win32_fdopen(fileno, mode);
4943
4944 /* move the file pointer to the same position */
4945 if (!fgetpos(pf, &pos)) {
4946 fsetpos(pfdup, &pos);
4947 }
4948 return pfdup;
4949}
4950
4951DllExport void*
4952win32_dynaload(const char* filename)
4953{
4954 dTHXa(NULL);
4955 char buf[MAX_PATH+1];
4956 const char *first;
4957
4958 /* LoadLibrary() doesn't recognize forward slashes correctly,
4959 * so turn 'em back. */
4960 first = strchr(filename, '/');
4961 if (first) {
4962 STRLEN len = strlen(filename);
4963 if (len <= MAX_PATH) {
4964 strcpy(buf, filename);
4965 filename = &buf[first - filename];
4966 while (*filename) {
4967 if (*filename == '/')
4968 *(char*)filename = '\\';
4969 ++filename;
4970 }
4971 filename = buf;
4972 }
4973 }
4974 aTHXa(PERL_GET_THX);
4975 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4976}
4977
4978XS(w32_SetChildShowWindow)
4979{
4980 dXSARGS;
4981 BOOL use_showwindow = w32_use_showwindow;
4982 /* use "unsigned short" because Perl has redefined "WORD" */
4983 unsigned short showwindow = w32_showwindow;
4984
4985 if (items > 1)
4986 croak_xs_usage(cv, "[showwindow]");
4987
4988 if (items == 0 || !SvOK(ST(0)))
4989 w32_use_showwindow = FALSE;
4990 else {
4991 w32_use_showwindow = TRUE;
4992 w32_showwindow = (unsigned short)SvIV(ST(0));
4993 }
4994
4995 EXTEND(SP, 1);
4996 if (use_showwindow)
4997 ST(0) = sv_2mortal(newSViv(showwindow));
4998 else
4999 ST(0) = &PL_sv_undef;
5000 XSRETURN(1);
5001}
5002
5003
5004#ifdef PERL_IS_MINIPERL
5005/* shelling out is much slower, full perl uses Win32.pm */
5006XS(w32_GetCwd)
5007{
5008 dXSARGS;
5009 /* Make the host for current directory */
5010 char* ptr = PerlEnv_get_childdir();
5011 /*
5012 * If ptr != Nullch
5013 * then it worked, set PV valid,
5014 * else return 'undef'
5015 */
5016 if (ptr) {
5017 SV *sv = sv_newmortal();
5018 sv_setpv(sv, ptr);
5019 PerlEnv_free_childdir(ptr);
5020
5021#ifndef INCOMPLETE_TAINTS
5022 SvTAINTED_on(sv);
5023#endif
5024
5025 ST(0) = sv;
5026 XSRETURN(1);
5027 }
5028 XSRETURN_UNDEF;
5029}
5030#endif
5031
5032void
5033Perl_init_os_extras(void)
5034{
5035 dTHXa(NULL);
5036 const char *file = __FILE__;
5037
5038 /* Initialize Win32CORE if it has been statically linked. */
5039#ifndef PERL_IS_MINIPERL
5040 void (*pfn_init)(pTHX);
5041 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
5042 ? GetModuleHandle(NULL)
5043 : w32_perldll_handle);
5044 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
5045 aTHXa(PERL_GET_THX);
5046 if (pfn_init)
5047 pfn_init(aTHX);
5048#else
5049 aTHXa(PERL_GET_THX);
5050#endif
5051
5052 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
5053#ifdef PERL_IS_MINIPERL
5054 newXS("Win32::GetCwd", w32_GetCwd, file);
5055#endif
5056}
5057
5058void *
5059win32_signal_context(void)
5060{
5061 dTHX;
5062#ifdef MULTIPLICITY
5063 if (!my_perl) {
5064 my_perl = PL_curinterp;
5065 PERL_SET_THX(my_perl);
5066 }
5067 return my_perl;
5068#else
5069 return PL_curinterp;
5070#endif
5071}
5072
5073
5074BOOL WINAPI
5075win32_ctrlhandler(DWORD dwCtrlType)
5076{
5077#ifdef MULTIPLICITY
5078 dTHXa(PERL_GET_SIG_CONTEXT);
5079
5080 if (!my_perl)
5081 return FALSE;
5082#endif
5083
5084 switch(dwCtrlType) {
5085 case CTRL_CLOSE_EVENT:
5086 /* A signal that the system sends to all processes attached to a console when
5087 the user closes the console (either by choosing the Close command from the
5088 console window's System menu, or by choosing the End Task command from the
5089 Task List
5090 */
5091 if (do_raise(aTHX_ 1)) /* SIGHUP */
5092 sig_terminate(aTHX_ 1);
5093 return TRUE;
5094
5095 case CTRL_C_EVENT:
5096 /* A CTRL+c signal was received */
5097 if (do_raise(aTHX_ SIGINT))
5098 sig_terminate(aTHX_ SIGINT);
5099 return TRUE;
5100
5101 case CTRL_BREAK_EVENT:
5102 /* A CTRL+BREAK signal was received */
5103 if (do_raise(aTHX_ SIGBREAK))
5104 sig_terminate(aTHX_ SIGBREAK);
5105 return TRUE;
5106
5107 case CTRL_LOGOFF_EVENT:
5108 /* A signal that the system sends to all console processes when a user is logging
5109 off. This signal does not indicate which user is logging off, so no
5110 assumptions can be made.
5111 */
5112 break;
5113 case CTRL_SHUTDOWN_EVENT:
5114 /* A signal that the system sends to all console processes when the system is
5115 shutting down.
5116 */
5117 if (do_raise(aTHX_ SIGTERM))
5118 sig_terminate(aTHX_ SIGTERM);
5119 return TRUE;
5120 default:
5121 break;
5122 }
5123 return FALSE;
5124}
5125
5126
5127#ifdef SET_INVALID_PARAMETER_HANDLER
5128# include <crtdbg.h>
5129#endif
5130
5131static void
5132ansify_path(void)
5133{
5134 size_t len;
5135 char *ansi_path;
5136 WCHAR *wide_path;
5137 WCHAR *wide_dir;
5138
5139 /* fetch Unicode version of PATH */
5140 len = 2000;
5141 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
5142 while (wide_path) {
5143 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
5144 if (newlen == 0) {
5145 win32_free(wide_path);
5146 return;
5147 }
5148 if (newlen < len)
5149 break;
5150 len = newlen;
5151 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
5152 }
5153 if (!wide_path)
5154 return;
5155
5156 /* convert to ANSI pathnames */
5157 wide_dir = wide_path;
5158 ansi_path = NULL;
5159 while (wide_dir) {
5160 WCHAR *sep = wcschr(wide_dir, ';');
5161 char *ansi_dir;
5162 size_t ansi_len;
5163 size_t wide_len;
5164
5165 if (sep)
5166 *sep++ = '\0';
5167
5168 /* remove quotes around pathname */
5169 if (*wide_dir == '"')
5170 ++wide_dir;
5171 wide_len = wcslen(wide_dir);
5172 if (wide_len && wide_dir[wide_len-1] == '"')
5173 wide_dir[wide_len-1] = '\0';
5174
5175 /* append ansi_dir to ansi_path */
5176 ansi_dir = win32_ansipath(wide_dir);
5177 ansi_len = strlen(ansi_dir);
5178 if (ansi_path) {
5179 size_t newlen = len + 1 + ansi_len;
5180 ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
5181 if (!ansi_path)
5182 break;
5183 ansi_path[len] = ';';
5184 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
5185 len = newlen;
5186 }
5187 else {
5188 len = ansi_len;
5189 ansi_path = (char*)win32_malloc(5+len+1);
5190 if (!ansi_path)
5191 break;
5192 memcpy(ansi_path, "PATH=", 5);
5193 memcpy(ansi_path+5, ansi_dir, len+1);
5194 len += 5;
5195 }
5196 win32_free(ansi_dir);
5197 wide_dir = sep;
5198 }
5199
5200 if (ansi_path) {
5201 /* Update C RTL environ array. This will only have full effect if
5202 * perl_parse() is later called with `environ` as the `env` argument.
5203 * Otherwise S_init_postdump_symbols() will overwrite PATH again.
5204 *
5205 * We do have to ansify() the PATH before Perl has been fully
5206 * initialized because S_find_script() uses the PATH when perl
5207 * is being invoked with the -S option. This happens before %ENV
5208 * is initialized in S_init_postdump_symbols().
5209 *
5210 * XXX Is this a bug? Should S_find_script() use the environment
5211 * XXX passed in the `env` arg to parse_perl()?
5212 */
5213 putenv(ansi_path);
5214 /* Keep system environment in sync because S_init_postdump_symbols()
5215 * will not call mg_set() if it initializes %ENV from `environ`.
5216 */
5217 SetEnvironmentVariableA("PATH", ansi_path+5);
5218 win32_free(ansi_path);
5219 }
5220 win32_free(wide_path);
5221}
5222
5223/* This hooks a function that is imported by the specified module. The hook is
5224 * local to that module. */
5225static bool
5226win32_hook_imported_function_in_module(
5227 HMODULE module, LPCSTR fun_name, FARPROC hook_ptr
5228)
5229{
5230 ULONG_PTR image_base = (ULONG_PTR)module;
5231 PIMAGE_DOS_HEADER dos_header = (PIMAGE_DOS_HEADER)image_base;
5232 PIMAGE_NT_HEADERS nt_headers
5233 = (PIMAGE_NT_HEADERS)(image_base + dos_header->e_lfanew);
5234 PIMAGE_OPTIONAL_HEADER opt_header = &nt_headers->OptionalHeader;
5235
5236 PIMAGE_DATA_DIRECTORY data_dir = opt_header->DataDirectory;
5237 DWORD data_dir_len = opt_header->NumberOfRvaAndSizes;
5238
5239 BOOL is_idt_present = data_dir_len > IMAGE_DIRECTORY_ENTRY_IMPORT
5240 && data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress != 0;
5241
5242 if (!is_idt_present)
5243 return FALSE;
5244
5245 BOOL found = FALSE;
5246
5247 /* Import Directory Table */
5248 PIMAGE_IMPORT_DESCRIPTOR idt = (PIMAGE_IMPORT_DESCRIPTOR)(
5249 image_base + data_dir[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress
5250 );
5251
5252 for (; idt->Name != 0; ++idt) {
5253 /* Import Lookup Table */
5254 PIMAGE_THUNK_DATA ilt
5255 = (PIMAGE_THUNK_DATA)(image_base + idt->OriginalFirstThunk);
5256 /* Import Address Table */
5257 PIMAGE_THUNK_DATA iat
5258 = (PIMAGE_THUNK_DATA)(image_base + idt->FirstThunk);
5259
5260 ULONG_PTR address_of_data;
5261 for (; address_of_data = ilt->u1.AddressOfData; ++ilt, ++iat) {
5262 /* Ordinal imports are quite rare, so skipping them will most likely
5263 * not cause any problems. */
5264 BOOL is_ordinal
5265 = address_of_data >> ((sizeof(address_of_data) * 8) - 1);
5266
5267 if (is_ordinal)
5268 continue;
5269
5270 LPCSTR name = (
5271 (PIMAGE_IMPORT_BY_NAME)(image_base + address_of_data)
5272 )->Name;
5273
5274 if (strEQ(name, fun_name)) {
5275 DWORD old_protect = 0;
5276 BOOL succ = VirtualProtect(
5277 &iat->u1.Function, sizeof(iat->u1.Function), PAGE_READWRITE,
5278 &old_protect
5279 );
5280 if (!succ)
5281 return FALSE;
5282
5283 iat->u1.Function = (ULONG_PTR)hook_ptr;
5284 found = TRUE;
5285
5286 VirtualProtect(
5287 &iat->u1.Function, sizeof(iat->u1.Function), old_protect,
5288 &old_protect
5289 );
5290 break;
5291 }
5292 }
5293 }
5294
5295 return found;
5296}
5297
5298typedef NTSTATUS (NTAPI *pNtQueryInformationFile_t)(HANDLE, PIO_STATUS_BLOCK, PVOID, ULONG, ULONG);
5299pNtQueryInformationFile_t pNtQueryInformationFile = NULL;
5300
5301typedef BOOL (WINAPI *pCloseHandle)(HANDLE h);
5302static pCloseHandle CloseHandle_orig;
5303
5304/* CloseHandle() that supports sockets. CRT uses mutexes during file operations,
5305 * so the lack of thread safety in this function isn't a problem. */
5306static BOOL WINAPI
5307my_CloseHandle(HANDLE h)
5308{
5309 /* In theory, passing a non-socket handle to closesocket() is fine. It
5310 * should return a WSAENOTSOCK error, which is easy to recover from.
5311 * However, we should avoid doing that because it's not that simple in
5312 * practice. For instance, it can deadlock on a handle to a stuck pipe (see:
5313 * https://github.com/Perl/perl5/issues/19963).
5314 *
5315 * There's no foolproof way to tell if a handle is a socket (mostly because
5316 * of the non-IFS sockets), but in some cases we can tell if a handle
5317 * is definitely *not* a socket.
5318 */
5319
5320 /* GetFileType() always returns FILE_TYPE_PIPE for sockets. */
5321 BOOL maybe_socket = (GetFileType(h) == FILE_TYPE_PIPE);
5322
5323 if (maybe_socket && pNtQueryInformationFile) {
5324 IO_STATUS_BLOCK isb;
5325 struct {
5326 ULONG name_len;
5327 WCHAR name[100];
5328 } volume = {0};
5329
5330 /* There are many ways to tell a named pipe from a socket, but almost
5331 * all of them can deadlock on a handle to a stuck pipe (like in the
5332 * bug ticket mentioned above). According to my tests,
5333 * FileVolumeNameInfomation is the only relevant function that doesn't
5334 * suffer from this problem.
5335 *
5336 * It's undocumented and it requires Windows 10, so on older systems
5337 * we always pass pipes to closesocket().
5338 */
5339 NTSTATUS s = pNtQueryInformationFile(
5340 h, &isb, &volume, sizeof(volume), 58 /* FileVolumeNameInformation */
5341 );
5342 if (NT_SUCCESS(s)) {
5343 maybe_socket = (_wcsnicmp(
5344 volume.name, L"\\Device\\NamedPipe", C_ARRAY_LENGTH(volume.name)
5345 ) != 0);
5346 }
5347 }
5348
5349 if (maybe_socket)
5350 if (closesocket((SOCKET)h) == 0)
5351 return TRUE;
5352 else if (WSAGetLastError() != WSAENOTSOCK)
5353 return FALSE;
5354
5355 return CloseHandle_orig(h);
5356}
5357
5358/* Hook CloseHandle() inside CRT so its functions like _close() or
5359 * _dup2() can close sockets properly. */
5360static void
5361win32_hook_closehandle_in_crt()
5362{
5363 /* Get the handle to the CRT module basing on the address of _close()
5364 * function. */
5365 HMODULE crt_handle;
5366 BOOL succ = GetModuleHandleExA(
5367 GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
5368 | GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, (LPCSTR)_close,
5369 &crt_handle
5370 );
5371 if (!succ)
5372 return;
5373
5374 CloseHandle_orig = (pCloseHandle)GetProcAddress(
5375 GetModuleHandleA("kernel32.dll"), "CloseHandle"
5376 );
5377 if (!CloseHandle_orig)
5378 return;
5379
5380 win32_hook_imported_function_in_module(
5381 crt_handle, "CloseHandle", (FARPROC)my_CloseHandle
5382 );
5383
5384 pNtQueryInformationFile = (pNtQueryInformationFile_t)GetProcAddress(
5385 GetModuleHandleA("ntdll.dll"), "NtQueryInformationFile"
5386 );
5387}
5388
5389/* Remove the hook installed by win32_hook_closehandle_crt(). This is needed in
5390 * case the Perl DLL is unloaded, which would cause the hook become invalid.
5391 * This can happen in embedded Perls, for example in mod_perl. */
5392static void
5393win32_unhook_closehandle_in_crt()
5394{
5395 if (!CloseHandle_orig)
5396 return;
5397
5398 HMODULE crt_handle;
5399 BOOL succ = GetModuleHandleExA(
5400 GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
5401 | GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT, (LPCSTR)_close,
5402 &crt_handle
5403 );
5404 if (!succ)
5405 return;
5406
5407 win32_hook_imported_function_in_module(
5408 crt_handle, "CloseHandle", (FARPROC)CloseHandle_orig
5409 );
5410
5411 CloseHandle_orig = NULL;
5412}
5413
5414void
5415Perl_win32_init(int *argcp, char ***argvp)
5416{
5417#ifdef SET_INVALID_PARAMETER_HANDLER
5418 _invalid_parameter_handler oldHandler, newHandler;
5419 newHandler = my_invalid_parameter_handler;
5420 oldHandler = _set_invalid_parameter_handler(newHandler);
5421 _CrtSetReportMode(_CRT_ASSERT, 0);
5422#endif
5423 /* Disable floating point errors, Perl will trap the ones we
5424 * care about. VC++ RTL defaults to switching these off
5425 * already, but some RTLs don't. Since we don't
5426 * want to be at the vendor's whim on the default, we set
5427 * it explicitly here.
5428 */
5429#if !defined(__GNUC__)
5430 _control87(MCW_EM, MCW_EM);
5431#endif
5432 MALLOC_INIT;
5433
5434 /* When the manifest resource requests Common-Controls v6 then
5435 * user32.dll no longer registers all the Windows classes used for
5436 * standard controls but leaves some of them to be registered by
5437 * comctl32.dll. InitCommonControls() doesn't do anything but calling
5438 * it makes sure comctl32.dll gets loaded into the process and registers
5439 * the standard control classes. Without this even normal Windows APIs
5440 * like MessageBox() can fail under some versions of Windows XP.
5441 */
5442 InitCommonControls();
5443
5444 WSADATA wsadata;
5445 WSAStartup(MAKEWORD(2, 2), &wsadata);
5446
5447 g_osver.dwOSVersionInfoSize = sizeof(g_osver);
5448 GetVersionEx(&g_osver);
5449
5450 win32_hook_closehandle_in_crt();
5451
5452 ansify_path();
5453
5454#ifndef WIN32_NO_REGISTRY
5455 {
5456 LONG retval;
5457 retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
5458 if (retval != ERROR_SUCCESS) {
5459 HKCU_Perl_hnd = NULL;
5460 }
5461 retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
5462 if (retval != ERROR_SUCCESS) {
5463 HKLM_Perl_hnd = NULL;
5464 }
5465 }
5466#endif
5467
5468 {
5469 FILETIME ft;
5470 if (!SystemTimeToFileTime(&time_t_epoch_base_systemtime,
5471 &ft)) {
5472 fprintf(stderr, "panic: cannot convert base system time to filetime\n"); /* no interp */
5473 exit(1);
5474 }
5475 time_t_epoch_base_filetime.LowPart = ft.dwLowDateTime;
5476 time_t_epoch_base_filetime.HighPart = ft.dwHighDateTime;
5477 }
5478
5479 MUTEX_INIT(&win32_read_console_mutex);
5480}
5481
5482void
5483Perl_win32_term(void)
5484{
5485 HINTS_REFCNT_TERM;
5486 OP_REFCNT_TERM;
5487 PERLIO_TERM;
5488 MALLOC_TERM;
5489 LOCALE_TERM;
5490 ENV_TERM;
5491#ifndef WIN32_NO_REGISTRY
5492 /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
5493 but no point of checking and we can't die() at this point */
5494 RegCloseKey(HKLM_Perl_hnd);
5495 RegCloseKey(HKCU_Perl_hnd);
5496 /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
5497#endif
5498 win32_unhook_closehandle_in_crt();
5499}
5500
5501void
5502win32_get_child_IO(child_IO_table* ptbl)
5503{
5504 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
5505 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
5506 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
5507}
5508
5509Sighandler_t
5510win32_signal(int sig, Sighandler_t subcode)
5511{
5512 dTHXa(NULL);
5513 if (sig < SIG_SIZE) {
5514 int save_errno = errno;
5515 Sighandler_t result;
5516#ifdef SET_INVALID_PARAMETER_HANDLER
5517 /* Silence our invalid parameter handler since we expect to make some
5518 * calls with invalid signal numbers giving a SIG_ERR result. */
5519 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
5520#endif
5521 result = signal(sig, subcode);
5522#ifdef SET_INVALID_PARAMETER_HANDLER
5523 set_silent_invalid_parameter_handler(oldvalue);
5524#endif
5525 aTHXa(PERL_GET_THX);
5526 if (result == SIG_ERR) {
5527 result = w32_sighandler[sig];
5528 errno = save_errno;
5529 }
5530 w32_sighandler[sig] = subcode;
5531 return result;
5532 }
5533 else {
5534 errno = EINVAL;
5535 return SIG_ERR;
5536 }
5537}
5538
5539/* The PerlMessageWindowClass's WindowProc */
5540LRESULT CALLBACK
5541win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
5542{
5543 return win32_process_message(hwnd, msg, wParam, lParam) ?
5544 0 : DefWindowProc(hwnd, msg, wParam, lParam);
5545}
5546
5547/* The real message handler. Can be called with
5548 * hwnd == NULL to process our thread messages. Returns TRUE for any messages
5549 * that it processes */
5550static LRESULT
5551win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
5552{
5553 /* BEWARE. The context retrieved using dTHX; is the context of the
5554 * 'parent' thread during the CreateWindow() phase - i.e. for all messages
5555 * up to and including WM_CREATE. If it ever happens that you need the
5556 * 'child' context before this, then it needs to be passed into
5557 * win32_create_message_window(), and passed to the WM_NCCREATE handler
5558 * from the lparam of CreateWindow(). It could then be stored/retrieved
5559 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
5560 * the dTHX calls here. */
5561 /* XXX For now it is assumed that the overhead of the dTHX; for what
5562 * are relativley infrequent code-paths, is better than the added
5563 * complexity of getting the correct context passed into
5564 * win32_create_message_window() */
5565 dTHX;
5566
5567 switch(msg) {
5568
5569#ifdef USE_ITHREADS
5570 case WM_USER_MESSAGE: {
5571 long child = find_pseudo_pid(aTHX_ (int)wParam);
5572 if (child >= 0) {
5573 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
5574 return 1;
5575 }
5576 break;
5577 }
5578#endif
5579
5580 case WM_USER_KILL: {
5581 /* We use WM_USER_KILL to fake kill() with other signals */
5582 int sig = (int)wParam;
5583 if (do_raise(aTHX_ sig))
5584 sig_terminate(aTHX_ sig);
5585
5586 return 1;
5587 }
5588
5589 case WM_TIMER: {
5590 /* alarm() is a one-shot but SetTimer() repeats so kill it */
5591 if (w32_timerid && w32_timerid==(UINT)wParam) {
5592 KillTimer(w32_message_hwnd, w32_timerid);
5593 w32_timerid=0;
5594
5595 /* Now fake a call to signal handler */
5596 if (do_raise(aTHX_ 14))
5597 sig_terminate(aTHX_ 14);
5598
5599 return 1;
5600 }
5601 break;
5602 }
5603
5604 default:
5605 break;
5606
5607 } /* switch */
5608
5609 /* Above or other stuff may have set a signal flag, and we may not have
5610 * been called from win32_async_check() (e.g. some other GUI's message
5611 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM
5612 * handler that die's, and the message loop that calls here is wrapped
5613 * in an eval, then you may well end up with orphaned windows - signals
5614 * are dispatched by win32_async_check() */
5615
5616 return 0;
5617}
5618
5619void
5620win32_create_message_window_class(void)
5621{
5622 /* create the window class for "message only" windows */
5623 WNDCLASS wc;
5624
5625 Zero(&wc, 1, wc);
5626 wc.lpfnWndProc = win32_message_window_proc;
5627 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
5628 wc.lpszClassName = "PerlMessageWindowClass";
5629
5630 /* second and subsequent calls will fail, but class
5631 * will already be registered */
5632 RegisterClass(&wc);
5633}
5634
5635HWND
5636win32_create_message_window(void)
5637{
5638 win32_create_message_window_class();
5639 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
5640 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5641}
5642
5643#ifdef HAVE_INTERP_INTERN
5644
5645static void
5646win32_csighandler(int sig)
5647{
5648#if 0
5649 dTHXa(PERL_GET_SIG_CONTEXT);
5650 Perl_warn(aTHX_ "Got signal %d",sig);
5651#endif
5652 /* Does nothing */
5653}
5654
5655#if defined(__MINGW32__) && defined(__cplusplus)
5656#define CAST_HWND__(x) (HWND__*)(x)
5657#else
5658#define CAST_HWND__(x) x
5659#endif
5660
5661void
5662Perl_sys_intern_init(pTHX)
5663{
5664 int i;
5665
5666 w32_perlshell_tokens = NULL;
5667 w32_perlshell_vec = (char**)NULL;
5668 w32_perlshell_items = 0;
5669 w32_fdpid = newAV();
5670 Newx(w32_children, 1, child_tab);
5671 w32_num_children = 0;
5672# ifdef USE_ITHREADS
5673 w32_pseudo_id = 0;
5674 Newx(w32_pseudo_children, 1, pseudo_child_tab);
5675 w32_num_pseudo_children = 0;
5676# endif
5677 w32_timerid = 0;
5678 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5679 w32_poll_count = 0;
5680 for (i=0; i < SIG_SIZE; i++) {
5681 w32_sighandler[i] = SIG_DFL;
5682 }
5683# ifdef MULTIPLICITY
5684 if (my_perl == PL_curinterp) {
5685# else
5686 {
5687# endif
5688 /* Force C runtime signal stuff to set its console handler */
5689 signal(SIGINT,win32_csighandler);
5690 signal(SIGBREAK,win32_csighandler);
5691
5692 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5693 * flag. This has the side-effect of disabling Ctrl-C events in all
5694 * processes in this group.
5695 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5696 * with a NULL handler.
5697 */
5698 SetConsoleCtrlHandler(NULL,FALSE);
5699
5700 /* Push our handler on top */
5701 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5702 }
5703}
5704
5705void
5706Perl_sys_intern_clear(pTHX)
5707{
5708
5709 Safefree(w32_perlshell_tokens);
5710 Safefree(w32_perlshell_vec);
5711 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5712 Safefree(w32_children);
5713 if (w32_timerid) {
5714 KillTimer(w32_message_hwnd, w32_timerid);
5715 w32_timerid = 0;
5716 }
5717 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5718 DestroyWindow(w32_message_hwnd);
5719# ifdef MULTIPLICITY
5720 if (my_perl == PL_curinterp) {
5721# else
5722 {
5723# endif
5724 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5725 }
5726# ifdef USE_ITHREADS
5727 Safefree(w32_pseudo_children);
5728# endif
5729}
5730
5731# ifdef USE_ITHREADS
5732
5733void
5734Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5735{
5736 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5737
5738 dst->perlshell_tokens = NULL;
5739 dst->perlshell_vec = (char**)NULL;
5740 dst->perlshell_items = 0;
5741 dst->fdpid = newAV();
5742 Newxz(dst->children, 1, child_tab);
5743 dst->pseudo_id = 0;
5744 Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5745 dst->timerid = 0;
5746 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE);
5747 dst->poll_count = 0;
5748 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5749}
5750# endif /* USE_ITHREADS */
5751#endif /* HAVE_INTERP_INTERN */
Unnamed repository; edit this file 'description' to name the repository.