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 #ifdef __BORLANDC__
1514         if (S_ISDIR(sbuf->st_mode))
1515             sbuf->st_mode |= S_IWRITE | S_IEXEC;
1516         else if (S_ISREG(sbuf->st_mode)) {
1517             int perms;
1518             if (l >= 4 && path[l-4] == '.') {
1519                 const char *e = path + l - 3;
1520                 if (strnicmp(e,"exe",3)
1521                     && strnicmp(e,"bat",3)
1522                     && strnicmp(e,"com",3)
1523                     && (IsWin95() || strnicmp(e,"cmd",3)))
1524                     sbuf->st_mode &= ~S_IEXEC;
1525                 else
1526                     sbuf->st_mode |= S_IEXEC;
1527             }
1528             else
1529                 sbuf->st_mode &= ~S_IEXEC;
1530             /* Propagate permissions to _group_ and _others_ */
1531             perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1532             sbuf->st_mode |= (perms>>3) | (perms>>6);
1533         }
1534 #endif
1535     }
1536     return res;
1537 }
1538
1539 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1540 #define SKIP_SLASHES(s) \
1541     STMT_START {                                \
1542         while (*(s) && isSLASH(*(s)))           \
1543             ++(s);                              \
1544     } STMT_END
1545 #define COPY_NONSLASHES(d,s) \
1546     STMT_START {                                \
1547         while (*(s) && !isSLASH(*(s)))          \
1548             *(d)++ = *(s)++;                    \
1549     } STMT_END
1550
1551 /* Find the longname of a given path.  path is destructively modified.
1552  * It should have space for at least MAX_PATH characters. */
1553 DllExport char *
1554 win32_longpath(char *path)
1555 {
1556     WIN32_FIND_DATA fdata;
1557     HANDLE fhand;
1558     char tmpbuf[MAX_PATH+1];
1559     char *tmpstart = tmpbuf;
1560     char *start = path;
1561     char sep;
1562     if (!path)
1563         return NULL;
1564
1565     /* drive prefix */
1566     if (isALPHA(path[0]) && path[1] == ':') {
1567         start = path + 2;
1568         *tmpstart++ = path[0];
1569         *tmpstart++ = ':';
1570     }
1571     /* UNC prefix */
1572     else if (isSLASH(path[0]) && isSLASH(path[1])) {
1573         start = path + 2;
1574         *tmpstart++ = path[0];
1575         *tmpstart++ = path[1];
1576         SKIP_SLASHES(start);
1577         COPY_NONSLASHES(tmpstart,start);        /* copy machine name */
1578         if (*start) {
1579             *tmpstart++ = *start++;
1580             SKIP_SLASHES(start);
1581             COPY_NONSLASHES(tmpstart,start);    /* copy share name */
1582         }
1583     }
1584     *tmpstart = '\0';
1585     while (*start) {
1586         /* copy initial slash, if any */
1587         if (isSLASH(*start)) {
1588             *tmpstart++ = *start++;
1589             *tmpstart = '\0';
1590             SKIP_SLASHES(start);
1591         }
1592
1593         /* FindFirstFile() expands "." and "..", so we need to pass
1594          * those through unmolested */
1595         if (*start == '.'
1596             && (!start[1] || isSLASH(start[1])
1597                 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1598         {
1599             COPY_NONSLASHES(tmpstart,start);    /* copy "." or ".." */
1600             *tmpstart = '\0';
1601             continue;
1602         }
1603
1604         /* if this is the end, bust outta here */
1605         if (!*start)
1606             break;
1607
1608         /* now we're at a non-slash; walk up to next slash */
1609         while (*start && !isSLASH(*start))
1610             ++start;
1611
1612         /* stop and find full name of component */
1613         sep = *start;
1614         *start = '\0';
1615         fhand = FindFirstFile(path,&fdata);
1616         *start = sep;
1617         if (fhand != INVALID_HANDLE_VALUE) {
1618             STRLEN len = strlen(fdata.cFileName);
1619             if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1620                 strcpy(tmpstart, fdata.cFileName);
1621                 tmpstart += len;
1622                 FindClose(fhand);
1623             }
1624             else {
1625                 FindClose(fhand);
1626                 errno = ERANGE;
1627                 return NULL;
1628             }
1629         }
1630         else {
1631             /* failed a step, just return without side effects */
1632             /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1633             errno = EINVAL;
1634             return NULL;
1635         }
1636     }
1637     strcpy(path,tmpbuf);
1638     return path;
1639 }
1640
1641 static void
1642 out_of_memory(void)
1643 {
1644     if (PL_curinterp) {
1645         dTHX;
1646         /* Can't use PerlIO to write as it allocates memory */
1647         PerlLIO_write(PerlIO_fileno(Perl_error_log),
1648                       PL_no_mem, strlen(PL_no_mem));
1649         my_exit(1);
1650     }
1651     exit(1);
1652 }
1653
1654 /* The win32_ansipath() function takes a Unicode filename and converts it
1655  * into the current Windows codepage. If some characters cannot be mapped,
1656  * then it will convert the short name instead.
1657  *
1658  * The buffer to the ansi pathname must be freed with win32_free() when it
1659  * it no longer needed.
1660  *
1661  * The argument to win32_ansipath() must exist before this function is
1662  * called; otherwise there is no way to determine the short path name.
1663  *
1664  * Ideas for future refinement:
1665  * - Only convert those segments of the path that are not in the current
1666  *   codepage, but leave the other segments in their long form.
1667  * - If the resulting name is longer than MAX_PATH, start converting
1668  *   additional path segments into short names until the full name
1669  *   is shorter than MAX_PATH.  Shorten the filename part last!
1670  */
1671 DllExport char *
1672 win32_ansipath(const WCHAR *widename)
1673 {
1674     char *name;
1675     BOOL use_default = FALSE;
1676     size_t widelen = wcslen(widename)+1;
1677     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1678                                   NULL, 0, NULL, NULL);
1679     name = win32_malloc(len);
1680     if (!name)
1681         out_of_memory();
1682
1683     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1684                         name, len, NULL, &use_default);
1685     if (use_default) {
1686         DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1687         if (shortlen) {
1688             WCHAR *shortname = win32_malloc(shortlen*sizeof(WCHAR));
1689             if (!shortname)
1690                 out_of_memory();
1691             shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
1692
1693             len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1694                                       NULL, 0, NULL, NULL);
1695             name = win32_realloc(name, len);
1696             if (!name)
1697                 out_of_memory();
1698             WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
1699                                 name, len, NULL, NULL);
1700             win32_free(shortname);
1701         }
1702     }
1703     return name;
1704 }
1705
1706 DllExport char *
1707 win32_getenv(const char *name)
1708 {
1709     dTHX;
1710     DWORD needlen;
1711     SV *curitem = NULL;
1712
1713     needlen = GetEnvironmentVariableA(name,NULL,0);
1714     if (needlen != 0) {
1715         curitem = sv_2mortal(newSVpvn("", 0));
1716         do {
1717             SvGROW(curitem, needlen+1);
1718             needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1719                                               needlen);
1720         } while (needlen >= SvLEN(curitem));
1721         SvCUR_set(curitem, needlen);
1722     }
1723     else {
1724         /* allow any environment variables that begin with 'PERL'
1725            to be stored in the registry */
1726         if (strncmp(name, "PERL", 4) == 0)
1727             (void)get_regstr(name, &curitem);
1728     }
1729     if (curitem && SvCUR(curitem))
1730         return SvPVX(curitem);
1731
1732     return NULL;
1733 }
1734
1735 DllExport int
1736 win32_putenv(const char *name)
1737 {
1738     dTHX;
1739     char* curitem;
1740     char* val;
1741     int relval = -1;
1742
1743     if (name) {
1744         Newx(curitem,strlen(name)+1,char);
1745         strcpy(curitem, name);
1746         val = strchr(curitem, '=');
1747         if (val) {
1748             /* The sane way to deal with the environment.
1749              * Has these advantages over putenv() & co.:
1750              *  * enables us to store a truly empty value in the
1751              *    environment (like in UNIX).
1752              *  * we don't have to deal with RTL globals, bugs and leaks.
1753              *  * Much faster.
1754              * Why you may want to enable USE_WIN32_RTL_ENV:
1755              *  * environ[] and RTL functions will not reflect changes,
1756              *    which might be an issue if extensions want to access
1757              *    the env. via RTL.  This cuts both ways, since RTL will
1758              *    not see changes made by extensions that call the Win32
1759              *    functions directly, either.
1760              * GSAR 97-06-07
1761              */
1762             *val++ = '\0';
1763             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1764                 relval = 0;
1765         }
1766         Safefree(curitem);
1767     }
1768     return relval;
1769 }
1770
1771 static long
1772 filetime_to_clock(PFILETIME ft)
1773 {
1774     __int64 qw = ft->dwHighDateTime;
1775     qw <<= 32;
1776     qw |= ft->dwLowDateTime;
1777     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1778     return (long) qw;
1779 }
1780
1781 DllExport int
1782 win32_times(struct tms *timebuf)
1783 {
1784     FILETIME user;
1785     FILETIME kernel;
1786     FILETIME dummy;
1787     clock_t process_time_so_far = clock();
1788     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1789                         &kernel,&user)) {
1790         timebuf->tms_utime = filetime_to_clock(&user);
1791         timebuf->tms_stime = filetime_to_clock(&kernel);
1792         timebuf->tms_cutime = 0;
1793         timebuf->tms_cstime = 0;
1794     } else {
1795         /* That failed - e.g. Win95 fallback to clock() */
1796         timebuf->tms_utime = process_time_so_far;
1797         timebuf->tms_stime = 0;
1798         timebuf->tms_cutime = 0;
1799         timebuf->tms_cstime = 0;
1800     }
1801     return process_time_so_far;
1802 }
1803
1804 /* fix utime() so it works on directories in NT */
1805 static BOOL
1806 filetime_from_time(PFILETIME pFileTime, time_t Time)
1807 {
1808     struct tm *pTM = localtime(&Time);
1809     SYSTEMTIME SystemTime;
1810     FILETIME LocalTime;
1811
1812     if (pTM == NULL)
1813         return FALSE;
1814
1815     SystemTime.wYear   = pTM->tm_year + 1900;
1816     SystemTime.wMonth  = pTM->tm_mon + 1;
1817     SystemTime.wDay    = pTM->tm_mday;
1818     SystemTime.wHour   = pTM->tm_hour;
1819     SystemTime.wMinute = pTM->tm_min;
1820     SystemTime.wSecond = pTM->tm_sec;
1821     SystemTime.wMilliseconds = 0;
1822
1823     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1824            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1825 }
1826
1827 DllExport int
1828 win32_unlink(const char *filename)
1829 {
1830     dTHX;
1831     int ret;
1832     DWORD attrs;
1833
1834     filename = PerlDir_mapA(filename);
1835     attrs = GetFileAttributesA(filename);
1836     if (attrs == 0xFFFFFFFF) {
1837         errno = ENOENT;
1838         return -1;
1839     }
1840     if (attrs & FILE_ATTRIBUTE_READONLY) {
1841         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1842         ret = unlink(filename);
1843         if (ret == -1)
1844             (void)SetFileAttributesA(filename, attrs);
1845     }
1846     else
1847         ret = unlink(filename);
1848     return ret;
1849 }
1850
1851 DllExport int
1852 win32_utime(const char *filename, struct utimbuf *times)
1853 {
1854     dTHX;
1855     HANDLE handle;
1856     FILETIME ftCreate;
1857     FILETIME ftAccess;
1858     FILETIME ftWrite;
1859     struct utimbuf TimeBuffer;
1860     int rc;
1861
1862     filename = PerlDir_mapA(filename);
1863     rc = utime(filename, times);
1864
1865     /* EACCES: path specifies directory or readonly file */
1866     if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1867         return rc;
1868
1869     if (times == NULL) {
1870         times = &TimeBuffer;
1871         time(&times->actime);
1872         times->modtime = times->actime;
1873     }
1874
1875     /* This will (and should) still fail on readonly files */
1876     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1877                          FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1878                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1879     if (handle == INVALID_HANDLE_VALUE)
1880         return rc;
1881
1882     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1883         filetime_from_time(&ftAccess, times->actime) &&
1884         filetime_from_time(&ftWrite, times->modtime) &&
1885         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1886     {
1887         rc = 0;
1888     }
1889
1890     CloseHandle(handle);
1891     return rc;
1892 }
1893
1894 typedef union {
1895     unsigned __int64    ft_i64;
1896     FILETIME            ft_val;
1897 } FT_t;
1898
1899 #ifdef __GNUC__
1900 #define Const64(x) x##LL
1901 #else
1902 #define Const64(x) x##i64
1903 #endif
1904 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1905 #define EPOCH_BIAS  Const64(116444736000000000)
1906
1907 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1908  * and appears to be unsupported even by glibc) */
1909 DllExport int
1910 win32_gettimeofday(struct timeval *tp, void *not_used)
1911 {
1912     FT_t ft;
1913
1914     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
1915     GetSystemTimeAsFileTime(&ft.ft_val);
1916
1917     /* seconds since epoch */
1918     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1919
1920     /* microseconds remaining */
1921     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1922
1923     return 0;
1924 }
1925
1926 DllExport int
1927 win32_uname(struct utsname *name)
1928 {
1929     struct hostent *hep;
1930     STRLEN nodemax = sizeof(name->nodename)-1;
1931
1932     /* sysname */
1933     switch (g_osver.dwPlatformId) {
1934     case VER_PLATFORM_WIN32_WINDOWS:
1935         strcpy(name->sysname, "Windows");
1936         break;
1937     case VER_PLATFORM_WIN32_NT:
1938         strcpy(name->sysname, "Windows NT");
1939         break;
1940     case VER_PLATFORM_WIN32s:
1941         strcpy(name->sysname, "Win32s");
1942         break;
1943     default:
1944         strcpy(name->sysname, "Win32 Unknown");
1945         break;
1946     }
1947
1948     /* release */
1949     sprintf(name->release, "%d.%d",
1950             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1951
1952     /* version */
1953     sprintf(name->version, "Build %d",
1954             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1955             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1956     if (g_osver.szCSDVersion[0]) {
1957         char *buf = name->version + strlen(name->version);
1958         sprintf(buf, " (%s)", g_osver.szCSDVersion);
1959     }
1960
1961     /* nodename */
1962     hep = win32_gethostbyname("localhost");
1963     if (hep) {
1964         STRLEN len = strlen(hep->h_name);
1965         if (len <= nodemax) {
1966             strcpy(name->nodename, hep->h_name);
1967         }
1968         else {
1969             strncpy(name->nodename, hep->h_name, nodemax);
1970             name->nodename[nodemax] = '\0';
1971         }
1972     }
1973     else {
1974         DWORD sz = nodemax;
1975         if (!GetComputerName(name->nodename, &sz))
1976             *name->nodename = '\0';
1977     }
1978
1979     /* machine (architecture) */
1980     {
1981         SYSTEM_INFO info;
1982         DWORD procarch;
1983         char *arch;
1984         GetSystemInfo(&info);
1985
1986 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1987  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1988         procarch = info.u.s.wProcessorArchitecture;
1989 #else
1990         procarch = info.wProcessorArchitecture;
1991 #endif
1992         switch (procarch) {
1993         case PROCESSOR_ARCHITECTURE_INTEL:
1994             arch = "x86"; break;
1995         case PROCESSOR_ARCHITECTURE_MIPS:
1996             arch = "mips"; break;
1997         case PROCESSOR_ARCHITECTURE_ALPHA:
1998             arch = "alpha"; break;
1999         case PROCESSOR_ARCHITECTURE_PPC:
2000             arch = "ppc"; break;
2001 #ifdef PROCESSOR_ARCHITECTURE_SHX
2002         case PROCESSOR_ARCHITECTURE_SHX:
2003             arch = "shx"; break;
2004 #endif
2005 #ifdef PROCESSOR_ARCHITECTURE_ARM
2006         case PROCESSOR_ARCHITECTURE_ARM:
2007             arch = "arm"; break;
2008 #endif
2009 #ifdef PROCESSOR_ARCHITECTURE_IA64
2010         case PROCESSOR_ARCHITECTURE_IA64:
2011             arch = "ia64"; break;
2012 #endif
2013 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2014         case PROCESSOR_ARCHITECTURE_ALPHA64:
2015             arch = "alpha64"; break;
2016 #endif
2017 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2018         case PROCESSOR_ARCHITECTURE_MSIL:
2019             arch = "msil"; break;
2020 #endif
2021 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2022         case PROCESSOR_ARCHITECTURE_AMD64:
2023             arch = "amd64"; break;
2024 #endif
2025 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2026         case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2027             arch = "ia32-64"; break;
2028 #endif
2029 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2030         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2031             arch = "unknown"; break;
2032 #endif
2033         default:
2034             sprintf(name->machine, "unknown(0x%x)", procarch);
2035             arch = name->machine;
2036             break;
2037         }
2038         if (name->machine != arch)
2039             strcpy(name->machine, arch);
2040     }
2041     return 0;
2042 }
2043
2044 /* Timing related stuff */
2045
2046 int
2047 do_raise(pTHX_ int sig)
2048 {
2049     if (sig < SIG_SIZE) {
2050         Sighandler_t handler = w32_sighandler[sig];
2051         if (handler == SIG_IGN) {
2052             return 0;
2053         }
2054         else if (handler != SIG_DFL) {
2055             (*handler)(sig);
2056             return 0;
2057         }
2058         else {
2059             /* Choose correct default behaviour */
2060             switch (sig) {
2061 #ifdef SIGCLD
2062                 case SIGCLD:
2063 #endif
2064 #ifdef SIGCHLD
2065                 case SIGCHLD:
2066 #endif
2067                 case 0:
2068                     return 0;
2069                 case SIGTERM:
2070                 default:
2071                     break;
2072             }
2073         }
2074     }
2075     /* Tell caller to exit thread/process as approriate */
2076     return 1;
2077 }
2078
2079 void
2080 sig_terminate(pTHX_ int sig)
2081 {
2082     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2083     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2084        thread
2085      */
2086     exit(sig);
2087 }
2088
2089 DllExport int
2090 win32_async_check(pTHX)
2091 {
2092     MSG msg;
2093     HWND hwnd = w32_message_hwnd;
2094
2095     /* Reset w32_poll_count before doing anything else, incase we dispatch
2096      * messages that end up calling back into perl */
2097     w32_poll_count = 0;
2098
2099     if (hwnd != INVALID_HANDLE_VALUE) {
2100         /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2101         * and ignores window messages - should co-exist better with windows apps e.g. Tk
2102         */
2103         if (hwnd == NULL)
2104             hwnd = (HWND)-1;
2105
2106         while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2107                PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2108         {
2109             /* re-post a WM_QUIT message (we'll mark it as read later) */
2110             if(msg.message == WM_QUIT) {
2111                 PostQuitMessage((int)msg.wParam);
2112                 break;
2113             }
2114
2115             if(!CallMsgFilter(&msg, MSGF_USER))
2116             {
2117                 TranslateMessage(&msg);
2118                 DispatchMessage(&msg);
2119             }
2120         }
2121     }
2122
2123     /* Call PeekMessage() to mark all pending messages in the queue as "old".
2124      * This is necessary when we are being called by win32_msgwait() to
2125      * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2126      * message over and over.  An example how this can happen is when
2127      * Perl is calling win32_waitpid() inside a GUI application and the GUI
2128      * is generating messages before the process terminated.
2129      */
2130     while (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD))
2131         /* keep going */ ;
2132
2133     /* Above or other stuff may have set a signal flag */
2134     if (PL_sig_pending)
2135         despatch_signals();
2136
2137     return 1;
2138 }
2139
2140 /* This function will not return until the timeout has elapsed, or until
2141  * one of the handles is ready. */
2142 DllExport DWORD
2143 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2144 {
2145     /* We may need several goes at this - so compute when we stop */
2146     DWORD ticks = 0;
2147     if (timeout != INFINITE) {
2148         ticks = GetTickCount();
2149         timeout += ticks;
2150     }
2151     while (1) {
2152         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2153         if (resultp)
2154            *resultp = result;
2155         if (result == WAIT_TIMEOUT) {
2156             /* Ran out of time - explicit return of zero to avoid -ve if we
2157                have scheduling issues
2158              */
2159             return 0;
2160         }
2161         if (timeout != INFINITE) {
2162             ticks = GetTickCount();
2163         }
2164         if (result == WAIT_OBJECT_0 + count) {
2165             /* Message has arrived - check it */
2166             (void)win32_async_check(aTHX);
2167         }
2168         else {
2169            /* Not timeout or message - one of handles is ready */
2170            break;
2171         }
2172     }
2173     /* compute time left to wait */
2174     ticks = timeout - ticks;
2175     /* If we are past the end say zero */
2176     return (ticks > 0) ? ticks : 0;
2177 }
2178
2179 int
2180 win32_internal_wait(int *status, DWORD timeout)
2181 {
2182     /* XXX this wait emulation only knows about processes
2183      * spawned via win32_spawnvp(P_NOWAIT, ...).
2184      */
2185     dTHX;
2186     int i, retval;
2187     DWORD exitcode, waitcode;
2188
2189 #ifdef USE_ITHREADS
2190     if (w32_num_pseudo_children) {
2191         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2192                       timeout, &waitcode);
2193         /* Time out here if there are no other children to wait for. */
2194         if (waitcode == WAIT_TIMEOUT) {
2195             if (!w32_num_children) {
2196                 return 0;
2197             }
2198         }
2199         else if (waitcode != WAIT_FAILED) {
2200             if (waitcode >= WAIT_ABANDONED_0
2201                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2202                 i = waitcode - WAIT_ABANDONED_0;
2203             else
2204                 i = waitcode - WAIT_OBJECT_0;
2205             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2206                 *status = (int)((exitcode & 0xff) << 8);
2207                 retval = (int)w32_pseudo_child_pids[i];
2208                 remove_dead_pseudo_process(i);
2209                 return -retval;
2210             }
2211         }
2212     }
2213 #endif
2214
2215     if (!w32_num_children) {
2216         errno = ECHILD;
2217         return -1;
2218     }
2219
2220     /* if a child exists, wait for it to die */
2221     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2222     if (waitcode == WAIT_TIMEOUT) {
2223         return 0;
2224     }
2225     if (waitcode != WAIT_FAILED) {
2226         if (waitcode >= WAIT_ABANDONED_0
2227             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2228             i = waitcode - WAIT_ABANDONED_0;
2229         else
2230             i = waitcode - WAIT_OBJECT_0;
2231         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2232             *status = (int)((exitcode & 0xff) << 8);
2233             retval = (int)w32_child_pids[i];
2234             remove_dead_process(i);
2235             return retval;
2236         }
2237     }
2238
2239     errno = GetLastError();
2240     return -1;
2241 }
2242
2243 DllExport int
2244 win32_waitpid(int pid, int *status, int flags)
2245 {
2246     dTHX;
2247     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2248     int retval = -1;
2249     long child;
2250     if (pid == -1)                              /* XXX threadid == 1 ? */
2251         return win32_internal_wait(status, timeout);
2252 #ifdef USE_ITHREADS
2253     else if (pid < 0) {
2254         child = find_pseudo_pid(-pid);
2255         if (child >= 0) {
2256             HANDLE hThread = w32_pseudo_child_handles[child];
2257             DWORD waitcode;
2258             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2259             if (waitcode == WAIT_TIMEOUT) {
2260                 return 0;
2261             }
2262             else if (waitcode == WAIT_OBJECT_0) {
2263                 if (GetExitCodeThread(hThread, &waitcode)) {
2264                     *status = (int)((waitcode & 0xff) << 8);
2265                     retval = (int)w32_pseudo_child_pids[child];
2266                     remove_dead_pseudo_process(child);
2267                     return -retval;
2268                 }
2269             }
2270             else
2271                 errno = ECHILD;
2272         }
2273         else if (IsWin95()) {
2274             pid = -pid;
2275             goto alien_process;
2276         }
2277     }
2278 #endif
2279     else {
2280         HANDLE hProcess;
2281         DWORD waitcode;
2282         child = find_pid(pid);
2283         if (child >= 0) {
2284             hProcess = w32_child_handles[child];
2285             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2286             if (waitcode == WAIT_TIMEOUT) {
2287                 return 0;
2288             }
2289             else if (waitcode == WAIT_OBJECT_0) {
2290                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2291                     *status = (int)((waitcode & 0xff) << 8);
2292                     retval = (int)w32_child_pids[child];
2293                     remove_dead_process(child);
2294                     return retval;
2295                 }
2296             }
2297             else
2298                 errno = ECHILD;
2299         }
2300         else {
2301 alien_process:
2302             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2303                                    (IsWin95() ? -pid : pid));
2304             if (hProcess) {
2305                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2306                 if (waitcode == WAIT_TIMEOUT) {
2307                     CloseHandle(hProcess);
2308                     return 0;
2309                 }
2310                 else if (waitcode == WAIT_OBJECT_0) {
2311                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2312                         *status = (int)((waitcode & 0xff) << 8);
2313                         CloseHandle(hProcess);
2314                         return pid;
2315                     }
2316                 }
2317                 CloseHandle(hProcess);
2318             }
2319             else
2320                 errno = ECHILD;
2321         }
2322     }
2323     return retval >= 0 ? pid : retval;
2324 }
2325
2326 DllExport int
2327 win32_wait(int *status)
2328 {
2329     return win32_internal_wait(status, INFINITE);
2330 }
2331
2332 DllExport unsigned int
2333 win32_sleep(unsigned int t)
2334 {
2335     dTHX;
2336     /* Win32 times are in ms so *1000 in and /1000 out */
2337     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2338 }
2339
2340 DllExport unsigned int
2341 win32_alarm(unsigned int sec)
2342 {
2343     /*
2344      * the 'obvious' implentation is SetTimer() with a callback
2345      * which does whatever receiving SIGALRM would do
2346      * we cannot use SIGALRM even via raise() as it is not
2347      * one of the supported codes in <signal.h>
2348      */
2349     dTHX;
2350
2351     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2352         w32_message_hwnd = win32_create_message_window();
2353
2354     if (sec) {
2355         if (w32_message_hwnd == NULL)
2356             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2357         else {
2358             w32_timerid = 1;
2359             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2360         }
2361     }
2362     else {
2363         if (w32_timerid) {
2364             KillTimer(w32_message_hwnd, w32_timerid);
2365             w32_timerid = 0;
2366         }
2367     }
2368     return 0;
2369 }
2370
2371 #ifdef HAVE_DES_FCRYPT
2372 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2373 #endif
2374
2375 DllExport char *
2376 win32_crypt(const char *txt, const char *salt)
2377 {
2378     dTHX;
2379 #ifdef HAVE_DES_FCRYPT
2380     return des_fcrypt(txt, salt, w32_crypt_buffer);
2381 #else
2382     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2383     return NULL;
2384 #endif
2385 }
2386
2387 #ifdef USE_FIXED_OSFHANDLE
2388
2389 #define FOPEN                   0x01    /* file handle open */
2390 #define FNOINHERIT              0x10    /* file handle opened O_NOINHERIT */
2391 #define FAPPEND                 0x20    /* file handle opened O_APPEND */
2392 #define FDEV                    0x40    /* file handle refers to device */
2393 #define FTEXT                   0x80    /* file handle is in text mode */
2394
2395 /***
2396 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2397 *
2398 *Purpose:
2399 *       This function allocates a free C Runtime file handle and associates
2400 *       it with the Win32 HANDLE specified by the first parameter. This is a
2401 *       temperary fix for WIN95's brain damage GetFileType() error on socket
2402 *       we just bypass that call for socket
2403 *
2404 *       This works with MSVC++ 4.0+ or GCC/Mingw32
2405 *
2406 *Entry:
2407 *       intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2408 *       int flags      - flags to associate with C Runtime file handle.
2409 *
2410 *Exit:
2411 *       returns index of entry in fh, if successful
2412 *       return -1, if no free entry is found
2413 *
2414 *Exceptions:
2415 *
2416 *******************************************************************************/
2417
2418 /*
2419  * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2420  * this lets sockets work on Win9X with GCC and should fix the problems
2421  * with perl95.exe
2422  *      -- BKS, 1-23-2000
2423 */
2424
2425 /* create an ioinfo entry, kill its handle, and steal the entry */
2426
2427 static int
2428 _alloc_osfhnd(void)
2429 {
2430     HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2431     int fh = _open_osfhandle((intptr_t)hF, 0);
2432     CloseHandle(hF);
2433     if (fh == -1)
2434         return fh;
2435     EnterCriticalSection(&(_pioinfo(fh)->lock));
2436     return fh;
2437 }
2438
2439 static int
2440 my_open_osfhandle(intptr_t osfhandle, int flags)
2441 {
2442     int fh;
2443     char fileflags;             /* _osfile flags */
2444
2445     /* copy relevant flags from second parameter */
2446     fileflags = FDEV;
2447
2448     if (flags & O_APPEND)
2449         fileflags |= FAPPEND;
2450
2451     if (flags & O_TEXT)
2452         fileflags |= FTEXT;
2453
2454     if (flags & O_NOINHERIT)
2455         fileflags |= FNOINHERIT;
2456
2457     /* attempt to allocate a C Runtime file handle */
2458     if ((fh = _alloc_osfhnd()) == -1) {
2459         errno = EMFILE;         /* too many open files */
2460         _doserrno = 0L;         /* not an OS error */
2461         return -1;              /* return error to caller */
2462     }
2463
2464     /* the file is open. now, set the info in _osfhnd array */
2465     _set_osfhnd(fh, osfhandle);
2466
2467     fileflags |= FOPEN;         /* mark as open */
2468
2469     _osfile(fh) = fileflags;    /* set osfile entry */
2470     LeaveCriticalSection(&_pioinfo(fh)->lock);
2471
2472     return fh;                  /* return handle */
2473 }
2474
2475 #endif  /* USE_FIXED_OSFHANDLE */
2476
2477 /* simulate flock by locking a range on the file */
2478
2479 #define LK_ERR(f,i)     ((f) ? (i = 0) : (errno = GetLastError()))
2480 #define LK_LEN          0xffff0000
2481
2482 DllExport int
2483 win32_flock(int fd, int oper)
2484 {
2485     OVERLAPPED o;
2486     int i = -1;
2487     HANDLE fh;
2488
2489     if (!IsWinNT()) {
2490         dTHX;
2491         Perl_croak_nocontext("flock() unimplemented on this platform");
2492         return -1;
2493     }
2494     fh = (HANDLE)_get_osfhandle(fd);
2495     memset(&o, 0, sizeof(o));
2496
2497     switch(oper) {
2498     case LOCK_SH:               /* shared lock */
2499         LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2500         break;
2501     case LOCK_EX:               /* exclusive lock */
2502         LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2503         break;
2504     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2505         LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2506         break;
2507     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2508         LK_ERR(LockFileEx(fh,
2509                        LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2510                        0, LK_LEN, 0, &o),i);
2511         break;
2512     case LOCK_UN:               /* unlock lock */
2513         LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2514         break;
2515     default:                    /* unknown */
2516         errno = EINVAL;
2517         break;
2518     }
2519     return i;
2520 }
2521
2522 #undef LK_ERR
2523 #undef LK_LEN
2524
2525 /*
2526  *  redirected io subsystem for all XS modules
2527  *
2528  */
2529
2530 DllExport int *
2531 win32_errno(void)
2532 {
2533     return (&errno);
2534 }
2535
2536 DllExport char ***
2537 win32_environ(void)
2538 {
2539     return (&(_environ));
2540 }
2541
2542 /* the rest are the remapped stdio routines */
2543 DllExport FILE *
2544 win32_stderr(void)
2545 {
2546     return (stderr);
2547 }
2548
2549 DllExport FILE *
2550 win32_stdin(void)
2551 {
2552     return (stdin);
2553 }
2554
2555 DllExport FILE *
2556 win32_stdout(void)
2557 {
2558     return (stdout);
2559 }
2560
2561 DllExport int
2562 win32_ferror(FILE *fp)
2563 {
2564     return (ferror(fp));
2565 }
2566
2567
2568 DllExport int
2569 win32_feof(FILE *fp)
2570 {
2571     return (feof(fp));
2572 }
2573
2574 /*
2575  * Since the errors returned by the socket error function
2576  * WSAGetLastError() are not known by the library routine strerror
2577  * we have to roll our own.
2578  */
2579
2580 DllExport char *
2581 win32_strerror(int e)
2582 {
2583 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2584     extern int sys_nerr;
2585 #endif
2586     DWORD source = 0;
2587
2588     if (e < 0 || e > sys_nerr) {
2589         dTHX;
2590         if (e < 0)
2591             e = GetLastError();
2592
2593         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2594                           w32_strerror_buffer,
2595                           sizeof(w32_strerror_buffer), NULL) == 0)
2596             strcpy(w32_strerror_buffer, "Unknown Error");
2597
2598         return w32_strerror_buffer;
2599     }
2600     return strerror(e);
2601 }
2602
2603 DllExport void
2604 win32_str_os_error(void *sv, DWORD dwErr)
2605 {
2606     DWORD dwLen;
2607     char *sMsg;
2608     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2609                           |FORMAT_MESSAGE_IGNORE_INSERTS
2610                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2611                            dwErr, 0, (char *)&sMsg, 1, NULL);
2612     /* strip trailing whitespace and period */
2613     if (0 < dwLen) {
2614         do {
2615             --dwLen;    /* dwLen doesn't include trailing null */
2616         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2617         if ('.' != sMsg[dwLen])
2618             dwLen++;
2619         sMsg[dwLen] = '\0';
2620     }
2621     if (0 == dwLen) {
2622         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2623         if (sMsg)
2624             dwLen = sprintf(sMsg,
2625                             "Unknown error #0x%lX (lookup 0x%lX)",
2626                             dwErr, GetLastError());
2627     }
2628     if (sMsg) {
2629         dTHX;
2630         sv_setpvn((SV*)sv, sMsg, dwLen);
2631         LocalFree(sMsg);
2632     }
2633 }
2634
2635 DllExport int
2636 win32_fprintf(FILE *fp, const char *format, ...)
2637 {
2638     va_list marker;
2639     va_start(marker, format);     /* Initialize variable arguments. */
2640
2641     return (vfprintf(fp, format, marker));
2642 }
2643
2644 DllExport int
2645 win32_printf(const char *format, ...)
2646 {
2647     va_list marker;
2648     va_start(marker, format);     /* Initialize variable arguments. */
2649
2650     return (vprintf(format, marker));
2651 }
2652
2653 DllExport int
2654 win32_vfprintf(FILE *fp, const char *format, va_list args)
2655 {
2656     return (vfprintf(fp, format, args));
2657 }
2658
2659 DllExport int
2660 win32_vprintf(const char *format, va_list args)
2661 {
2662     return (vprintf(format, args));
2663 }
2664
2665 DllExport size_t
2666 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2667 {
2668     return fread(buf, size, count, fp);
2669 }
2670
2671 DllExport size_t
2672 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2673 {
2674     return fwrite(buf, size, count, fp);
2675 }
2676
2677 #define MODE_SIZE 10
2678
2679 DllExport FILE *
2680 win32_fopen(const char *filename, const char *mode)
2681 {
2682     dTHX;
2683     FILE *f;
2684
2685     if (!*filename)
2686         return NULL;
2687
2688     if (stricmp(filename, "/dev/null")==0)
2689         filename = "NUL";
2690
2691     f = fopen(PerlDir_mapA(filename), mode);
2692     /* avoid buffering headaches for child processes */
2693     if (f && *mode == 'a')
2694         win32_fseek(f, 0, SEEK_END);
2695     return f;
2696 }
2697
2698 #ifndef USE_SOCKETS_AS_HANDLES
2699 #undef fdopen
2700 #define fdopen my_fdopen
2701 #endif
2702
2703 DllExport FILE *
2704 win32_fdopen(int handle, const char *mode)
2705 {
2706     dTHX;
2707     FILE *f;
2708     f = fdopen(handle, (char *) mode);
2709     /* avoid buffering headaches for child processes */
2710     if (f && *mode == 'a')
2711         win32_fseek(f, 0, SEEK_END);
2712     return f;
2713 }
2714
2715 DllExport FILE *
2716 win32_freopen(const char *path, const char *mode, FILE *stream)
2717 {
2718     dTHX;
2719     if (stricmp(path, "/dev/null")==0)
2720         path = "NUL";
2721
2722     return freopen(PerlDir_mapA(path), mode, stream);
2723 }
2724
2725 DllExport int
2726 win32_fclose(FILE *pf)
2727 {
2728     return my_fclose(pf);       /* defined in win32sck.c */
2729 }
2730
2731 DllExport int
2732 win32_fputs(const char *s,FILE *pf)
2733 {
2734     return fputs(s, pf);
2735 }
2736
2737 DllExport int
2738 win32_fputc(int c,FILE *pf)
2739 {
2740     return fputc(c,pf);
2741 }
2742
2743 DllExport int
2744 win32_ungetc(int c,FILE *pf)
2745 {
2746     return ungetc(c,pf);
2747 }
2748
2749 DllExport int
2750 win32_getc(FILE *pf)
2751 {
2752     return getc(pf);
2753 }
2754
2755 DllExport int
2756 win32_fileno(FILE *pf)
2757 {
2758     return fileno(pf);
2759 }
2760
2761 DllExport void
2762 win32_clearerr(FILE *pf)
2763 {
2764     clearerr(pf);
2765     return;
2766 }
2767
2768 DllExport int
2769 win32_fflush(FILE *pf)
2770 {
2771     return fflush(pf);
2772 }
2773
2774 DllExport Off_t
2775 win32_ftell(FILE *pf)
2776 {
2777 #if defined(WIN64) || defined(USE_LARGE_FILES)
2778 #if defined(__BORLANDC__) /* buk */
2779     return win32_tell( fileno( pf ) );
2780 #else
2781     fpos_t pos;
2782     if (fgetpos(pf, &pos))
2783         return -1;
2784     return (Off_t)pos;
2785 #endif
2786 #else
2787     return ftell(pf);
2788 #endif
2789 }
2790
2791 DllExport int
2792 win32_fseek(FILE *pf, Off_t offset,int origin)
2793 {
2794 #if defined(WIN64) || defined(USE_LARGE_FILES)
2795 #if defined(__BORLANDC__) /* buk */
2796     return win32_lseek(
2797         fileno(pf),
2798         offset,
2799         origin
2800         );
2801 #else
2802     fpos_t pos;
2803     switch (origin) {
2804     case SEEK_CUR:
2805         if (fgetpos(pf, &pos))
2806             return -1;
2807         offset += pos;
2808         break;
2809     case SEEK_END:
2810         fseek(pf, 0, SEEK_END);
2811         pos = _telli64(fileno(pf));
2812         offset += pos;
2813         break;
2814     case SEEK_SET:
2815         break;
2816     default:
2817         errno = EINVAL;
2818         return -1;
2819     }
2820     return fsetpos(pf, &offset);
2821 #endif
2822 #else
2823     return fseek(pf, (long)offset, origin);
2824 #endif
2825 }
2826
2827 DllExport int
2828 win32_fgetpos(FILE *pf,fpos_t *p)
2829 {
2830 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2831     if( win32_tell(fileno(pf)) == -1L ) {
2832         errno = EBADF;
2833         return -1;
2834     }
2835     return 0;
2836 #else
2837     return fgetpos(pf, p);
2838 #endif
2839 }
2840
2841 DllExport int
2842 win32_fsetpos(FILE *pf,const fpos_t *p)
2843 {
2844 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2845     return win32_lseek(fileno(pf), *p, SEEK_CUR);
2846 #else
2847     return fsetpos(pf, p);
2848 #endif
2849 }
2850
2851 DllExport void
2852 win32_rewind(FILE *pf)
2853 {
2854     rewind(pf);
2855     return;
2856 }
2857
2858 DllExport int
2859 win32_tmpfd(void)
2860 {
2861     dTHX;
2862     char prefix[MAX_PATH+1];
2863     char filename[MAX_PATH+1];
2864     DWORD len = GetTempPath(MAX_PATH, prefix);
2865     if (len && len < MAX_PATH) {
2866         if (GetTempFileName(prefix, "plx", 0, filename)) {
2867             HANDLE fh = CreateFile(filename,
2868                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2869                                    0,
2870                                    NULL,
2871                                    CREATE_ALWAYS,
2872                                    FILE_ATTRIBUTE_NORMAL
2873                                    | FILE_FLAG_DELETE_ON_CLOSE,
2874                                    NULL);
2875             if (fh != INVALID_HANDLE_VALUE) {
2876                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2877                 if (fd >= 0) {
2878 #if defined(__BORLANDC__)
2879                     setmode(fd,O_BINARY);
2880 #endif
2881                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2882                                           "Created tmpfile=%s\n",filename));
2883                     return fd;
2884                 }
2885             }
2886         }
2887     }
2888     return -1;
2889 }
2890
2891 DllExport FILE*
2892 win32_tmpfile(void)
2893 {
2894     int fd = win32_tmpfd();
2895     if (fd >= 0)
2896         return win32_fdopen(fd, "w+b");
2897     return NULL;
2898 }
2899
2900 DllExport void
2901 win32_abort(void)
2902 {
2903     abort();
2904     return;
2905 }
2906
2907 DllExport int
2908 win32_fstat(int fd, Stat_t *sbufptr)
2909 {
2910 #ifdef __BORLANDC__
2911     /* A file designated by filehandle is not shown as accessible
2912      * for write operations, probably because it is opened for reading.
2913      * --Vadim Konovalov
2914      */
2915     BY_HANDLE_FILE_INFORMATION bhfi;
2916 #if defined(WIN64) || defined(USE_LARGE_FILES)
2917     /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2918     struct stat tmp;
2919     int rc = fstat(fd,&tmp);
2920
2921     sbufptr->st_dev   = tmp.st_dev;
2922     sbufptr->st_ino   = tmp.st_ino;
2923     sbufptr->st_mode  = tmp.st_mode;
2924     sbufptr->st_nlink = tmp.st_nlink;
2925     sbufptr->st_uid   = tmp.st_uid;
2926     sbufptr->st_gid   = tmp.st_gid;
2927     sbufptr->st_rdev  = tmp.st_rdev;
2928     sbufptr->st_size  = tmp.st_size;
2929     sbufptr->st_atime = tmp.st_atime;
2930     sbufptr->st_mtime = tmp.st_mtime;
2931     sbufptr->st_ctime = tmp.st_ctime;
2932 #else
2933     int rc = fstat(fd,sbufptr);
2934 #endif
2935
2936     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2937 #if defined(WIN64) || defined(USE_LARGE_FILES)
2938         sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2939 #endif
2940         sbufptr->st_mode &= 0xFE00;
2941         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2942             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2943         else
2944             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2945               + ((S_IREAD|S_IWRITE) >> 6));
2946     }
2947     return rc;
2948 #else
2949     return my_fstat(fd,sbufptr);
2950 #endif
2951 }
2952
2953 DllExport int
2954 win32_pipe(int *pfd, unsigned int size, int mode)
2955 {
2956     return _pipe(pfd, size, mode);
2957 }
2958
2959 DllExport PerlIO*
2960 win32_popenlist(const char *mode, IV narg, SV **args)
2961 {
2962  dTHX;
2963  Perl_croak(aTHX_ "List form of pipe open not implemented");
2964  return NULL;
2965 }
2966
2967 /*
2968  * a popen() clone that respects PERL5SHELL
2969  *
2970  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2971  */
2972
2973 DllExport PerlIO*
2974 win32_popen(const char *command, const char *mode)
2975 {
2976 #ifdef USE_RTL_POPEN
2977     return _popen(command, mode);
2978 #else
2979     dTHX;
2980     int p[2];
2981     int parent, child;
2982     int stdfd, oldfd;
2983     int ourmode;
2984     int childpid;
2985     DWORD nhandle;
2986     HANDLE old_h;
2987     int lock_held = 0;
2988
2989     /* establish which ends read and write */
2990     if (strchr(mode,'w')) {
2991         stdfd = 0;              /* stdin */
2992         parent = 1;
2993         child = 0;
2994         nhandle = STD_INPUT_HANDLE;
2995     }
2996     else if (strchr(mode,'r')) {
2997         stdfd = 1;              /* stdout */
2998         parent = 0;
2999         child = 1;
3000         nhandle = STD_OUTPUT_HANDLE;
3001     }
3002     else
3003         return NULL;
3004
3005     /* set the correct mode */
3006     if (strchr(mode,'b'))
3007         ourmode = O_BINARY;
3008     else if (strchr(mode,'t'))
3009         ourmode = O_TEXT;
3010     else
3011         ourmode = _fmode & (O_TEXT | O_BINARY);
3012
3013     /* the child doesn't inherit handles */
3014     ourmode |= O_NOINHERIT;
3015
3016     if (win32_pipe(p, 512, ourmode) == -1)
3017         return NULL;
3018
3019     /* save the old std handle (this needs to happen before the
3020      * dup2(), since that might call SetStdHandle() too) */
3021     OP_REFCNT_LOCK;
3022     lock_held = 1;
3023     old_h = GetStdHandle(nhandle);
3024
3025     /* save current stdfd */
3026     if ((oldfd = win32_dup(stdfd)) == -1)
3027         goto cleanup;
3028
3029     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3030     /* stdfd will be inherited by the child */
3031     if (win32_dup2(p[child], stdfd) == -1)
3032         goto cleanup;
3033
3034     /* close the child end in parent */
3035     win32_close(p[child]);
3036
3037     /* set the new std handle (in case dup2() above didn't) */
3038     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3039
3040     /* start the child */
3041     {
3042         dTHX;
3043         if ((childpid = do_spawn_nowait((char*)command)) == -1)
3044             goto cleanup;
3045
3046         /* revert stdfd to whatever it was before */
3047         if (win32_dup2(oldfd, stdfd) == -1)
3048             goto cleanup;
3049
3050         /* close saved handle */
3051         win32_close(oldfd);
3052
3053         /* restore the old std handle (this needs to happen after the
3054          * dup2(), since that might call SetStdHandle() too */
3055         if (lock_held) {
3056             SetStdHandle(nhandle, old_h);
3057             OP_REFCNT_UNLOCK;
3058             lock_held = 0;
3059         }
3060
3061         LOCK_FDPID_MUTEX;
3062         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3063         UNLOCK_FDPID_MUTEX;
3064
3065         /* set process id so that it can be returned by perl's open() */
3066         PL_forkprocess = childpid;
3067     }
3068
3069     /* we have an fd, return a file stream */
3070     return (PerlIO_fdopen(p[parent], (char *)mode));
3071
3072 cleanup:
3073     /* we don't need to check for errors here */
3074     win32_close(p[0]);
3075     win32_close(p[1]);
3076     if (oldfd != -1) {
3077         win32_dup2(oldfd, stdfd);
3078         win32_close(oldfd);
3079     }
3080     if (lock_held) {
3081         SetStdHandle(nhandle, old_h);
3082         OP_REFCNT_UNLOCK;
3083         lock_held = 0;
3084     }
3085     return (NULL);
3086
3087 #endif /* USE_RTL_POPEN */
3088 }
3089
3090 /*
3091  * pclose() clone
3092  */
3093
3094 DllExport int
3095 win32_pclose(PerlIO *pf)
3096 {
3097 #ifdef USE_RTL_POPEN
3098     return _pclose(pf);
3099 #else
3100     dTHX;
3101     int childpid, status;
3102     SV *sv;
3103
3104     LOCK_FDPID_MUTEX;
3105     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3106
3107     if (SvIOK(sv))
3108         childpid = SvIVX(sv);
3109     else
3110         childpid = 0;
3111
3112     if (!childpid) {
3113         UNLOCK_FDPID_MUTEX;
3114         errno = EBADF;
3115         return -1;
3116     }
3117
3118 #ifdef USE_PERLIO
3119     PerlIO_close(pf);
3120 #else
3121     fclose(pf);
3122 #endif
3123     SvIVX(sv) = 0;
3124     UNLOCK_FDPID_MUTEX;
3125
3126     if (win32_waitpid(childpid, &status, 0) == -1)
3127         return -1;
3128
3129     return status;
3130
3131 #endif /* USE_RTL_POPEN */
3132 }
3133
3134 static BOOL WINAPI
3135 Nt4CreateHardLinkW(
3136     LPCWSTR lpFileName,
3137     LPCWSTR lpExistingFileName,
3138     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3139 {
3140     HANDLE handle;
3141     WCHAR wFullName[MAX_PATH+1];
3142     LPVOID lpContext = NULL;
3143     WIN32_STREAM_ID StreamId;
3144     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3145     DWORD dwWritten;
3146     DWORD dwLen;
3147     BOOL bSuccess;
3148
3149     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3150                                      BOOL, BOOL, LPVOID*) =
3151         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3152                             BOOL, BOOL, LPVOID*))
3153         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3154     if (pfnBackupWrite == NULL)
3155         return 0;
3156
3157     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3158     if (dwLen == 0)
3159         return 0;
3160     dwLen = (dwLen+1)*sizeof(WCHAR);
3161
3162     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3163                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3164                          NULL, OPEN_EXISTING, 0, NULL);
3165     if (handle == INVALID_HANDLE_VALUE)
3166         return 0;
3167
3168     StreamId.dwStreamId = BACKUP_LINK;
3169     StreamId.dwStreamAttributes = 0;
3170     StreamId.dwStreamNameSize = 0;
3171 #if defined(__BORLANDC__) \
3172  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3173     StreamId.Size.u.HighPart = 0;
3174     StreamId.Size.u.LowPart = dwLen;
3175 #else
3176     StreamId.Size.HighPart = 0;
3177     StreamId.Size.LowPart = dwLen;
3178 #endif
3179
3180     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3181                               FALSE, FALSE, &lpContext);
3182     if (bSuccess) {
3183         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3184                                   FALSE, FALSE, &lpContext);
3185         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3186     }
3187
3188     CloseHandle(handle);
3189     return bSuccess;
3190 }
3191
3192 DllExport int
3193 win32_link(const char *oldname, const char *newname)
3194 {
3195     dTHX;
3196     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3197     WCHAR wOldName[MAX_PATH+1];
3198     WCHAR wNewName[MAX_PATH+1];
3199
3200     if (IsWin95())
3201         Perl_croak(aTHX_ PL_no_func, "link");
3202
3203     pfnCreateHardLinkW =
3204         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3205         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3206     if (pfnCreateHardLinkW == NULL)
3207         pfnCreateHardLinkW = Nt4CreateHardLinkW;
3208
3209     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3210         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3211         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3212         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3213     {
3214         return 0;
3215     }
3216     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3217     return -1;
3218 }
3219
3220 DllExport int
3221 win32_rename(const char *oname, const char *newname)
3222 {
3223     char szOldName[MAX_PATH+1];
3224     char szNewName[MAX_PATH+1];
3225     BOOL bResult;
3226     dTHX;
3227
3228     /* XXX despite what the documentation says about MoveFileEx(),
3229      * it doesn't work under Windows95!
3230      */
3231     if (IsWinNT()) {
3232         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3233         if (stricmp(newname, oname))
3234             dwFlags |= MOVEFILE_REPLACE_EXISTING;
3235         strcpy(szOldName, PerlDir_mapA(oname));
3236         bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3237         if (!bResult) {
3238             DWORD err = GetLastError();
3239             switch (err) {
3240             case ERROR_BAD_NET_NAME:
3241             case ERROR_BAD_NETPATH:
3242             case ERROR_BAD_PATHNAME:
3243             case ERROR_FILE_NOT_FOUND:
3244             case ERROR_FILENAME_EXCED_RANGE:
3245             case ERROR_INVALID_DRIVE:
3246             case ERROR_NO_MORE_FILES:
3247             case ERROR_PATH_NOT_FOUND:
3248                 errno = ENOENT;
3249                 break;
3250             default:
3251                 errno = EACCES;
3252                 break;
3253             }
3254             return -1;
3255         }
3256         return 0;
3257     }
3258     else {
3259         int retval = 0;
3260         char szTmpName[MAX_PATH+1];
3261         char dname[MAX_PATH+1];
3262         char *endname = NULL;
3263         STRLEN tmplen = 0;
3264         DWORD from_attr, to_attr;
3265
3266         strcpy(szOldName, PerlDir_mapA(oname));
3267         strcpy(szNewName, PerlDir_mapA(newname));
3268
3269         /* if oname doesn't exist, do nothing */
3270         from_attr = GetFileAttributes(szOldName);
3271         if (from_attr == 0xFFFFFFFF) {
3272             errno = ENOENT;
3273             return -1;
3274         }
3275
3276         /* if newname exists, rename it to a temporary name so that we
3277          * don't delete it in case oname happens to be the same file
3278          * (but perhaps accessed via a different path)
3279          */
3280         to_attr = GetFileAttributes(szNewName);
3281         if (to_attr != 0xFFFFFFFF) {
3282             /* if newname is a directory, we fail
3283              * XXX could overcome this with yet more convoluted logic */
3284             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3285                 errno = EACCES;
3286                 return -1;
3287             }
3288             tmplen = strlen(szNewName);
3289             strcpy(szTmpName,szNewName);
3290             endname = szTmpName+tmplen;
3291             for (; endname > szTmpName ; --endname) {
3292                 if (*endname == '/' || *endname == '\\') {
3293                     *endname = '\0';
3294                     break;
3295                 }
3296             }
3297             if (endname > szTmpName)
3298                 endname = strcpy(dname,szTmpName);
3299             else
3300                 endname = ".";
3301
3302             /* get a temporary filename in same directory
3303              * XXX is this really the best we can do? */
3304             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3305                 errno = ENOENT;
3306                 return -1;
3307             }
3308             DeleteFile(szTmpName);
3309
3310             retval = rename(szNewName, szTmpName);
3311             if (retval != 0) {
3312                 errno = EACCES;
3313                 return retval;
3314             }
3315         }
3316
3317         /* rename oname to newname */
3318         retval = rename(szOldName, szNewName);
3319
3320         /* if we created a temporary file before ... */
3321         if (endname != NULL) {
3322             /* ...and rename succeeded, delete temporary file/directory */
3323             if (retval == 0)
3324                 DeleteFile(szTmpName);
3325             /* else restore it to what it was */
3326             else
3327                 (void)rename(szTmpName, szNewName);
3328         }
3329         return retval;
3330     }
3331 }
3332
3333 DllExport int
3334 win32_setmode(int fd, int mode)
3335 {
3336     return setmode(fd, mode);
3337 }
3338
3339 DllExport int
3340 win32_chsize(int fd, Off_t size)
3341 {
3342 #if defined(WIN64) || defined(USE_LARGE_FILES)
3343     int retval = 0;
3344     Off_t cur, end, extend;
3345
3346     cur = win32_tell(fd);
3347     if (cur < 0)
3348         return -1;
3349     end = win32_lseek(fd, 0, SEEK_END);
3350     if (end < 0)
3351         return -1;
3352     extend = size - end;
3353     if (extend == 0) {
3354         /* do nothing */
3355     }
3356     else if (extend > 0) {
3357         /* must grow the file, padding with nulls */
3358         char b[4096];
3359         int oldmode = win32_setmode(fd, O_BINARY);
3360         size_t count;
3361         memset(b, '\0', sizeof(b));
3362         do {
3363             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3364             count = win32_write(fd, b, count);
3365             if ((int)count < 0) {
3366                 retval = -1;
3367                 break;
3368             }
3369         } while ((extend -= count) > 0);
3370         win32_setmode(fd, oldmode);
3371     }
3372     else {
3373         /* shrink the file */
3374         win32_lseek(fd, size, SEEK_SET);
3375         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3376             errno = EACCES;
3377             retval = -1;
3378         }
3379     }
3380 finish:
3381     win32_lseek(fd, cur, SEEK_SET);
3382     return retval;
3383 #else
3384     return chsize(fd, (long)size);
3385 #endif
3386 }
3387
3388 DllExport Off_t
3389 win32_lseek(int fd, Off_t offset, int origin)
3390 {
3391 #if defined(WIN64) || defined(USE_LARGE_FILES)
3392 #if defined(__BORLANDC__) /* buk */
3393     LARGE_INTEGER pos;
3394     pos.QuadPart = offset;
3395     pos.LowPart = SetFilePointer(
3396         (HANDLE)_get_osfhandle(fd),
3397         pos.LowPart,
3398         &pos.HighPart,
3399         origin
3400     );
3401     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3402         pos.QuadPart = -1;
3403     }
3404
3405     return pos.QuadPart;
3406 #else
3407     return _lseeki64(fd, offset, origin);
3408 #endif
3409 #else
3410     return lseek(fd, (long)offset, origin);
3411 #endif
3412 }
3413
3414 DllExport Off_t
3415 win32_tell(int fd)
3416 {
3417 #if defined(WIN64) || defined(USE_LARGE_FILES)
3418 #if defined(__BORLANDC__) /* buk */
3419     LARGE_INTEGER pos;
3420     pos.QuadPart = 0;
3421     pos.LowPart = SetFilePointer(
3422         (HANDLE)_get_osfhandle(fd),
3423         pos.LowPart,
3424         &pos.HighPart,
3425         FILE_CURRENT
3426     );
3427     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3428         pos.QuadPart = -1;
3429     }
3430
3431     return pos.QuadPart;
3432     /* return tell(fd); */
3433 #else
3434     return _telli64(fd);
3435 #endif
3436 #else
3437     return tell(fd);
3438 #endif
3439 }
3440
3441 DllExport int
3442 win32_open(const char *path, int flag, ...)
3443 {
3444     dTHX;
3445     va_list ap;
3446     int pmode;
3447
3448     va_start(ap, flag);
3449     pmode = va_arg(ap, int);
3450     va_end(ap);
3451
3452     if (stricmp(path, "/dev/null")==0)
3453         path = "NUL";
3454
3455     return open(PerlDir_mapA(path), flag, pmode);
3456 }
3457
3458 /* close() that understands socket */
3459 extern int my_close(int);       /* in win32sck.c */
3460
3461 DllExport int
3462 win32_close(int fd)
3463 {
3464     return my_close(fd);
3465 }
3466
3467 DllExport int
3468 win32_eof(int fd)
3469 {
3470     return eof(fd);
3471 }
3472
3473 DllExport int
3474 win32_dup(int fd)
3475 {
3476     return dup(fd);
3477 }
3478
3479 DllExport int
3480 win32_dup2(int fd1,int fd2)
3481 {
3482     return dup2(fd1,fd2);
3483 }
3484
3485 #ifdef PERL_MSVCRT_READFIX
3486
3487 #define LF              10      /* line feed */
3488 #define CR              13      /* carriage return */
3489 #define CTRLZ           26      /* ctrl-z means eof for text */
3490 #define FOPEN           0x01    /* file handle open */
3491 #define FEOFLAG         0x02    /* end of file has been encountered */
3492 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3493 #define FPIPE           0x08    /* file handle refers to a pipe */
3494 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3495 #define FDEV            0x40    /* file handle refers to device */
3496 #define FTEXT           0x80    /* file handle is in text mode */
3497 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3498
3499 int __cdecl
3500 _fixed_read(int fh, void *buf, unsigned cnt)
3501 {
3502     int bytes_read;                 /* number of bytes read */
3503     char *buffer;                   /* buffer to read to */
3504     int os_read;                    /* bytes read on OS call */
3505     char *p, *q;                    /* pointers into buffer */
3506     char peekchr;                   /* peek-ahead character */
3507     ULONG filepos;                  /* file position after seek */
3508     ULONG dosretval;                /* o.s. return value */
3509
3510     /* validate handle */
3511     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3512          !(_osfile(fh) & FOPEN))
3513     {
3514         /* out of range -- return error */
3515         errno = EBADF;
3516         _doserrno = 0;  /* not o.s. error */
3517         return -1;
3518     }
3519
3520     /*
3521      * If lockinitflag is FALSE, assume fd is device
3522      * lockinitflag is set to TRUE by open.
3523      */
3524     if (_pioinfo(fh)->lockinitflag)
3525         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3526
3527     bytes_read = 0;                 /* nothing read yet */
3528     buffer = (char*)buf;
3529
3530     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3531         /* nothing to read or at EOF, so return 0 read */
3532         goto functionexit;
3533     }
3534
3535     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3536         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3537          * char */
3538         *buffer++ = _pipech(fh);
3539         ++bytes_read;
3540         --cnt;
3541         _pipech(fh) = LF;           /* mark as empty */
3542     }
3543
3544     /* read the data */
3545
3546     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3547     {
3548         /* ReadFile has reported an error. recognize two special cases.
3549          *
3550          *      1. map ERROR_ACCESS_DENIED to EBADF
3551          *
3552          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3553          *         means the handle is a read-handle on a pipe for which
3554          *         all write-handles have been closed and all data has been
3555          *         read. */
3556
3557         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3558             /* wrong read/write mode should return EBADF, not EACCES */
3559             errno = EBADF;
3560             _doserrno = dosretval;
3561             bytes_read = -1;
3562             goto functionexit;
3563         }
3564         else if (dosretval == ERROR_BROKEN_PIPE) {
3565             bytes_read = 0;
3566             goto functionexit;
3567         }
3568         else {
3569             bytes_read = -1;
3570             goto functionexit;
3571         }
3572     }
3573
3574     bytes_read += os_read;          /* update bytes read */
3575
3576     if (_osfile(fh) & FTEXT) {
3577         /* now must translate CR-LFs to LFs in the buffer */
3578
3579         /* set CRLF flag to indicate LF at beginning of buffer */
3580         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3581         /*    _osfile(fh) |= FCRLF;                      */
3582         /* else                                          */
3583         /*    _osfile(fh) &= ~FCRLF;                     */
3584
3585         _osfile(fh) &= ~FCRLF;
3586
3587         /* convert chars in the buffer: p is src, q is dest */
3588         p = q = (char*)buf;
3589         while (p < (char *)buf + bytes_read) {
3590             if (*p == CTRLZ) {
3591                 /* if fh is not a device, set ctrl-z flag */
3592                 if (!(_osfile(fh) & FDEV))
3593                     _osfile(fh) |= FEOFLAG;
3594                 break;              /* stop translating */
3595             }
3596             else if (*p != CR)
3597                 *q++ = *p++;
3598             else {
3599                 /* *p is CR, so must check next char for LF */
3600                 if (p < (char *)buf + bytes_read - 1) {
3601                     if (*(p+1) == LF) {
3602                         p += 2;
3603                         *q++ = LF;  /* convert CR-LF to LF */
3604                     }
3605                     else
3606                         *q++ = *p++;    /* store char normally */
3607                 }
3608                 else {
3609                     /* This is the hard part.  We found a CR at end of
3610                        buffer.  We must peek ahead to see if next char
3611                        is an LF. */
3612                     ++p;
3613
3614                     dosretval = 0;
3615                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3616                                     (LPDWORD)&os_read, NULL))
3617                         dosretval = GetLastError();
3618
3619                     if (dosretval != 0 || os_read == 0) {
3620                         /* couldn't read ahead, store CR */
3621                         *q++ = CR;
3622                     }
3623                     else {
3624                         /* peekchr now has the extra character -- we now
3625                            have several possibilities:
3626                            1. disk file and char is not LF; just seek back
3627                               and copy CR
3628                            2. disk file and char is LF; store LF, don't seek back
3629                            3. pipe/device and char is LF; store LF.
3630                            4. pipe/device and char isn't LF, store CR and
3631                               put char in pipe lookahead buffer. */
3632                         if (_osfile(fh) & (FDEV|FPIPE)) {
3633                             /* non-seekable device */
3634                             if (peekchr == LF)
3635                                 *q++ = LF;
3636                             else {
3637                                 *q++ = CR;
3638                                 _pipech(fh) = peekchr;
3639                             }
3640                         }
3641                         else {
3642                             /* disk file */
3643                             if (peekchr == LF) {
3644                                 /* nothing read yet; must make some
3645                                    progress */
3646                                 *q++ = LF;
3647                                 /* turn on this flag for tell routine */
3648                                 _osfile(fh) |= FCRLF;
3649                             }
3650                             else {
3651                                 HANDLE osHandle;        /* o.s. handle value */
3652                                 /* seek back */
3653                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3654                                 {
3655                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3656                                         dosretval = GetLastError();
3657                                 }
3658                                 if (peekchr != LF)
3659                                     *q++ = CR;
3660                             }
3661                         }
3662                     }
3663                 }
3664             }
3665         }
3666
3667         /* we now change bytes_read to reflect the true number of chars
3668            in the buffer */
3669         bytes_read = q - (char *)buf;
3670     }
3671
3672 functionexit:
3673     if (_pioinfo(fh)->lockinitflag)
3674         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3675
3676     return bytes_read;
3677 }
3678
3679 #endif  /* PERL_MSVCRT_READFIX */
3680
3681 DllExport int
3682 win32_read(int fd, void *buf, unsigned int cnt)
3683 {
3684 #ifdef PERL_MSVCRT_READFIX
3685     return _fixed_read(fd, buf, cnt);
3686 #else
3687     return read(fd, buf, cnt);
3688 #endif
3689 }
3690
3691 DllExport int
3692 win32_write(int fd, const void *buf, unsigned int cnt)
3693 {
3694     return write(fd, buf, cnt);
3695 }
3696
3697 DllExport int
3698 win32_mkdir(const char *dir, int mode)
3699 {
3700     dTHX;
3701     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3702 }
3703
3704 DllExport int
3705 win32_rmdir(const char *dir)
3706 {
3707     dTHX;
3708     return rmdir(PerlDir_mapA(dir));
3709 }
3710
3711 DllExport int
3712 win32_chdir(const char *dir)
3713 {
3714     dTHX;
3715     if (!dir) {
3716         errno = ENOENT;
3717         return -1;
3718     }
3719     return chdir(dir);
3720 }
3721
3722 DllExport  int
3723 win32_access(const char *path, int mode)
3724 {
3725     dTHX;
3726     return access(PerlDir_mapA(path), mode);
3727 }
3728
3729 DllExport  int
3730 win32_chmod(const char *path, int mode)
3731 {
3732     dTHX;
3733     return chmod(PerlDir_mapA(path), mode);
3734 }
3735
3736
3737 static char *
3738 create_command_line(char *cname, STRLEN clen, const char * const *args)
3739 {
3740     dTHX;
3741     int index, argc;
3742     char *cmd, *ptr;
3743     const char *arg;
3744     STRLEN len = 0;
3745     bool bat_file = FALSE;
3746     bool cmd_shell = FALSE;
3747     bool dumb_shell = FALSE;
3748     bool extra_quotes = FALSE;
3749     bool quote_next = FALSE;
3750
3751     if (!cname)
3752         cname = (char*)args[0];
3753
3754     /* The NT cmd.exe shell has the following peculiarity that needs to be
3755      * worked around.  It strips a leading and trailing dquote when any
3756      * of the following is true:
3757      *    1. the /S switch was used
3758      *    2. there are more than two dquotes
3759      *    3. there is a special character from this set: &<>()@^|
3760      *    4. no whitespace characters within the two dquotes
3761      *    5. string between two dquotes isn't an executable file
3762      * To work around this, we always add a leading and trailing dquote
3763      * to the string, if the first argument is either "cmd.exe" or "cmd",
3764      * and there were at least two or more arguments passed to cmd.exe
3765      * (not including switches).
3766      * XXX the above rules (from "cmd /?") don't seem to be applied
3767      * always, making for the convolutions below :-(
3768      */
3769     if (cname) {
3770         if (!clen)
3771             clen = strlen(cname);
3772
3773         if (clen > 4
3774             && (stricmp(&cname[clen-4], ".bat") == 0
3775                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3776         {
3777             bat_file = TRUE;
3778             if (!IsWin95())
3779                 len += 3;
3780         }
3781         else {
3782             char *exe = strrchr(cname, '/');
3783             char *exe2 = strrchr(cname, '\\');
3784             if (exe2 > exe)
3785                 exe = exe2;
3786             if (exe)
3787                 ++exe;
3788             else
3789                 exe = cname;
3790             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3791                 cmd_shell = TRUE;
3792                 len += 3;
3793             }
3794             else if (stricmp(exe, "command.com") == 0
3795                      || stricmp(exe, "command") == 0)
3796             {
3797                 dumb_shell = TRUE;
3798             }
3799         }
3800     }
3801
3802     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3803     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3804         STRLEN curlen = strlen(arg);
3805         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3806             len += 2;   /* assume quoting needed (worst case) */
3807         len += curlen + 1;
3808         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3809     }
3810     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3811
3812     argc = index;
3813     Newx(cmd, len, char);
3814     ptr = cmd;
3815
3816     if (bat_file && !IsWin95()) {
3817         *ptr++ = '"';
3818         extra_quotes = TRUE;
3819     }
3820
3821     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3822         bool do_quote = 0;
3823         STRLEN curlen = strlen(arg);
3824
3825         /* we want to protect empty arguments and ones with spaces with
3826          * dquotes, but only if they aren't already there */
3827         if (!dumb_shell) {
3828             if (!curlen) {
3829                 do_quote = 1;
3830             }
3831             else if (quote_next) {
3832                 /* see if it really is multiple arguments pretending to
3833                  * be one and force a set of quotes around it */
3834                 if (*find_next_space(arg))
3835                     do_quote = 1;
3836             }
3837             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3838                 STRLEN i = 0;
3839                 while (i < curlen) {
3840                     if (isSPACE(arg[i])) {
3841                         do_quote = 1;
3842                     }
3843                     else if (arg[i] == '"') {
3844                         do_quote = 0;
3845                         break;
3846                     }
3847                     i++;
3848                 }
3849             }
3850         }
3851
3852         if (do_quote)
3853             *ptr++ = '"';
3854
3855         strcpy(ptr, arg);
3856         ptr += curlen;
3857
3858         if (do_quote)
3859             *ptr++ = '"';
3860
3861         if (args[index+1])
3862             *ptr++ = ' ';
3863
3864         if (!extra_quotes
3865             && cmd_shell
3866             && curlen >= 2
3867             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3868             && stricmp(arg+curlen-2, "/c") == 0)
3869         {
3870             /* is there a next argument? */
3871             if (args[index+1]) {
3872                 /* are there two or more next arguments? */
3873                 if (args[index+2]) {
3874                     *ptr++ = '"';
3875                     extra_quotes = TRUE;
3876                 }
3877                 else {
3878                     /* single argument, force quoting if it has spaces */
3879                     quote_next = TRUE;
3880                 }
3881             }
3882         }
3883     }
3884
3885     if (extra_quotes)
3886         *ptr++ = '"';
3887
3888     *ptr = '\0';
3889
3890     return cmd;
3891 }
3892
3893 static char *
3894 qualified_path(const char *cmd)
3895 {
3896     dTHX;
3897     char *pathstr;
3898     char *fullcmd, *curfullcmd;
3899     STRLEN cmdlen = 0;
3900     int has_slash = 0;
3901
3902     if (!cmd)
3903         return NULL;
3904     fullcmd = (char*)cmd;
3905     while (*fullcmd) {
3906         if (*fullcmd == '/' || *fullcmd == '\\')
3907             has_slash++;
3908         fullcmd++;
3909         cmdlen++;
3910     }
3911
3912     /* look in PATH */
3913     pathstr = PerlEnv_getenv("PATH");
3914
3915     /* worst case: PATH is a single directory; we need additional space
3916      * to append "/", ".exe" and trailing "\0" */
3917     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3918     curfullcmd = fullcmd;
3919
3920     while (1) {
3921         DWORD res;
3922
3923         /* start by appending the name to the current prefix */
3924         strcpy(curfullcmd, cmd);
3925         curfullcmd += cmdlen;
3926
3927         /* if it doesn't end with '.', or has no extension, try adding
3928          * a trailing .exe first */
3929         if (cmd[cmdlen-1] != '.'
3930             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3931         {
3932             strcpy(curfullcmd, ".exe");
3933             res = GetFileAttributes(fullcmd);
3934             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3935                 return fullcmd;
3936             *curfullcmd = '\0';
3937         }
3938
3939         /* that failed, try the bare name */
3940         res = GetFileAttributes(fullcmd);
3941         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3942             return fullcmd;
3943
3944         /* quit if no other path exists, or if cmd already has path */
3945         if (!pathstr || !*pathstr || has_slash)
3946             break;
3947
3948         /* skip leading semis */
3949         while (*pathstr == ';')
3950             pathstr++;
3951
3952         /* build a new prefix from scratch */
3953         curfullcmd = fullcmd;
3954         while (*pathstr && *pathstr != ';') {
3955             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3956                 pathstr++;              /* skip initial '"' */
3957                 while (*pathstr && *pathstr != '"') {
3958                     *curfullcmd++ = *pathstr++;
3959                 }
3960                 if (*pathstr)
3961                     pathstr++;          /* skip trailing '"' */
3962             }
3963             else {
3964                 *curfullcmd++ = *pathstr++;
3965             }
3966         }
3967         if (*pathstr)
3968             pathstr++;                  /* skip trailing semi */
3969         if (curfullcmd > fullcmd        /* append a dir separator */
3970             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3971         {
3972             *curfullcmd++ = '\\';
3973         }
3974     }
3975
3976     Safefree(fullcmd);
3977     return NULL;
3978 }
3979
3980 /* The following are just place holders.
3981  * Some hosts may provide and environment that the OS is
3982  * not tracking, therefore, these host must provide that
3983  * environment and the current directory to CreateProcess
3984  */
3985
3986 DllExport void*
3987 win32_get_childenv(void)
3988 {
3989     return NULL;
3990 }
3991
3992 DllExport void
3993 win32_free_childenv(void* d)
3994 {
3995 }
3996
3997 DllExport void
3998 win32_clearenv(void)
3999 {
4000     char *envv = GetEnvironmentStrings();
4001     char *cur = envv;
4002     STRLEN len;
4003     while (*cur) {
4004         char *end = strchr(cur,'=');
4005         if (end && end != cur) {
4006             *end = '\0';
4007             SetEnvironmentVariable(cur, NULL);
4008             *end = '=';
4009             cur = end + strlen(end+1)+2;
4010         }
4011         else if ((len = strlen(cur)))
4012             cur += len+1;
4013     }
4014     FreeEnvironmentStrings(envv);
4015 }
4016
4017 DllExport char*
4018 win32_get_childdir(void)
4019 {
4020     dTHX;
4021     char* ptr;
4022     char szfilename[MAX_PATH+1];
4023
4024     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4025     Newx(ptr, strlen(szfilename)+1, char);
4026     strcpy(ptr, szfilename);
4027     return ptr;
4028 }
4029
4030 DllExport void
4031 win32_free_childdir(char* d)
4032 {
4033     dTHX;
4034     Safefree(d);
4035 }
4036
4037
4038 /* XXX this needs to be made more compatible with the spawnvp()
4039  * provided by the various RTLs.  In particular, searching for
4040  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4041  * This doesn't significantly affect perl itself, because we
4042  * always invoke things using PERL5SHELL if a direct attempt to
4043  * spawn the executable fails.
4044  *
4045  * XXX splitting and rejoining the commandline between do_aspawn()
4046  * and win32_spawnvp() could also be avoided.
4047  */
4048
4049 DllExport int
4050 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4051 {
4052 #ifdef USE_RTL_SPAWNVP
4053     return spawnvp(mode, cmdname, (char * const *)argv);
4054 #else
4055     dTHX;
4056     int ret;
4057     void* env;
4058     char* dir;
4059     child_IO_table tbl;
4060     STARTUPINFO StartupInfo;
4061     PROCESS_INFORMATION ProcessInformation;
4062     DWORD create = 0;
4063     char *cmd;
4064     char *fullcmd = NULL;
4065     char *cname = (char *)cmdname;
4066     STRLEN clen = 0;
4067
4068     if (cname) {
4069         clen = strlen(cname);
4070         /* if command name contains dquotes, must remove them */
4071         if (strchr(cname, '"')) {
4072             cmd = cname;
4073             Newx(cname,clen+1,char);
4074             clen = 0;
4075             while (*cmd) {
4076                 if (*cmd != '"') {
4077                     cname[clen] = *cmd;
4078                     ++clen;
4079                 }
4080                 ++cmd;
4081             }
4082             cname[clen] = '\0';
4083         }
4084     }
4085
4086     cmd = create_command_line(cname, clen, argv);
4087
4088     env = PerlEnv_get_childenv();
4089     dir = PerlEnv_get_childdir();
4090
4091     switch(mode) {
4092     case P_NOWAIT:      /* asynch + remember result */
4093         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4094             errno = EAGAIN;
4095             ret = -1;
4096             goto RETVAL;
4097         }
4098         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4099          * in win32_kill()
4100          */
4101         create |= CREATE_NEW_PROCESS_GROUP;
4102         /* FALL THROUGH */
4103
4104     case P_WAIT:        /* synchronous execution */
4105         break;
4106     default:            /* invalid mode */
4107         errno = EINVAL;
4108         ret = -1;
4109         goto RETVAL;
4110     }
4111     memset(&StartupInfo,0,sizeof(StartupInfo));
4112     StartupInfo.cb = sizeof(StartupInfo);
4113     memset(&tbl,0,sizeof(tbl));
4114     PerlEnv_get_child_IO(&tbl);
4115     StartupInfo.dwFlags         = tbl.dwFlags;
4116     StartupInfo.dwX             = tbl.dwX;
4117     StartupInfo.dwY             = tbl.dwY;
4118     StartupInfo.dwXSize         = tbl.dwXSize;
4119     StartupInfo.dwYSize         = tbl.dwYSize;
4120     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
4121     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
4122     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4123     StartupInfo.wShowWindow     = tbl.wShowWindow;
4124     StartupInfo.hStdInput       = tbl.childStdIn;
4125     StartupInfo.hStdOutput      = tbl.childStdOut;
4126     StartupInfo.hStdError       = tbl.childStdErr;
4127     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4128         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4129         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4130     {
4131         create |= CREATE_NEW_CONSOLE;
4132     }
4133     else {
4134         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4135     }
4136     if (w32_use_showwindow) {
4137         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4138         StartupInfo.wShowWindow = w32_showwindow;
4139     }
4140
4141     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4142                           cname,cmd));
4143 RETRY:
4144     if (!CreateProcess(cname,           /* search PATH to find executable */
4145                        cmd,             /* executable, and its arguments */
4146                        NULL,            /* process attributes */
4147                        NULL,            /* thread attributes */
4148                        TRUE,            /* inherit handles */
4149                        create,          /* creation flags */
4150                        (LPVOID)env,     /* inherit environment */
4151                        dir,             /* inherit cwd */
4152                        &StartupInfo,
4153                        &ProcessInformation))
4154     {
4155         /* initial NULL argument to CreateProcess() does a PATH
4156          * search, but it always first looks in the directory
4157          * where the current process was started, which behavior
4158          * is undesirable for backward compatibility.  So we
4159          * jump through our own hoops by picking out the path
4160          * we really want it to use. */
4161         if (!fullcmd) {
4162             fullcmd = qualified_path(cname);
4163             if (fullcmd) {
4164                 if (cname != cmdname)
4165                     Safefree(cname);
4166                 cname = fullcmd;
4167                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4168                                       "Retrying [%s] with same args\n",
4169                                       cname));
4170                 goto RETRY;
4171             }
4172         }
4173         errno = ENOENT;
4174         ret = -1;
4175         goto RETVAL;
4176     }
4177
4178     if (mode == P_NOWAIT) {
4179         /* asynchronous spawn -- store handle, return PID */
4180         ret = (int)ProcessInformation.dwProcessId;
4181         if (IsWin95() && ret < 0)
4182             ret = -ret;
4183
4184         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4185         w32_child_pids[w32_num_children] = (DWORD)ret;
4186         ++w32_num_children;
4187     }
4188     else  {
4189         DWORD status;
4190         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4191         /* FIXME: if msgwait returned due to message perhaps forward the
4192            "signal" to the process
4193          */
4194         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4195         ret = (int)status;
4196         CloseHandle(ProcessInformation.hProcess);
4197     }
4198
4199     CloseHandle(ProcessInformation.hThread);
4200
4201 RETVAL:
4202     PerlEnv_free_childenv(env);
4203     PerlEnv_free_childdir(dir);
4204     Safefree(cmd);
4205     if (cname != cmdname)
4206         Safefree(cname);
4207     return ret;
4208 #endif
4209 }
4210
4211 DllExport int
4212 win32_execv(const char *cmdname, const char *const *argv)
4213 {
4214 #ifdef USE_ITHREADS
4215     dTHX;
4216     /* if this is a pseudo-forked child, we just want to spawn
4217      * the new program, and return */
4218     if (w32_pseudo_id)
4219 #  ifdef __BORLANDC__
4220         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4221 #  else
4222         return spawnv(P_WAIT, cmdname, argv);
4223 #  endif
4224 #endif
4225 #ifdef __BORLANDC__
4226     return execv(cmdname, (char *const *)argv);
4227 #else
4228     return execv(cmdname, argv);
4229 #endif
4230 }
4231
4232 DllExport int
4233 win32_execvp(const char *cmdname, const char *const *argv)
4234 {
4235 #ifdef USE_ITHREADS
4236     dTHX;
4237     /* if this is a pseudo-forked child, we just want to spawn
4238      * the new program, and return */
4239     if (w32_pseudo_id) {
4240         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4241         if (status != -1) {
4242             my_exit(status);
4243             return 0;
4244         }
4245         else
4246             return status;
4247     }
4248 #endif
4249 #ifdef __BORLANDC__
4250     return execvp(cmdname, (char *const *)argv);
4251 #else
4252     return execvp(cmdname, argv);
4253 #endif
4254 }
4255
4256 DllExport void
4257 win32_perror(const char *str)
4258 {
4259     perror(str);
4260 }
4261
4262 DllExport void
4263 win32_setbuf(FILE *pf, char *buf)
4264 {
4265     setbuf(pf, buf);
4266 }
4267
4268 DllExport int
4269 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4270 {
4271     return setvbuf(pf, buf, type, size);
4272 }
4273
4274 DllExport int
4275 win32_flushall(void)
4276 {
4277     return flushall();
4278 }
4279
4280 DllExport int
4281 win32_fcloseall(void)
4282 {
4283     return fcloseall();
4284 }
4285
4286 DllExport char*
4287 win32_fgets(char *s, int n, FILE *pf)
4288 {
4289     return fgets(s, n, pf);
4290 }
4291
4292 DllExport char*
4293 win32_gets(char *s)
4294 {
4295     return gets(s);
4296 }
4297
4298 DllExport int
4299 win32_fgetc(FILE *pf)
4300 {
4301     return fgetc(pf);
4302 }
4303
4304 DllExport int
4305 win32_putc(int c, FILE *pf)
4306 {
4307     return putc(c,pf);
4308 }
4309
4310 DllExport int
4311 win32_puts(const char *s)
4312 {
4313     return puts(s);
4314 }
4315
4316 DllExport int
4317 win32_getchar(void)
4318 {
4319     return getchar();
4320 }
4321
4322 DllExport int
4323 win32_putchar(int c)
4324 {
4325     return putchar(c);
4326 }
4327
4328 #ifdef MYMALLOC
4329
4330 #ifndef USE_PERL_SBRK
4331
4332 static char *committed = NULL;          /* XXX threadead */
4333 static char *base      = NULL;          /* XXX threadead */
4334 static char *reserved  = NULL;          /* XXX threadead */
4335 static char *brk       = NULL;          /* XXX threadead */
4336 static DWORD pagesize  = 0;             /* XXX threadead */
4337
4338 void *
4339 sbrk(ptrdiff_t need)
4340 {
4341  void *result;
4342  if (!pagesize)
4343   {SYSTEM_INFO info;
4344    GetSystemInfo(&info);
4345    /* Pretend page size is larger so we don't perpetually
4346     * call the OS to commit just one page ...
4347     */
4348    pagesize = info.dwPageSize << 3;
4349   }
4350  if (brk+need >= reserved)
4351   {
4352    DWORD size = brk+need-reserved;
4353    char *addr;
4354    char *prev_committed = NULL;
4355    if (committed && reserved && committed < reserved)
4356     {
4357      /* Commit last of previous chunk cannot span allocations */
4358      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4359      if (addr)
4360       {
4361       /* Remember where we committed from in case we want to decommit later */
4362       prev_committed = committed;
4363       committed = reserved;
4364       }
4365     }
4366    /* Reserve some (more) space
4367     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4368     * this is only address space not memory...
4369     * Note this is a little sneaky, 1st call passes NULL as reserved
4370     * so lets system choose where we start, subsequent calls pass
4371     * the old end address so ask for a contiguous block
4372     */
4373 sbrk_reserve:
4374    if (size < 64*1024*1024)
4375     size = 64*1024*1024;
4376    size = ((size + pagesize - 1) / pagesize) * pagesize;
4377    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4378    if (addr)
4379     {
4380      reserved = addr+size;
4381      if (!base)
4382       base = addr;
4383      if (!committed)
4384       committed = base;
4385      if (!brk)
4386       brk = committed;
4387     }
4388    else if (reserved)
4389     {
4390       /* The existing block could not be extended far enough, so decommit
4391        * anything that was just committed above and start anew */
4392       if (prev_committed)
4393        {
4394        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4395         return (void *) -1;
4396        }
4397       reserved = base = committed = brk = NULL;
4398       size = need;
4399       goto sbrk_reserve;
4400     }
4401    else
4402     {
4403      return (void *) -1;
4404     }
4405   }
4406  result = brk;
4407  brk += need;
4408  if (brk > committed)
4409   {
4410    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4411    char *addr;
4412    if (committed+size > reserved)
4413     size = reserved-committed;
4414    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4415    if (addr)
4416     committed += size;
4417    else
4418     return (void *) -1;
4419   }
4420  return result;
4421 }
4422
4423 #endif
4424 #endif
4425
4426 DllExport void*
4427 win32_malloc(size_t size)
4428 {
4429     return malloc(size);
4430 }
4431
4432 DllExport void*
4433 win32_calloc(size_t numitems, size_t size)
4434 {
4435     return calloc(numitems,size);
4436 }
4437
4438 DllExport void*
4439 win32_realloc(void *block, size_t size)
4440 {
4441     return realloc(block,size);
4442 }
4443
4444 DllExport void
4445 win32_free(void *block)
4446 {
4447     free(block);
4448 }
4449
4450
4451 DllExport int
4452 win32_open_osfhandle(intptr_t handle, int flags)
4453 {
4454 #ifdef USE_FIXED_OSFHANDLE
4455     if (IsWin95())
4456         return my_open_osfhandle(handle, flags);
4457 #endif
4458     return _open_osfhandle(handle, flags);
4459 }
4460
4461 DllExport intptr_t
4462 win32_get_osfhandle(int fd)
4463 {
4464     return (intptr_t)_get_osfhandle(fd);
4465 }
4466
4467 DllExport FILE *
4468 win32_fdupopen(FILE *pf)
4469 {
4470     FILE* pfdup;
4471     fpos_t pos;
4472     char mode[3];
4473     int fileno = win32_dup(win32_fileno(pf));
4474
4475     /* open the file in the same mode */
4476 #ifdef __BORLANDC__
4477     if((pf)->flags & _F_READ) {
4478         mode[0] = 'r';
4479         mode[1] = 0;
4480     }
4481     else if((pf)->flags & _F_WRIT) {
4482         mode[0] = 'a';
4483         mode[1] = 0;
4484     }
4485     else if((pf)->flags & _F_RDWR) {
4486         mode[0] = 'r';
4487         mode[1] = '+';
4488         mode[2] = 0;
4489     }
4490 #else
4491     if((pf)->_flag & _IOREAD) {
4492         mode[0] = 'r';
4493         mode[1] = 0;
4494     }
4495     else if((pf)->_flag & _IOWRT) {
4496         mode[0] = 'a';
4497         mode[1] = 0;
4498     }
4499     else if((pf)->_flag & _IORW) {
4500         mode[0] = 'r';
4501         mode[1] = '+';
4502         mode[2] = 0;
4503     }
4504 #endif
4505
4506     /* it appears that the binmode is attached to the
4507      * file descriptor so binmode files will be handled
4508      * correctly
4509      */
4510     pfdup = win32_fdopen(fileno, mode);
4511
4512     /* move the file pointer to the same position */
4513     if (!fgetpos(pf, &pos)) {
4514         fsetpos(pfdup, &pos);
4515     }
4516     return pfdup;
4517 }
4518
4519 DllExport void*
4520 win32_dynaload(const char* filename)
4521 {
4522     dTHX;
4523     char buf[MAX_PATH+1];
4524     char *first;
4525
4526     /* LoadLibrary() doesn't recognize forward slashes correctly,
4527      * so turn 'em back. */
4528     first = strchr(filename, '/');
4529     if (first) {
4530         STRLEN len = strlen(filename);
4531         if (len <= MAX_PATH) {
4532             strcpy(buf, filename);
4533             filename = &buf[first - filename];
4534             while (*filename) {
4535                 if (*filename == '/')
4536                     *(char*)filename = '\\';
4537                 ++filename;
4538             }
4539             filename = buf;
4540         }
4541     }
4542     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4543 }
4544
4545 XS(w32_SetChildShowWindow)
4546 {
4547     dXSARGS;
4548     BOOL use_showwindow = w32_use_showwindow;
4549     /* use "unsigned short" because Perl has redefined "WORD" */
4550     unsigned short showwindow = w32_showwindow;
4551
4552     if (items > 1)
4553         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4554
4555     if (items == 0 || !SvOK(ST(0)))
4556         w32_use_showwindow = FALSE;
4557     else {
4558         w32_use_showwindow = TRUE;
4559         w32_showwindow = (unsigned short)SvIV(ST(0));
4560     }
4561
4562     EXTEND(SP, 1);
4563     if (use_showwindow)
4564         ST(0) = sv_2mortal(newSViv(showwindow));
4565     else
4566         ST(0) = &PL_sv_undef;
4567     XSRETURN(1);
4568 }
4569
4570 void
4571 Perl_init_os_extras(void)
4572 {
4573     dTHX;
4574     char *file = __FILE__;
4575
4576     /* Initialize Win32CORE if it has been statically linked. */
4577     void (*pfn_init)(pTHX);
4578 #if defined(__BORLANDC__)
4579     /* makedef.pl seems to have given up on fixing this issue in the .def file */
4580     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4581 #else
4582     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4583 #endif
4584     if (pfn_init)
4585         pfn_init(aTHX);
4586
4587     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4588 }
4589
4590 void *
4591 win32_signal_context(void)
4592 {
4593     dTHX;
4594 #ifdef MULTIPLICITY
4595     if (!my_perl) {
4596         my_perl = PL_curinterp;
4597         PERL_SET_THX(my_perl);
4598     }
4599     return my_perl;
4600 #else
4601     return PL_curinterp;
4602 #endif
4603 }
4604
4605
4606 BOOL WINAPI
4607 win32_ctrlhandler(DWORD dwCtrlType)
4608 {
4609 #ifdef MULTIPLICITY
4610     dTHXa(PERL_GET_SIG_CONTEXT);
4611
4612     if (!my_perl)
4613         return FALSE;
4614 #endif
4615
4616     switch(dwCtrlType) {
4617     case CTRL_CLOSE_EVENT:
4618      /*  A signal that the system sends to all processes attached to a console when
4619          the user closes the console (either by choosing the Close command from the
4620          console window's System menu, or by choosing the End Task command from the
4621          Task List
4622       */
4623         if (do_raise(aTHX_ 1))        /* SIGHUP */
4624             sig_terminate(aTHX_ 1);
4625         return TRUE;
4626
4627     case CTRL_C_EVENT:
4628         /*  A CTRL+c signal was received */
4629         if (do_raise(aTHX_ SIGINT))
4630             sig_terminate(aTHX_ SIGINT);
4631         return TRUE;
4632
4633     case CTRL_BREAK_EVENT:
4634         /*  A CTRL+BREAK signal was received */
4635         if (do_raise(aTHX_ SIGBREAK))
4636             sig_terminate(aTHX_ SIGBREAK);
4637         return TRUE;
4638
4639     case CTRL_LOGOFF_EVENT:
4640       /*  A signal that the system sends to all console processes when a user is logging
4641           off. This signal does not indicate which user is logging off, so no
4642           assumptions can be made.
4643        */
4644         break;
4645     case CTRL_SHUTDOWN_EVENT:
4646       /*  A signal that the system sends to all console processes when the system is
4647           shutting down.
4648        */
4649         if (do_raise(aTHX_ SIGTERM))
4650             sig_terminate(aTHX_ SIGTERM);
4651         return TRUE;
4652     default:
4653         break;
4654     }
4655     return FALSE;
4656 }
4657
4658
4659 #ifdef SET_INVALID_PARAMETER_HANDLER
4660 #  include <crtdbg.h>
4661 #endif
4662
4663 static void
4664 ansify_path(void)
4665 {
4666     size_t len;
4667     char *ansi_path;
4668     WCHAR *wide_path;
4669     WCHAR *wide_dir;
4670
4671     /* win32_ansipath() requires Windows 2000 or later */
4672     if (!IsWin2000())
4673         return;
4674
4675     /* fetch Unicode version of PATH */
4676     len = 2000;
4677     wide_path = win32_malloc(len*sizeof(WCHAR));
4678     while (wide_path) {
4679         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4680         if (newlen < len)
4681             break;
4682         len = newlen;
4683         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4684     }
4685     if (!wide_path)
4686         return;
4687
4688     /* convert to ANSI pathnames */
4689     wide_dir = wide_path;
4690     ansi_path = NULL;
4691     while (wide_dir) {
4692         WCHAR *sep = wcschr(wide_dir, ';');
4693         char *ansi_dir;
4694         size_t ansi_len;
4695         size_t wide_len;
4696
4697         if (sep)
4698             *sep++ = '\0';
4699
4700         /* remove quotes around pathname */
4701         if (*wide_dir == '"')
4702             ++wide_dir;
4703         wide_len = wcslen(wide_dir);
4704         if (wide_len && wide_dir[wide_len-1] == '"')
4705             wide_dir[wide_len-1] = '\0';
4706
4707         /* append ansi_dir to ansi_path */
4708         ansi_dir = win32_ansipath(wide_dir);
4709         ansi_len = strlen(ansi_dir);
4710         if (ansi_path) {
4711             size_t newlen = len + 1 + ansi_len;
4712             ansi_path = win32_realloc(ansi_path, newlen+1);
4713             if (!ansi_path)
4714                 break;
4715             ansi_path[len] = ';';
4716             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4717             len = newlen;
4718         }
4719         else {
4720             len = ansi_len;
4721             ansi_path = win32_malloc(5+len+1);
4722             if (!ansi_path)
4723                 break;
4724             memcpy(ansi_path, "PATH=", 5);
4725             memcpy(ansi_path+5, ansi_dir, len+1);
4726             len += 5;
4727         }
4728         win32_free(ansi_dir);
4729         wide_dir = sep;
4730     }
4731
4732     if (ansi_path) {
4733         /* Update C RTL environ array.  This will only have full effect if
4734          * perl_parse() is later called with `environ` as the `env` argument.
4735          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4736          *
4737          * We do have to ansify() the PATH before Perl has been fully
4738          * initialized because S_find_script() uses the PATH when perl
4739          * is being invoked with the -S option.  This happens before %ENV
4740          * is initialized in S_init_postdump_symbols().
4741          *
4742          * XXX Is this a bug? Should S_find_script() use the environment
4743          * XXX passed in the `env` arg to parse_perl()?
4744          */
4745         putenv(ansi_path);
4746         /* Keep system environment in sync because S_init_postdump_symbols()
4747          * will not call mg_set() if it initializes %ENV from `environ`.
4748          */
4749         SetEnvironmentVariableA("PATH", ansi_path+5);
4750         /* We are intentionally leaking the ansi_path string here because
4751          * the Borland runtime library puts it directly into the environ
4752          * array.  The Microsoft runtime library seems to make a copy,
4753          * but will leak the copy should it be replaced again later.
4754          * Since this code is only called once during PERL_SYS_INIT this
4755          * shouldn't really matter.
4756          */
4757     }
4758     win32_free(wide_path);
4759 }
4760
4761 void
4762 Perl_win32_init(int *argcp, char ***argvp)
4763 {
4764     HMODULE module;
4765
4766 #ifdef SET_INVALID_PARAMETER_HANDLER
4767     _invalid_parameter_handler oldHandler, newHandler;
4768     newHandler = my_invalid_parameter_handler;
4769     oldHandler = _set_invalid_parameter_handler(newHandler);
4770     _CrtSetReportMode(_CRT_ASSERT, 0);
4771 #endif
4772     /* Disable floating point errors, Perl will trap the ones we
4773      * care about.  VC++ RTL defaults to switching these off
4774      * already, but the Borland RTL doesn't.  Since we don't
4775      * want to be at the vendor's whim on the default, we set
4776      * it explicitly here.
4777      */
4778 #if !defined(_ALPHA_) && !defined(__GNUC__)
4779     _control87(MCW_EM, MCW_EM);
4780 #endif
4781     MALLOC_INIT;
4782
4783     module = GetModuleHandle("ntdll.dll");
4784     if (module) {
4785         *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4786     }
4787
4788     module = GetModuleHandle("kernel32.dll");
4789     if (module) {
4790         *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4791         *(FARPROC*)&pfnProcess32First           = GetProcAddress(module, "Process32First");
4792         *(FARPROC*)&pfnProcess32Next            = GetProcAddress(module, "Process32Next");
4793     }
4794
4795     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4796     GetVersionEx(&g_osver);
4797
4798     ansify_path();
4799 }
4800
4801 void
4802 Perl_win32_term(void)
4803 {
4804     dTHX;
4805     HINTS_REFCNT_TERM;
4806     OP_REFCNT_TERM;
4807     PERLIO_TERM;
4808     MALLOC_TERM;
4809 }
4810
4811 void
4812 win32_get_child_IO(child_IO_table* ptbl)
4813 {
4814     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4815     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4816     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4817 }
4818
4819 Sighandler_t
4820 win32_signal(int sig, Sighandler_t subcode)
4821 {
4822     dTHX;
4823     if (sig < SIG_SIZE) {
4824         int save_errno = errno;
4825         Sighandler_t result = signal(sig, subcode);
4826         if (result == SIG_ERR) {
4827             result = w32_sighandler[sig];
4828             errno = save_errno;
4829         }
4830         w32_sighandler[sig] = subcode;
4831         return result;
4832     }
4833     else {
4834         errno = EINVAL;
4835         return SIG_ERR;
4836     }
4837 }
4838
4839 /* The PerlMessageWindowClass's WindowProc */
4840 LRESULT CALLBACK
4841 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4842 {
4843     return win32_process_message(hwnd, msg, wParam, lParam) ?
4844         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4845 }
4846
4847 /* we use a message filter hook to process thread messages, passing any
4848  * messages that we don't process on to the rest of the hook chain
4849  * Anyone else writing a message loop that wants to play nicely with perl
4850  * should do
4851  *   CallMsgFilter(&msg, MSGF_***);
4852  * between their GetMessage and DispatchMessage calls.  */
4853 LRESULT CALLBACK
4854 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4855     LPMSG pmsg = (LPMSG)lParam;
4856
4857     /* we'll process it if code says we're allowed, and it's a thread message */
4858     if (code >= 0 && pmsg->hwnd == NULL
4859             && win32_process_message(pmsg->hwnd, pmsg->message,
4860                                      pmsg->wParam, pmsg->lParam))
4861     {
4862             return TRUE;
4863     }
4864
4865     /* XXX: MSDN says that hhk is ignored, but we should really use the
4866      * return value from SetWindowsHookEx() in win32_create_message_window().  */
4867     return CallNextHookEx(NULL, code, wParam, lParam);
4868 }
4869
4870 /* The real message handler. Can be called with
4871  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4872  * that it processes */
4873 static LRESULT
4874 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4875 {
4876     /* BEWARE. The context retrieved using dTHX; is the context of the
4877      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4878      * up to and including WM_CREATE.  If it ever happens that you need the
4879      * 'child' context before this, then it needs to be passed into
4880      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4881      * from the lparam of CreateWindow().  It could then be stored/retrieved
4882      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4883      * the dTHX calls here. */
4884     /* XXX For now it is assumed that the overhead of the dTHX; for what
4885      * are relativley infrequent code-paths, is better than the added
4886      * complexity of getting the correct context passed into
4887      * win32_create_message_window() */
4888
4889     switch(msg) {
4890
4891 #ifdef USE_ITHREADS
4892         case WM_USER_MESSAGE: {
4893             long child = find_pseudo_pid((int)wParam);
4894             if (child >= 0) {
4895                 dTHX;
4896                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4897                 return 1;
4898             }
4899             break;
4900         }
4901 #endif
4902
4903         case WM_USER_KILL: {
4904             dTHX;
4905             /* We use WM_USER_KILL to fake kill() with other signals */
4906             int sig = (int)wParam;
4907             if (do_raise(aTHX_ sig))
4908                 sig_terminate(aTHX_ sig);
4909
4910             return 1;
4911         }
4912
4913         case WM_TIMER: {
4914             dTHX;
4915             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4916             if (w32_timerid && w32_timerid==(UINT)wParam) {
4917                 KillTimer(w32_message_hwnd, w32_timerid);
4918                 w32_timerid=0;
4919
4920                 /* Now fake a call to signal handler */
4921                 if (do_raise(aTHX_ 14))
4922                     sig_terminate(aTHX_ 14);
4923
4924                 return 1;
4925             }
4926             break;
4927         }
4928
4929         default:
4930             break;
4931
4932     } /* switch */
4933
4934     /* Above or other stuff may have set a signal flag, and we may not have
4935      * been called from win32_async_check() (e.g. some other GUI's message
4936      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
4937      * handler that die's, and the message loop that calls here is wrapped
4938      * in an eval, then you may well end up with orphaned windows - signals
4939      * are dispatched by win32_async_check() */
4940
4941     return 0;
4942 }
4943
4944 void
4945 win32_create_message_window_class(void)
4946 {
4947     /* create the window class for "message only" windows */
4948     WNDCLASS wc;
4949
4950     Zero(&wc, 1, wc);
4951     wc.lpfnWndProc = win32_message_window_proc;
4952     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4953     wc.lpszClassName = "PerlMessageWindowClass";
4954
4955     /* second and subsequent calls will fail, but class
4956      * will already be registered */
4957     RegisterClass(&wc);
4958 }
4959
4960 HWND
4961 win32_create_message_window(void)
4962 {
4963     HWND hwnd = NULL;
4964
4965     /* "message-only" windows have been implemented in Windows 2000 and later.
4966      * On earlier versions we'll continue to post messages to a specific
4967      * thread and use hwnd==NULL.  This is brittle when either an embedding
4968      * application or an XS module is also posting messages to hwnd=NULL
4969      * because once removed from the queue they cannot be delivered to the
4970      * "right" place with DispatchMessage() anymore, as there is no WindowProc
4971      * if there is no window handle.
4972      */
4973     /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4974      * documentation to the contrary, however, there is some evidence that
4975      * there may be problems with the implementation on Win98. As it is not
4976      * officially supported we take the cautious route and stick with thread
4977      * messages (hwnd == NULL) on platforms prior to Win2k.
4978      */
4979     if (IsWin2000()) {
4980         win32_create_message_window_class();
4981
4982         hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4983                 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4984     }
4985
4986     /* If we din't create a window for any reason, then we'll use thread
4987      * messages for our signalling, so we install a hook which
4988      * is called by CallMsgFilter in win32_async_check(), or any other
4989      * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
4990      * that use OLE, etc. */
4991     if(!hwnd) {
4992         SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
4993                 NULL, GetCurrentThreadId());
4994     }
4995
4996     return hwnd;
4997 }
4998
4999 #ifdef HAVE_INTERP_INTERN
5000
5001 static void
5002 win32_csighandler(int sig)
5003 {
5004 #if 0
5005     dTHXa(PERL_GET_SIG_CONTEXT);
5006     Perl_warn(aTHX_ "Got signal %d",sig);
5007 #endif
5008     /* Does nothing */
5009 }
5010
5011 #if defined(__MINGW32__) && defined(__cplusplus)
5012 #define CAST_HWND__(x) (HWND__*)(x)
5013 #else
5014 #define CAST_HWND__(x) x
5015 #endif
5016
5017 void
5018 Perl_sys_intern_init(pTHX)
5019 {
5020     int i;
5021
5022     w32_perlshell_tokens        = NULL;
5023     w32_perlshell_vec           = (char**)NULL;
5024     w32_perlshell_items         = 0;
5025     w32_fdpid                   = newAV();
5026     Newx(w32_children, 1, child_tab);
5027     w32_num_children            = 0;
5028 #  ifdef USE_ITHREADS
5029     w32_pseudo_id               = 0;
5030     Newx(w32_pseudo_children, 1, pseudo_child_tab);
5031     w32_num_pseudo_children     = 0;
5032 #  endif
5033     w32_timerid                 = 0;
5034     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
5035     w32_poll_count              = 0;
5036     for (i=0; i < SIG_SIZE; i++) {
5037         w32_sighandler[i] = SIG_DFL;
5038     }
5039 #  ifdef MULTIPLICITY
5040     if (my_perl == PL_curinterp) {
5041 #  else
5042     {
5043 #  endif
5044         /* Force C runtime signal stuff to set its console handler */
5045         signal(SIGINT,win32_csighandler);
5046         signal(SIGBREAK,win32_csighandler);
5047
5048         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5049          * flag.  This has the side-effect of disabling Ctrl-C events in all
5050          * processes in this group.  At least on Windows NT and later we
5051          * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5052          * with a NULL handler.  This is not valid on Windows 9X.
5053          */
5054         if (IsWinNT())
5055             SetConsoleCtrlHandler(NULL,FALSE);
5056
5057         /* Push our handler on top */
5058         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5059     }
5060 }
5061
5062 void
5063 Perl_sys_intern_clear(pTHX)
5064 {
5065     Safefree(w32_perlshell_tokens);
5066     Safefree(w32_perlshell_vec);
5067     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5068     Safefree(w32_children);
5069     if (w32_timerid) {
5070         KillTimer(w32_message_hwnd, w32_timerid);
5071         w32_timerid = 0;
5072     }
5073     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5074         DestroyWindow(w32_message_hwnd);
5075 #  ifdef MULTIPLICITY
5076     if (my_perl == PL_curinterp) {
5077 #  else
5078     {
5079 #  endif
5080         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5081     }
5082 #  ifdef USE_ITHREADS
5083     Safefree(w32_pseudo_children);
5084 #  endif
5085 }
5086
5087 #  ifdef USE_ITHREADS
5088
5089 void
5090 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5091 {
5092     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5093
5094     dst->perlshell_tokens       = NULL;
5095     dst->perlshell_vec          = (char**)NULL;
5096     dst->perlshell_items        = 0;
5097     dst->fdpid                  = newAV();
5098     Newxz(dst->children, 1, child_tab);
5099     dst->pseudo_id              = 0;
5100     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5101     dst->timerid                = 0;
5102     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
5103     dst->poll_count             = 0;
5104     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5105 }
5106 #  endif /* USE_ITHREADS */
5107 #endif /* HAVE_INTERP_INTERN */