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