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