win32/win32.c

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