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