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