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