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