win32/win32.c

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