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