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