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 enable USE_WIN32_RTL_ENV:
1771              *  * environ[] and RTL functions will not reflect changes,
1772              *    which might be an issue if extensions want to access
1773              *    the env. via RTL.  This cuts both ways, since RTL will
1774              *    not see changes made by extensions that call the Win32
1775              *    functions directly, either.
1776              * GSAR 97-06-07
1777              */
1778             *val++ = '\0';
1779             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1780                 relval = 0;
1781         }
1782         Safefree(curitem);
1783     }
1784     return relval;
1785 }
1786
1787 static long
1788 filetime_to_clock(PFILETIME ft)
1789 {
1790     __int64 qw = ft->dwHighDateTime;
1791     qw <<= 32;
1792     qw |= ft->dwLowDateTime;
1793     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1794     return (long) qw;
1795 }
1796
1797 DllExport int
1798 win32_times(struct tms *timebuf)
1799 {
1800     FILETIME user;
1801     FILETIME kernel;
1802     FILETIME dummy;
1803     clock_t process_time_so_far = clock();
1804     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1805                         &kernel,&user)) {
1806         timebuf->tms_utime = filetime_to_clock(&user);
1807         timebuf->tms_stime = filetime_to_clock(&kernel);
1808         timebuf->tms_cutime = 0;
1809         timebuf->tms_cstime = 0;
1810     } else {
1811         /* That failed - e.g. Win95 fallback to clock() */
1812         timebuf->tms_utime = process_time_so_far;
1813         timebuf->tms_stime = 0;
1814         timebuf->tms_cutime = 0;
1815         timebuf->tms_cstime = 0;
1816     }
1817     return process_time_so_far;
1818 }
1819
1820 /* fix utime() so it works on directories in NT */
1821 static BOOL
1822 filetime_from_time(PFILETIME pFileTime, time_t Time)
1823 {
1824     struct tm *pTM = localtime(&Time);
1825     SYSTEMTIME SystemTime;
1826     FILETIME LocalTime;
1827
1828     if (pTM == NULL)
1829         return FALSE;
1830
1831     SystemTime.wYear   = pTM->tm_year + 1900;
1832     SystemTime.wMonth  = pTM->tm_mon + 1;
1833     SystemTime.wDay    = pTM->tm_mday;
1834     SystemTime.wHour   = pTM->tm_hour;
1835     SystemTime.wMinute = pTM->tm_min;
1836     SystemTime.wSecond = pTM->tm_sec;
1837     SystemTime.wMilliseconds = 0;
1838
1839     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1840            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1841 }
1842
1843 DllExport int
1844 win32_unlink(const char *filename)
1845 {
1846     dTHX;
1847     int ret;
1848     DWORD attrs;
1849
1850     filename = PerlDir_mapA(filename);
1851     attrs = GetFileAttributesA(filename);
1852     if (attrs == 0xFFFFFFFF) {
1853         errno = ENOENT;
1854         return -1;
1855     }
1856     if (attrs & FILE_ATTRIBUTE_READONLY) {
1857         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1858         ret = unlink(filename);
1859         if (ret == -1)
1860             (void)SetFileAttributesA(filename, attrs);
1861     }
1862     else
1863         ret = unlink(filename);
1864     return ret;
1865 }
1866
1867 DllExport int
1868 win32_utime(const char *filename, struct utimbuf *times)
1869 {
1870     dTHX;
1871     HANDLE handle;
1872     FILETIME ftCreate;
1873     FILETIME ftAccess;
1874     FILETIME ftWrite;
1875     struct utimbuf TimeBuffer;
1876     int rc;
1877
1878     filename = PerlDir_mapA(filename);
1879     rc = utime(filename, times);
1880
1881     /* EACCES: path specifies directory or readonly file */
1882     if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1883         return rc;
1884
1885     if (times == NULL) {
1886         times = &TimeBuffer;
1887         time(&times->actime);
1888         times->modtime = times->actime;
1889     }
1890
1891     /* This will (and should) still fail on readonly files */
1892     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1893                          FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1894                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1895     if (handle == INVALID_HANDLE_VALUE)
1896         return rc;
1897
1898     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1899         filetime_from_time(&ftAccess, times->actime) &&
1900         filetime_from_time(&ftWrite, times->modtime) &&
1901         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1902     {
1903         rc = 0;
1904     }
1905
1906     CloseHandle(handle);
1907     return rc;
1908 }
1909
1910 typedef union {
1911     unsigned __int64    ft_i64;
1912     FILETIME            ft_val;
1913 } FT_t;
1914
1915 #ifdef __GNUC__
1916 #define Const64(x) x##LL
1917 #else
1918 #define Const64(x) x##i64
1919 #endif
1920 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1921 #define EPOCH_BIAS  Const64(116444736000000000)
1922
1923 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1924  * and appears to be unsupported even by glibc) */
1925 DllExport int
1926 win32_gettimeofday(struct timeval *tp, void *not_used)
1927 {
1928     FT_t ft;
1929
1930     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
1931     GetSystemTimeAsFileTime(&ft.ft_val);
1932
1933     /* seconds since epoch */
1934     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1935
1936     /* microseconds remaining */
1937     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1938
1939     return 0;
1940 }
1941
1942 DllExport int
1943 win32_uname(struct utsname *name)
1944 {
1945     struct hostent *hep;
1946     STRLEN nodemax = sizeof(name->nodename)-1;
1947
1948     /* sysname */
1949     switch (g_osver.dwPlatformId) {
1950     case VER_PLATFORM_WIN32_WINDOWS:
1951         strcpy(name->sysname, "Windows");
1952         break;
1953     case VER_PLATFORM_WIN32_NT:
1954         strcpy(name->sysname, "Windows NT");
1955         break;
1956     case VER_PLATFORM_WIN32s:
1957         strcpy(name->sysname, "Win32s");
1958         break;
1959     default:
1960         strcpy(name->sysname, "Win32 Unknown");
1961         break;
1962     }
1963
1964     /* release */
1965     sprintf(name->release, "%d.%d",
1966             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1967
1968     /* version */
1969     sprintf(name->version, "Build %d",
1970             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1971             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1972     if (g_osver.szCSDVersion[0]) {
1973         char *buf = name->version + strlen(name->version);
1974         sprintf(buf, " (%s)", g_osver.szCSDVersion);
1975     }
1976
1977     /* nodename */
1978     hep = win32_gethostbyname("localhost");
1979     if (hep) {
1980         STRLEN len = strlen(hep->h_name);
1981         if (len <= nodemax) {
1982             strcpy(name->nodename, hep->h_name);
1983         }
1984         else {
1985             strncpy(name->nodename, hep->h_name, nodemax);
1986             name->nodename[nodemax] = '\0';
1987         }
1988     }
1989     else {
1990         DWORD sz = nodemax;
1991         if (!GetComputerName(name->nodename, &sz))
1992             *name->nodename = '\0';
1993     }
1994
1995     /* machine (architecture) */
1996     {
1997         SYSTEM_INFO info;
1998         DWORD procarch;
1999         char *arch;
2000         GetSystemInfo(&info);
2001
2002 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2003  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2004         procarch = info.u.s.wProcessorArchitecture;
2005 #else
2006         procarch = info.wProcessorArchitecture;
2007 #endif
2008         switch (procarch) {
2009         case PROCESSOR_ARCHITECTURE_INTEL:
2010             arch = "x86"; break;
2011         case PROCESSOR_ARCHITECTURE_MIPS:
2012             arch = "mips"; break;
2013         case PROCESSOR_ARCHITECTURE_ALPHA:
2014             arch = "alpha"; break;
2015         case PROCESSOR_ARCHITECTURE_PPC:
2016             arch = "ppc"; break;
2017 #ifdef PROCESSOR_ARCHITECTURE_SHX
2018         case PROCESSOR_ARCHITECTURE_SHX:
2019             arch = "shx"; break;
2020 #endif
2021 #ifdef PROCESSOR_ARCHITECTURE_ARM
2022         case PROCESSOR_ARCHITECTURE_ARM:
2023             arch = "arm"; break;
2024 #endif
2025 #ifdef PROCESSOR_ARCHITECTURE_IA64
2026         case PROCESSOR_ARCHITECTURE_IA64:
2027             arch = "ia64"; break;
2028 #endif
2029 #ifdef PROCESSOR_ARCHITECTURE_ALPHA64
2030         case PROCESSOR_ARCHITECTURE_ALPHA64:
2031             arch = "alpha64"; break;
2032 #endif
2033 #ifdef PROCESSOR_ARCHITECTURE_MSIL
2034         case PROCESSOR_ARCHITECTURE_MSIL:
2035             arch = "msil"; break;
2036 #endif
2037 #ifdef PROCESSOR_ARCHITECTURE_AMD64
2038         case PROCESSOR_ARCHITECTURE_AMD64:
2039             arch = "amd64"; break;
2040 #endif
2041 #ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
2042         case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
2043             arch = "ia32-64"; break;
2044 #endif
2045 #ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
2046         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2047             arch = "unknown"; break;
2048 #endif
2049         default:
2050             sprintf(name->machine, "unknown(0x%x)", procarch);
2051             arch = name->machine;
2052             break;
2053         }
2054         if (name->machine != arch)
2055             strcpy(name->machine, arch);
2056     }
2057     return 0;
2058 }
2059
2060 /* Timing related stuff */
2061
2062 int
2063 do_raise(pTHX_ int sig)
2064 {
2065     if (sig < SIG_SIZE) {
2066         Sighandler_t handler = w32_sighandler[sig];
2067         if (handler == SIG_IGN) {
2068             return 0;
2069         }
2070         else if (handler != SIG_DFL) {
2071             (*handler)(sig);
2072             return 0;
2073         }
2074         else {
2075             /* Choose correct default behaviour */
2076             switch (sig) {
2077 #ifdef SIGCLD
2078                 case SIGCLD:
2079 #endif
2080 #ifdef SIGCHLD
2081                 case SIGCHLD:
2082 #endif
2083                 case 0:
2084                     return 0;
2085                 case SIGTERM:
2086                 default:
2087                     break;
2088             }
2089         }
2090     }
2091     /* Tell caller to exit thread/process as approriate */
2092     return 1;
2093 }
2094
2095 void
2096 sig_terminate(pTHX_ int sig)
2097 {
2098     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2099     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2100        thread
2101      */
2102     exit(sig);
2103 }
2104
2105 DllExport int
2106 win32_async_check(pTHX)
2107 {
2108     MSG msg;
2109     HWND hwnd = w32_message_hwnd;
2110
2111     /* Reset w32_poll_count before doing anything else, incase we dispatch
2112      * messages that end up calling back into perl */
2113     w32_poll_count = 0;
2114
2115     if (hwnd != INVALID_HANDLE_VALUE) {
2116         /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2117         * and ignores window messages - should co-exist better with windows apps e.g. Tk
2118         */
2119         if (hwnd == NULL)
2120             hwnd = (HWND)-1;
2121
2122         while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2123                PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2124         {
2125             /* re-post a WM_QUIT message (we'll mark it as read later) */
2126             if(msg.message == WM_QUIT) {
2127                 PostQuitMessage((int)msg.wParam);
2128                 break;
2129             }
2130
2131             if(!CallMsgFilter(&msg, MSGF_USER))
2132             {
2133                 TranslateMessage(&msg);
2134                 DispatchMessage(&msg);
2135             }
2136         }
2137     }
2138
2139     /* Call PeekMessage() to mark all pending messages in the queue as "old".
2140      * This is necessary when we are being called by win32_msgwait() to
2141      * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2142      * message over and over.  An example how this can happen is when
2143      * Perl is calling win32_waitpid() inside a GUI application and the GUI
2144      * is generating messages before the process terminated.
2145      */
2146     PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2147
2148     /* Above or other stuff may have set a signal flag */
2149     if (PL_sig_pending)
2150         despatch_signals();
2151
2152     return 1;
2153 }
2154
2155 /* This function will not return until the timeout has elapsed, or until
2156  * one of the handles is ready. */
2157 DllExport DWORD
2158 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2159 {
2160     /* We may need several goes at this - so compute when we stop */
2161     DWORD ticks = 0;
2162     if (timeout != INFINITE) {
2163         ticks = GetTickCount();
2164         timeout += ticks;
2165     }
2166     while (1) {
2167         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2168         if (resultp)
2169            *resultp = result;
2170         if (result == WAIT_TIMEOUT) {
2171             /* Ran out of time - explicit return of zero to avoid -ve if we
2172                have scheduling issues
2173              */
2174             return 0;
2175         }
2176         if (timeout != INFINITE) {
2177             ticks = GetTickCount();
2178         }
2179         if (result == WAIT_OBJECT_0 + count) {
2180             /* Message has arrived - check it */
2181             (void)win32_async_check(aTHX);
2182         }
2183         else {
2184            /* Not timeout or message - one of handles is ready */
2185            break;
2186         }
2187     }
2188     /* compute time left to wait */
2189     ticks = timeout - ticks;
2190     /* If we are past the end say zero */
2191     return (ticks > 0) ? ticks : 0;
2192 }
2193
2194 int
2195 win32_internal_wait(int *status, DWORD timeout)
2196 {
2197     /* XXX this wait emulation only knows about processes
2198      * spawned via win32_spawnvp(P_NOWAIT, ...).
2199      */
2200     dTHX;
2201     int i, retval;
2202     DWORD exitcode, waitcode;
2203
2204 #ifdef USE_ITHREADS
2205     if (w32_num_pseudo_children) {
2206         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2207                       timeout, &waitcode);
2208         /* Time out here if there are no other children to wait for. */
2209         if (waitcode == WAIT_TIMEOUT) {
2210             if (!w32_num_children) {
2211                 return 0;
2212             }
2213         }
2214         else if (waitcode != WAIT_FAILED) {
2215             if (waitcode >= WAIT_ABANDONED_0
2216                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2217                 i = waitcode - WAIT_ABANDONED_0;
2218             else
2219                 i = waitcode - WAIT_OBJECT_0;
2220             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2221                 *status = (int)((exitcode & 0xff) << 8);
2222                 retval = (int)w32_pseudo_child_pids[i];
2223                 remove_dead_pseudo_process(i);
2224                 return -retval;
2225             }
2226         }
2227     }
2228 #endif
2229
2230     if (!w32_num_children) {
2231         errno = ECHILD;
2232         return -1;
2233     }
2234
2235     /* if a child exists, wait for it to die */
2236     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2237     if (waitcode == WAIT_TIMEOUT) {
2238         return 0;
2239     }
2240     if (waitcode != WAIT_FAILED) {
2241         if (waitcode >= WAIT_ABANDONED_0
2242             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2243             i = waitcode - WAIT_ABANDONED_0;
2244         else
2245             i = waitcode - WAIT_OBJECT_0;
2246         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2247             *status = (int)((exitcode & 0xff) << 8);
2248             retval = (int)w32_child_pids[i];
2249             remove_dead_process(i);
2250             return retval;
2251         }
2252     }
2253
2254     errno = GetLastError();
2255     return -1;
2256 }
2257
2258 DllExport int
2259 win32_waitpid(int pid, int *status, int flags)
2260 {
2261     dTHX;
2262     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2263     int retval = -1;
2264     long child;
2265     if (pid == -1)                              /* XXX threadid == 1 ? */
2266         return win32_internal_wait(status, timeout);
2267 #ifdef USE_ITHREADS
2268     else if (pid < 0) {
2269         child = find_pseudo_pid(-pid);
2270         if (child >= 0) {
2271             HANDLE hThread = w32_pseudo_child_handles[child];
2272             DWORD waitcode;
2273             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2274             if (waitcode == WAIT_TIMEOUT) {
2275                 return 0;
2276             }
2277             else if (waitcode == WAIT_OBJECT_0) {
2278                 if (GetExitCodeThread(hThread, &waitcode)) {
2279                     *status = (int)((waitcode & 0xff) << 8);
2280                     retval = (int)w32_pseudo_child_pids[child];
2281                     remove_dead_pseudo_process(child);
2282                     return -retval;
2283                 }
2284             }
2285             else
2286                 errno = ECHILD;
2287         }
2288         else if (IsWin95()) {
2289             pid = -pid;
2290             goto alien_process;
2291         }
2292     }
2293 #endif
2294     else {
2295         HANDLE hProcess;
2296         DWORD waitcode;
2297         child = find_pid(pid);
2298         if (child >= 0) {
2299             hProcess = w32_child_handles[child];
2300             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2301             if (waitcode == WAIT_TIMEOUT) {
2302                 return 0;
2303             }
2304             else if (waitcode == WAIT_OBJECT_0) {
2305                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2306                     *status = (int)((waitcode & 0xff) << 8);
2307                     retval = (int)w32_child_pids[child];
2308                     remove_dead_process(child);
2309                     return retval;
2310                 }
2311             }
2312             else
2313                 errno = ECHILD;
2314         }
2315         else {
2316 alien_process:
2317             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2318                                    (IsWin95() ? -pid : pid));
2319             if (hProcess) {
2320                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2321                 if (waitcode == WAIT_TIMEOUT) {
2322                     CloseHandle(hProcess);
2323                     return 0;
2324                 }
2325                 else if (waitcode == WAIT_OBJECT_0) {
2326                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2327                         *status = (int)((waitcode & 0xff) << 8);
2328                         CloseHandle(hProcess);
2329                         return pid;
2330                     }
2331                 }
2332                 CloseHandle(hProcess);
2333             }
2334             else
2335                 errno = ECHILD;
2336         }
2337     }
2338     return retval >= 0 ? pid : retval;
2339 }
2340
2341 DllExport int
2342 win32_wait(int *status)
2343 {
2344     return win32_internal_wait(status, INFINITE);
2345 }
2346
2347 DllExport unsigned int
2348 win32_sleep(unsigned int t)
2349 {
2350     dTHX;
2351     /* Win32 times are in ms so *1000 in and /1000 out */
2352     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2353 }
2354
2355 DllExport unsigned int
2356 win32_alarm(unsigned int sec)
2357 {
2358     /*
2359      * the 'obvious' implentation is SetTimer() with a callback
2360      * which does whatever receiving SIGALRM would do
2361      * we cannot use SIGALRM even via raise() as it is not
2362      * one of the supported codes in <signal.h>
2363      */
2364     dTHX;
2365
2366     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2367         w32_message_hwnd = win32_create_message_window();
2368
2369     if (sec) {
2370         if (w32_message_hwnd == NULL)
2371             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2372         else {
2373             w32_timerid = 1;
2374             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2375         }
2376     }
2377     else {
2378         if (w32_timerid) {
2379             KillTimer(w32_message_hwnd, w32_timerid);
2380             w32_timerid = 0;
2381         }
2382     }
2383     return 0;
2384 }
2385
2386 #ifdef HAVE_DES_FCRYPT
2387 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2388 #endif
2389
2390 DllExport char *
2391 win32_crypt(const char *txt, const char *salt)
2392 {
2393     dTHX;
2394 #ifdef HAVE_DES_FCRYPT
2395     return des_fcrypt(txt, salt, w32_crypt_buffer);
2396 #else
2397     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2398     return NULL;
2399 #endif
2400 }
2401
2402 #ifdef USE_FIXED_OSFHANDLE
2403
2404 #define FOPEN                   0x01    /* file handle open */
2405 #define FNOINHERIT              0x10    /* file handle opened O_NOINHERIT */
2406 #define FAPPEND                 0x20    /* file handle opened O_APPEND */
2407 #define FDEV                    0x40    /* file handle refers to device */
2408 #define FTEXT                   0x80    /* file handle is in text mode */
2409
2410 /***
2411 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2412 *
2413 *Purpose:
2414 *       This function allocates a free C Runtime file handle and associates
2415 *       it with the Win32 HANDLE specified by the first parameter. This is a
2416 *       temperary fix for WIN95's brain damage GetFileType() error on socket
2417 *       we just bypass that call for socket
2418 *
2419 *       This works with MSVC++ 4.0+ or GCC/Mingw32
2420 *
2421 *Entry:
2422 *       intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2423 *       int flags      - flags to associate with C Runtime file handle.
2424 *
2425 *Exit:
2426 *       returns index of entry in fh, if successful
2427 *       return -1, if no free entry is found
2428 *
2429 *Exceptions:
2430 *
2431 *******************************************************************************/
2432
2433 /*
2434  * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2435  * this lets sockets work on Win9X with GCC and should fix the problems
2436  * with perl95.exe
2437  *      -- BKS, 1-23-2000
2438 */
2439
2440 /* create an ioinfo entry, kill its handle, and steal the entry */
2441
2442 static int
2443 _alloc_osfhnd(void)
2444 {
2445     HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2446     int fh = _open_osfhandle((intptr_t)hF, 0);
2447     CloseHandle(hF);
2448     if (fh == -1)
2449         return fh;
2450     EnterCriticalSection(&(_pioinfo(fh)->lock));
2451     return fh;
2452 }
2453
2454 static int
2455 my_open_osfhandle(intptr_t osfhandle, int flags)
2456 {
2457     int fh;
2458     char fileflags;             /* _osfile flags */
2459
2460     /* copy relevant flags from second parameter */
2461     fileflags = FDEV;
2462
2463     if (flags & O_APPEND)
2464         fileflags |= FAPPEND;
2465
2466     if (flags & O_TEXT)
2467         fileflags |= FTEXT;
2468
2469     if (flags & O_NOINHERIT)
2470         fileflags |= FNOINHERIT;
2471
2472     /* attempt to allocate a C Runtime file handle */
2473     if ((fh = _alloc_osfhnd()) == -1) {
2474         errno = EMFILE;         /* too many open files */
2475         _doserrno = 0L;         /* not an OS error */
2476         return -1;              /* return error to caller */
2477     }
2478
2479     /* the file is open. now, set the info in _osfhnd array */
2480     _set_osfhnd(fh, osfhandle);
2481
2482     fileflags |= FOPEN;         /* mark as open */
2483
2484     _osfile(fh) = fileflags;    /* set osfile entry */
2485     LeaveCriticalSection(&_pioinfo(fh)->lock);
2486
2487     return fh;                  /* return handle */
2488 }
2489
2490 #endif  /* USE_FIXED_OSFHANDLE */
2491
2492 /* simulate flock by locking a range on the file */
2493
2494 #define LK_ERR(f,i)     ((f) ? (i = 0) : (errno = GetLastError()))
2495 #define LK_LEN          0xffff0000
2496
2497 DllExport int
2498 win32_flock(int fd, int oper)
2499 {
2500     OVERLAPPED o;
2501     int i = -1;
2502     HANDLE fh;
2503
2504     if (!IsWinNT()) {
2505         dTHX;
2506         Perl_croak_nocontext("flock() unimplemented on this platform");
2507         return -1;
2508     }
2509     fh = (HANDLE)_get_osfhandle(fd);
2510     memset(&o, 0, sizeof(o));
2511
2512     switch(oper) {
2513     case LOCK_SH:               /* shared lock */
2514         LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2515         break;
2516     case LOCK_EX:               /* exclusive lock */
2517         LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2518         break;
2519     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2520         LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2521         break;
2522     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2523         LK_ERR(LockFileEx(fh,
2524                        LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2525                        0, LK_LEN, 0, &o),i);
2526         break;
2527     case LOCK_UN:               /* unlock lock */
2528         LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2529         break;
2530     default:                    /* unknown */
2531         errno = EINVAL;
2532         break;
2533     }
2534     return i;
2535 }
2536
2537 #undef LK_ERR
2538 #undef LK_LEN
2539
2540 /*
2541  *  redirected io subsystem for all XS modules
2542  *
2543  */
2544
2545 DllExport int *
2546 win32_errno(void)
2547 {
2548     return (&errno);
2549 }
2550
2551 DllExport char ***
2552 win32_environ(void)
2553 {
2554     return (&(_environ));
2555 }
2556
2557 /* the rest are the remapped stdio routines */
2558 DllExport FILE *
2559 win32_stderr(void)
2560 {
2561     return (stderr);
2562 }
2563
2564 DllExport FILE *
2565 win32_stdin(void)
2566 {
2567     return (stdin);
2568 }
2569
2570 DllExport FILE *
2571 win32_stdout(void)
2572 {
2573     return (stdout);
2574 }
2575
2576 DllExport int
2577 win32_ferror(FILE *fp)
2578 {
2579     return (ferror(fp));
2580 }
2581
2582
2583 DllExport int
2584 win32_feof(FILE *fp)
2585 {
2586     return (feof(fp));
2587 }
2588
2589 /*
2590  * Since the errors returned by the socket error function
2591  * WSAGetLastError() are not known by the library routine strerror
2592  * we have to roll our own.
2593  */
2594
2595 DllExport char *
2596 win32_strerror(int e)
2597 {
2598 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2599     extern int sys_nerr;
2600 #endif
2601     DWORD source = 0;
2602
2603     if (e < 0 || e > sys_nerr) {
2604         dTHX;
2605         if (e < 0)
2606             e = GetLastError();
2607
2608         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2609                           w32_strerror_buffer,
2610                           sizeof(w32_strerror_buffer), NULL) == 0)
2611             strcpy(w32_strerror_buffer, "Unknown Error");
2612
2613         return w32_strerror_buffer;
2614     }
2615     return strerror(e);
2616 }
2617
2618 DllExport void
2619 win32_str_os_error(void *sv, DWORD dwErr)
2620 {
2621     DWORD dwLen;
2622     char *sMsg;
2623     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2624                           |FORMAT_MESSAGE_IGNORE_INSERTS
2625                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2626                            dwErr, 0, (char *)&sMsg, 1, NULL);
2627     /* strip trailing whitespace and period */
2628     if (0 < dwLen) {
2629         do {
2630             --dwLen;    /* dwLen doesn't include trailing null */
2631         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2632         if ('.' != sMsg[dwLen])
2633             dwLen++;
2634         sMsg[dwLen] = '\0';
2635     }
2636     if (0 == dwLen) {
2637         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2638         if (sMsg)
2639             dwLen = sprintf(sMsg,
2640                             "Unknown error #0x%lX (lookup 0x%lX)",
2641                             dwErr, GetLastError());
2642     }
2643     if (sMsg) {
2644         dTHX;
2645         sv_setpvn((SV*)sv, sMsg, dwLen);
2646         LocalFree(sMsg);
2647     }
2648 }
2649
2650 DllExport int
2651 win32_fprintf(FILE *fp, const char *format, ...)
2652 {
2653     va_list marker;
2654     va_start(marker, format);     /* Initialize variable arguments. */
2655
2656     return (vfprintf(fp, format, marker));
2657 }
2658
2659 DllExport int
2660 win32_printf(const char *format, ...)
2661 {
2662     va_list marker;
2663     va_start(marker, format);     /* Initialize variable arguments. */
2664
2665     return (vprintf(format, marker));
2666 }
2667
2668 DllExport int
2669 win32_vfprintf(FILE *fp, const char *format, va_list args)
2670 {
2671     return (vfprintf(fp, format, args));
2672 }
2673
2674 DllExport int
2675 win32_vprintf(const char *format, va_list args)
2676 {
2677     return (vprintf(format, args));
2678 }
2679
2680 DllExport size_t
2681 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2682 {
2683     return fread(buf, size, count, fp);
2684 }
2685
2686 DllExport size_t
2687 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2688 {
2689     return fwrite(buf, size, count, fp);
2690 }
2691
2692 #define MODE_SIZE 10
2693
2694 DllExport FILE *
2695 win32_fopen(const char *filename, const char *mode)
2696 {
2697     dTHX;
2698     FILE *f;
2699
2700     if (!*filename)
2701         return NULL;
2702
2703     if (stricmp(filename, "/dev/null")==0)
2704         filename = "NUL";
2705
2706     f = fopen(PerlDir_mapA(filename), mode);
2707     /* avoid buffering headaches for child processes */
2708     if (f && *mode == 'a')
2709         win32_fseek(f, 0, SEEK_END);
2710     return f;
2711 }
2712
2713 #ifndef USE_SOCKETS_AS_HANDLES
2714 #undef fdopen
2715 #define fdopen my_fdopen
2716 #endif
2717
2718 DllExport FILE *
2719 win32_fdopen(int handle, const char *mode)
2720 {
2721     dTHX;
2722     FILE *f;
2723     f = fdopen(handle, (char *) mode);
2724     /* avoid buffering headaches for child processes */
2725     if (f && *mode == 'a')
2726         win32_fseek(f, 0, SEEK_END);
2727     return f;
2728 }
2729
2730 DllExport FILE *
2731 win32_freopen(const char *path, const char *mode, FILE *stream)
2732 {
2733     dTHX;
2734     if (stricmp(path, "/dev/null")==0)
2735         path = "NUL";
2736
2737     return freopen(PerlDir_mapA(path), mode, stream);
2738 }
2739
2740 DllExport int
2741 win32_fclose(FILE *pf)
2742 {
2743     return my_fclose(pf);       /* defined in win32sck.c */
2744 }
2745
2746 DllExport int
2747 win32_fputs(const char *s,FILE *pf)
2748 {
2749     return fputs(s, pf);
2750 }
2751
2752 DllExport int
2753 win32_fputc(int c,FILE *pf)
2754 {
2755     return fputc(c,pf);
2756 }
2757
2758 DllExport int
2759 win32_ungetc(int c,FILE *pf)
2760 {
2761     return ungetc(c,pf);
2762 }
2763
2764 DllExport int
2765 win32_getc(FILE *pf)
2766 {
2767     return getc(pf);
2768 }
2769
2770 DllExport int
2771 win32_fileno(FILE *pf)
2772 {
2773     return fileno(pf);
2774 }
2775
2776 DllExport void
2777 win32_clearerr(FILE *pf)
2778 {
2779     clearerr(pf);
2780     return;
2781 }
2782
2783 DllExport int
2784 win32_fflush(FILE *pf)
2785 {
2786     return fflush(pf);
2787 }
2788
2789 DllExport Off_t
2790 win32_ftell(FILE *pf)
2791 {
2792 #if defined(WIN64) || defined(USE_LARGE_FILES)
2793 #if defined(__BORLANDC__) /* buk */
2794     return win32_tell( fileno( pf ) );
2795 #else
2796     fpos_t pos;
2797     if (fgetpos(pf, &pos))
2798         return -1;
2799     return (Off_t)pos;
2800 #endif
2801 #else
2802     return ftell(pf);
2803 #endif
2804 }
2805
2806 DllExport int
2807 win32_fseek(FILE *pf, Off_t offset,int origin)
2808 {
2809 #if defined(WIN64) || defined(USE_LARGE_FILES)
2810 #if defined(__BORLANDC__) /* buk */
2811     return win32_lseek(
2812         fileno(pf),
2813         offset,
2814         origin
2815         );
2816 #else
2817     fpos_t pos;
2818     switch (origin) {
2819     case SEEK_CUR:
2820         if (fgetpos(pf, &pos))
2821             return -1;
2822         offset += pos;
2823         break;
2824     case SEEK_END:
2825         fseek(pf, 0, SEEK_END);
2826         pos = _telli64(fileno(pf));
2827         offset += pos;
2828         break;
2829     case SEEK_SET:
2830         break;
2831     default:
2832         errno = EINVAL;
2833         return -1;
2834     }
2835     return fsetpos(pf, &offset);
2836 #endif
2837 #else
2838     return fseek(pf, (long)offset, origin);
2839 #endif
2840 }
2841
2842 DllExport int
2843 win32_fgetpos(FILE *pf,fpos_t *p)
2844 {
2845 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2846     if( win32_tell(fileno(pf)) == -1L ) {
2847         errno = EBADF;
2848         return -1;
2849     }
2850     return 0;
2851 #else
2852     return fgetpos(pf, p);
2853 #endif
2854 }
2855
2856 DllExport int
2857 win32_fsetpos(FILE *pf,const fpos_t *p)
2858 {
2859 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2860     return win32_lseek(fileno(pf), *p, SEEK_CUR);
2861 #else
2862     return fsetpos(pf, p);
2863 #endif
2864 }
2865
2866 DllExport void
2867 win32_rewind(FILE *pf)
2868 {
2869     rewind(pf);
2870     return;
2871 }
2872
2873 DllExport int
2874 win32_tmpfd(void)
2875 {
2876     dTHX;
2877     char prefix[MAX_PATH+1];
2878     char filename[MAX_PATH+1];
2879     DWORD len = GetTempPath(MAX_PATH, prefix);
2880     if (len && len < MAX_PATH) {
2881         if (GetTempFileName(prefix, "plx", 0, filename)) {
2882             HANDLE fh = CreateFile(filename,
2883                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2884                                    0,
2885                                    NULL,
2886                                    CREATE_ALWAYS,
2887                                    FILE_ATTRIBUTE_NORMAL
2888                                    | FILE_FLAG_DELETE_ON_CLOSE,
2889                                    NULL);
2890             if (fh != INVALID_HANDLE_VALUE) {
2891                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2892                 if (fd >= 0) {
2893 #if defined(__BORLANDC__)
2894                     setmode(fd,O_BINARY);
2895 #endif
2896                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2897                                           "Created tmpfile=%s\n",filename));
2898                     return fd;
2899                 }
2900             }
2901         }
2902     }
2903     return -1;
2904 }
2905
2906 DllExport FILE*
2907 win32_tmpfile(void)
2908 {
2909     int fd = win32_tmpfd();
2910     if (fd >= 0)
2911         return win32_fdopen(fd, "w+b");
2912     return NULL;
2913 }
2914
2915 DllExport void
2916 win32_abort(void)
2917 {
2918     abort();
2919     return;
2920 }
2921
2922 DllExport int
2923 win32_fstat(int fd, Stat_t *sbufptr)
2924 {
2925 #ifdef __BORLANDC__
2926     /* A file designated by filehandle is not shown as accessible
2927      * for write operations, probably because it is opened for reading.
2928      * --Vadim Konovalov
2929      */
2930     BY_HANDLE_FILE_INFORMATION bhfi;
2931 #if defined(WIN64) || defined(USE_LARGE_FILES)
2932     /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2933     struct stat tmp;
2934     int rc = fstat(fd,&tmp);
2935
2936     sbufptr->st_dev   = tmp.st_dev;
2937     sbufptr->st_ino   = tmp.st_ino;
2938     sbufptr->st_mode  = tmp.st_mode;
2939     sbufptr->st_nlink = tmp.st_nlink;
2940     sbufptr->st_uid   = tmp.st_uid;
2941     sbufptr->st_gid   = tmp.st_gid;
2942     sbufptr->st_rdev  = tmp.st_rdev;
2943     sbufptr->st_size  = tmp.st_size;
2944     sbufptr->st_atime = tmp.st_atime;
2945     sbufptr->st_mtime = tmp.st_mtime;
2946     sbufptr->st_ctime = tmp.st_ctime;
2947 #else
2948     int rc = fstat(fd,sbufptr);
2949 #endif
2950
2951     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2952 #if defined(WIN64) || defined(USE_LARGE_FILES)
2953         sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2954 #endif
2955         sbufptr->st_mode &= 0xFE00;
2956         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2957             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2958         else
2959             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2960               + ((S_IREAD|S_IWRITE) >> 6));
2961     }
2962     return rc;
2963 #else
2964     return my_fstat(fd,sbufptr);
2965 #endif
2966 }
2967
2968 DllExport int
2969 win32_pipe(int *pfd, unsigned int size, int mode)
2970 {
2971     return _pipe(pfd, size, mode);
2972 }
2973
2974 DllExport PerlIO*
2975 win32_popenlist(const char *mode, IV narg, SV **args)
2976 {
2977  dTHX;
2978  Perl_croak(aTHX_ "List form of pipe open not implemented");
2979  return NULL;
2980 }
2981
2982 /*
2983  * a popen() clone that respects PERL5SHELL
2984  *
2985  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2986  */
2987
2988 DllExport PerlIO*
2989 win32_popen(const char *command, const char *mode)
2990 {
2991 #ifdef USE_RTL_POPEN
2992     return _popen(command, mode);
2993 #else
2994     dTHX;
2995     int p[2];
2996     int parent, child;
2997     int stdfd, oldfd;
2998     int ourmode;
2999     int childpid;
3000     DWORD nhandle;
3001     HANDLE old_h;
3002     int lock_held = 0;
3003
3004     /* establish which ends read and write */
3005     if (strchr(mode,'w')) {
3006         stdfd = 0;              /* stdin */
3007         parent = 1;
3008         child = 0;
3009         nhandle = STD_INPUT_HANDLE;
3010     }
3011     else if (strchr(mode,'r')) {
3012         stdfd = 1;              /* stdout */
3013         parent = 0;
3014         child = 1;
3015         nhandle = STD_OUTPUT_HANDLE;
3016     }
3017     else
3018         return NULL;
3019
3020     /* set the correct mode */
3021     if (strchr(mode,'b'))
3022         ourmode = O_BINARY;
3023     else if (strchr(mode,'t'))
3024         ourmode = O_TEXT;
3025     else
3026         ourmode = _fmode & (O_TEXT | O_BINARY);
3027
3028     /* the child doesn't inherit handles */
3029     ourmode |= O_NOINHERIT;
3030
3031     if (win32_pipe(p, 512, ourmode) == -1)
3032         return NULL;
3033
3034     /* save the old std handle (this needs to happen before the
3035      * dup2(), since that might call SetStdHandle() too) */
3036     OP_REFCNT_LOCK;
3037     lock_held = 1;
3038     old_h = GetStdHandle(nhandle);
3039
3040     /* save current stdfd */
3041     if ((oldfd = win32_dup(stdfd)) == -1)
3042         goto cleanup;
3043
3044     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
3045     /* stdfd will be inherited by the child */
3046     if (win32_dup2(p[child], stdfd) == -1)
3047         goto cleanup;
3048
3049     /* close the child end in parent */
3050     win32_close(p[child]);
3051
3052     /* set the new std handle (in case dup2() above didn't) */
3053     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
3054
3055     /* start the child */
3056     {
3057         dTHX;
3058         if ((childpid = do_spawn_nowait((char*)command)) == -1)
3059             goto cleanup;
3060
3061         /* revert stdfd to whatever it was before */
3062         if (win32_dup2(oldfd, stdfd) == -1)
3063             goto cleanup;
3064
3065         /* close saved handle */
3066         win32_close(oldfd);
3067
3068         /* restore the old std handle (this needs to happen after the
3069          * dup2(), since that might call SetStdHandle() too */
3070         if (lock_held) {
3071             SetStdHandle(nhandle, old_h);
3072             OP_REFCNT_UNLOCK;
3073             lock_held = 0;
3074         }
3075
3076         LOCK_FDPID_MUTEX;
3077         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3078         UNLOCK_FDPID_MUTEX;
3079
3080         /* set process id so that it can be returned by perl's open() */
3081         PL_forkprocess = childpid;
3082     }
3083
3084     /* we have an fd, return a file stream */
3085     return (PerlIO_fdopen(p[parent], (char *)mode));
3086
3087 cleanup:
3088     /* we don't need to check for errors here */
3089     win32_close(p[0]);
3090     win32_close(p[1]);
3091     if (oldfd != -1) {
3092         win32_dup2(oldfd, stdfd);
3093         win32_close(oldfd);
3094     }
3095     if (lock_held) {
3096         SetStdHandle(nhandle, old_h);
3097         OP_REFCNT_UNLOCK;
3098         lock_held = 0;
3099     }
3100     return (NULL);
3101
3102 #endif /* USE_RTL_POPEN */
3103 }
3104
3105 /*
3106  * pclose() clone
3107  */
3108
3109 DllExport int
3110 win32_pclose(PerlIO *pf)
3111 {
3112 #ifdef USE_RTL_POPEN
3113     return _pclose(pf);
3114 #else
3115     dTHX;
3116     int childpid, status;
3117     SV *sv;
3118
3119     LOCK_FDPID_MUTEX;
3120     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3121
3122     if (SvIOK(sv))
3123         childpid = SvIVX(sv);
3124     else
3125         childpid = 0;
3126
3127     if (!childpid) {
3128         UNLOCK_FDPID_MUTEX;
3129         errno = EBADF;
3130         return -1;
3131     }
3132
3133 #ifdef USE_PERLIO
3134     PerlIO_close(pf);
3135 #else
3136     fclose(pf);
3137 #endif
3138     SvIVX(sv) = 0;
3139     UNLOCK_FDPID_MUTEX;
3140
3141     if (win32_waitpid(childpid, &status, 0) == -1)
3142         return -1;
3143
3144     return status;
3145
3146 #endif /* USE_RTL_POPEN */
3147 }
3148
3149 static BOOL WINAPI
3150 Nt4CreateHardLinkW(
3151     LPCWSTR lpFileName,
3152     LPCWSTR lpExistingFileName,
3153     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
3154 {
3155     HANDLE handle;
3156     WCHAR wFullName[MAX_PATH+1];
3157     LPVOID lpContext = NULL;
3158     WIN32_STREAM_ID StreamId;
3159     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
3160     DWORD dwWritten;
3161     DWORD dwLen;
3162     BOOL bSuccess;
3163
3164     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
3165                                      BOOL, BOOL, LPVOID*) =
3166         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
3167                             BOOL, BOOL, LPVOID*))
3168         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
3169     if (pfnBackupWrite == NULL)
3170         return 0;
3171
3172     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
3173     if (dwLen == 0)
3174         return 0;
3175     dwLen = (dwLen+1)*sizeof(WCHAR);
3176
3177     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
3178                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
3179                          NULL, OPEN_EXISTING, 0, NULL);
3180     if (handle == INVALID_HANDLE_VALUE)
3181         return 0;
3182
3183     StreamId.dwStreamId = BACKUP_LINK;
3184     StreamId.dwStreamAttributes = 0;
3185     StreamId.dwStreamNameSize = 0;
3186 #if defined(__BORLANDC__) \
3187  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
3188     StreamId.Size.u.HighPart = 0;
3189     StreamId.Size.u.LowPart = dwLen;
3190 #else
3191     StreamId.Size.HighPart = 0;
3192     StreamId.Size.LowPart = dwLen;
3193 #endif
3194
3195     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3196                               FALSE, FALSE, &lpContext);
3197     if (bSuccess) {
3198         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3199                                   FALSE, FALSE, &lpContext);
3200         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3201     }
3202
3203     CloseHandle(handle);
3204     return bSuccess;
3205 }
3206
3207 DllExport int
3208 win32_link(const char *oldname, const char *newname)
3209 {
3210     dTHX;
3211     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3212     WCHAR wOldName[MAX_PATH+1];
3213     WCHAR wNewName[MAX_PATH+1];
3214
3215     if (IsWin95())
3216         Perl_croak(aTHX_ PL_no_func, "link");
3217
3218     pfnCreateHardLinkW =
3219         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3220         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3221     if (pfnCreateHardLinkW == NULL)
3222         pfnCreateHardLinkW = Nt4CreateHardLinkW;
3223
3224     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3225         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3226         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3227         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3228     {
3229         return 0;
3230     }
3231     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3232     return -1;
3233 }
3234
3235 DllExport int
3236 win32_rename(const char *oname, const char *newname)
3237 {
3238     char szOldName[MAX_PATH+1];
3239     char szNewName[MAX_PATH+1];
3240     BOOL bResult;
3241     dTHX;
3242
3243     /* XXX despite what the documentation says about MoveFileEx(),
3244      * it doesn't work under Windows95!
3245      */
3246     if (IsWinNT()) {
3247         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3248         if (stricmp(newname, oname))
3249             dwFlags |= MOVEFILE_REPLACE_EXISTING;
3250         strcpy(szOldName, PerlDir_mapA(oname));
3251         bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3252         if (!bResult) {
3253             DWORD err = GetLastError();
3254             switch (err) {
3255             case ERROR_BAD_NET_NAME:
3256             case ERROR_BAD_NETPATH:
3257             case ERROR_BAD_PATHNAME:
3258             case ERROR_FILE_NOT_FOUND:
3259             case ERROR_FILENAME_EXCED_RANGE:
3260             case ERROR_INVALID_DRIVE:
3261             case ERROR_NO_MORE_FILES:
3262             case ERROR_PATH_NOT_FOUND:
3263                 errno = ENOENT;
3264                 break;
3265             default:
3266                 errno = EACCES;
3267                 break;
3268             }
3269             return -1;
3270         }
3271         return 0;
3272     }
3273     else {
3274         int retval = 0;
3275         char szTmpName[MAX_PATH+1];
3276         char dname[MAX_PATH+1];
3277         char *endname = NULL;
3278         STRLEN tmplen = 0;
3279         DWORD from_attr, to_attr;
3280
3281         strcpy(szOldName, PerlDir_mapA(oname));
3282         strcpy(szNewName, PerlDir_mapA(newname));
3283
3284         /* if oname doesn't exist, do nothing */
3285         from_attr = GetFileAttributes(szOldName);
3286         if (from_attr == 0xFFFFFFFF) {
3287             errno = ENOENT;
3288             return -1;
3289         }
3290
3291         /* if newname exists, rename it to a temporary name so that we
3292          * don't delete it in case oname happens to be the same file
3293          * (but perhaps accessed via a different path)
3294          */
3295         to_attr = GetFileAttributes(szNewName);
3296         if (to_attr != 0xFFFFFFFF) {
3297             /* if newname is a directory, we fail
3298              * XXX could overcome this with yet more convoluted logic */
3299             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3300                 errno = EACCES;
3301                 return -1;
3302             }
3303             tmplen = strlen(szNewName);
3304             strcpy(szTmpName,szNewName);
3305             endname = szTmpName+tmplen;
3306             for (; endname > szTmpName ; --endname) {
3307                 if (*endname == '/' || *endname == '\\') {
3308                     *endname = '\0';
3309                     break;
3310                 }
3311             }
3312             if (endname > szTmpName)
3313                 endname = strcpy(dname,szTmpName);
3314             else
3315                 endname = ".";
3316
3317             /* get a temporary filename in same directory
3318              * XXX is this really the best we can do? */
3319             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3320                 errno = ENOENT;
3321                 return -1;
3322             }
3323             DeleteFile(szTmpName);
3324
3325             retval = rename(szNewName, szTmpName);
3326             if (retval != 0) {
3327                 errno = EACCES;
3328                 return retval;
3329             }
3330         }
3331
3332         /* rename oname to newname */
3333         retval = rename(szOldName, szNewName);
3334
3335         /* if we created a temporary file before ... */
3336         if (endname != NULL) {
3337             /* ...and rename succeeded, delete temporary file/directory */
3338             if (retval == 0)
3339                 DeleteFile(szTmpName);
3340             /* else restore it to what it was */
3341             else
3342                 (void)rename(szTmpName, szNewName);
3343         }
3344         return retval;
3345     }
3346 }
3347
3348 DllExport int
3349 win32_setmode(int fd, int mode)
3350 {
3351     return setmode(fd, mode);
3352 }
3353
3354 DllExport int
3355 win32_chsize(int fd, Off_t size)
3356 {
3357 #if defined(WIN64) || defined(USE_LARGE_FILES)
3358     int retval = 0;
3359     Off_t cur, end, extend;
3360
3361     cur = win32_tell(fd);
3362     if (cur < 0)
3363         return -1;
3364     end = win32_lseek(fd, 0, SEEK_END);
3365     if (end < 0)
3366         return -1;
3367     extend = size - end;
3368     if (extend == 0) {
3369         /* do nothing */
3370     }
3371     else if (extend > 0) {
3372         /* must grow the file, padding with nulls */
3373         char b[4096];
3374         int oldmode = win32_setmode(fd, O_BINARY);
3375         size_t count;
3376         memset(b, '\0', sizeof(b));
3377         do {
3378             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3379             count = win32_write(fd, b, count);
3380             if ((int)count < 0) {
3381                 retval = -1;
3382                 break;
3383             }
3384         } while ((extend -= count) > 0);
3385         win32_setmode(fd, oldmode);
3386     }
3387     else {
3388         /* shrink the file */
3389         win32_lseek(fd, size, SEEK_SET);
3390         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3391             errno = EACCES;
3392             retval = -1;
3393         }
3394     }
3395 finish:
3396     win32_lseek(fd, cur, SEEK_SET);
3397     return retval;
3398 #else
3399     return chsize(fd, (long)size);
3400 #endif
3401 }
3402
3403 DllExport Off_t
3404 win32_lseek(int fd, Off_t offset, int origin)
3405 {
3406 #if defined(WIN64) || defined(USE_LARGE_FILES)
3407 #if defined(__BORLANDC__) /* buk */
3408     LARGE_INTEGER pos;
3409     pos.QuadPart = offset;
3410     pos.LowPart = SetFilePointer(
3411         (HANDLE)_get_osfhandle(fd),
3412         pos.LowPart,
3413         &pos.HighPart,
3414         origin
3415     );
3416     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3417         pos.QuadPart = -1;
3418     }
3419
3420     return pos.QuadPart;
3421 #else
3422     return _lseeki64(fd, offset, origin);
3423 #endif
3424 #else
3425     return lseek(fd, (long)offset, origin);
3426 #endif
3427 }
3428
3429 DllExport Off_t
3430 win32_tell(int fd)
3431 {
3432 #if defined(WIN64) || defined(USE_LARGE_FILES)
3433 #if defined(__BORLANDC__) /* buk */
3434     LARGE_INTEGER pos;
3435     pos.QuadPart = 0;
3436     pos.LowPart = SetFilePointer(
3437         (HANDLE)_get_osfhandle(fd),
3438         pos.LowPart,
3439         &pos.HighPart,
3440         FILE_CURRENT
3441     );
3442     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3443         pos.QuadPart = -1;
3444     }
3445
3446     return pos.QuadPart;
3447     /* return tell(fd); */
3448 #else
3449     return _telli64(fd);
3450 #endif
3451 #else
3452     return tell(fd);
3453 #endif
3454 }
3455
3456 DllExport int
3457 win32_open(const char *path, int flag, ...)
3458 {
3459     dTHX;
3460     va_list ap;
3461     int pmode;
3462
3463     va_start(ap, flag);
3464     pmode = va_arg(ap, int);
3465     va_end(ap);
3466
3467     if (stricmp(path, "/dev/null")==0)
3468         path = "NUL";
3469
3470     return open(PerlDir_mapA(path), flag, pmode);
3471 }
3472
3473 /* close() that understands socket */
3474 extern int my_close(int);       /* in win32sck.c */
3475
3476 DllExport int
3477 win32_close(int fd)
3478 {
3479     return my_close(fd);
3480 }
3481
3482 DllExport int
3483 win32_eof(int fd)
3484 {
3485     return eof(fd);
3486 }
3487
3488 DllExport int
3489 win32_dup(int fd)
3490 {
3491     return dup(fd);
3492 }
3493
3494 DllExport int
3495 win32_dup2(int fd1,int fd2)
3496 {
3497     return dup2(fd1,fd2);
3498 }
3499
3500 #ifdef PERL_MSVCRT_READFIX
3501
3502 #define LF              10      /* line feed */
3503 #define CR              13      /* carriage return */
3504 #define CTRLZ           26      /* ctrl-z means eof for text */
3505 #define FOPEN           0x01    /* file handle open */
3506 #define FEOFLAG         0x02    /* end of file has been encountered */
3507 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3508 #define FPIPE           0x08    /* file handle refers to a pipe */
3509 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3510 #define FDEV            0x40    /* file handle refers to device */
3511 #define FTEXT           0x80    /* file handle is in text mode */
3512 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3513
3514 int __cdecl
3515 _fixed_read(int fh, void *buf, unsigned cnt)
3516 {
3517     int bytes_read;                 /* number of bytes read */
3518     char *buffer;                   /* buffer to read to */
3519     int os_read;                    /* bytes read on OS call */
3520     char *p, *q;                    /* pointers into buffer */
3521     char peekchr;                   /* peek-ahead character */
3522     ULONG filepos;                  /* file position after seek */
3523     ULONG dosretval;                /* o.s. return value */
3524
3525     /* validate handle */
3526     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3527          !(_osfile(fh) & FOPEN))
3528     {
3529         /* out of range -- return error */
3530         errno = EBADF;
3531         _doserrno = 0;  /* not o.s. error */
3532         return -1;
3533     }
3534
3535     /*
3536      * If lockinitflag is FALSE, assume fd is device
3537      * lockinitflag is set to TRUE by open.
3538      */
3539     if (_pioinfo(fh)->lockinitflag)
3540         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3541
3542     bytes_read = 0;                 /* nothing read yet */
3543     buffer = (char*)buf;
3544
3545     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3546         /* nothing to read or at EOF, so return 0 read */
3547         goto functionexit;
3548     }
3549
3550     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3551         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3552          * char */
3553         *buffer++ = _pipech(fh);
3554         ++bytes_read;
3555         --cnt;
3556         _pipech(fh) = LF;           /* mark as empty */
3557     }
3558
3559     /* read the data */
3560
3561     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3562     {
3563         /* ReadFile has reported an error. recognize two special cases.
3564          *
3565          *      1. map ERROR_ACCESS_DENIED to EBADF
3566          *
3567          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3568          *         means the handle is a read-handle on a pipe for which
3569          *         all write-handles have been closed and all data has been
3570          *         read. */
3571
3572         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3573             /* wrong read/write mode should return EBADF, not EACCES */
3574             errno = EBADF;
3575             _doserrno = dosretval;
3576             bytes_read = -1;
3577             goto functionexit;
3578         }
3579         else if (dosretval == ERROR_BROKEN_PIPE) {
3580             bytes_read = 0;
3581             goto functionexit;
3582         }
3583         else {
3584             bytes_read = -1;
3585             goto functionexit;
3586         }
3587     }
3588
3589     bytes_read += os_read;          /* update bytes read */
3590
3591     if (_osfile(fh) & FTEXT) {
3592         /* now must translate CR-LFs to LFs in the buffer */
3593
3594         /* set CRLF flag to indicate LF at beginning of buffer */
3595         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3596         /*    _osfile(fh) |= FCRLF;                      */
3597         /* else                                          */
3598         /*    _osfile(fh) &= ~FCRLF;                     */
3599
3600         _osfile(fh) &= ~FCRLF;
3601
3602         /* convert chars in the buffer: p is src, q is dest */
3603         p = q = (char*)buf;
3604         while (p < (char *)buf + bytes_read) {
3605             if (*p == CTRLZ) {
3606                 /* if fh is not a device, set ctrl-z flag */
3607                 if (!(_osfile(fh) & FDEV))
3608                     _osfile(fh) |= FEOFLAG;
3609                 break;              /* stop translating */
3610             }
3611             else if (*p != CR)
3612                 *q++ = *p++;
3613             else {
3614                 /* *p is CR, so must check next char for LF */
3615                 if (p < (char *)buf + bytes_read - 1) {
3616                     if (*(p+1) == LF) {
3617                         p += 2;
3618                         *q++ = LF;  /* convert CR-LF to LF */
3619                     }
3620                     else
3621                         *q++ = *p++;    /* store char normally */
3622                 }
3623                 else {
3624                     /* This is the hard part.  We found a CR at end of
3625                        buffer.  We must peek ahead to see if next char
3626                        is an LF. */
3627                     ++p;
3628
3629                     dosretval = 0;
3630                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3631                                     (LPDWORD)&os_read, NULL))
3632                         dosretval = GetLastError();
3633
3634                     if (dosretval != 0 || os_read == 0) {
3635                         /* couldn't read ahead, store CR */
3636                         *q++ = CR;
3637                     }
3638                     else {
3639                         /* peekchr now has the extra character -- we now
3640                            have several possibilities:
3641                            1. disk file and char is not LF; just seek back
3642                               and copy CR
3643                            2. disk file and char is LF; store LF, don't seek back
3644                            3. pipe/device and char is LF; store LF.
3645                            4. pipe/device and char isn't LF, store CR and
3646                               put char in pipe lookahead buffer. */
3647                         if (_osfile(fh) & (FDEV|FPIPE)) {
3648                             /* non-seekable device */
3649                             if (peekchr == LF)
3650                                 *q++ = LF;
3651                             else {
3652                                 *q++ = CR;
3653                                 _pipech(fh) = peekchr;
3654                             }
3655                         }
3656                         else {
3657                             /* disk file */
3658                             if (peekchr == LF) {
3659                                 /* nothing read yet; must make some
3660                                    progress */
3661                                 *q++ = LF;
3662                                 /* turn on this flag for tell routine */
3663                                 _osfile(fh) |= FCRLF;
3664                             }
3665                             else {
3666                                 HANDLE osHandle;        /* o.s. handle value */
3667                                 /* seek back */
3668                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3669                                 {
3670                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3671                                         dosretval = GetLastError();
3672                                 }
3673                                 if (peekchr != LF)
3674                                     *q++ = CR;
3675                             }
3676                         }
3677                     }
3678                 }
3679             }
3680         }
3681
3682         /* we now change bytes_read to reflect the true number of chars
3683            in the buffer */
3684         bytes_read = q - (char *)buf;
3685     }
3686
3687 functionexit:
3688     if (_pioinfo(fh)->lockinitflag)
3689         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3690
3691     return bytes_read;
3692 }
3693
3694 #endif  /* PERL_MSVCRT_READFIX */
3695
3696 DllExport int
3697 win32_read(int fd, void *buf, unsigned int cnt)
3698 {
3699 #ifdef PERL_MSVCRT_READFIX
3700     return _fixed_read(fd, buf, cnt);
3701 #else
3702     return read(fd, buf, cnt);
3703 #endif
3704 }
3705
3706 DllExport int
3707 win32_write(int fd, const void *buf, unsigned int cnt)
3708 {
3709     return write(fd, buf, cnt);
3710 }
3711
3712 DllExport int
3713 win32_mkdir(const char *dir, int mode)
3714 {
3715     dTHX;
3716     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3717 }
3718
3719 DllExport int
3720 win32_rmdir(const char *dir)
3721 {
3722     dTHX;
3723     return rmdir(PerlDir_mapA(dir));
3724 }
3725
3726 DllExport int
3727 win32_chdir(const char *dir)
3728 {
3729     dTHX;
3730     if (!dir) {
3731         errno = ENOENT;
3732         return -1;
3733     }
3734     return chdir(dir);
3735 }
3736
3737 DllExport  int
3738 win32_access(const char *path, int mode)
3739 {
3740     dTHX;
3741     return access(PerlDir_mapA(path), mode);
3742 }
3743
3744 DllExport  int
3745 win32_chmod(const char *path, int mode)
3746 {
3747     dTHX;
3748     return chmod(PerlDir_mapA(path), mode);
3749 }
3750
3751
3752 static char *
3753 create_command_line(char *cname, STRLEN clen, const char * const *args)
3754 {
3755     dTHX;
3756     int index, argc;
3757     char *cmd, *ptr;
3758     const char *arg;
3759     STRLEN len = 0;
3760     bool bat_file = FALSE;
3761     bool cmd_shell = FALSE;
3762     bool dumb_shell = FALSE;
3763     bool extra_quotes = FALSE;
3764     bool quote_next = FALSE;
3765
3766     if (!cname)
3767         cname = (char*)args[0];
3768
3769     /* The NT cmd.exe shell has the following peculiarity that needs to be
3770      * worked around.  It strips a leading and trailing dquote when any
3771      * of the following is true:
3772      *    1. the /S switch was used
3773      *    2. there are more than two dquotes
3774      *    3. there is a special character from this set: &<>()@^|
3775      *    4. no whitespace characters within the two dquotes
3776      *    5. string between two dquotes isn't an executable file
3777      * To work around this, we always add a leading and trailing dquote
3778      * to the string, if the first argument is either "cmd.exe" or "cmd",
3779      * and there were at least two or more arguments passed to cmd.exe
3780      * (not including switches).
3781      * XXX the above rules (from "cmd /?") don't seem to be applied
3782      * always, making for the convolutions below :-(
3783      */
3784     if (cname) {
3785         if (!clen)
3786             clen = strlen(cname);
3787
3788         if (clen > 4
3789             && (stricmp(&cname[clen-4], ".bat") == 0
3790                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3791         {
3792             bat_file = TRUE;
3793             if (!IsWin95())
3794                 len += 3;
3795         }
3796         else {
3797             char *exe = strrchr(cname, '/');
3798             char *exe2 = strrchr(cname, '\\');
3799             if (exe2 > exe)
3800                 exe = exe2;
3801             if (exe)
3802                 ++exe;
3803             else
3804                 exe = cname;
3805             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3806                 cmd_shell = TRUE;
3807                 len += 3;
3808             }
3809             else if (stricmp(exe, "command.com") == 0
3810                      || stricmp(exe, "command") == 0)
3811             {
3812                 dumb_shell = TRUE;
3813             }
3814         }
3815     }
3816
3817     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3818     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3819         STRLEN curlen = strlen(arg);
3820         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3821             len += 2;   /* assume quoting needed (worst case) */
3822         len += curlen + 1;
3823         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3824     }
3825     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3826
3827     argc = index;
3828     Newx(cmd, len, char);
3829     ptr = cmd;
3830
3831     if (bat_file && !IsWin95()) {
3832         *ptr++ = '"';
3833         extra_quotes = TRUE;
3834     }
3835
3836     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3837         bool do_quote = 0;
3838         STRLEN curlen = strlen(arg);
3839
3840         /* we want to protect empty arguments and ones with spaces with
3841          * dquotes, but only if they aren't already there */
3842         if (!dumb_shell) {
3843             if (!curlen) {
3844                 do_quote = 1;
3845             }
3846             else if (quote_next) {
3847                 /* see if it really is multiple arguments pretending to
3848                  * be one and force a set of quotes around it */
3849                 if (*find_next_space(arg))
3850                     do_quote = 1;
3851             }
3852             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3853                 STRLEN i = 0;
3854                 while (i < curlen) {
3855                     if (isSPACE(arg[i])) {
3856                         do_quote = 1;
3857                     }
3858                     else if (arg[i] == '"') {
3859                         do_quote = 0;
3860                         break;
3861                     }
3862                     i++;
3863                 }
3864             }
3865         }
3866
3867         if (do_quote)
3868             *ptr++ = '"';
3869
3870         strcpy(ptr, arg);
3871         ptr += curlen;
3872
3873         if (do_quote)
3874             *ptr++ = '"';
3875
3876         if (args[index+1])
3877             *ptr++ = ' ';
3878
3879         if (!extra_quotes
3880             && cmd_shell
3881             && curlen >= 2
3882             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3883             && stricmp(arg+curlen-2, "/c") == 0)
3884         {
3885             /* is there a next argument? */
3886             if (args[index+1]) {
3887                 /* are there two or more next arguments? */
3888                 if (args[index+2]) {
3889                     *ptr++ = '"';
3890                     extra_quotes = TRUE;
3891                 }
3892                 else {
3893                     /* single argument, force quoting if it has spaces */
3894                     quote_next = TRUE;
3895                 }
3896             }
3897         }
3898     }
3899
3900     if (extra_quotes)
3901         *ptr++ = '"';
3902
3903     *ptr = '\0';
3904
3905     return cmd;
3906 }
3907
3908 static char *
3909 qualified_path(const char *cmd)
3910 {
3911     dTHX;
3912     char *pathstr;
3913     char *fullcmd, *curfullcmd;
3914     STRLEN cmdlen = 0;
3915     int has_slash = 0;
3916
3917     if (!cmd)
3918         return NULL;
3919     fullcmd = (char*)cmd;
3920     while (*fullcmd) {
3921         if (*fullcmd == '/' || *fullcmd == '\\')
3922             has_slash++;
3923         fullcmd++;
3924         cmdlen++;
3925     }
3926
3927     /* look in PATH */
3928     pathstr = PerlEnv_getenv("PATH");
3929
3930     /* worst case: PATH is a single directory; we need additional space
3931      * to append "/", ".exe" and trailing "\0" */
3932     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3933     curfullcmd = fullcmd;
3934
3935     while (1) {
3936         DWORD res;
3937
3938         /* start by appending the name to the current prefix */
3939         strcpy(curfullcmd, cmd);
3940         curfullcmd += cmdlen;
3941
3942         /* if it doesn't end with '.', or has no extension, try adding
3943          * a trailing .exe first */
3944         if (cmd[cmdlen-1] != '.'
3945             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3946         {
3947             strcpy(curfullcmd, ".exe");
3948             res = GetFileAttributes(fullcmd);
3949             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3950                 return fullcmd;
3951             *curfullcmd = '\0';
3952         }
3953
3954         /* that failed, try the bare name */
3955         res = GetFileAttributes(fullcmd);
3956         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3957             return fullcmd;
3958
3959         /* quit if no other path exists, or if cmd already has path */
3960         if (!pathstr || !*pathstr || has_slash)
3961             break;
3962
3963         /* skip leading semis */
3964         while (*pathstr == ';')
3965             pathstr++;
3966
3967         /* build a new prefix from scratch */
3968         curfullcmd = fullcmd;
3969         while (*pathstr && *pathstr != ';') {
3970             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3971                 pathstr++;              /* skip initial '"' */
3972                 while (*pathstr && *pathstr != '"') {
3973                     *curfullcmd++ = *pathstr++;
3974                 }
3975                 if (*pathstr)
3976                     pathstr++;          /* skip trailing '"' */
3977             }
3978             else {
3979                 *curfullcmd++ = *pathstr++;
3980             }
3981         }
3982         if (*pathstr)
3983             pathstr++;                  /* skip trailing semi */
3984         if (curfullcmd > fullcmd        /* append a dir separator */
3985             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3986         {
3987             *curfullcmd++ = '\\';
3988         }
3989     }
3990
3991     Safefree(fullcmd);
3992     return NULL;
3993 }
3994
3995 /* The following are just place holders.
3996  * Some hosts may provide and environment that the OS is
3997  * not tracking, therefore, these host must provide that
3998  * environment and the current directory to CreateProcess
3999  */
4000
4001 DllExport void*
4002 win32_get_childenv(void)
4003 {
4004     return NULL;
4005 }
4006
4007 DllExport void
4008 win32_free_childenv(void* d)
4009 {
4010 }
4011
4012 DllExport void
4013 win32_clearenv(void)
4014 {
4015     char *envv = GetEnvironmentStrings();
4016     char *cur = envv;
4017     STRLEN len;
4018     while (*cur) {
4019         char *end = strchr(cur,'=');
4020         if (end && end != cur) {
4021             *end = '\0';
4022             SetEnvironmentVariable(cur, NULL);
4023             *end = '=';
4024             cur = end + strlen(end+1)+2;
4025         }
4026         else if ((len = strlen(cur)))
4027             cur += len+1;
4028     }
4029     FreeEnvironmentStrings(envv);
4030 }
4031
4032 DllExport char*
4033 win32_get_childdir(void)
4034 {
4035     dTHX;
4036     char* ptr;
4037     char szfilename[MAX_PATH+1];
4038
4039     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4040     Newx(ptr, strlen(szfilename)+1, char);
4041     strcpy(ptr, szfilename);
4042     return ptr;
4043 }
4044
4045 DllExport void
4046 win32_free_childdir(char* d)
4047 {
4048     dTHX;
4049     Safefree(d);
4050 }
4051
4052
4053 /* XXX this needs to be made more compatible with the spawnvp()
4054  * provided by the various RTLs.  In particular, searching for
4055  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4056  * This doesn't significantly affect perl itself, because we
4057  * always invoke things using PERL5SHELL if a direct attempt to
4058  * spawn the executable fails.
4059  *
4060  * XXX splitting and rejoining the commandline between do_aspawn()
4061  * and win32_spawnvp() could also be avoided.
4062  */
4063
4064 DllExport int
4065 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4066 {
4067 #ifdef USE_RTL_SPAWNVP
4068     return spawnvp(mode, cmdname, (char * const *)argv);
4069 #else
4070     dTHX;
4071     int ret;
4072     void* env;
4073     char* dir;
4074     child_IO_table tbl;
4075     STARTUPINFO StartupInfo;
4076     PROCESS_INFORMATION ProcessInformation;
4077     DWORD create = 0;
4078     char *cmd;
4079     char *fullcmd = NULL;
4080     char *cname = (char *)cmdname;
4081     STRLEN clen = 0;
4082
4083     if (cname) {
4084         clen = strlen(cname);
4085         /* if command name contains dquotes, must remove them */
4086         if (strchr(cname, '"')) {
4087             cmd = cname;
4088             Newx(cname,clen+1,char);
4089             clen = 0;
4090             while (*cmd) {
4091                 if (*cmd != '"') {
4092                     cname[clen] = *cmd;
4093                     ++clen;
4094                 }
4095                 ++cmd;
4096             }
4097             cname[clen] = '\0';
4098         }
4099     }
4100
4101     cmd = create_command_line(cname, clen, argv);
4102
4103     env = PerlEnv_get_childenv();
4104     dir = PerlEnv_get_childdir();
4105
4106     switch(mode) {
4107     case P_NOWAIT:      /* asynch + remember result */
4108         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4109             errno = EAGAIN;
4110             ret = -1;
4111             goto RETVAL;
4112         }
4113         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4114          * in win32_kill()
4115          */
4116         create |= CREATE_NEW_PROCESS_GROUP;
4117         /* FALL THROUGH */
4118
4119     case P_WAIT:        /* synchronous execution */
4120         break;
4121     default:            /* invalid mode */
4122         errno = EINVAL;
4123         ret = -1;
4124         goto RETVAL;
4125     }
4126     memset(&StartupInfo,0,sizeof(StartupInfo));
4127     StartupInfo.cb = sizeof(StartupInfo);
4128     memset(&tbl,0,sizeof(tbl));
4129     PerlEnv_get_child_IO(&tbl);
4130     StartupInfo.dwFlags         = tbl.dwFlags;
4131     StartupInfo.dwX             = tbl.dwX;
4132     StartupInfo.dwY             = tbl.dwY;
4133     StartupInfo.dwXSize         = tbl.dwXSize;
4134     StartupInfo.dwYSize         = tbl.dwYSize;
4135     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
4136     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
4137     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4138     StartupInfo.wShowWindow     = tbl.wShowWindow;
4139     StartupInfo.hStdInput       = tbl.childStdIn;
4140     StartupInfo.hStdOutput      = tbl.childStdOut;
4141     StartupInfo.hStdError       = tbl.childStdErr;
4142     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4143         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4144         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4145     {
4146         create |= CREATE_NEW_CONSOLE;
4147     }
4148     else {
4149         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4150     }
4151     if (w32_use_showwindow) {
4152         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4153         StartupInfo.wShowWindow = w32_showwindow;
4154     }
4155
4156     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4157                           cname,cmd));
4158 RETRY:
4159     if (!CreateProcess(cname,           /* search PATH to find executable */
4160                        cmd,             /* executable, and its arguments */
4161                        NULL,            /* process attributes */
4162                        NULL,            /* thread attributes */
4163                        TRUE,            /* inherit handles */
4164                        create,          /* creation flags */
4165                        (LPVOID)env,     /* inherit environment */
4166                        dir,             /* inherit cwd */
4167                        &StartupInfo,
4168                        &ProcessInformation))
4169     {
4170         /* initial NULL argument to CreateProcess() does a PATH
4171          * search, but it always first looks in the directory
4172          * where the current process was started, which behavior
4173          * is undesirable for backward compatibility.  So we
4174          * jump through our own hoops by picking out the path
4175          * we really want it to use. */
4176         if (!fullcmd) {
4177             fullcmd = qualified_path(cname);
4178             if (fullcmd) {
4179                 if (cname != cmdname)
4180                     Safefree(cname);
4181                 cname = fullcmd;
4182                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4183                                       "Retrying [%s] with same args\n",
4184                                       cname));
4185                 goto RETRY;
4186             }
4187         }
4188         errno = ENOENT;
4189         ret = -1;
4190         goto RETVAL;
4191     }
4192
4193     if (mode == P_NOWAIT) {
4194         /* asynchronous spawn -- store handle, return PID */
4195         ret = (int)ProcessInformation.dwProcessId;
4196         if (IsWin95() && ret < 0)
4197             ret = -ret;
4198
4199         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4200         w32_child_pids[w32_num_children] = (DWORD)ret;
4201         ++w32_num_children;
4202     }
4203     else  {
4204         DWORD status;
4205         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4206         /* FIXME: if msgwait returned due to message perhaps forward the
4207            "signal" to the process
4208          */
4209         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4210         ret = (int)status;
4211         CloseHandle(ProcessInformation.hProcess);
4212     }
4213
4214     CloseHandle(ProcessInformation.hThread);
4215
4216 RETVAL:
4217     PerlEnv_free_childenv(env);
4218     PerlEnv_free_childdir(dir);
4219     Safefree(cmd);
4220     if (cname != cmdname)
4221         Safefree(cname);
4222     return ret;
4223 #endif
4224 }
4225
4226 DllExport int
4227 win32_execv(const char *cmdname, const char *const *argv)
4228 {
4229 #ifdef USE_ITHREADS
4230     dTHX;
4231     /* if this is a pseudo-forked child, we just want to spawn
4232      * the new program, and return */
4233     if (w32_pseudo_id)
4234 #  ifdef __BORLANDC__
4235         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4236 #  else
4237         return spawnv(P_WAIT, cmdname, argv);
4238 #  endif
4239 #endif
4240 #ifdef __BORLANDC__
4241     return execv(cmdname, (char *const *)argv);
4242 #else
4243     return execv(cmdname, argv);
4244 #endif
4245 }
4246
4247 DllExport int
4248 win32_execvp(const char *cmdname, const char *const *argv)
4249 {
4250 #ifdef USE_ITHREADS
4251     dTHX;
4252     /* if this is a pseudo-forked child, we just want to spawn
4253      * the new program, and return */
4254     if (w32_pseudo_id) {
4255         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4256         if (status != -1) {
4257             my_exit(status);
4258             return 0;
4259         }
4260         else
4261             return status;
4262     }
4263 #endif
4264 #ifdef __BORLANDC__
4265     return execvp(cmdname, (char *const *)argv);
4266 #else
4267     return execvp(cmdname, argv);
4268 #endif
4269 }
4270
4271 DllExport void
4272 win32_perror(const char *str)
4273 {
4274     perror(str);
4275 }
4276
4277 DllExport void
4278 win32_setbuf(FILE *pf, char *buf)
4279 {
4280     setbuf(pf, buf);
4281 }
4282
4283 DllExport int
4284 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4285 {
4286     return setvbuf(pf, buf, type, size);
4287 }
4288
4289 DllExport int
4290 win32_flushall(void)
4291 {
4292     return flushall();
4293 }
4294
4295 DllExport int
4296 win32_fcloseall(void)
4297 {
4298     return fcloseall();
4299 }
4300
4301 DllExport char*
4302 win32_fgets(char *s, int n, FILE *pf)
4303 {
4304     return fgets(s, n, pf);
4305 }
4306
4307 DllExport char*
4308 win32_gets(char *s)
4309 {
4310     return gets(s);
4311 }
4312
4313 DllExport int
4314 win32_fgetc(FILE *pf)
4315 {
4316     return fgetc(pf);
4317 }
4318
4319 DllExport int
4320 win32_putc(int c, FILE *pf)
4321 {
4322     return putc(c,pf);
4323 }
4324
4325 DllExport int
4326 win32_puts(const char *s)
4327 {
4328     return puts(s);
4329 }
4330
4331 DllExport int
4332 win32_getchar(void)
4333 {
4334     return getchar();
4335 }
4336
4337 DllExport int
4338 win32_putchar(int c)
4339 {
4340     return putchar(c);
4341 }
4342
4343 #ifdef MYMALLOC
4344
4345 #ifndef USE_PERL_SBRK
4346
4347 static char *committed = NULL;          /* XXX threadead */
4348 static char *base      = NULL;          /* XXX threadead */
4349 static char *reserved  = NULL;          /* XXX threadead */
4350 static char *brk       = NULL;          /* XXX threadead */
4351 static DWORD pagesize  = 0;             /* XXX threadead */
4352
4353 void *
4354 sbrk(ptrdiff_t need)
4355 {
4356  void *result;
4357  if (!pagesize)
4358   {SYSTEM_INFO info;
4359    GetSystemInfo(&info);
4360    /* Pretend page size is larger so we don't perpetually
4361     * call the OS to commit just one page ...
4362     */
4363    pagesize = info.dwPageSize << 3;
4364   }
4365  if (brk+need >= reserved)
4366   {
4367    DWORD size = brk+need-reserved;
4368    char *addr;
4369    char *prev_committed = NULL;
4370    if (committed && reserved && committed < reserved)
4371     {
4372      /* Commit last of previous chunk cannot span allocations */
4373      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4374      if (addr)
4375       {
4376       /* Remember where we committed from in case we want to decommit later */
4377       prev_committed = committed;
4378       committed = reserved;
4379       }
4380     }
4381    /* Reserve some (more) space
4382     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4383     * this is only address space not memory...
4384     * Note this is a little sneaky, 1st call passes NULL as reserved
4385     * so lets system choose where we start, subsequent calls pass
4386     * the old end address so ask for a contiguous block
4387     */
4388 sbrk_reserve:
4389    if (size < 64*1024*1024)
4390     size = 64*1024*1024;
4391    size = ((size + pagesize - 1) / pagesize) * pagesize;
4392    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4393    if (addr)
4394     {
4395      reserved = addr+size;
4396      if (!base)
4397       base = addr;
4398      if (!committed)
4399       committed = base;
4400      if (!brk)
4401       brk = committed;
4402     }
4403    else if (reserved)
4404     {
4405       /* The existing block could not be extended far enough, so decommit
4406        * anything that was just committed above and start anew */
4407       if (prev_committed)
4408        {
4409        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4410         return (void *) -1;
4411        }
4412       reserved = base = committed = brk = NULL;
4413       size = need;
4414       goto sbrk_reserve;
4415     }
4416    else
4417     {
4418      return (void *) -1;
4419     }
4420   }
4421  result = brk;
4422  brk += need;
4423  if (brk > committed)
4424   {
4425    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4426    char *addr;
4427    if (committed+size > reserved)
4428     size = reserved-committed;
4429    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4430    if (addr)
4431     committed += size;
4432    else
4433     return (void *) -1;
4434   }
4435  return result;
4436 }
4437
4438 #endif
4439 #endif
4440
4441 DllExport void*
4442 win32_malloc(size_t size)
4443 {
4444     return malloc(size);
4445 }
4446
4447 DllExport void*
4448 win32_calloc(size_t numitems, size_t size)
4449 {
4450     return calloc(numitems,size);
4451 }
4452
4453 DllExport void*
4454 win32_realloc(void *block, size_t size)
4455 {
4456     return realloc(block,size);
4457 }
4458
4459 DllExport void
4460 win32_free(void *block)
4461 {
4462     free(block);
4463 }
4464
4465
4466 DllExport int
4467 win32_open_osfhandle(intptr_t handle, int flags)
4468 {
4469 #ifdef USE_FIXED_OSFHANDLE
4470     if (IsWin95())
4471         return my_open_osfhandle(handle, flags);
4472 #endif
4473     return _open_osfhandle(handle, flags);
4474 }
4475
4476 DllExport intptr_t
4477 win32_get_osfhandle(int fd)
4478 {
4479     return (intptr_t)_get_osfhandle(fd);
4480 }
4481
4482 DllExport FILE *
4483 win32_fdupopen(FILE *pf)
4484 {
4485     FILE* pfdup;
4486     fpos_t pos;
4487     char mode[3];
4488     int fileno = win32_dup(win32_fileno(pf));
4489
4490     /* open the file in the same mode */
4491 #ifdef __BORLANDC__
4492     if((pf)->flags & _F_READ) {
4493         mode[0] = 'r';
4494         mode[1] = 0;
4495     }
4496     else if((pf)->flags & _F_WRIT) {
4497         mode[0] = 'a';
4498         mode[1] = 0;
4499     }
4500     else if((pf)->flags & _F_RDWR) {
4501         mode[0] = 'r';
4502         mode[1] = '+';
4503         mode[2] = 0;
4504     }
4505 #else
4506     if((pf)->_flag & _IOREAD) {
4507         mode[0] = 'r';
4508         mode[1] = 0;
4509     }
4510     else if((pf)->_flag & _IOWRT) {
4511         mode[0] = 'a';
4512         mode[1] = 0;
4513     }
4514     else if((pf)->_flag & _IORW) {
4515         mode[0] = 'r';
4516         mode[1] = '+';
4517         mode[2] = 0;
4518     }
4519 #endif
4520
4521     /* it appears that the binmode is attached to the
4522      * file descriptor so binmode files will be handled
4523      * correctly
4524      */
4525     pfdup = win32_fdopen(fileno, mode);
4526
4527     /* move the file pointer to the same position */
4528     if (!fgetpos(pf, &pos)) {
4529         fsetpos(pfdup, &pos);
4530     }
4531     return pfdup;
4532 }
4533
4534 DllExport void*
4535 win32_dynaload(const char* filename)
4536 {
4537     dTHX;
4538     char buf[MAX_PATH+1];
4539     char *first;
4540
4541     /* LoadLibrary() doesn't recognize forward slashes correctly,
4542      * so turn 'em back. */
4543     first = strchr(filename, '/');
4544     if (first) {
4545         STRLEN len = strlen(filename);
4546         if (len <= MAX_PATH) {
4547             strcpy(buf, filename);
4548             filename = &buf[first - filename];
4549             while (*filename) {
4550                 if (*filename == '/')
4551                     *(char*)filename = '\\';
4552                 ++filename;
4553             }
4554             filename = buf;
4555         }
4556     }
4557     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4558 }
4559
4560 XS(w32_SetChildShowWindow)
4561 {
4562     dXSARGS;
4563     BOOL use_showwindow = w32_use_showwindow;
4564     /* use "unsigned short" because Perl has redefined "WORD" */
4565     unsigned short showwindow = w32_showwindow;
4566
4567     if (items > 1)
4568         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4569
4570     if (items == 0 || !SvOK(ST(0)))
4571         w32_use_showwindow = FALSE;
4572     else {
4573         w32_use_showwindow = TRUE;
4574         w32_showwindow = (unsigned short)SvIV(ST(0));
4575     }
4576
4577     EXTEND(SP, 1);
4578     if (use_showwindow)
4579         ST(0) = sv_2mortal(newSViv(showwindow));
4580     else
4581         ST(0) = &PL_sv_undef;
4582     XSRETURN(1);
4583 }
4584
4585 void
4586 Perl_init_os_extras(void)
4587 {
4588     dTHX;
4589     char *file = __FILE__;
4590
4591     /* Initialize Win32CORE if it has been statically linked. */
4592     void (*pfn_init)(pTHX);
4593 #if defined(__BORLANDC__)
4594     /* makedef.pl seems to have given up on fixing this issue in the .def file */
4595     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4596 #else
4597     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4598 #endif
4599     if (pfn_init)
4600         pfn_init(aTHX);
4601
4602     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4603 }
4604
4605 void *
4606 win32_signal_context(void)
4607 {
4608     dTHX;
4609 #ifdef MULTIPLICITY
4610     if (!my_perl) {
4611         my_perl = PL_curinterp;
4612         PERL_SET_THX(my_perl);
4613     }
4614     return my_perl;
4615 #else
4616     return PL_curinterp;
4617 #endif
4618 }
4619
4620
4621 BOOL WINAPI
4622 win32_ctrlhandler(DWORD dwCtrlType)
4623 {
4624 #ifdef MULTIPLICITY
4625     dTHXa(PERL_GET_SIG_CONTEXT);
4626
4627     if (!my_perl)
4628         return FALSE;
4629 #endif
4630
4631     switch(dwCtrlType) {
4632     case CTRL_CLOSE_EVENT:
4633      /*  A signal that the system sends to all processes attached to a console when
4634          the user closes the console (either by choosing the Close command from the
4635          console window's System menu, or by choosing the End Task command from the
4636          Task List
4637       */
4638         if (do_raise(aTHX_ 1))        /* SIGHUP */
4639             sig_terminate(aTHX_ 1);
4640         return TRUE;
4641
4642     case CTRL_C_EVENT:
4643         /*  A CTRL+c signal was received */
4644         if (do_raise(aTHX_ SIGINT))
4645             sig_terminate(aTHX_ SIGINT);
4646         return TRUE;
4647
4648     case CTRL_BREAK_EVENT:
4649         /*  A CTRL+BREAK signal was received */
4650         if (do_raise(aTHX_ SIGBREAK))
4651             sig_terminate(aTHX_ SIGBREAK);
4652         return TRUE;
4653
4654     case CTRL_LOGOFF_EVENT:
4655       /*  A signal that the system sends to all console processes when a user is logging
4656           off. This signal does not indicate which user is logging off, so no
4657           assumptions can be made.
4658        */
4659         break;
4660     case CTRL_SHUTDOWN_EVENT:
4661       /*  A signal that the system sends to all console processes when the system is
4662           shutting down.
4663        */
4664         if (do_raise(aTHX_ SIGTERM))
4665             sig_terminate(aTHX_ SIGTERM);
4666         return TRUE;
4667     default:
4668         break;
4669     }
4670     return FALSE;
4671 }
4672
4673
4674 #ifdef SET_INVALID_PARAMETER_HANDLER
4675 #  include <crtdbg.h>
4676 #endif
4677
4678 static void
4679 ansify_path(void)
4680 {
4681     size_t len;
4682     char *ansi_path;
4683     WCHAR *wide_path;
4684     WCHAR *wide_dir;
4685
4686     /* win32_ansipath() requires Windows 2000 or later */
4687     if (!IsWin2000())
4688         return;
4689
4690     /* fetch Unicode version of PATH */
4691     len = 2000;
4692     wide_path = win32_malloc(len*sizeof(WCHAR));
4693     while (wide_path) {
4694         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4695         if (newlen < len)
4696             break;
4697         len = newlen;
4698         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4699     }
4700     if (!wide_path)
4701         return;
4702
4703     /* convert to ANSI pathnames */
4704     wide_dir = wide_path;
4705     ansi_path = NULL;
4706     while (wide_dir) {
4707         WCHAR *sep = wcschr(wide_dir, ';');
4708         char *ansi_dir;
4709         size_t ansi_len;
4710         size_t wide_len;
4711
4712         if (sep)
4713             *sep++ = '\0';
4714
4715         /* remove quotes around pathname */
4716         if (*wide_dir == '"')
4717             ++wide_dir;
4718         wide_len = wcslen(wide_dir);
4719         if (wide_len && wide_dir[wide_len-1] == '"')
4720             wide_dir[wide_len-1] = '\0';
4721
4722         /* append ansi_dir to ansi_path */
4723         ansi_dir = win32_ansipath(wide_dir);
4724         ansi_len = strlen(ansi_dir);
4725         if (ansi_path) {
4726             size_t newlen = len + 1 + ansi_len;
4727             ansi_path = win32_realloc(ansi_path, newlen+1);
4728             if (!ansi_path)
4729                 break;
4730             ansi_path[len] = ';';
4731             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4732             len = newlen;
4733         }
4734         else {
4735             len = ansi_len;
4736             ansi_path = win32_malloc(5+len+1);
4737             if (!ansi_path)
4738                 break;
4739             memcpy(ansi_path, "PATH=", 5);
4740             memcpy(ansi_path+5, ansi_dir, len+1);
4741             len += 5;
4742         }
4743         win32_free(ansi_dir);
4744         wide_dir = sep;
4745     }
4746
4747     if (ansi_path) {
4748         /* Update C RTL environ array.  This will only have full effect if
4749          * perl_parse() is later called with `environ` as the `env` argument.
4750          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4751          *
4752          * We do have to ansify() the PATH before Perl has been fully
4753          * initialized because S_find_script() uses the PATH when perl
4754          * is being invoked with the -S option.  This happens before %ENV
4755          * is initialized in S_init_postdump_symbols().
4756          *
4757          * XXX Is this a bug? Should S_find_script() use the environment
4758          * XXX passed in the `env` arg to parse_perl()?
4759          */
4760         putenv(ansi_path);
4761         /* Keep system environment in sync because S_init_postdump_symbols()
4762          * will not call mg_set() if it initializes %ENV from `environ`.
4763          */
4764         SetEnvironmentVariableA("PATH", ansi_path+5);
4765         /* We are intentionally leaking the ansi_path string here because
4766          * the Borland runtime library puts it directly into the environ
4767          * array.  The Microsoft runtime library seems to make a copy,
4768          * but will leak the copy should it be replaced again later.
4769          * Since this code is only called once during PERL_SYS_INIT this
4770          * shouldn't really matter.
4771          */
4772     }
4773     win32_free(wide_path);
4774 }
4775
4776 void
4777 Perl_win32_init(int *argcp, char ***argvp)
4778 {
4779     HMODULE module;
4780
4781 #ifdef SET_INVALID_PARAMETER_HANDLER
4782     _invalid_parameter_handler oldHandler, newHandler;
4783     newHandler = my_invalid_parameter_handler;
4784     oldHandler = _set_invalid_parameter_handler(newHandler);
4785     _CrtSetReportMode(_CRT_ASSERT, 0);
4786 #endif
4787     /* Disable floating point errors, Perl will trap the ones we
4788      * care about.  VC++ RTL defaults to switching these off
4789      * already, but the Borland RTL doesn't.  Since we don't
4790      * want to be at the vendor's whim on the default, we set
4791      * it explicitly here.
4792      */
4793 #if !defined(_ALPHA_) && !defined(__GNUC__)
4794     _control87(MCW_EM, MCW_EM);
4795 #endif
4796     MALLOC_INIT;
4797
4798     module = GetModuleHandle("ntdll.dll");
4799     if (module) {
4800         *(FARPROC*)&pfnZwQuerySystemInformation = GetProcAddress(module, "ZwQuerySystemInformation");
4801     }
4802
4803     module = GetModuleHandle("kernel32.dll");
4804     if (module) {
4805         *(FARPROC*)&pfnCreateToolhelp32Snapshot = GetProcAddress(module, "CreateToolhelp32Snapshot");
4806         *(FARPROC*)&pfnProcess32First           = GetProcAddress(module, "Process32First");
4807         *(FARPROC*)&pfnProcess32Next            = GetProcAddress(module, "Process32Next");
4808     }
4809
4810     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4811     GetVersionEx(&g_osver);
4812
4813     ansify_path();
4814 }
4815
4816 void
4817 Perl_win32_term(void)
4818 {
4819     dTHX;
4820     HINTS_REFCNT_TERM;
4821     OP_REFCNT_TERM;
4822     PERLIO_TERM;
4823     MALLOC_TERM;
4824 }
4825
4826 void
4827 win32_get_child_IO(child_IO_table* ptbl)
4828 {
4829     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4830     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4831     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4832 }
4833
4834 Sighandler_t
4835 win32_signal(int sig, Sighandler_t subcode)
4836 {
4837     dTHX;
4838     if (sig < SIG_SIZE) {
4839         int save_errno = errno;
4840         Sighandler_t result = signal(sig, subcode);
4841         if (result == SIG_ERR) {
4842             result = w32_sighandler[sig];
4843             errno = save_errno;
4844         }
4845         w32_sighandler[sig] = subcode;
4846         return result;
4847     }
4848     else {
4849         errno = EINVAL;
4850         return SIG_ERR;
4851     }
4852 }
4853
4854 /* The PerlMessageWindowClass's WindowProc */
4855 LRESULT CALLBACK
4856 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4857 {
4858     return win32_process_message(hwnd, msg, wParam, lParam) ?
4859         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4860 }
4861
4862 /* we use a message filter hook to process thread messages, passing any
4863  * messages that we don't process on to the rest of the hook chain
4864  * Anyone else writing a message loop that wants to play nicely with perl
4865  * should do
4866  *   CallMsgFilter(&msg, MSGF_***);
4867  * between their GetMessage and DispatchMessage calls.  */
4868 LRESULT CALLBACK
4869 win32_message_filter_proc(int code, WPARAM wParam, LPARAM lParam) {
4870     LPMSG pmsg = (LPMSG)lParam;
4871
4872     /* we'll process it if code says we're allowed, and it's a thread message */
4873     if (code >= 0 && pmsg->hwnd == NULL
4874             && win32_process_message(pmsg->hwnd, pmsg->message,
4875                                      pmsg->wParam, pmsg->lParam))
4876     {
4877             return TRUE;
4878     }
4879
4880     /* XXX: MSDN says that hhk is ignored, but we should really use the
4881      * return value from SetWindowsHookEx() in win32_create_message_window().  */
4882     return CallNextHookEx(NULL, code, wParam, lParam);
4883 }
4884
4885 /* The real message handler. Can be called with
4886  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4887  * that it processes */
4888 static LRESULT
4889 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4890 {
4891     /* BEWARE. The context retrieved using dTHX; is the context of the
4892      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4893      * up to and including WM_CREATE.  If it ever happens that you need the
4894      * 'child' context before this, then it needs to be passed into
4895      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4896      * from the lparam of CreateWindow().  It could then be stored/retrieved
4897      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4898      * the dTHX calls here. */
4899     /* XXX For now it is assumed that the overhead of the dTHX; for what
4900      * are relativley infrequent code-paths, is better than the added
4901      * complexity of getting the correct context passed into
4902      * win32_create_message_window() */
4903
4904     switch(msg) {
4905
4906 #ifdef USE_ITHREADS
4907         case WM_USER_MESSAGE: {
4908             long child = find_pseudo_pid((int)wParam);
4909             if (child >= 0) {
4910                 dTHX;
4911                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4912                 return 1;
4913             }
4914             break;
4915         }
4916 #endif
4917
4918         case WM_USER_KILL: {
4919             dTHX;
4920             /* We use WM_USER_KILL to fake kill() with other signals */
4921             int sig = (int)wParam;
4922             if (do_raise(aTHX_ sig))
4923                 sig_terminate(aTHX_ sig);
4924
4925             return 1;
4926         }
4927
4928         case WM_TIMER: {
4929             dTHX;
4930             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4931             if (w32_timerid && w32_timerid==(UINT)wParam) {
4932                 KillTimer(w32_message_hwnd, w32_timerid);
4933                 w32_timerid=0;
4934
4935                 /* Now fake a call to signal handler */
4936                 if (do_raise(aTHX_ 14))
4937                     sig_terminate(aTHX_ 14);
4938
4939                 return 1;
4940             }
4941             break;
4942         }
4943
4944         default:
4945             break;
4946
4947     } /* switch */
4948
4949     /* Above or other stuff may have set a signal flag, and we may not have
4950      * been called from win32_async_check() (e.g. some other GUI's message
4951      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
4952      * handler that die's, and the message loop that calls here is wrapped
4953      * in an eval, then you may well end up with orphaned windows - signals
4954      * are dispatched by win32_async_check() */
4955
4956     return 0;
4957 }
4958
4959 void
4960 win32_create_message_window_class(void)
4961 {
4962     /* create the window class for "message only" windows */
4963     WNDCLASS wc;
4964
4965     Zero(&wc, 1, wc);
4966     wc.lpfnWndProc = win32_message_window_proc;
4967     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4968     wc.lpszClassName = "PerlMessageWindowClass";
4969
4970     /* second and subsequent calls will fail, but class
4971      * will already be registered */
4972     RegisterClass(&wc);
4973 }
4974
4975 HWND
4976 win32_create_message_window(void)
4977 {
4978     HWND hwnd = NULL;
4979
4980     /* "message-only" windows have been implemented in Windows 2000 and later.
4981      * On earlier versions we'll continue to post messages to a specific
4982      * thread and use hwnd==NULL.  This is brittle when either an embedding
4983      * application or an XS module is also posting messages to hwnd=NULL
4984      * because once removed from the queue they cannot be delivered to the
4985      * "right" place with DispatchMessage() anymore, as there is no WindowProc
4986      * if there is no window handle.
4987      */
4988     /* Using HWND_MESSAGE appears to work under Win98, despite MSDN
4989      * documentation to the contrary, however, there is some evidence that
4990      * there may be problems with the implementation on Win98. As it is not
4991      * officially supported we take the cautious route and stick with thread
4992      * messages (hwnd == NULL) on platforms prior to Win2k.
4993      */
4994     if (IsWin2000()) {
4995         win32_create_message_window_class();
4996
4997         hwnd = CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4998                 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4999     }
5000
5001     /* If we din't create a window for any reason, then we'll use thread
5002      * messages for our signalling, so we install a hook which
5003      * is called by CallMsgFilter in win32_async_check(), or any other
5004      * modal loop (e.g. Win32::MsgBox or any other GUI extention, or anything
5005      * that use OLE, etc. */
5006     if(!hwnd) {
5007         SetWindowsHookEx(WH_MSGFILTER, win32_message_filter_proc,
5008                 NULL, GetCurrentThreadId());
5009     }
5010
5011     return hwnd;
5012 }
5013
5014 #ifdef HAVE_INTERP_INTERN
5015
5016 static void
5017 win32_csighandler(int sig)
5018 {
5019 #if 0
5020     dTHXa(PERL_GET_SIG_CONTEXT);
5021     Perl_warn(aTHX_ "Got signal %d",sig);
5022 #endif
5023     /* Does nothing */
5024 }
5025
5026 #if defined(__MINGW32__) && defined(__cplusplus)
5027 #define CAST_HWND__(x) (HWND__*)(x)
5028 #else
5029 #define CAST_HWND__(x) x
5030 #endif
5031
5032 void
5033 Perl_sys_intern_init(pTHX)
5034 {
5035     int i;
5036
5037     w32_perlshell_tokens        = NULL;
5038     w32_perlshell_vec           = (char**)NULL;
5039     w32_perlshell_items         = 0;
5040     w32_fdpid                   = newAV();
5041     Newx(w32_children, 1, child_tab);
5042     w32_num_children            = 0;
5043 #  ifdef USE_ITHREADS
5044     w32_pseudo_id               = 0;
5045     Newx(w32_pseudo_children, 1, pseudo_child_tab);
5046     w32_num_pseudo_children     = 0;
5047 #  endif
5048     w32_timerid                 = 0;
5049     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
5050     w32_poll_count              = 0;
5051     for (i=0; i < SIG_SIZE; i++) {
5052         w32_sighandler[i] = SIG_DFL;
5053     }
5054 #  ifdef MULTIPLICITY
5055     if (my_perl == PL_curinterp) {
5056 #  else
5057     {
5058 #  endif
5059         /* Force C runtime signal stuff to set its console handler */
5060         signal(SIGINT,win32_csighandler);
5061         signal(SIGBREAK,win32_csighandler);
5062
5063         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
5064          * flag.  This has the side-effect of disabling Ctrl-C events in all
5065          * processes in this group.  At least on Windows NT and later we
5066          * can re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
5067          * with a NULL handler.  This is not valid on Windows 9X.
5068          */
5069         if (IsWinNT())
5070             SetConsoleCtrlHandler(NULL,FALSE);
5071
5072         /* Push our handler on top */
5073         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5074     }
5075 }
5076
5077 void
5078 Perl_sys_intern_clear(pTHX)
5079 {
5080     Safefree(w32_perlshell_tokens);
5081     Safefree(w32_perlshell_vec);
5082     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5083     Safefree(w32_children);
5084     if (w32_timerid) {
5085         KillTimer(w32_message_hwnd, w32_timerid);
5086         w32_timerid = 0;
5087     }
5088     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
5089         DestroyWindow(w32_message_hwnd);
5090 #  ifdef MULTIPLICITY
5091     if (my_perl == PL_curinterp) {
5092 #  else
5093     {
5094 #  endif
5095         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5096     }
5097 #  ifdef USE_ITHREADS
5098     Safefree(w32_pseudo_children);
5099 #  endif
5100 }
5101
5102 #  ifdef USE_ITHREADS
5103
5104 void
5105 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5106 {
5107     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
5108
5109     dst->perlshell_tokens       = NULL;
5110     dst->perlshell_vec          = (char**)NULL;
5111     dst->perlshell_items        = 0;
5112     dst->fdpid                  = newAV();
5113     Newxz(dst->children, 1, child_tab);
5114     dst->pseudo_id              = 0;
5115     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
5116     dst->timerid                = 0;
5117     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
5118     dst->poll_count             = 0;
5119     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5120 }
5121 #  endif /* USE_ITHREADS */
5122 #endif /* HAVE_INTERP_INTERN */