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