win32/win32.c

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