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