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