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