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