win32/win32.c

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