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