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