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