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