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