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