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