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