win32/win32.c

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