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_isatty(int fd)
3513 {
3514     /* The Microsoft isatty() function returns true for *all*
3515      * character mode devices, including "nul".  Our implementation
3516      * should only return true if the handle has a console buffer.
3517      */
3518     DWORD mode;
3519     HANDLE fh = (HANDLE)_get_osfhandle(fd);
3520     if (fh == (HANDLE)-1) {
3521         /* errno is already set to EBADF */
3522         return 0;
3523     }
3524
3525     if (GetConsoleMode(fh, &mode))
3526         return 1;
3527
3528     errno = ENOTTY;
3529     return 0;
3530 }
3531
3532 DllExport int
3533 win32_dup(int fd)
3534 {
3535     return dup(fd);
3536 }
3537
3538 DllExport int
3539 win32_dup2(int fd1,int fd2)
3540 {
3541     return dup2(fd1,fd2);
3542 }
3543
3544 #ifdef PERL_MSVCRT_READFIX
3545
3546 #define LF              10      /* line feed */
3547 #define CR              13      /* carriage return */
3548 #define CTRLZ           26      /* ctrl-z means eof for text */
3549 #define FOPEN           0x01    /* file handle open */
3550 #define FEOFLAG         0x02    /* end of file has been encountered */
3551 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3552 #define FPIPE           0x08    /* file handle refers to a pipe */
3553 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3554 #define FDEV            0x40    /* file handle refers to device */
3555 #define FTEXT           0x80    /* file handle is in text mode */
3556 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3557
3558 int __cdecl
3559 _fixed_read(int fh, void *buf, unsigned cnt)
3560 {
3561     int bytes_read;                 /* number of bytes read */
3562     char *buffer;                   /* buffer to read to */
3563     int os_read;                    /* bytes read on OS call */
3564     char *p, *q;                    /* pointers into buffer */
3565     char peekchr;                   /* peek-ahead character */
3566     ULONG filepos;                  /* file position after seek */
3567     ULONG dosretval;                /* o.s. return value */
3568
3569     /* validate handle */
3570     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3571          !(_osfile(fh) & FOPEN))
3572     {
3573         /* out of range -- return error */
3574         errno = EBADF;
3575         _doserrno = 0;  /* not o.s. error */
3576         return -1;
3577     }
3578
3579     /*
3580      * If lockinitflag is FALSE, assume fd is device
3581      * lockinitflag is set to TRUE by open.
3582      */
3583     if (_pioinfo(fh)->lockinitflag)
3584         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3585
3586     bytes_read = 0;                 /* nothing read yet */
3587     buffer = (char*)buf;
3588
3589     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3590         /* nothing to read or at EOF, so return 0 read */
3591         goto functionexit;
3592     }
3593
3594     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3595         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3596          * char */
3597         *buffer++ = _pipech(fh);
3598         ++bytes_read;
3599         --cnt;
3600         _pipech(fh) = LF;           /* mark as empty */
3601     }
3602
3603     /* read the data */
3604
3605     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3606     {
3607         /* ReadFile has reported an error. recognize two special cases.
3608          *
3609          *      1. map ERROR_ACCESS_DENIED to EBADF
3610          *
3611          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3612          *         means the handle is a read-handle on a pipe for which
3613          *         all write-handles have been closed and all data has been
3614          *         read. */
3615
3616         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3617             /* wrong read/write mode should return EBADF, not EACCES */
3618             errno = EBADF;
3619             _doserrno = dosretval;
3620             bytes_read = -1;
3621             goto functionexit;
3622         }
3623         else if (dosretval == ERROR_BROKEN_PIPE) {
3624             bytes_read = 0;
3625             goto functionexit;
3626         }
3627         else {
3628             bytes_read = -1;
3629             goto functionexit;
3630         }
3631     }
3632
3633     bytes_read += os_read;          /* update bytes read */
3634
3635     if (_osfile(fh) & FTEXT) {
3636         /* now must translate CR-LFs to LFs in the buffer */
3637
3638         /* set CRLF flag to indicate LF at beginning of buffer */
3639         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3640         /*    _osfile(fh) |= FCRLF;                      */
3641         /* else                                          */
3642         /*    _osfile(fh) &= ~FCRLF;                     */
3643
3644         _osfile(fh) &= ~FCRLF;
3645
3646         /* convert chars in the buffer: p is src, q is dest */
3647         p = q = (char*)buf;
3648         while (p < (char *)buf + bytes_read) {
3649             if (*p == CTRLZ) {
3650                 /* if fh is not a device, set ctrl-z flag */
3651                 if (!(_osfile(fh) & FDEV))
3652                     _osfile(fh) |= FEOFLAG;
3653                 break;              /* stop translating */
3654             }
3655             else if (*p != CR)
3656                 *q++ = *p++;
3657             else {
3658                 /* *p is CR, so must check next char for LF */
3659                 if (p < (char *)buf + bytes_read - 1) {
3660                     if (*(p+1) == LF) {
3661                         p += 2;
3662                         *q++ = LF;  /* convert CR-LF to LF */
3663                     }
3664                     else
3665                         *q++ = *p++;    /* store char normally */
3666                 }
3667                 else {
3668                     /* This is the hard part.  We found a CR at end of
3669                        buffer.  We must peek ahead to see if next char
3670                        is an LF. */
3671                     ++p;
3672
3673                     dosretval = 0;
3674                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3675                                     (LPDWORD)&os_read, NULL))
3676                         dosretval = GetLastError();
3677
3678                     if (dosretval != 0 || os_read == 0) {
3679                         /* couldn't read ahead, store CR */
3680                         *q++ = CR;
3681                     }
3682                     else {
3683                         /* peekchr now has the extra character -- we now
3684                            have several possibilities:
3685                            1. disk file and char is not LF; just seek back
3686                               and copy CR
3687                            2. disk file and char is LF; store LF, don't seek back
3688                            3. pipe/device and char is LF; store LF.
3689                            4. pipe/device and char isn't LF, store CR and
3690                               put char in pipe lookahead buffer. */
3691                         if (_osfile(fh) & (FDEV|FPIPE)) {
3692                             /* non-seekable device */
3693                             if (peekchr == LF)
3694                                 *q++ = LF;
3695                             else {
3696                                 *q++ = CR;
3697                                 _pipech(fh) = peekchr;
3698                             }
3699                         }
3700                         else {
3701                             /* disk file */
3702                             if (peekchr == LF) {
3703                                 /* nothing read yet; must make some
3704                                    progress */
3705                                 *q++ = LF;
3706                                 /* turn on this flag for tell routine */
3707                                 _osfile(fh) |= FCRLF;
3708                             }
3709                             else {
3710                                 HANDLE osHandle;        /* o.s. handle value */
3711                                 /* seek back */
3712                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3713                                 {
3714                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3715                                         dosretval = GetLastError();
3716                                 }
3717                                 if (peekchr != LF)
3718                                     *q++ = CR;
3719                             }
3720                         }
3721                     }
3722                 }
3723             }
3724         }
3725
3726         /* we now change bytes_read to reflect the true number of chars
3727            in the buffer */
3728         bytes_read = q - (char *)buf;
3729     }
3730
3731 functionexit:
3732     if (_pioinfo(fh)->lockinitflag)
3733         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3734
3735     return bytes_read;
3736 }
3737
3738 #endif  /* PERL_MSVCRT_READFIX */
3739
3740 DllExport int
3741 win32_read(int fd, void *buf, unsigned int cnt)
3742 {
3743 #ifdef PERL_MSVCRT_READFIX
3744     return _fixed_read(fd, buf, cnt);
3745 #else
3746     return read(fd, buf, cnt);
3747 #endif
3748 }
3749
3750 DllExport int
3751 win32_write(int fd, const void *buf, unsigned int cnt)
3752 {
3753     return write(fd, buf, cnt);
3754 }
3755
3756 DllExport int
3757 win32_mkdir(const char *dir, int mode)
3758 {
3759     dTHX;
3760     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3761 }
3762
3763 DllExport int
3764 win32_rmdir(const char *dir)
3765 {
3766     dTHX;
3767     return rmdir(PerlDir_mapA(dir));
3768 }
3769
3770 DllExport int
3771 win32_chdir(const char *dir)
3772 {
3773     dTHX;
3774     if (!dir) {
3775         errno = ENOENT;
3776         return -1;
3777     }
3778     return chdir(dir);
3779 }
3780
3781 DllExport  int
3782 win32_access(const char *path, int mode)
3783 {
3784     dTHX;
3785     return access(PerlDir_mapA(path), mode);
3786 }
3787
3788 DllExport  int
3789 win32_chmod(const char *path, int mode)
3790 {
3791     dTHX;
3792     return chmod(PerlDir_mapA(path), mode);
3793 }
3794
3795
3796 static char *
3797 create_command_line(char *cname, STRLEN clen, const char * const *args)
3798 {
3799     dTHX;
3800     int index, argc;
3801     char *cmd, *ptr;
3802     const char *arg;
3803     STRLEN len = 0;
3804     bool bat_file = FALSE;
3805     bool cmd_shell = FALSE;
3806     bool dumb_shell = FALSE;
3807     bool extra_quotes = FALSE;
3808     bool quote_next = FALSE;
3809
3810     if (!cname)
3811         cname = (char*)args[0];
3812
3813     /* The NT cmd.exe shell has the following peculiarity that needs to be
3814      * worked around.  It strips a leading and trailing dquote when any
3815      * of the following is true:
3816      *    1. the /S switch was used
3817      *    2. there are more than two dquotes
3818      *    3. there is a special character from this set: &<>()@^|
3819      *    4. no whitespace characters within the two dquotes
3820      *    5. string between two dquotes isn't an executable file
3821      * To work around this, we always add a leading and trailing dquote
3822      * to the string, if the first argument is either "cmd.exe" or "cmd",
3823      * and there were at least two or more arguments passed to cmd.exe
3824      * (not including switches).
3825      * XXX the above rules (from "cmd /?") don't seem to be applied
3826      * always, making for the convolutions below :-(
3827      */
3828     if (cname) {
3829         if (!clen)
3830             clen = strlen(cname);
3831
3832         if (clen > 4
3833             && (stricmp(&cname[clen-4], ".bat") == 0
3834                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3835         {
3836             bat_file = TRUE;
3837             if (!IsWin95())
3838                 len += 3;
3839         }
3840         else {
3841             char *exe = strrchr(cname, '/');
3842             char *exe2 = strrchr(cname, '\\');
3843             if (exe2 > exe)
3844                 exe = exe2;
3845             if (exe)
3846                 ++exe;
3847             else
3848                 exe = cname;
3849             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3850                 cmd_shell = TRUE;
3851                 len += 3;
3852             }
3853             else if (stricmp(exe, "command.com") == 0
3854                      || stricmp(exe, "command") == 0)
3855             {
3856                 dumb_shell = TRUE;
3857             }
3858         }
3859     }
3860
3861     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3862     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3863         STRLEN curlen = strlen(arg);
3864         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3865             len += 2;   /* assume quoting needed (worst case) */
3866         len += curlen + 1;
3867         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3868     }
3869     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3870
3871     argc = index;
3872     Newx(cmd, len, char);
3873     ptr = cmd;
3874
3875     if (bat_file && !IsWin95()) {
3876         *ptr++ = '"';
3877         extra_quotes = TRUE;
3878     }
3879
3880     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3881         bool do_quote = 0;
3882         STRLEN curlen = strlen(arg);
3883
3884         /* we want to protect empty arguments and ones with spaces with
3885          * dquotes, but only if they aren't already there */
3886         if (!dumb_shell) {
3887             if (!curlen) {
3888                 do_quote = 1;
3889             }
3890             else if (quote_next) {
3891                 /* see if it really is multiple arguments pretending to
3892                  * be one and force a set of quotes around it */
3893                 if (*find_next_space(arg))
3894                     do_quote = 1;
3895             }
3896             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3897                 STRLEN i = 0;
3898                 while (i < curlen) {
3899                     if (isSPACE(arg[i])) {
3900                         do_quote = 1;
3901                     }
3902                     else if (arg[i] == '"') {
3903                         do_quote = 0;
3904                         break;
3905                     }
3906                     i++;
3907                 }
3908             }
3909         }
3910
3911         if (do_quote)
3912             *ptr++ = '"';
3913
3914         strcpy(ptr, arg);
3915         ptr += curlen;
3916
3917         if (do_quote)
3918             *ptr++ = '"';
3919
3920         if (args[index+1])
3921             *ptr++ = ' ';
3922
3923         if (!extra_quotes
3924             && cmd_shell
3925             && curlen >= 2
3926             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3927             && stricmp(arg+curlen-2, "/c") == 0)
3928         {
3929             /* is there a next argument? */
3930             if (args[index+1]) {
3931                 /* are there two or more next arguments? */
3932                 if (args[index+2]) {
3933                     *ptr++ = '"';
3934                     extra_quotes = TRUE;
3935                 }
3936                 else {
3937                     /* single argument, force quoting if it has spaces */
3938                     quote_next = TRUE;
3939                 }
3940             }
3941         }
3942     }
3943
3944     if (extra_quotes)
3945         *ptr++ = '"';
3946
3947     *ptr = '\0';
3948
3949     return cmd;
3950 }
3951
3952 static char *
3953 qualified_path(const char *cmd)
3954 {
3955     dTHX;
3956     char *pathstr;
3957     char *fullcmd, *curfullcmd;
3958     STRLEN cmdlen = 0;
3959     int has_slash = 0;
3960
3961     if (!cmd)
3962         return NULL;
3963     fullcmd = (char*)cmd;
3964     while (*fullcmd) {
3965         if (*fullcmd == '/' || *fullcmd == '\\')
3966             has_slash++;
3967         fullcmd++;
3968         cmdlen++;
3969     }
3970
3971     /* look in PATH */
3972     pathstr = PerlEnv_getenv("PATH");
3973
3974     /* worst case: PATH is a single directory; we need additional space
3975      * to append "/", ".exe" and trailing "\0" */
3976     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3977     curfullcmd = fullcmd;
3978
3979     while (1) {
3980         DWORD res;
3981
3982         /* start by appending the name to the current prefix */
3983         strcpy(curfullcmd, cmd);
3984         curfullcmd += cmdlen;
3985
3986         /* if it doesn't end with '.', or has no extension, try adding
3987          * a trailing .exe first */
3988         if (cmd[cmdlen-1] != '.'
3989             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3990         {
3991             strcpy(curfullcmd, ".exe");
3992             res = GetFileAttributes(fullcmd);
3993             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3994                 return fullcmd;
3995             *curfullcmd = '\0';
3996         }
3997
3998         /* that failed, try the bare name */
3999         res = GetFileAttributes(fullcmd);
4000         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
4001             return fullcmd;
4002
4003         /* quit if no other path exists, or if cmd already has path */
4004         if (!pathstr || !*pathstr || has_slash)
4005             break;
4006
4007         /* skip leading semis */
4008         while (*pathstr == ';')
4009             pathstr++;
4010
4011         /* build a new prefix from scratch */
4012         curfullcmd = fullcmd;
4013         while (*pathstr && *pathstr != ';') {
4014             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
4015                 pathstr++;              /* skip initial '"' */
4016                 while (*pathstr && *pathstr != '"') {
4017                     *curfullcmd++ = *pathstr++;
4018                 }
4019                 if (*pathstr)
4020                     pathstr++;          /* skip trailing '"' */
4021             }
4022             else {
4023                 *curfullcmd++ = *pathstr++;
4024             }
4025         }
4026         if (*pathstr)
4027             pathstr++;                  /* skip trailing semi */
4028         if (curfullcmd > fullcmd        /* append a dir separator */
4029             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
4030         {
4031             *curfullcmd++ = '\\';
4032         }
4033     }
4034
4035     Safefree(fullcmd);
4036     return NULL;
4037 }
4038
4039 /* The following are just place holders.
4040  * Some hosts may provide and environment that the OS is
4041  * not tracking, therefore, these host must provide that
4042  * environment and the current directory to CreateProcess
4043  */
4044
4045 DllExport void*
4046 win32_get_childenv(void)
4047 {
4048     return NULL;
4049 }
4050
4051 DllExport void
4052 win32_free_childenv(void* d)
4053 {
4054 }
4055
4056 DllExport void
4057 win32_clearenv(void)
4058 {
4059     char *envv = GetEnvironmentStrings();
4060     char *cur = envv;
4061     STRLEN len;
4062     while (*cur) {
4063         char *end = strchr(cur,'=');
4064         if (end && end != cur) {
4065             *end = '\0';
4066             SetEnvironmentVariable(cur, NULL);
4067             *end = '=';
4068             cur = end + strlen(end+1)+2;
4069         }
4070         else if ((len = strlen(cur)))
4071             cur += len+1;
4072     }
4073     FreeEnvironmentStrings(envv);
4074 }
4075
4076 DllExport char*
4077 win32_get_childdir(void)
4078 {
4079     dTHX;
4080     char* ptr;
4081     char szfilename[MAX_PATH+1];
4082
4083     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4084     Newx(ptr, strlen(szfilename)+1, char);
4085     strcpy(ptr, szfilename);
4086     return ptr;
4087 }
4088
4089 DllExport void
4090 win32_free_childdir(char* d)
4091 {
4092     dTHX;
4093     Safefree(d);
4094 }
4095
4096
4097 /* XXX this needs to be made more compatible with the spawnvp()
4098  * provided by the various RTLs.  In particular, searching for
4099  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4100  * This doesn't significantly affect perl itself, because we
4101  * always invoke things using PERL5SHELL if a direct attempt to
4102  * spawn the executable fails.
4103  *
4104  * XXX splitting and rejoining the commandline between do_aspawn()
4105  * and win32_spawnvp() could also be avoided.
4106  */
4107
4108 DllExport int
4109 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4110 {
4111 #ifdef USE_RTL_SPAWNVP
4112     return spawnvp(mode, cmdname, (char * const *)argv);
4113 #else
4114     dTHX;
4115     int ret;
4116     void* env;
4117     char* dir;
4118     child_IO_table tbl;
4119     STARTUPINFO StartupInfo;
4120     PROCESS_INFORMATION ProcessInformation;
4121     DWORD create = 0;
4122     char *cmd;
4123     char *fullcmd = NULL;
4124     char *cname = (char *)cmdname;
4125     STRLEN clen = 0;
4126
4127     if (cname) {
4128         clen = strlen(cname);
4129         /* if command name contains dquotes, must remove them */
4130         if (strchr(cname, '"')) {
4131             cmd = cname;
4132             Newx(cname,clen+1,char);
4133             clen = 0;
4134             while (*cmd) {
4135                 if (*cmd != '"') {
4136                     cname[clen] = *cmd;
4137                     ++clen;
4138                 }
4139                 ++cmd;
4140             }
4141             cname[clen] = '\0';
4142         }
4143     }
4144
4145     cmd = create_command_line(cname, clen, argv);
4146
4147     env = PerlEnv_get_childenv();
4148     dir = PerlEnv_get_childdir();
4149
4150     switch(mode) {
4151     case P_NOWAIT:      /* asynch + remember result */
4152         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4153             errno = EAGAIN;
4154             ret = -1;
4155             goto RETVAL;
4156         }
4157         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4158          * in win32_kill()
4159          */
4160         create |= CREATE_NEW_PROCESS_GROUP;
4161         /* FALL THROUGH */
4162
4163     case P_WAIT:        /* synchronous execution */
4164         break;
4165     default:            /* invalid mode */
4166         errno = EINVAL;
4167         ret = -1;
4168         goto RETVAL;
4169     }
4170     memset(&StartupInfo,0,sizeof(StartupInfo));
4171     StartupInfo.cb = sizeof(StartupInfo);
4172     memset(&tbl,0,sizeof(tbl));
4173     PerlEnv_get_child_IO(&tbl);
4174     StartupInfo.dwFlags         = tbl.dwFlags;
4175     StartupInfo.dwX             = tbl.dwX;
4176     StartupInfo.dwY             = tbl.dwY;
4177     StartupInfo.dwXSize         = tbl.dwXSize;
4178     StartupInfo.dwYSize         = tbl.dwYSize;
4179     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
4180     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
4181     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4182     StartupInfo.wShowWindow     = tbl.wShowWindow;
4183     StartupInfo.hStdInput       = tbl.childStdIn;
4184     StartupInfo.hStdOutput      = tbl.childStdOut;
4185     StartupInfo.hStdError       = tbl.childStdErr;
4186     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4187         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4188         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4189     {
4190         create |= CREATE_NEW_CONSOLE;
4191     }
4192     else {
4193         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4194     }
4195     if (w32_use_showwindow) {
4196         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4197         StartupInfo.wShowWindow = w32_showwindow;
4198     }
4199
4200     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4201                           cname,cmd));
4202 RETRY:
4203     if (!CreateProcess(cname,           /* search PATH to find executable */
4204                        cmd,             /* executable, and its arguments */
4205                        NULL,            /* process attributes */
4206                        NULL,            /* thread attributes */
4207                        TRUE,            /* inherit handles */
4208                        create,          /* creation flags */
4209                        (LPVOID)env,     /* inherit environment */
4210                        dir,             /* inherit cwd */
4211                        &StartupInfo,
4212                        &ProcessInformation))
4213     {
4214         /* initial NULL argument to CreateProcess() does a PATH
4215          * search, but it always first looks in the directory
4216          * where the current process was started, which behavior
4217          * is undesirable for backward compatibility.  So we
4218          * jump through our own hoops by picking out the path
4219          * we really want it to use. */
4220         if (!fullcmd) {
4221             fullcmd = qualified_path(cname);
4222             if (fullcmd) {
4223                 if (cname != cmdname)
4224                     Safefree(cname);
4225                 cname = fullcmd;
4226                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4227                                       "Retrying [%s] with same args\n",
4228                                       cname));
4229                 goto RETRY;
4230             }
4231         }
4232         errno = ENOENT;
4233         ret = -1;
4234         goto RETVAL;
4235     }
4236
4237     if (mode == P_NOWAIT) {
4238         /* asynchronous spawn -- store handle, return PID */
4239         ret = (int)ProcessInformation.dwProcessId;
4240         if (IsWin95() && ret < 0)
4241             ret = -ret;
4242
4243         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4244         w32_child_pids[w32_num_children] = (DWORD)ret;
4245         ++w32_num_children;
4246     }
4247     else  {
4248         DWORD status;
4249         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4250         /* FIXME: if msgwait returned due to message perhaps forward the
4251            "signal" to the process
4252          */
4253         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4254         ret = (int)status;
4255         CloseHandle(ProcessInformation.hProcess);
4256     }
4257
4258     CloseHandle(ProcessInformation.hThread);
4259
4260 RETVAL:
4261     PerlEnv_free_childenv(env);
4262     PerlEnv_free_childdir(dir);
4263     Safefree(cmd);
4264     if (cname != cmdname)
4265         Safefree(cname);
4266     return ret;
4267 #endif
4268 }
4269
4270 DllExport int
4271 win32_execv(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 #  ifdef __BORLANDC__
4279         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4280 #  else
4281         return spawnv(P_WAIT, cmdname, argv);
4282 #  endif
4283 #endif
4284 #ifdef __BORLANDC__
4285     return execv(cmdname, (char *const *)argv);
4286 #else
4287     return execv(cmdname, argv);
4288 #endif
4289 }
4290
4291 DllExport int
4292 win32_execvp(const char *cmdname, const char *const *argv)
4293 {
4294 #ifdef USE_ITHREADS
4295     dTHX;
4296     /* if this is a pseudo-forked child, we just want to spawn
4297      * the new program, and return */
4298     if (w32_pseudo_id) {
4299         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4300         if (status != -1) {
4301             my_exit(status);
4302             return 0;
4303         }
4304         else
4305             return status;
4306     }
4307 #endif
4308 #ifdef __BORLANDC__
4309     return execvp(cmdname, (char *const *)argv);
4310 #else
4311     return execvp(cmdname, argv);
4312 #endif
4313 }
4314
4315 DllExport void
4316 win32_perror(const char *str)
4317 {
4318     perror(str);
4319 }
4320
4321 DllExport void
4322 win32_setbuf(FILE *pf, char *buf)
4323 {
4324     setbuf(pf, buf);
4325 }
4326
4327 DllExport int
4328 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4329 {
4330     return setvbuf(pf, buf, type, size);
4331 }
4332
4333 DllExport int
4334 win32_flushall(void)
4335 {
4336     return flushall();
4337 }
4338
4339 DllExport int
4340 win32_fcloseall(void)
4341 {
4342     return fcloseall();
4343 }
4344
4345 DllExport char*
4346 win32_fgets(char *s, int n, FILE *pf)
4347 {
4348     return fgets(s, n, pf);
4349 }
4350
4351 DllExport char*
4352 win32_gets(char *s)
4353 {
4354     return gets(s);
4355 }
4356
4357 DllExport int
4358 win32_fgetc(FILE *pf)
4359 {
4360     return fgetc(pf);
4361 }
4362
4363 DllExport int
4364 win32_putc(int c, FILE *pf)
4365 {
4366     return putc(c,pf);
4367 }
4368
4369 DllExport int
4370 win32_puts(const char *s)
4371 {
4372     return puts(s);
4373 }
4374
4375 DllExport int
4376 win32_getchar(void)
4377 {
4378     return getchar();
4379 }
4380
4381 DllExport int
4382 win32_putchar(int c)
4383 {
4384     return putchar(c);
4385 }
4386
4387 #ifdef MYMALLOC
4388
4389 #ifndef USE_PERL_SBRK
4390
4391 static char *committed = NULL;          /* XXX threadead */
4392 static char *base      = NULL;          /* XXX threadead */
4393 static char *reserved  = NULL;          /* XXX threadead */
4394 static char *brk       = NULL;          /* XXX threadead */
4395 static DWORD pagesize  = 0;             /* XXX threadead */
4396
4397 void *
4398 sbrk(ptrdiff_t need)
4399 {
4400  void *result;
4401  if (!pagesize)
4402   {SYSTEM_INFO info;
4403    GetSystemInfo(&info);
4404    /* Pretend page size is larger so we don't perpetually
4405     * call the OS to commit just one page ...
4406     */
4407    pagesize = info.dwPageSize << 3;
4408   }
4409  if (brk+need >= reserved)
4410   {
4411    DWORD size = brk+need-reserved;
4412    char *addr;
4413    char *prev_committed = NULL;
4414    if (committed && reserved && committed < reserved)
4415     {
4416      /* Commit last of previous chunk cannot span allocations */
4417      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4418      if (addr)
4419       {
4420       /* Remember where we committed from in case we want to decommit later */
4421       prev_committed = committed;
4422       committed = reserved;
4423       }
4424     }
4425    /* Reserve some (more) space
4426     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4427     * this is only address space not memory...
4428     * Note this is a little sneaky, 1st call passes NULL as reserved
4429     * so lets system choose where we start, subsequent calls pass
4430     * the old end address so ask for a contiguous block
4431     */
4432 sbrk_reserve:
4433    if (size < 64*1024*1024)
4434     size = 64*1024*1024;
4435    size = ((size + pagesize - 1) / pagesize) * pagesize;
4436    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4437    if (addr)
4438     {
4439      reserved = addr+size;
4440      if (!base)
4441       base = addr;
4442      if (!committed)
4443       committed = base;
4444      if (!brk)
4445       brk = committed;
4446     }
4447    else if (reserved)
4448     {
4449       /* The existing block could not be extended far enough, so decommit
4450        * anything that was just committed above and start anew */
4451       if (prev_committed)
4452        {
4453        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4454         return (void *) -1;
4455        }
4456       reserved = base = committed = brk = NULL;
4457       size = need;
4458       goto sbrk_reserve;
4459     }
4460    else
4461     {
4462      return (void *) -1;
4463     }
4464   }
4465  result = brk;
4466  brk += need;
4467  if (brk > committed)
4468   {
4469    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4470    char *addr;
4471    if (committed+size > reserved)
4472     size = reserved-committed;
4473    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4474    if (addr)
4475     committed += size;
4476    else
4477     return (void *) -1;
4478   }
4479  return result;
4480 }
4481
4482 #endif
4483 #endif
4484
4485 DllExport void*
4486 win32_malloc(size_t size)
4487 {
4488     return malloc(size);
4489 }
4490
4491 DllExport void*
4492 win32_calloc(size_t numitems, size_t size)
4493 {
4494     return calloc(numitems,size);
4495 }
4496
4497 DllExport void*
4498 win32_realloc(void *block, size_t size)
4499 {
4500     return realloc(block,size);
4501 }
4502
4503 DllExport void
4504 win32_free(void *block)
4505 {
4506     free(block);
4507 }
4508
4509
4510 DllExport int
4511 win32_open_osfhandle(intptr_t handle, int flags)
4512 {
4513 #ifdef USE_FIXED_OSFHANDLE
4514     if (IsWin95())
4515         return my_open_osfhandle(handle, flags);
4516 #endif
4517     return _open_osfhandle(handle, flags);
4518 }
4519
4520 DllExport intptr_t
4521 win32_get_osfhandle(int fd)
4522 {
4523     return (intptr_t)_get_osfhandle(fd);
4524 }
4525
4526 DllExport FILE *
4527 win32_fdupopen(FILE *pf)
4528 {
4529     FILE* pfdup;
4530     fpos_t pos;
4531     char mode[3];
4532     int fileno = win32_dup(win32_fileno(pf));
4533
4534     /* open the file in the same mode */
4535 #ifdef __BORLANDC__
4536     if((pf)->flags & _F_READ) {
4537         mode[0] = 'r';
4538         mode[1] = 0;
4539     }
4540     else if((pf)->flags & _F_WRIT) {
4541         mode[0] = 'a';
4542         mode[1] = 0;
4543     }
4544     else if((pf)->flags & _F_RDWR) {
4545         mode[0] = 'r';
4546         mode[1] = '+';
4547         mode[2] = 0;
4548     }
4549 #else
4550     if((pf)->_flag & _IOREAD) {
4551         mode[0] = 'r';
4552         mode[1] = 0;
4553     }
4554     else if((pf)->_flag & _IOWRT) {
4555         mode[0] = 'a';
4556         mode[1] = 0;
4557     }
4558     else if((pf)->_flag & _IORW) {
4559         mode[0] = 'r';
4560         mode[1] = '+';
4561         mode[2] = 0;
4562     }
4563 #endif
4564
4565     /* it appears that the binmode is attached to the
4566      * file descriptor so binmode files will be handled
4567      * correctly
4568      */
4569     pfdup = win32_fdopen(fileno, mode);
4570
4571     /* move the file pointer to the same position */
4572     if (!fgetpos(pf, &pos)) {
4573         fsetpos(pfdup, &pos);
4574     }
4575     return pfdup;
4576 }
4577
4578 DllExport void*
4579 win32_dynaload(const char* filename)
4580 {
4581     dTHX;
4582     char buf[MAX_PATH+1];
4583     char *first;
4584
4585     /* LoadLibrary() doesn't recognize forward slashes correctly,
4586      * so turn 'em back. */
4587     first = strchr(filename, '/');
4588     if (first) {
4589         STRLEN len = strlen(filename);
4590         if (len <= MAX_PATH) {
4591             strcpy(buf, filename);
4592             filename = &buf[first - filename];
4593             while (*filename) {
4594                 if (*filename == '/')
4595                     *(char*)filename = '\\';
4596                 ++filename;
4597             }
4598             filename = buf;
4599         }
4600     }
4601     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4602 }
4603
4604 XS(w32_SetChildShowWindow)
4605 {
4606     dXSARGS;
4607     BOOL use_showwindow = w32_use_showwindow;
4608     /* use "unsigned short" because Perl has redefined "WORD" */
4609     unsigned short showwindow = w32_showwindow;
4610
4611     if (items > 1)
4612         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4613
4614     if (items == 0 || !SvOK(ST(0)))
4615         w32_use_showwindow = FALSE;
4616     else {
4617         w32_use_showwindow = TRUE;
4618         w32_showwindow = (unsigned short)SvIV(ST(0));
4619     }
4620
4621     EXTEND(SP, 1);
4622     if (use_showwindow)
4623         ST(0) = sv_2mortal(newSViv(showwindow));
4624     else
4625         ST(0) = &PL_sv_undef;
4626     XSRETURN(1);
4627 }
4628
4629 void
4630 Perl_init_os_extras(void)
4631 {
4632     dTHX;
4633     char *file = __FILE__;
4634
4635     /* Initialize Win32CORE if it has been statically linked. */
4636     void (*pfn_init)(pTHX);
4637 #if defined(__BORLANDC__)
4638     /* makedef.pl seems to have given up on fixing this issue in the .def file */
4639     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4640 #else
4641     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4642 #endif
4643     if (pfn_init)
4644         pfn_init(aTHX);
4645
4646     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4647 }
4648
4649 void *
4650 win32_signal_context(void)
4651 {
4652     dTHX;
4653 #ifdef MULTIPLICITY
4654     if (!my_perl) {
4655         my_perl = PL_curinterp;
4656         PERL_SET_THX(my_perl);
4657     }
4658     return my_perl;
4659 #else
4660     return PL_curinterp;
4661 #endif
4662 }
4663
4664
4665 BOOL WINAPI
4666 win32_ctrlhandler(DWORD dwCtrlType)
4667 {
4668 #ifdef MULTIPLICITY
4669     dTHXa(PERL_GET_SIG_CONTEXT);
4670
4671     if (!my_perl)
4672         return FALSE;
4673 #endif
4674
4675     switch(dwCtrlType) {
4676     case CTRL_CLOSE_EVENT:
4677      /*  A signal that the system sends to all processes attached to a console when
4678          the user closes the console (either by choosing the Close command from the
4679          console window's System menu, or by choosing the End Task command from the
4680          Task List
4681       */
4682         if (do_raise(aTHX_ 1))        /* SIGHUP */
4683             sig_terminate(aTHX_ 1);
4684         return TRUE;
4685
4686     case CTRL_C_EVENT:
4687         /*  A CTRL+c signal was received */
4688         if (do_raise(aTHX_ SIGINT))
4689             sig_terminate(aTHX_ SIGINT);
4690         return TRUE;
4691
4692     case CTRL_BREAK_EVENT:
4693         /*  A CTRL+BREAK signal was received */
4694         if (do_raise(aTHX_ SIGBREAK))
4695             sig_terminate(aTHX_ SIGBREAK);
4696         return TRUE;
4697
4698     case CTRL_LOGOFF_EVENT:
4699       /*  A signal that the system sends to all console processes when a user is logging
4700           off. This signal does not indicate which user is logging off, so no
4701           assumptions can be made.
4702        */
4703         break;
4704     case CTRL_SHUTDOWN_EVENT:
4705       /*  A signal that the system sends to all console processes when the system is
4706           shutting down.
4707        */
4708         if (do_raise(aTHX_ SIGTERM))
4709             sig_terminate(aTHX_ SIGTERM);
4710         return TRUE;
4711     default:
4712         break;
4713     }
4714     return FALSE;
4715 }
4716
4717
4718 #ifdef SET_INVALID_PARAMETER_HANDLER
4719 #  include <crtdbg.h>
4720 #endif
4721
4722 static void
4723 ansify_path(void)
4724 {
4725     size_t len;
4726     char *ansi_path;
4727     WCHAR *wide_path;
4728     WCHAR *wide_dir;
4729
4730     /* win32_ansipath() requires Windows 2000 or later */
4731     if (!IsWin2000())
4732         return;
4733
4734     /* fetch Unicode version of PATH */
4735     len = 2000;
4736     wide_path = win32_malloc(len*sizeof(WCHAR));
4737     while (wide_path) {
4738         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4739         if (newlen < len)
4740             break;
4741         len = newlen;
4742         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4743     }
4744     if (!wide_path)
4745         return;
4746
4747     /* convert to ANSI pathnames */
4748     wide_dir = wide_path;
4749     ansi_path = NULL;
4750     while (wide_dir) {
4751         WCHAR *sep = wcschr(wide_dir, ';');
4752         char *ansi_dir;
4753         size_t ansi_len;
4754         size_t wide_len;
4755
4756         if (sep)
4757             *sep++ = '\0';
4758
4759         /* remove quotes around pathname */
4760         if (*wide_dir == '"')
4761             ++wide_dir;
4762         wide_len = wcslen(wide_dir);
4763         if (wide_len && wide_dir[wide_len-1] == '"')
4764             wide_dir[wide_len-1] = '\0';
4765
4766         /* append ansi_dir to ansi_path */
4767         ansi_dir = win32_ansipath(wide_dir);
4768         ansi_len = strlen(ansi_dir);
4769         if (ansi_path) {
4770             size_t newlen = len + 1 + ansi_len;
4771             ansi_path = win32_realloc(ansi_path, newlen+1);
4772             if (!ansi_path)
4773                 break;
4774             ansi_path[len] = ';';
4775             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4776             len = newlen;
4777         }
4778         else {
4779             len = ansi_len;
4780             ansi_path = win32_malloc(5+len+1);
4781             if (!ansi_path)
4782                 break;
4783             memcpy(ansi_path, "PATH=", 5);
4784             memcpy(ansi_path+5, ansi_dir, len+1);
4785             len += 5;
4786         }
4787         win32_free(ansi_dir);
4788         wide_dir = sep;
4789     }
4790
4791     if (ansi_path) {
4792         /* Update C RTL environ array.  This will only have full effect if
4793          * perl_parse() is later called with `environ` as the `env` argument.
4794          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4795          *
4796          * We do have to ansify() the PATH before Perl has been fully
4797          * initialized because S_find_script() uses the PATH when perl
4798          * is being invoked with the -S option.  This happens before %ENV
4799          * is initialized in S_init_postdump_symbols().
4800          *
4801          * XXX Is this a bug? Should S_find_script() use the environment
4802          * XXX passed in the `env` arg to parse_perl()?
4803          */
4804         putenv(ansi_path);
4805         /* Keep system environment in sync because S_init_postdump_symbols()
4806          * will not call mg_set() if it initializes %ENV from `environ`.
4807          */
4808         SetEnvironmentVariableA("PATH", ansi_path+5);
4809         /* We are intentionally leaking the ansi_path string here because
4810          * the Borland runtime library puts it directly into the environ
4811          * array.  The Microsoft runtime library seems to make a copy,
4812          * but will leak the copy should it be replaced again later.
4813          * Since this code is only called once during PERL_SYS_INIT this
4814          * shouldn't really matter.
4815          */
4816     }
4817     win32_free(wide_path);
4818 }
4819
4820 void
4821 Perl_win32_init(int *argcp, char ***argvp)
4822 {
4823     HMODULE module;
4824
4825 #ifdef SET_INVALID_PARAMETER_HANDLER
4826     _invalid_parameter_handler oldHandler, newHandler;
4827     newHandler = my_invalid_parameter_handler;
4828     oldHandler = _set_invalid_parameter_handler(newHandler);
4829     _CrtSetReportMode(_CRT_ASSERT, 0);
4830 #endif
4831     /* Disable floating point errors, Perl will trap the ones we
4832      * care about.  VC++ RTL defaults to switching these off
4833      * already, but the Borland RTL doesn't.  Since we don't
4834      * want to be at the vendor's whim on the default, we set
4835      * it explicitly here.
4836      */
4837 #if !defined(_ALPHA_) && !defined(__GNUC__)
4838     _control87(MCW_EM, MCW_EM);
4839 #endif
4840     MALLOC_INIT;
4841
4842     /* When the manifest resource requests Common-Controls v6 then
4843      * user32.dll no longer registers all the Windows classes used for
4844      * standard controls but leaves some of them to be registered by
4845      * comctl32.dll.  InitCommonControls() doesn't do anything but calling
4846      * it makes sure comctl32.dll gets loaded into the process and registers
4847      * the standard control classes.  Without this even normal Windows APIs
4848      * like MessageBox() can fail under some versions of Windows XP.
4849      */
4850     InitCommonControls();
4851
4852     module = GetModuleHandle("ntdll.dll");
4853     if (module) {
4854         *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4855     }
4856
4857     module = GetModuleHandle("kernel32.dll");
4858     if (module) {
4859         *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4860         *(FARPROC*)&pfnProcess32First           = GetProcAddress(module, "Process32First");
4861         *(FARPROC*)&pfnProcess32Next            = GetProcAddress(module, "Process32Next");
4862     }
4863
4864     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4865     GetVersionEx(&g_osver);
4866
4867     ansify_path();
4868 }
4869
4870 void
4871 Perl_win32_term(void)
4872 {
4873     dTHX;
4874     HINTS_REFCNT_TERM;
4875     OP_REFCNT_TERM;
4876     PERLIO_TERM;
4877     MALLOC_TERM;
4878 }
4879
4880 void
4881 win32_get_child_IO(child_IO_table* ptbl)
4882 {
4883     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4884     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4885     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4886 }
4887
4888 Sighandler_t
4889 win32_signal(int sig, Sighandler_t subcode)
4890 {
4891     dTHX;
4892     if (sig < SIG_SIZE) {
4893         int save_errno = errno;
4894         Sighandler_t result = signal(sig, subcode);
4895         if (result == SIG_ERR) {
4896             result = w32_sighandler[sig];
4897             errno = save_errno;
4898         }
4899         w32_sighandler[sig] = subcode;
4900         return result;
4901     }
4902     else {
4903         errno = EINVAL;
4904         return SIG_ERR;
4905     }
4906 }
4907
4908 /* The PerlMessageWindowClass's WindowProc */
4909 LRESULT CALLBACK
4910 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4911 {
4912     return win32_process_message(hwnd, msg, wParam, lParam) ?
4913         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4914 }
4915
4916 /* we use a message filter hook to process thread messages, passing any
4917  * messages that we don't process on to the rest of the hook chain
4918  * Anyone else writing a message loop that wants to play nicely with perl
4919  * should do
4920  *   CallMsgFilter(&msg, MSGF_***);
4921  * between their GetMessage and DispatchMessage calls.  */
4922 LRESULT CALLBACK
4923 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4924     LPMSG pmsg = (LPMSG)lParam;
4925
4926     /* we'll process it if code says we're allowed, and it's a thread message */
4927     if (code >= 0 && pmsg->hwnd == NULL
4928             && win32_process_message(pmsg->hwnd, pmsg->message,
4929                                      pmsg->wParam, pmsg->lParam))
4930     {
4931             return TRUE;
4932     }
4933
4934     /* XXX: MSDN says that hhk is ignored, but we should really use the
4935      * return value from SetWindowsHookEx() in win32_create_message_window().  */
4936     return CallNextHookEx(NULL, code, wParam, lParam);
4937 }
4938
4939 /* The real message handler. Can be called with
4940  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4941  * that it processes */
4942 static LRESULT
4943 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4944 {
4945     /* BEWARE. The context retrieved using dTHX; is the context of the
4946      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4947      * up to and including WM_CREATE.  If it ever happens that you need the
4948      * 'child' context before this, then it needs to be passed into
4949      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4950      * from the lparam of CreateWindow().  It could then be stored/retrieved
4951      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4952      * the dTHX calls here. */
4953     /* XXX For now it is assumed that the overhead of the dTHX; for what
4954      * are relativley infrequent code-paths, is better than the added
4955      * complexity of getting the correct context passed into
4956      * win32_create_message_window() */
4957
4958     switch(msg) {
4959
4960 #ifdef USE_ITHREADS
4961         case WM_USER_MESSAGE: {
4962             long child = find_pseudo_pid((int)wParam);
4963             if (child >= 0) {
4964                 dTHX;
4965                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4966                 return 1;
4967             }
4968             break;
4969         }
4970 #endif
4971
4972         case WM_USER_KILL: {
4973             dTHX;
4974             /* We use WM_USER_KILL to fake kill() with other signals */
4975             int sig = (int)wParam;
4976             if (do_raise(aTHX_ sig))
4977                 sig_terminate(aTHX_ sig);
4978
4979             return 1;
4980         }
4981
4982         case WM_TIMER: {
4983             dTHX;
4984             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4985             if (w32_timerid && w32_timerid==(UINT)wParam) {
4986                 KillTimer(w32_message_hwnd, w32_timerid);
4987                 w32_timerid=0;
4988
4989                 /* Now fake a call to signal handler */
4990                 if (do_raise(aTHX_ 14))
4991                     sig_terminate(aTHX_ 14);
4992
4993                 return 1;
4994             }
4995             break;
4996         }
4997
4998         default:
4999             break;
5000
5001     } /* switch */
5002
5003     /* Above or other stuff may have set a signal flag, and we may not have
5004      * been called from win32_async_check() (e.g. some other GUI's message
5005      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
5006      * handler that die's, and the message loop that calls here is wrapped
5007      * in an eval, then you may well end up with orphaned windows - signals
5008      * are dispatched by win32_async_check() */
5009
5010     return 0;
5011 }
5012
5013 void
5014 win32_create_message_window_class(void)
5015 {
5016     /* create the window class for "message only" windows */
5017     WNDCLASS wc;
5018
5019     Zero(&wc, 1, wc);
5020     wc.lpfnWndProc = win32_message_window_proc;
5021     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
5022     wc.lpszClassName = "PerlMessageWindowClass";
5023
5024     /* second and subsequent calls will fail, but class
5025      * will already be registered */
5026     RegisterClass(&wc);
5027 }
5028
5029 HWND
5030 win32_create_message_window(void)
5031 {
5032     HWND hwnd = NULL;
5033
5034     /* "message-only" windows have been implemented in Windows 2000 and later.
5035      * On earlier versions we'll continue to post messages to a specific
5036      * thread and use hwnd==NULL.  This is brittle when either an embedding
5037      * application or an XS module is also posting messages to hwnd=NULL
5038      * because once removed from the queue they cannot be delivered to the
5039      * "right" place with DispatchMessage() anymore, as there is no WindowProc
5040      * if there is no window handle.
5041      */
5042     /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
5043      * documentation to the contrary, however, there is some evidence that
5044      * there may be problems with the implementation on Win98. As it is not
5045      * officially supported we take the cautious route and stick with thread
5046      * messages (hwnd == NULL) on platforms prior to Win2k.
5047      */
5048     if (IsWin2000()) {
5049         win32_create_message_window_class();
5050
5051         hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
5052                 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
5053     }
5054
5055     /* If we din't create a window for any reason, then we'll use thread
5056      * messages for our signalling, so we install a hook which
5057      * is called by CallMsgFilter in win32_async_check(), or any other
5058      * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5059      * that use OLE, etc. */
5060     if(!hwnd) {
5061         SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5062                 NULL, GetCurrentThreadId());
5063     }
5064
5065     return hwnd;
5066 }
5067
5068 #ifdef HAVE_INTERP_INTERN
5069
5070 static void
5071 win32_csighandler(int sig)
5072 {
5073 #if 0
5074     dTHXa(PERL_GET_SIG_CONTEXT);
5075     Perl_warn(aTHX_ "Got signal %d",sig);
5076 #endif
5077     /* Does nothing */
5078 }
5079
5080 #if defined(__MINGW32__) && defined(__cplusplus)
5081 #define CAST_HWND__(x) (HWND__*)(x)
5082 #else
5083 #define CAST_HWND__(x) x
5084 #endif
5085
5086 void
5087 Perl_sys_intern_init(pTHX)
5088 {
5089     int i;
5090
5091     w32_perlshell_tokens        = NULL;
5092     w32_perlshell_vec           = (char**)NULL;
5093     w32_perlshell_items         = 0;
5094     w32_fdpid                   = newAV();
5095     Newx(w32_children, 1, child_tab);
5096     w32_num_children            = 0;
5097 #  ifdef USE_ITHREADS
5098     w32_pseudo_id               = 0;
5099     Newx(w32_pseudo_children, 1, pseudo_child_tab);
5100     w32_num_pseudo_children     = 0;
5101 #  endif
5102     w32_timerid                 = 0;
5103     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
5104     w32_poll_count              = 0;
5105     for (i=0; i < SIG_SIZE; i++) {
5106         w32_sighandler[i] = SIG_DFL;
5107     }
5108 #  ifdef MULTIPLICITY
5109     if (my_perl == PL_curinterp) {
5110 #  else
5111     {
5112 #  endif
5113         /* Force C runtime signal stuff to set its console handler */
5114         signal(SIGINT,win32_csighandler);
5115         signal(SIGBREAK,win32_csighandler);
5116
5117         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5118          * flag.  This has the side-effect of disabling Ctrl-C events in all
5119          * processes in this group.  At least on Windows NT and later we
5120          * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5121          * with a NULL handler.  This is not valid on Windows 9X.
5122          */
5123         if (IsWinNT())
5124             SetConsoleCtrlHandler(NULL,FALSE);
5125
5126         /* Push our handler on top */
5127         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5128     }
5129 }
5130
5131 void
5132 Perl_sys_intern_clear(pTHX)
5133 {
5134     Safefree(w32_perlshell_tokens);
5135     Safefree(w32_perlshell_vec);
5136     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5137     Safefree(w32_children);
5138     if (w32_timerid) {
5139         KillTimer(w32_message_hwnd, w32_timerid);
5140         w32_timerid = 0;
5141     }
5142     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5143         DestroyWindow(w32_message_hwnd);
5144 #  ifdef MULTIPLICITY
5145     if (my_perl == PL_curinterp) {
5146 #  else
5147     {
5148 #  endif
5149         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5150     }
5151 #  ifdef USE_ITHREADS
5152     Safefree(w32_pseudo_children);
5153 #  endif
5154 }
5155
5156 #  ifdef USE_ITHREADS
5157
5158 void
5159 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5160 {
5161     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5162
5163     dst->perlshell_tokens       = NULL;
5164     dst->perlshell_vec          = (char**)NULL;
5165     dst->perlshell_items        = 0;
5166     dst->fdpid                  = newAV();
5167     Newxz(dst->children, 1, child_tab);
5168     dst->pseudo_id              = 0;
5169     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5170     dst->timerid                = 0;
5171     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
5172     dst->poll_count             = 0;
5173     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5174 }
5175 #  endif /* USE_ITHREADS */
5176 #endif /* HAVE_INTERP_INTERN */