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