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