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