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