win32/win32.c

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