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