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,(DWORD)(endtime-ticks.ft_i64)
2245                                             , QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2246         if (resultp)
2247            *resultp = result;
2248         if (result == WAIT_TIMEOUT) {
2249             /* Ran out of time - explicit return of zero to avoid -ve if we
2250                have scheduling issues
2251              */
2252             return 0;
2253         }
2254         if (timeout != INFINITE) {
2255             GetSystemTimeAsFileTime(&ticks.ft_val);
2256             ticks.ft_i64 /= 10000;
2257         }
2258         if (result == WAIT_OBJECT_0 + count) {
2259             /* Message has arrived - check it */
2260             (void)win32_async_check(aTHX);
2261         }
2262         else {
2263            /* Not timeout or message - one of handles is ready */
2264            break;
2265         }
2266     }
2267     /* If we are past the end say zero */
2268     if(!ticks.ft_i64 || ticks.ft_i64 > endtime)
2269         return 0;
2270     /* compute time left to wait */
2271     ticks.ft_i64 = endtime - ticks.ft_i64;
2272     /*if more ms than DWORD, then return max DWORD*/
2273     return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64:UINT_MAX;
2274 }
2275
2276 int
2277 win32_internal_wait(int *status, DWORD timeout)
2278 {
2279     /* XXX this wait emulation only knows about processes
2280      * spawned via win32_spawnvp(P_NOWAIT, ...).
2281      */
2282     dTHX;
2283     int i, retval;
2284     DWORD exitcode, waitcode;
2285
2286 #ifdef USE_ITHREADS
2287     if (w32_num_pseudo_children) {
2288         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2289                       timeout, &waitcode);
2290         /* Time out here if there are no other children to wait for. */
2291         if (waitcode == WAIT_TIMEOUT) {
2292             if (!w32_num_children) {
2293                 return 0;
2294             }
2295         }
2296         else if (waitcode != WAIT_FAILED) {
2297             if (waitcode >= WAIT_ABANDONED_0
2298                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2299                 i = waitcode - WAIT_ABANDONED_0;
2300             else
2301                 i = waitcode - WAIT_OBJECT_0;
2302             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2303                 *status = (int)((exitcode & 0xff) << 8);
2304                 retval = (int)w32_pseudo_child_pids[i];
2305                 remove_dead_pseudo_process(i);
2306                 return -retval;
2307             }
2308         }
2309     }
2310 #endif
2311
2312     if (!w32_num_children) {
2313         errno = ECHILD;
2314         return -1;
2315     }
2316
2317     /* if a child exists, wait for it to die */
2318     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2319     if (waitcode == WAIT_TIMEOUT) {
2320         return 0;
2321     }
2322     if (waitcode != WAIT_FAILED) {
2323         if (waitcode >= WAIT_ABANDONED_0
2324             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2325             i = waitcode - WAIT_ABANDONED_0;
2326         else
2327             i = waitcode - WAIT_OBJECT_0;
2328         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2329             *status = (int)((exitcode & 0xff) << 8);
2330             retval = (int)w32_child_pids[i];
2331             remove_dead_process(i);
2332             return retval;
2333         }
2334     }
2335
2336     errno = GetLastError();
2337     return -1;
2338 }
2339
2340 DllExport int
2341 win32_waitpid(int pid, int *status, int flags)
2342 {
2343     dTHX;
2344     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2345     int retval = -1;
2346     long child;
2347     if (pid == -1)                              /* XXX threadid == 1 ? */
2348         return win32_internal_wait(status, timeout);
2349 #ifdef USE_ITHREADS
2350     else if (pid < 0) {
2351         child = find_pseudo_pid(-pid);
2352         if (child >= 0) {
2353             HANDLE hThread = w32_pseudo_child_handles[child];
2354             DWORD waitcode;
2355             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2356             if (waitcode == WAIT_TIMEOUT) {
2357                 return 0;
2358             }
2359             else if (waitcode == WAIT_OBJECT_0) {
2360                 if (GetExitCodeThread(hThread, &waitcode)) {
2361                     *status = (int)((waitcode & 0xff) << 8);
2362                     retval = (int)w32_pseudo_child_pids[child];
2363                     remove_dead_pseudo_process(child);
2364                     return -retval;
2365                 }
2366             }
2367             else
2368                 errno = ECHILD;
2369         }
2370     }
2371 #endif
2372     else {
2373         HANDLE hProcess;
2374         DWORD waitcode;
2375         child = find_pid(pid);
2376         if (child >= 0) {
2377             hProcess = w32_child_handles[child];
2378             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2379             if (waitcode == WAIT_TIMEOUT) {
2380                 return 0;
2381             }
2382             else if (waitcode == WAIT_OBJECT_0) {
2383                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2384                     *status = (int)((waitcode & 0xff) << 8);
2385                     retval = (int)w32_child_pids[child];
2386                     remove_dead_process(child);
2387                     return retval;
2388                 }
2389             }
2390             else
2391                 errno = ECHILD;
2392         }
2393         else {
2394             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2395             if (hProcess) {
2396                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2397                 if (waitcode == WAIT_TIMEOUT) {
2398                     CloseHandle(hProcess);
2399                     return 0;
2400                 }
2401                 else if (waitcode == WAIT_OBJECT_0) {
2402                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2403                         *status = (int)((waitcode & 0xff) << 8);
2404                         CloseHandle(hProcess);
2405                         return pid;
2406                     }
2407                 }
2408                 CloseHandle(hProcess);
2409             }
2410             else
2411                 errno = ECHILD;
2412         }
2413     }
2414     return retval >= 0 ? pid : retval;
2415 }
2416
2417 DllExport int
2418 win32_wait(int *status)
2419 {
2420     return win32_internal_wait(status, INFINITE);
2421 }
2422
2423 DllExport unsigned int
2424 win32_sleep(unsigned int t)
2425 {
2426     dTHX;
2427     /* Win32 times are in ms so *1000 in and /1000 out */
2428     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2429 }
2430
2431 DllExport unsigned int
2432 win32_alarm(unsigned int sec)
2433 {
2434     /*
2435      * the 'obvious' implentation is SetTimer() with a callback
2436      * which does whatever receiving SIGALRM would do
2437      * we cannot use SIGALRM even via raise() as it is not
2438      * one of the supported codes in <signal.h>
2439      */
2440     dTHX;
2441
2442     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2443         w32_message_hwnd = win32_create_message_window();
2444
2445     if (sec) {
2446         if (w32_message_hwnd == NULL)
2447             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2448         else {
2449             w32_timerid = 1;
2450             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2451         }
2452     }
2453     else {
2454         if (w32_timerid) {
2455             KillTimer(w32_message_hwnd, w32_timerid);
2456             w32_timerid = 0;
2457         }
2458     }
2459     return 0;
2460 }
2461
2462 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2463
2464 DllExport char *
2465 win32_crypt(const char *txt, const char *salt)
2466 {
2467     dTHX;
2468     return des_fcrypt(txt, salt, w32_crypt_buffer);
2469 }
2470
2471 /* simulate flock by locking a range on the file */
2472
2473 #define LK_LEN          0xffff0000
2474
2475 DllExport int
2476 win32_flock(int fd, int oper)
2477 {
2478     OVERLAPPED o;
2479     int i = -1;
2480     HANDLE fh;
2481
2482     fh = (HANDLE)_get_osfhandle(fd);
2483     if (fh == (HANDLE)-1)  /* _get_osfhandle() already sets errno to EBADF */
2484         return -1;
2485
2486     memset(&o, 0, sizeof(o));
2487
2488     switch(oper) {
2489     case LOCK_SH:               /* shared lock */
2490         if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2491             i = 0;
2492         break;
2493     case LOCK_EX:               /* exclusive lock */
2494         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2495             i = 0;
2496         break;
2497     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2498         if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2499             i = 0;
2500         break;
2501     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2502         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2503                        0, LK_LEN, 0, &o))
2504             i = 0;
2505         break;
2506     case LOCK_UN:               /* unlock lock */
2507         if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2508             i = 0;
2509         break;
2510     default:                    /* unknown */
2511         errno = EINVAL;
2512         return -1;
2513     }
2514     if (i == -1) {
2515         if (GetLastError() == ERROR_LOCK_VIOLATION)
2516             errno = WSAEWOULDBLOCK;
2517         else
2518             errno = EINVAL;
2519     }
2520     return i;
2521 }
2522
2523 #undef LK_LEN
2524
2525 /*
2526  *  redirected io subsystem for all XS modules
2527  *
2528  */
2529
2530 DllExport int *
2531 win32_errno(void)
2532 {
2533     return (&errno);
2534 }
2535
2536 DllExport char ***
2537 win32_environ(void)
2538 {
2539     return (&(_environ));
2540 }
2541
2542 /* the rest are the remapped stdio routines */
2543 DllExport FILE *
2544 win32_stderr(void)
2545 {
2546     return (stderr);
2547 }
2548
2549 DllExport FILE *
2550 win32_stdin(void)
2551 {
2552     return (stdin);
2553 }
2554
2555 DllExport FILE *
2556 win32_stdout(void)
2557 {
2558     return (stdout);
2559 }
2560
2561 DllExport int
2562 win32_ferror(FILE *fp)
2563 {
2564     return (ferror(fp));
2565 }
2566
2567
2568 DllExport int
2569 win32_feof(FILE *fp)
2570 {
2571     return (feof(fp));
2572 }
2573
2574 /*
2575  * Since the errors returned by the socket error function
2576  * WSAGetLastError() are not known by the library routine strerror
2577  * we have to roll our own.
2578  */
2579
2580 DllExport char *
2581 win32_strerror(int e)
2582 {
2583 #if !defined __MINGW32__      /* compiler intolerance */
2584     extern int sys_nerr;
2585 #endif
2586
2587     if (e < 0 || e > sys_nerr) {
2588         dTHX;
2589         if (e < 0)
2590             e = GetLastError();
2591
2592         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2593                          |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2594                           w32_strerror_buffer, sizeof(w32_strerror_buffer),
2595                           NULL) == 0)
2596         {
2597             strcpy(w32_strerror_buffer, "Unknown Error");
2598         }
2599         return w32_strerror_buffer;
2600     }
2601 #undef strerror
2602     return strerror(e);
2603 #define strerror win32_strerror
2604 }
2605
2606 DllExport void
2607 win32_str_os_error(void *sv, DWORD dwErr)
2608 {
2609     DWORD dwLen;
2610     char *sMsg;
2611     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2612                           |FORMAT_MESSAGE_IGNORE_INSERTS
2613                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2614                            dwErr, 0, (char *)&sMsg, 1, NULL);
2615     /* strip trailing whitespace and period */
2616     if (0 < dwLen) {
2617         do {
2618             --dwLen;    /* dwLen doesn't include trailing null */
2619         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2620         if ('.' != sMsg[dwLen])
2621             dwLen++;
2622         sMsg[dwLen] = '\0';
2623     }
2624     if (0 == dwLen) {
2625         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2626         if (sMsg)
2627             dwLen = sprintf(sMsg,
2628                             "Unknown error #0x%lX (lookup 0x%lX)",
2629                             dwErr, GetLastError());
2630     }
2631     if (sMsg) {
2632         dTHX;
2633         sv_setpvn((SV*)sv, sMsg, dwLen);
2634         LocalFree(sMsg);
2635     }
2636 }
2637
2638 DllExport int
2639 win32_fprintf(FILE *fp, const char *format, ...)
2640 {
2641     va_list marker;
2642     va_start(marker, format);     /* Initialize variable arguments. */
2643
2644     return (vfprintf(fp, format, marker));
2645 }
2646
2647 DllExport int
2648 win32_printf(const char *format, ...)
2649 {
2650     va_list marker;
2651     va_start(marker, format);     /* Initialize variable arguments. */
2652
2653     return (vprintf(format, marker));
2654 }
2655
2656 DllExport int
2657 win32_vfprintf(FILE *fp, const char *format, va_list args)
2658 {
2659     return (vfprintf(fp, format, args));
2660 }
2661
2662 DllExport int
2663 win32_vprintf(const char *format, va_list args)
2664 {
2665     return (vprintf(format, args));
2666 }
2667
2668 DllExport size_t
2669 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2670 {
2671     return fread(buf, size, count, fp);
2672 }
2673
2674 DllExport size_t
2675 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2676 {
2677     return fwrite(buf, size, count, fp);
2678 }
2679
2680 #define MODE_SIZE 10
2681
2682 DllExport FILE *
2683 win32_fopen(const char *filename, const char *mode)
2684 {
2685     dTHX;
2686     FILE *f;
2687
2688     if (!*filename)
2689         return NULL;
2690
2691     if (stricmp(filename, "/dev/null")==0)
2692         filename = "NUL";
2693
2694     f = fopen(PerlDir_mapA(filename), mode);
2695     /* avoid buffering headaches for child processes */
2696     if (f && *mode == 'a')
2697         win32_fseek(f, 0, SEEK_END);
2698     return f;
2699 }
2700
2701 #ifndef USE_SOCKETS_AS_HANDLES
2702 #undef fdopen
2703 #define fdopen my_fdopen
2704 #endif
2705
2706 DllExport FILE *
2707 win32_fdopen(int handle, const char *mode)
2708 {
2709     dTHX;
2710     FILE *f;
2711     f = fdopen(handle, (char *) mode);
2712     /* avoid buffering headaches for child processes */
2713     if (f && *mode == 'a')
2714         win32_fseek(f, 0, SEEK_END);
2715     return f;
2716 }
2717
2718 DllExport FILE *
2719 win32_freopen(const char *path, const char *mode, FILE *stream)
2720 {
2721     dTHX;
2722     if (stricmp(path, "/dev/null")==0)
2723         path = "NUL";
2724
2725     return freopen(PerlDir_mapA(path), mode, stream);
2726 }
2727
2728 DllExport int
2729 win32_fclose(FILE *pf)
2730 {
2731     return my_fclose(pf);       /* defined in win32sck.c */
2732 }
2733
2734 DllExport int
2735 win32_fputs(const char *s,FILE *pf)
2736 {
2737     return fputs(s, pf);
2738 }
2739
2740 DllExport int
2741 win32_fputc(int c,FILE *pf)
2742 {
2743     return fputc(c,pf);
2744 }
2745
2746 DllExport int
2747 win32_ungetc(int c,FILE *pf)
2748 {
2749     return ungetc(c,pf);
2750 }
2751
2752 DllExport int
2753 win32_getc(FILE *pf)
2754 {
2755     return getc(pf);
2756 }
2757
2758 DllExport int
2759 win32_fileno(FILE *pf)
2760 {
2761     return fileno(pf);
2762 }
2763
2764 DllExport void
2765 win32_clearerr(FILE *pf)
2766 {
2767     clearerr(pf);
2768     return;
2769 }
2770
2771 DllExport int
2772 win32_fflush(FILE *pf)
2773 {
2774     return fflush(pf);
2775 }
2776
2777 DllExport Off_t
2778 win32_ftell(FILE *pf)
2779 {
2780 #if defined(WIN64) || defined(USE_LARGE_FILES)
2781     fpos_t pos;
2782     if (fgetpos(pf, &pos))
2783         return -1;
2784     return (Off_t)pos;
2785 #else
2786     return ftell(pf);
2787 #endif
2788 }
2789
2790 DllExport int
2791 win32_fseek(FILE *pf, Off_t offset,int origin)
2792 {
2793 #if defined(WIN64) || defined(USE_LARGE_FILES)
2794     fpos_t pos;
2795     switch (origin) {
2796     case SEEK_CUR:
2797         if (fgetpos(pf, &pos))
2798             return -1;
2799         offset += pos;
2800         break;
2801     case SEEK_END:
2802         fseek(pf, 0, SEEK_END);
2803         pos = _telli64(fileno(pf));
2804         offset += pos;
2805         break;
2806     case SEEK_SET:
2807         break;
2808     default:
2809         errno = EINVAL;
2810         return -1;
2811     }
2812     return fsetpos(pf, &offset);
2813 #else
2814     return fseek(pf, (long)offset, origin);
2815 #endif
2816 }
2817
2818 DllExport int
2819 win32_fgetpos(FILE *pf,fpos_t *p)
2820 {
2821     return fgetpos(pf, p);
2822 }
2823
2824 DllExport int
2825 win32_fsetpos(FILE *pf,const fpos_t *p)
2826 {
2827     return fsetpos(pf, p);
2828 }
2829
2830 DllExport void
2831 win32_rewind(FILE *pf)
2832 {
2833     rewind(pf);
2834     return;
2835 }
2836
2837 DllExport int
2838 win32_tmpfd(void)
2839 {
2840     dTHX;
2841     char prefix[MAX_PATH+1];
2842     char filename[MAX_PATH+1];
2843     DWORD len = GetTempPath(MAX_PATH, prefix);
2844     if (len && len < MAX_PATH) {
2845         if (GetTempFileName(prefix, "plx", 0, filename)) {
2846             HANDLE fh = CreateFile(filename,
2847                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2848                                    0,
2849                                    NULL,
2850                                    CREATE_ALWAYS,
2851                                    FILE_ATTRIBUTE_NORMAL
2852                                    | FILE_FLAG_DELETE_ON_CLOSE,
2853                                    NULL);
2854             if (fh != INVALID_HANDLE_VALUE) {
2855                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2856                 if (fd >= 0) {
2857                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2858                                           "Created tmpfile=%s\n",filename));
2859                     return fd;
2860                 }
2861             }
2862         }
2863     }
2864     return -1;
2865 }
2866
2867 DllExport FILE*
2868 win32_tmpfile(void)
2869 {
2870     int fd = win32_tmpfd();
2871     if (fd >= 0)
2872         return win32_fdopen(fd, "w+b");
2873     return NULL;
2874 }
2875
2876 DllExport void
2877 win32_abort(void)
2878 {
2879     abort();
2880     return;
2881 }
2882
2883 DllExport int
2884 win32_fstat(int fd, Stat_t *sbufptr)
2885 {
2886 #if defined(WIN64) || defined(USE_LARGE_FILES)
2887     return _fstati64(fd, sbufptr);
2888 #else
2889     return fstat(fd, sbufptr);
2890 #endif
2891 }
2892
2893 DllExport int
2894 win32_pipe(int *pfd, unsigned int size, int mode)
2895 {
2896     return _pipe(pfd, size, mode);
2897 }
2898
2899 DllExport PerlIO*
2900 win32_popenlist(const char *mode, IV narg, SV **args)
2901 {
2902  dTHX;
2903  Perl_croak(aTHX_ "List form of pipe open not implemented");
2904  return NULL;
2905 }
2906
2907 /*
2908  * a popen() clone that respects PERL5SHELL
2909  *
2910  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2911  */
2912
2913 DllExport PerlIO*
2914 win32_popen(const char *command, const char *mode)
2915 {
2916 #ifdef USE_RTL_POPEN
2917     return _popen(command, mode);
2918 #else
2919     dTHX;
2920     int p[2];
2921     int parent, child;
2922     int stdfd, oldfd;
2923     int ourmode;
2924     int childpid;
2925     DWORD nhandle;
2926     HANDLE old_h;
2927     int lock_held = 0;
2928
2929     /* establish which ends read and write */
2930     if (strchr(mode,'w')) {
2931         stdfd = 0;              /* stdin */
2932         parent = 1;
2933         child = 0;
2934         nhandle = STD_INPUT_HANDLE;
2935     }
2936     else if (strchr(mode,'r')) {
2937         stdfd = 1;              /* stdout */
2938         parent = 0;
2939         child = 1;
2940         nhandle = STD_OUTPUT_HANDLE;
2941     }
2942     else
2943         return NULL;
2944
2945     /* set the correct mode */
2946     if (strchr(mode,'b'))
2947         ourmode = O_BINARY;
2948     else if (strchr(mode,'t'))
2949         ourmode = O_TEXT;
2950     else
2951         ourmode = _fmode & (O_TEXT | O_BINARY);
2952
2953     /* the child doesn't inherit handles */
2954     ourmode |= O_NOINHERIT;
2955
2956     if (win32_pipe(p, 512, ourmode) == -1)
2957         return NULL;
2958
2959     /* save the old std handle (this needs to happen before the
2960      * dup2(), since that might call SetStdHandle() too) */
2961     OP_REFCNT_LOCK;
2962     lock_held = 1;
2963     old_h = GetStdHandle(nhandle);
2964
2965     /* save current stdfd */
2966     if ((oldfd = win32_dup(stdfd)) == -1)
2967         goto cleanup;
2968
2969     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2970     /* stdfd will be inherited by the child */
2971     if (win32_dup2(p[child], stdfd) == -1)
2972         goto cleanup;
2973
2974     /* close the child end in parent */
2975     win32_close(p[child]);
2976
2977     /* set the new std handle (in case dup2() above didn't) */
2978     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2979
2980     /* start the child */
2981     {
2982         dTHX;
2983         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2984             goto cleanup;
2985
2986         /* revert stdfd to whatever it was before */
2987         if (win32_dup2(oldfd, stdfd) == -1)
2988             goto cleanup;
2989
2990         /* close saved handle */
2991         win32_close(oldfd);
2992
2993         /* restore the old std handle (this needs to happen after the
2994          * dup2(), since that might call SetStdHandle() too */
2995         if (lock_held) {
2996             SetStdHandle(nhandle, old_h);
2997             OP_REFCNT_UNLOCK;
2998             lock_held = 0;
2999         }
3000
3001         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3002
3003         /* set process id so that it can be returned by perl's open() */
3004         PL_forkprocess = childpid;
3005     }
3006
3007     /* we have an fd, return a file stream */
3008     return (PerlIO_fdopen(p[parent], (char *)mode));
3009
3010 cleanup:
3011     /* we don't need to check for errors here */
3012     win32_close(p[0]);
3013     win32_close(p[1]);
3014     if (oldfd != -1) {
3015         win32_dup2(oldfd, stdfd);
3016         win32_close(oldfd);
3017     }
3018     if (lock_held) {
3019         SetStdHandle(nhandle, old_h);
3020         OP_REFCNT_UNLOCK;
3021         lock_held = 0;
3022     }
3023     return (NULL);
3024
3025 #endif /* USE_RTL_POPEN */
3026 }
3027
3028 /*
3029  * pclose() clone
3030  */
3031
3032 DllExport int
3033 win32_pclose(PerlIO *pf)
3034 {
3035 #ifdef USE_RTL_POPEN
3036     return _pclose(pf);
3037 #else
3038     dTHX;
3039     int childpid, status;
3040     SV *sv;
3041
3042     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3043
3044     if (SvIOK(sv))
3045         childpid = SvIVX(sv);
3046     else
3047         childpid = 0;
3048
3049     if (!childpid) {
3050         errno = EBADF;
3051         return -1;
3052     }
3053
3054 #ifdef USE_PERLIO
3055     PerlIO_close(pf);
3056 #else
3057     fclose(pf);
3058 #endif
3059     SvIVX(sv) = 0;
3060
3061     if (win32_waitpid(childpid, &status, 0) == -1)
3062         return -1;
3063
3064     return status;
3065
3066 #endif /* USE_RTL_POPEN */
3067 }
3068
3069 DllExport int
3070 win32_link(const char *oldname, const char *newname)
3071 {
3072     dTHX;
3073     WCHAR wOldName[MAX_PATH+1];
3074     WCHAR wNewName[MAX_PATH+1];
3075
3076     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3077         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3078         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3079         CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3080     {
3081         return 0;
3082     }
3083     /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
3084        both permissions errors and if the source is a directory, while
3085        POSIX wants EACCES and EPERM respectively.
3086
3087        Determined by experimentation on Windows 7 x64 SP1, since MS
3088        don't document what error codes are returned.
3089     */
3090     switch (GetLastError()) {
3091     case ERROR_BAD_NET_NAME:
3092     case ERROR_BAD_NETPATH:
3093     case ERROR_BAD_PATHNAME:
3094     case ERROR_FILE_NOT_FOUND:
3095     case ERROR_FILENAME_EXCED_RANGE:
3096     case ERROR_INVALID_DRIVE:
3097     case ERROR_PATH_NOT_FOUND:
3098       errno = ENOENT;
3099       break;
3100     case ERROR_ALREADY_EXISTS:
3101       errno = EEXIST;
3102       break;
3103     case ERROR_ACCESS_DENIED:
3104       errno = EACCES;
3105       break;
3106     case ERROR_NOT_SAME_DEVICE:
3107       errno = EXDEV;
3108       break;
3109     default:
3110       /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */
3111       errno = EINVAL;
3112       break;
3113     }
3114     return -1;
3115 }
3116
3117 DllExport int
3118 win32_rename(const char *oname, const char *newname)
3119 {
3120     char szOldName[MAX_PATH+1];
3121     BOOL bResult;
3122     DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3123     dTHX;
3124
3125     if (stricmp(newname, oname))
3126         dwFlags |= MOVEFILE_REPLACE_EXISTING;
3127     strcpy(szOldName, PerlDir_mapA(oname));
3128
3129     bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3130     if (!bResult) {
3131         DWORD err = GetLastError();
3132         switch (err) {
3133         case ERROR_BAD_NET_NAME:
3134         case ERROR_BAD_NETPATH:
3135         case ERROR_BAD_PATHNAME:
3136         case ERROR_FILE_NOT_FOUND:
3137         case ERROR_FILENAME_EXCED_RANGE:
3138         case ERROR_INVALID_DRIVE:
3139         case ERROR_NO_MORE_FILES:
3140         case ERROR_PATH_NOT_FOUND:
3141             errno = ENOENT;
3142             break;
3143         default:
3144             errno = EACCES;
3145             break;
3146         }
3147         return -1;
3148     }
3149     return 0;
3150 }
3151
3152 DllExport int
3153 win32_setmode(int fd, int mode)
3154 {
3155     return setmode(fd, mode);
3156 }
3157
3158 DllExport int
3159 win32_chsize(int fd, Off_t size)
3160 {
3161 #if defined(WIN64) || defined(USE_LARGE_FILES)
3162     int retval = 0;
3163     Off_t cur, end, extend;
3164
3165     cur = win32_tell(fd);
3166     if (cur < 0)
3167         return -1;
3168     end = win32_lseek(fd, 0, SEEK_END);
3169     if (end < 0)
3170         return -1;
3171     extend = size - end;
3172     if (extend == 0) {
3173         /* do nothing */
3174     }
3175     else if (extend > 0) {
3176         /* must grow the file, padding with nulls */
3177         char b[4096];
3178         int oldmode = win32_setmode(fd, O_BINARY);
3179         size_t count;
3180         memset(b, '\0', sizeof(b));
3181         do {
3182             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3183             count = win32_write(fd, b, count);
3184             if ((int)count < 0) {
3185                 retval = -1;
3186                 break;
3187             }
3188         } while ((extend -= count) > 0);
3189         win32_setmode(fd, oldmode);
3190     }
3191     else {
3192         /* shrink the file */
3193         win32_lseek(fd, size, SEEK_SET);
3194         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3195             errno = EACCES;
3196             retval = -1;
3197         }
3198     }
3199 finish:
3200     win32_lseek(fd, cur, SEEK_SET);
3201     return retval;
3202 #else
3203     return chsize(fd, (long)size);
3204 #endif
3205 }
3206
3207 DllExport Off_t
3208 win32_lseek(int fd, Off_t offset, int origin)
3209 {
3210 #if defined(WIN64) || defined(USE_LARGE_FILES)
3211     return _lseeki64(fd, offset, origin);
3212 #else
3213     return lseek(fd, (long)offset, origin);
3214 #endif
3215 }
3216
3217 DllExport Off_t
3218 win32_tell(int fd)
3219 {
3220 #if defined(WIN64) || defined(USE_LARGE_FILES)
3221     return _telli64(fd);
3222 #else
3223     return tell(fd);
3224 #endif
3225 }
3226
3227 DllExport int
3228 win32_open(const char *path, int flag, ...)
3229 {
3230     dTHX;
3231     va_list ap;
3232     int pmode;
3233
3234     va_start(ap, flag);
3235     pmode = va_arg(ap, int);
3236     va_end(ap);
3237
3238     if (stricmp(path, "/dev/null")==0)
3239         path = "NUL";
3240
3241     return open(PerlDir_mapA(path), flag, pmode);
3242 }
3243
3244 /* close() that understands socket */
3245 extern int my_close(int);       /* in win32sck.c */
3246
3247 DllExport int
3248 win32_close(int fd)
3249 {
3250     return my_close(fd);
3251 }
3252
3253 DllExport int
3254 win32_eof(int fd)
3255 {
3256     return eof(fd);
3257 }
3258
3259 DllExport int
3260 win32_isatty(int fd)
3261 {
3262     /* The Microsoft isatty() function returns true for *all*
3263      * character mode devices, including "nul".  Our implementation
3264      * should only return true if the handle has a console buffer.
3265      */
3266     DWORD mode;
3267     HANDLE fh = (HANDLE)_get_osfhandle(fd);
3268     if (fh == (HANDLE)-1) {
3269         /* errno is already set to EBADF */
3270         return 0;
3271     }
3272
3273     if (GetConsoleMode(fh, &mode))
3274         return 1;
3275
3276     errno = ENOTTY;
3277     return 0;
3278 }
3279
3280 DllExport int
3281 win32_dup(int fd)
3282 {
3283     return dup(fd);
3284 }
3285
3286 DllExport int
3287 win32_dup2(int fd1,int fd2)
3288 {
3289     return dup2(fd1,fd2);
3290 }
3291
3292 DllExport int
3293 win32_read(int fd, void *buf, unsigned int cnt)
3294 {
3295     return read(fd, buf, cnt);
3296 }
3297
3298 DllExport int
3299 win32_write(int fd, const void *buf, unsigned int cnt)
3300 {
3301     return write(fd, buf, cnt);
3302 }
3303
3304 DllExport int
3305 win32_mkdir(const char *dir, int mode)
3306 {
3307     dTHX;
3308     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3309 }
3310
3311 DllExport int
3312 win32_rmdir(const char *dir)
3313 {
3314     dTHX;
3315     return rmdir(PerlDir_mapA(dir));
3316 }
3317
3318 DllExport int
3319 win32_chdir(const char *dir)
3320 {
3321     dTHX;
3322     if (!dir) {
3323         errno = ENOENT;
3324         return -1;
3325     }
3326     return chdir(dir);
3327 }
3328
3329 DllExport  int
3330 win32_access(const char *path, int mode)
3331 {
3332     dTHX;
3333     return access(PerlDir_mapA(path), mode);
3334 }
3335
3336 DllExport  int
3337 win32_chmod(const char *path, int mode)
3338 {
3339     dTHX;
3340     return chmod(PerlDir_mapA(path), mode);
3341 }
3342
3343
3344 static char *
3345 create_command_line(char *cname, STRLEN clen, const char * const *args)
3346 {
3347     dTHX;
3348     int index, argc;
3349     char *cmd, *ptr;
3350     const char *arg;
3351     STRLEN len = 0;
3352     bool bat_file = FALSE;
3353     bool cmd_shell = FALSE;
3354     bool dumb_shell = FALSE;
3355     bool extra_quotes = FALSE;
3356     bool quote_next = FALSE;
3357
3358     if (!cname)
3359         cname = (char*)args[0];
3360
3361     /* The NT cmd.exe shell has the following peculiarity that needs to be
3362      * worked around.  It strips a leading and trailing dquote when any
3363      * of the following is true:
3364      *    1. the /S switch was used
3365      *    2. there are more than two dquotes
3366      *    3. there is a special character from this set: &<>()@^|
3367      *    4. no whitespace characters within the two dquotes
3368      *    5. string between two dquotes isn't an executable file
3369      * To work around this, we always add a leading and trailing dquote
3370      * to the string, if the first argument is either "cmd.exe" or "cmd",
3371      * and there were at least two or more arguments passed to cmd.exe
3372      * (not including switches).
3373      * XXX the above rules (from "cmd /?") don't seem to be applied
3374      * always, making for the convolutions below :-(
3375      */
3376     if (cname) {
3377         if (!clen)
3378             clen = strlen(cname);
3379
3380         if (clen > 4
3381             && (stricmp(&cname[clen-4], ".bat") == 0
3382                 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3383         {
3384             bat_file = TRUE;
3385             len += 3;
3386         }
3387         else {
3388             char *exe = strrchr(cname, '/');
3389             char *exe2 = strrchr(cname, '\\');
3390             if (exe2 > exe)
3391                 exe = exe2;
3392             if (exe)
3393                 ++exe;
3394             else
3395                 exe = cname;
3396             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3397                 cmd_shell = TRUE;
3398                 len += 3;
3399             }
3400             else if (stricmp(exe, "command.com") == 0
3401                      || stricmp(exe, "command") == 0)
3402             {
3403                 dumb_shell = TRUE;
3404             }
3405         }
3406     }
3407
3408     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3409     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3410         STRLEN curlen = strlen(arg);
3411         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3412             len += 2;   /* assume quoting needed (worst case) */
3413         len += curlen + 1;
3414         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3415     }
3416     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3417
3418     argc = index;
3419     Newx(cmd, len, char);
3420     ptr = cmd;
3421
3422     if (bat_file) {
3423         *ptr++ = '"';
3424         extra_quotes = TRUE;
3425     }
3426
3427     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3428         bool do_quote = 0;
3429         STRLEN curlen = strlen(arg);
3430
3431         /* we want to protect empty arguments and ones with spaces with
3432          * dquotes, but only if they aren't already there */
3433         if (!dumb_shell) {
3434             if (!curlen) {
3435                 do_quote = 1;
3436             }
3437             else if (quote_next) {
3438                 /* see if it really is multiple arguments pretending to
3439                  * be one and force a set of quotes around it */
3440                 if (*find_next_space(arg))
3441                     do_quote = 1;
3442             }
3443             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3444                 STRLEN i = 0;
3445                 while (i < curlen) {
3446                     if (isSPACE(arg[i])) {
3447                         do_quote = 1;
3448                     }
3449                     else if (arg[i] == '"') {
3450                         do_quote = 0;
3451                         break;
3452                     }
3453                     i++;
3454                 }
3455             }
3456         }
3457
3458         if (do_quote)
3459             *ptr++ = '"';
3460
3461         strcpy(ptr, arg);
3462         ptr += curlen;
3463
3464         if (do_quote)
3465             *ptr++ = '"';
3466
3467         if (args[index+1])
3468             *ptr++ = ' ';
3469
3470         if (!extra_quotes
3471             && cmd_shell
3472             && curlen >= 2
3473             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3474             && stricmp(arg+curlen-2, "/c") == 0)
3475         {
3476             /* is there a next argument? */
3477             if (args[index+1]) {
3478                 /* are there two or more next arguments? */
3479                 if (args[index+2]) {
3480                     *ptr++ = '"';
3481                     extra_quotes = TRUE;
3482                 }
3483                 else {
3484                     /* single argument, force quoting if it has spaces */
3485                     quote_next = TRUE;
3486                 }
3487             }
3488         }
3489     }
3490
3491     if (extra_quotes)
3492         *ptr++ = '"';
3493
3494     *ptr = '\0';
3495
3496     return cmd;
3497 }
3498
3499 static char *
3500 qualified_path(const char *cmd)
3501 {
3502     dTHX;
3503     char *pathstr;
3504     char *fullcmd, *curfullcmd;
3505     STRLEN cmdlen = 0;
3506     int has_slash = 0;
3507
3508     if (!cmd)
3509         return NULL;
3510     fullcmd = (char*)cmd;
3511     while (*fullcmd) {
3512         if (*fullcmd == '/' || *fullcmd == '\\')
3513             has_slash++;
3514         fullcmd++;
3515         cmdlen++;
3516     }
3517
3518     /* look in PATH */
3519     pathstr = PerlEnv_getenv("PATH");
3520
3521     /* worst case: PATH is a single directory; we need additional space
3522      * to append "/", ".exe" and trailing "\0" */
3523     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3524     curfullcmd = fullcmd;
3525
3526     while (1) {
3527         DWORD res;
3528
3529         /* start by appending the name to the current prefix */
3530         strcpy(curfullcmd, cmd);
3531         curfullcmd += cmdlen;
3532
3533         /* if it doesn't end with '.', or has no extension, try adding
3534          * a trailing .exe first */
3535         if (cmd[cmdlen-1] != '.'
3536             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3537         {
3538             strcpy(curfullcmd, ".exe");
3539             res = GetFileAttributes(fullcmd);
3540             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3541                 return fullcmd;
3542             *curfullcmd = '\0';
3543         }
3544
3545         /* that failed, try the bare name */
3546         res = GetFileAttributes(fullcmd);
3547         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3548             return fullcmd;
3549
3550         /* quit if no other path exists, or if cmd already has path */
3551         if (!pathstr || !*pathstr || has_slash)
3552             break;
3553
3554         /* skip leading semis */
3555         while (*pathstr == ';')
3556             pathstr++;
3557
3558         /* build a new prefix from scratch */
3559         curfullcmd = fullcmd;
3560         while (*pathstr && *pathstr != ';') {
3561             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3562                 pathstr++;              /* skip initial '"' */
3563                 while (*pathstr && *pathstr != '"') {
3564                     *curfullcmd++ = *pathstr++;
3565                 }
3566                 if (*pathstr)
3567                     pathstr++;          /* skip trailing '"' */
3568             }
3569             else {
3570                 *curfullcmd++ = *pathstr++;
3571             }
3572         }
3573         if (*pathstr)
3574             pathstr++;                  /* skip trailing semi */
3575         if (curfullcmd > fullcmd        /* append a dir separator */
3576             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3577         {
3578             *curfullcmd++ = '\\';
3579         }
3580     }
3581
3582     Safefree(fullcmd);
3583     return NULL;
3584 }
3585
3586 /* The following are just place holders.
3587  * Some hosts may provide and environment that the OS is
3588  * not tracking, therefore, these host must provide that
3589  * environment and the current directory to CreateProcess
3590  */
3591
3592 DllExport void*
3593 win32_get_childenv(void)
3594 {
3595     return NULL;
3596 }
3597
3598 DllExport void
3599 win32_free_childenv(void* d)
3600 {
3601 }
3602
3603 DllExport void
3604 win32_clearenv(void)
3605 {
3606     char *envv = GetEnvironmentStrings();
3607     char *cur = envv;
3608     STRLEN len;
3609     while (*cur) {
3610         char *end = strchr(cur,'=');
3611         if (end && end != cur) {
3612             *end = '\0';
3613             SetEnvironmentVariable(cur, NULL);
3614             *end = '=';
3615             cur = end + strlen(end+1)+2;
3616         }
3617         else if ((len = strlen(cur)))
3618             cur += len+1;
3619     }
3620     FreeEnvironmentStrings(envv);
3621 }
3622
3623 DllExport char*
3624 win32_get_childdir(void)
3625 {
3626     dTHX;
3627     char* ptr;
3628     char szfilename[MAX_PATH+1];
3629
3630     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3631     Newx(ptr, strlen(szfilename)+1, char);
3632     strcpy(ptr, szfilename);
3633     return ptr;
3634 }
3635
3636 DllExport void
3637 win32_free_childdir(char* d)
3638 {
3639     dTHX;
3640     Safefree(d);
3641 }
3642
3643
3644 /* XXX this needs to be made more compatible with the spawnvp()
3645  * provided by the various RTLs.  In particular, searching for
3646  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3647  * This doesn't significantly affect perl itself, because we
3648  * always invoke things using PERL5SHELL if a direct attempt to
3649  * spawn the executable fails.
3650  *
3651  * XXX splitting and rejoining the commandline between do_aspawn()
3652  * and win32_spawnvp() could also be avoided.
3653  */
3654
3655 DllExport int
3656 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3657 {
3658 #ifdef USE_RTL_SPAWNVP
3659     return spawnvp(mode, cmdname, (char * const *)argv);
3660 #else
3661     dTHX;
3662     int ret;
3663     void* env;
3664     char* dir;
3665     child_IO_table tbl;
3666     STARTUPINFO StartupInfo;
3667     PROCESS_INFORMATION ProcessInformation;
3668     DWORD create = 0;
3669     char *cmd;
3670     char *fullcmd = NULL;
3671     char *cname = (char *)cmdname;
3672     STRLEN clen = 0;
3673
3674     if (cname) {
3675         clen = strlen(cname);
3676         /* if command name contains dquotes, must remove them */
3677         if (strchr(cname, '"')) {
3678             cmd = cname;
3679             Newx(cname,clen+1,char);
3680             clen = 0;
3681             while (*cmd) {
3682                 if (*cmd != '"') {
3683                     cname[clen] = *cmd;
3684                     ++clen;
3685                 }
3686                 ++cmd;
3687             }
3688             cname[clen] = '\0';
3689         }
3690     }
3691
3692     cmd = create_command_line(cname, clen, argv);
3693
3694     env = PerlEnv_get_childenv();
3695     dir = PerlEnv_get_childdir();
3696
3697     switch(mode) {
3698     case P_NOWAIT:      /* asynch + remember result */
3699         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3700             errno = EAGAIN;
3701             ret = -1;
3702             goto RETVAL;
3703         }
3704         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3705          * in win32_kill()
3706          */
3707         create |= CREATE_NEW_PROCESS_GROUP;
3708         /* FALL THROUGH */
3709
3710     case P_WAIT:        /* synchronous execution */
3711         break;
3712     default:            /* invalid mode */
3713         errno = EINVAL;
3714         ret = -1;
3715         goto RETVAL;
3716     }
3717     memset(&StartupInfo,0,sizeof(StartupInfo));
3718     StartupInfo.cb = sizeof(StartupInfo);
3719     memset(&tbl,0,sizeof(tbl));
3720     PerlEnv_get_child_IO(&tbl);
3721     StartupInfo.dwFlags         = tbl.dwFlags;
3722     StartupInfo.dwX             = tbl.dwX;
3723     StartupInfo.dwY             = tbl.dwY;
3724     StartupInfo.dwXSize         = tbl.dwXSize;
3725     StartupInfo.dwYSize         = tbl.dwYSize;
3726     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3727     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3728     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3729     StartupInfo.wShowWindow     = tbl.wShowWindow;
3730     StartupInfo.hStdInput       = tbl.childStdIn;
3731     StartupInfo.hStdOutput      = tbl.childStdOut;
3732     StartupInfo.hStdError       = tbl.childStdErr;
3733     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3734         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3735         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3736     {
3737         create |= CREATE_NEW_CONSOLE;
3738     }
3739     else {
3740         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3741     }
3742     if (w32_use_showwindow) {
3743         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3744         StartupInfo.wShowWindow = w32_showwindow;
3745     }
3746
3747     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3748                           cname,cmd));
3749 RETRY:
3750     if (!CreateProcess(cname,           /* search PATH to find executable */
3751                        cmd,             /* executable, and its arguments */
3752                        NULL,            /* process attributes */
3753                        NULL,            /* thread attributes */
3754                        TRUE,            /* inherit handles */
3755                        create,          /* creation flags */
3756                        (LPVOID)env,     /* inherit environment */
3757                        dir,             /* inherit cwd */
3758                        &StartupInfo,
3759                        &ProcessInformation))
3760     {
3761         /* initial NULL argument to CreateProcess() does a PATH
3762          * search, but it always first looks in the directory
3763          * where the current process was started, which behavior
3764          * is undesirable for backward compatibility.  So we
3765          * jump through our own hoops by picking out the path
3766          * we really want it to use. */
3767         if (!fullcmd) {
3768             fullcmd = qualified_path(cname);
3769             if (fullcmd) {
3770                 if (cname != cmdname)
3771                     Safefree(cname);
3772                 cname = fullcmd;
3773                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3774                                       "Retrying [%s] with same args\n",
3775                                       cname));
3776                 goto RETRY;
3777             }
3778         }
3779         errno = ENOENT;
3780         ret = -1;
3781         goto RETVAL;
3782     }
3783
3784     if (mode == P_NOWAIT) {
3785         /* asynchronous spawn -- store handle, return PID */
3786         ret = (int)ProcessInformation.dwProcessId;
3787
3788         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3789         w32_child_pids[w32_num_children] = (DWORD)ret;
3790         ++w32_num_children;
3791     }
3792     else  {
3793         DWORD status;
3794         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3795         /* FIXME: if msgwait returned due to message perhaps forward the
3796            "signal" to the process
3797          */
3798         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3799         ret = (int)status;
3800         CloseHandle(ProcessInformation.hProcess);
3801     }
3802
3803     CloseHandle(ProcessInformation.hThread);
3804
3805 RETVAL:
3806     PerlEnv_free_childenv(env);
3807     PerlEnv_free_childdir(dir);
3808     Safefree(cmd);
3809     if (cname != cmdname)
3810         Safefree(cname);
3811     return ret;
3812 #endif
3813 }
3814
3815 DllExport int
3816 win32_execv(const char *cmdname, const char *const *argv)
3817 {
3818 #ifdef USE_ITHREADS
3819     dTHX;
3820     /* if this is a pseudo-forked child, we just want to spawn
3821      * the new program, and return */
3822     if (w32_pseudo_id)
3823         return spawnv(P_WAIT, cmdname, argv);
3824 #endif
3825     return execv(cmdname, argv);
3826 }
3827
3828 DllExport int
3829 win32_execvp(const char *cmdname, const char *const *argv)
3830 {
3831 #ifdef USE_ITHREADS
3832     dTHX;
3833     /* if this is a pseudo-forked child, we just want to spawn
3834      * the new program, and return */
3835     if (w32_pseudo_id) {
3836         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3837         if (status != -1) {
3838             my_exit(status);
3839             return 0;
3840         }
3841         else
3842             return status;
3843     }
3844 #endif
3845     return execvp(cmdname, argv);
3846 }
3847
3848 DllExport void
3849 win32_perror(const char *str)
3850 {
3851     perror(str);
3852 }
3853
3854 DllExport void
3855 win32_setbuf(FILE *pf, char *buf)
3856 {
3857     setbuf(pf, buf);
3858 }
3859
3860 DllExport int
3861 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3862 {
3863     return setvbuf(pf, buf, type, size);
3864 }
3865
3866 DllExport int
3867 win32_flushall(void)
3868 {
3869     return flushall();
3870 }
3871
3872 DllExport int
3873 win32_fcloseall(void)
3874 {
3875     return fcloseall();
3876 }
3877
3878 DllExport char*
3879 win32_fgets(char *s, int n, FILE *pf)
3880 {
3881     return fgets(s, n, pf);
3882 }
3883
3884 DllExport char*
3885 win32_gets(char *s)
3886 {
3887     return gets(s);
3888 }
3889
3890 DllExport int
3891 win32_fgetc(FILE *pf)
3892 {
3893     return fgetc(pf);
3894 }
3895
3896 DllExport int
3897 win32_putc(int c, FILE *pf)
3898 {
3899     return putc(c,pf);
3900 }
3901
3902 DllExport int
3903 win32_puts(const char *s)
3904 {
3905     return puts(s);
3906 }
3907
3908 DllExport int
3909 win32_getchar(void)
3910 {
3911     return getchar();
3912 }
3913
3914 DllExport int
3915 win32_putchar(int c)
3916 {
3917     return putchar(c);
3918 }
3919
3920 #ifdef MYMALLOC
3921
3922 #ifndef USE_PERL_SBRK
3923
3924 static char *committed = NULL;          /* XXX threadead */
3925 static char *base      = NULL;          /* XXX threadead */
3926 static char *reserved  = NULL;          /* XXX threadead */
3927 static char *brk       = NULL;          /* XXX threadead */
3928 static DWORD pagesize  = 0;             /* XXX threadead */
3929
3930 void *
3931 sbrk(ptrdiff_t need)
3932 {
3933  void *result;
3934  if (!pagesize)
3935   {SYSTEM_INFO info;
3936    GetSystemInfo(&info);
3937    /* Pretend page size is larger so we don't perpetually
3938     * call the OS to commit just one page ...
3939     */
3940    pagesize = info.dwPageSize << 3;
3941   }
3942  if (brk+need >= reserved)
3943   {
3944    DWORD size = brk+need-reserved;
3945    char *addr;
3946    char *prev_committed = NULL;
3947    if (committed && reserved && committed < reserved)
3948     {
3949      /* Commit last of previous chunk cannot span allocations */
3950      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3951      if (addr)
3952       {
3953       /* Remember where we committed from in case we want to decommit later */
3954       prev_committed = committed;
3955       committed = reserved;
3956       }
3957     }
3958    /* Reserve some (more) space
3959     * Contiguous blocks give us greater efficiency, so reserve big blocks -
3960     * this is only address space not memory...
3961     * Note this is a little sneaky, 1st call passes NULL as reserved
3962     * so lets system choose where we start, subsequent calls pass
3963     * the old end address so ask for a contiguous block
3964     */
3965 sbrk_reserve:
3966    if (size < 64*1024*1024)
3967     size = 64*1024*1024;
3968    size = ((size + pagesize - 1) / pagesize) * pagesize;
3969    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3970    if (addr)
3971     {
3972      reserved = addr+size;
3973      if (!base)
3974       base = addr;
3975      if (!committed)
3976       committed = base;
3977      if (!brk)
3978       brk = committed;
3979     }
3980    else if (reserved)
3981     {
3982       /* The existing block could not be extended far enough, so decommit
3983        * anything that was just committed above and start anew */
3984       if (prev_committed)
3985        {
3986        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
3987         return (void *) -1;
3988        }
3989       reserved = base = committed = brk = NULL;
3990       size = need;
3991       goto sbrk_reserve;
3992     }
3993    else
3994     {
3995      return (void *) -1;
3996     }
3997   }
3998  result = brk;
3999  brk += need;
4000  if (brk > committed)
4001   {
4002    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4003    char *addr;
4004    if (committed+size > reserved)
4005     size = reserved-committed;
4006    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4007    if (addr)
4008     committed += size;
4009    else
4010     return (void *) -1;
4011   }
4012  return result;
4013 }
4014
4015 #endif
4016 #endif
4017
4018 DllExport void*
4019 win32_malloc(size_t size)
4020 {
4021     return malloc(size);
4022 }
4023
4024 DllExport void*
4025 win32_calloc(size_t numitems, size_t size)
4026 {
4027     return calloc(numitems,size);
4028 }
4029
4030 DllExport void*
4031 win32_realloc(void *block, size_t size)
4032 {
4033     return realloc(block,size);
4034 }
4035
4036 DllExport void
4037 win32_free(void *block)
4038 {
4039     free(block);
4040 }
4041
4042
4043 DllExport int
4044 win32_open_osfhandle(intptr_t handle, int flags)
4045 {
4046     return _open_osfhandle(handle, flags);
4047 }
4048
4049 DllExport intptr_t
4050 win32_get_osfhandle(int fd)
4051 {
4052     return (intptr_t)_get_osfhandle(fd);
4053 }
4054
4055 DllExport FILE *
4056 win32_fdupopen(FILE *pf)
4057 {
4058     FILE* pfdup;
4059     fpos_t pos;
4060     char mode[3];
4061     int fileno = win32_dup(win32_fileno(pf));
4062
4063     /* open the file in the same mode */
4064     if((pf)->_flag & _IOREAD) {
4065         mode[0] = 'r';
4066         mode[1] = 0;
4067     }
4068     else if((pf)->_flag & _IOWRT) {
4069         mode[0] = 'a';
4070         mode[1] = 0;
4071     }
4072     else if((pf)->_flag & _IORW) {
4073         mode[0] = 'r';
4074         mode[1] = '+';
4075         mode[2] = 0;
4076     }
4077
4078     /* it appears that the binmode is attached to the
4079      * file descriptor so binmode files will be handled
4080      * correctly
4081      */
4082     pfdup = win32_fdopen(fileno, mode);
4083
4084     /* move the file pointer to the same position */
4085     if (!fgetpos(pf, &pos)) {
4086         fsetpos(pfdup, &pos);
4087     }
4088     return pfdup;
4089 }
4090
4091 DllExport void*
4092 win32_dynaload(const char* filename)
4093 {
4094     dTHX;
4095     char buf[MAX_PATH+1];
4096     char *first;
4097
4098     /* LoadLibrary() doesn't recognize forward slashes correctly,
4099      * so turn 'em back. */
4100     first = strchr(filename, '/');
4101     if (first) {
4102         STRLEN len = strlen(filename);
4103         if (len <= MAX_PATH) {
4104             strcpy(buf, filename);
4105             filename = &buf[first - filename];
4106             while (*filename) {
4107                 if (*filename == '/')
4108                     *(char*)filename = '\\';
4109                 ++filename;
4110             }
4111             filename = buf;
4112         }
4113     }
4114     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4115 }
4116
4117 XS(w32_SetChildShowWindow)
4118 {
4119     dXSARGS;
4120     BOOL use_showwindow = w32_use_showwindow;
4121     /* use "unsigned short" because Perl has redefined "WORD" */
4122     unsigned short showwindow = w32_showwindow;
4123
4124     if (items > 1)
4125         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4126
4127     if (items == 0 || !SvOK(ST(0)))
4128         w32_use_showwindow = FALSE;
4129     else {
4130         w32_use_showwindow = TRUE;
4131         w32_showwindow = (unsigned short)SvIV(ST(0));
4132     }
4133
4134     EXTEND(SP, 1);
4135     if (use_showwindow)
4136         ST(0) = sv_2mortal(newSViv(showwindow));
4137     else
4138         ST(0) = &PL_sv_undef;
4139     XSRETURN(1);
4140 }
4141
4142 void
4143 Perl_init_os_extras(void)
4144 {
4145     dTHX;
4146     char *file = __FILE__;
4147
4148     /* Initialize Win32CORE if it has been statically linked. */
4149     void (*pfn_init)(pTHX);
4150     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4151     if (pfn_init)
4152         pfn_init(aTHX);
4153
4154     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4155 }
4156
4157 void *
4158 win32_signal_context(void)
4159 {
4160     dTHX;
4161 #ifdef MULTIPLICITY
4162     if (!my_perl) {
4163         my_perl = PL_curinterp;
4164         PERL_SET_THX(my_perl);
4165     }
4166     return my_perl;
4167 #else
4168     return PL_curinterp;
4169 #endif
4170 }
4171
4172
4173 BOOL WINAPI
4174 win32_ctrlhandler(DWORD dwCtrlType)
4175 {
4176 #ifdef MULTIPLICITY
4177     dTHXa(PERL_GET_SIG_CONTEXT);
4178
4179     if (!my_perl)
4180         return FALSE;
4181 #endif
4182
4183     switch(dwCtrlType) {
4184     case CTRL_CLOSE_EVENT:
4185      /*  A signal that the system sends to all processes attached to a console when
4186          the user closes the console (either by choosing the Close command from the
4187          console window's System menu, or by choosing the End Task command from the
4188          Task List
4189       */
4190         if (do_raise(aTHX_ 1))        /* SIGHUP */
4191             sig_terminate(aTHX_ 1);
4192         return TRUE;
4193
4194     case CTRL_C_EVENT:
4195         /*  A CTRL+c signal was received */
4196         if (do_raise(aTHX_ SIGINT))
4197             sig_terminate(aTHX_ SIGINT);
4198         return TRUE;
4199
4200     case CTRL_BREAK_EVENT:
4201         /*  A CTRL+BREAK signal was received */
4202         if (do_raise(aTHX_ SIGBREAK))
4203             sig_terminate(aTHX_ SIGBREAK);
4204         return TRUE;
4205
4206     case CTRL_LOGOFF_EVENT:
4207       /*  A signal that the system sends to all console processes when a user is logging
4208           off. This signal does not indicate which user is logging off, so no
4209           assumptions can be made.
4210        */
4211         break;
4212     case CTRL_SHUTDOWN_EVENT:
4213       /*  A signal that the system sends to all console processes when the system is
4214           shutting down.
4215        */
4216         if (do_raise(aTHX_ SIGTERM))
4217             sig_terminate(aTHX_ SIGTERM);
4218         return TRUE;
4219     default:
4220         break;
4221     }
4222     return FALSE;
4223 }
4224
4225
4226 #ifdef SET_INVALID_PARAMETER_HANDLER
4227 #  include <crtdbg.h>
4228 #endif
4229
4230 static void
4231 ansify_path(void)
4232 {
4233     size_t len;
4234     char *ansi_path;
4235     WCHAR *wide_path;
4236     WCHAR *wide_dir;
4237
4238     /* fetch Unicode version of PATH */
4239     len = 2000;
4240     wide_path = win32_malloc(len*sizeof(WCHAR));
4241     while (wide_path) {
4242         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4243         if (newlen < len)
4244             break;
4245         len = newlen;
4246         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4247     }
4248     if (!wide_path)
4249         return;
4250
4251     /* convert to ANSI pathnames */
4252     wide_dir = wide_path;
4253     ansi_path = NULL;
4254     while (wide_dir) {
4255         WCHAR *sep = wcschr(wide_dir, ';');
4256         char *ansi_dir;
4257         size_t ansi_len;
4258         size_t wide_len;
4259
4260         if (sep)
4261             *sep++ = '\0';
4262
4263         /* remove quotes around pathname */
4264         if (*wide_dir == '"')
4265             ++wide_dir;
4266         wide_len = wcslen(wide_dir);
4267         if (wide_len && wide_dir[wide_len-1] == '"')
4268             wide_dir[wide_len-1] = '\0';
4269
4270         /* append ansi_dir to ansi_path */
4271         ansi_dir = win32_ansipath(wide_dir);
4272         ansi_len = strlen(ansi_dir);
4273         if (ansi_path) {
4274             size_t newlen = len + 1 + ansi_len;
4275             ansi_path = win32_realloc(ansi_path, newlen+1);
4276             if (!ansi_path)
4277                 break;
4278             ansi_path[len] = ';';
4279             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4280             len = newlen;
4281         }
4282         else {
4283             len = ansi_len;
4284             ansi_path = win32_malloc(5+len+1);
4285             if (!ansi_path)
4286                 break;
4287             memcpy(ansi_path, "PATH=", 5);
4288             memcpy(ansi_path+5, ansi_dir, len+1);
4289             len += 5;
4290         }
4291         win32_free(ansi_dir);
4292         wide_dir = sep;
4293     }
4294
4295     if (ansi_path) {
4296         /* Update C RTL environ array.  This will only have full effect if
4297          * perl_parse() is later called with `environ` as the `env` argument.
4298          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4299          *
4300          * We do have to ansify() the PATH before Perl has been fully
4301          * initialized because S_find_script() uses the PATH when perl
4302          * is being invoked with the -S option.  This happens before %ENV
4303          * is initialized in S_init_postdump_symbols().
4304          *
4305          * XXX Is this a bug? Should S_find_script() use the environment
4306          * XXX passed in the `env` arg to parse_perl()?
4307          */
4308         putenv(ansi_path);
4309         /* Keep system environment in sync because S_init_postdump_symbols()
4310          * will not call mg_set() if it initializes %ENV from `environ`.
4311          */
4312         SetEnvironmentVariableA("PATH", ansi_path+5);
4313         /* We are intentionally leaking the ansi_path string here because
4314          * the some runtime libraries puts it directly into the environ
4315          * array.  The Microsoft runtime library seems to make a copy,
4316          * but will leak the copy should it be replaced again later.
4317          * Since this code is only called once during PERL_SYS_INIT this
4318          * shouldn't really matter.
4319          */
4320     }
4321     win32_free(wide_path);
4322 }
4323
4324 void
4325 Perl_win32_init(int *argcp, char ***argvp)
4326 {
4327 #ifdef SET_INVALID_PARAMETER_HANDLER
4328     _invalid_parameter_handler oldHandler, newHandler;
4329     newHandler = my_invalid_parameter_handler;
4330     oldHandler = _set_invalid_parameter_handler(newHandler);
4331     _CrtSetReportMode(_CRT_ASSERT, 0);
4332 #endif
4333     /* Disable floating point errors, Perl will trap the ones we
4334      * care about.  VC++ RTL defaults to switching these off
4335      * already, but some RTLs don't.  Since we don't
4336      * want to be at the vendor's whim on the default, we set
4337      * it explicitly here.
4338      */
4339 #if !defined(__GNUC__)
4340     _control87(MCW_EM, MCW_EM);
4341 #endif
4342     MALLOC_INIT;
4343
4344     /* When the manifest resource requests Common-Controls v6 then
4345      * user32.dll no longer registers all the Windows classes used for
4346      * standard controls but leaves some of them to be registered by
4347      * comctl32.dll.  InitCommonControls() doesn't do anything but calling
4348      * it makes sure comctl32.dll gets loaded into the process and registers
4349      * the standard control classes.  Without this even normal Windows APIs
4350      * like MessageBox() can fail under some versions of Windows XP.
4351      */
4352     InitCommonControls();
4353
4354     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4355     GetVersionEx(&g_osver);
4356
4357     ansify_path();
4358 }
4359
4360 void
4361 Perl_win32_term(void)
4362 {
4363     dTHX;
4364     HINTS_REFCNT_TERM;
4365     OP_REFCNT_TERM;
4366     PERLIO_TERM;
4367     MALLOC_TERM;
4368 }
4369
4370 void
4371 win32_get_child_IO(child_IO_table* ptbl)
4372 {
4373     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4374     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4375     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4376 }
4377
4378 Sighandler_t
4379 win32_signal(int sig, Sighandler_t subcode)
4380 {
4381     dTHX;
4382     if (sig < SIG_SIZE) {
4383         int save_errno = errno;
4384         Sighandler_t result;
4385 #ifdef SET_INVALID_PARAMETER_HANDLER
4386         /* Silence our invalid parameter handler since we expect to make some
4387          * calls with invalid signal numbers giving a SIG_ERR result. */
4388         BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4389 #endif
4390         result = signal(sig, subcode);
4391 #ifdef SET_INVALID_PARAMETER_HANDLER
4392         set_silent_invalid_parameter_handler(oldvalue);
4393 #endif
4394         if (result == SIG_ERR) {
4395             result = w32_sighandler[sig];
4396             errno = save_errno;
4397         }
4398         w32_sighandler[sig] = subcode;
4399         return result;
4400     }
4401     else {
4402         errno = EINVAL;
4403         return SIG_ERR;
4404     }
4405 }
4406
4407 /* The PerlMessageWindowClass's WindowProc */
4408 LRESULT CALLBACK
4409 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4410 {
4411     return win32_process_message(hwnd, msg, wParam, lParam) ?
4412         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4413 }
4414
4415 /* The real message handler. Can be called with
4416  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4417  * that it processes */
4418 static LRESULT
4419 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4420 {
4421     /* BEWARE. The context retrieved using dTHX; is the context of the
4422      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4423      * up to and including WM_CREATE.  If it ever happens that you need the
4424      * 'child' context before this, then it needs to be passed into
4425      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4426      * from the lparam of CreateWindow().  It could then be stored/retrieved
4427      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4428      * the dTHX calls here. */
4429     /* XXX For now it is assumed that the overhead of the dTHX; for what
4430      * are relativley infrequent code-paths, is better than the added
4431      * complexity of getting the correct context passed into
4432      * win32_create_message_window() */
4433
4434     switch(msg) {
4435
4436 #ifdef USE_ITHREADS
4437         case WM_USER_MESSAGE: {
4438             long child = find_pseudo_pid((int)wParam);
4439             if (child >= 0) {
4440                 dTHX;
4441                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4442                 return 1;
4443             }
4444             break;
4445         }
4446 #endif
4447
4448         case WM_USER_KILL: {
4449             dTHX;
4450             /* We use WM_USER_KILL to fake kill() with other signals */
4451             int sig = (int)wParam;
4452             if (do_raise(aTHX_ sig))
4453                 sig_terminate(aTHX_ sig);
4454
4455             return 1;
4456         }
4457
4458         case WM_TIMER: {
4459             dTHX;
4460             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4461             if (w32_timerid && w32_timerid==(UINT)wParam) {
4462                 KillTimer(w32_message_hwnd, w32_timerid);
4463                 w32_timerid=0;
4464
4465                 /* Now fake a call to signal handler */
4466                 if (do_raise(aTHX_ 14))
4467                     sig_terminate(aTHX_ 14);
4468
4469                 return 1;
4470             }
4471             break;
4472         }
4473
4474         default:
4475             break;
4476
4477     } /* switch */
4478
4479     /* Above or other stuff may have set a signal flag, and we may not have
4480      * been called from win32_async_check() (e.g. some other GUI's message
4481      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
4482      * handler that die's, and the message loop that calls here is wrapped
4483      * in an eval, then you may well end up with orphaned windows - signals
4484      * are dispatched by win32_async_check() */
4485
4486     return 0;
4487 }
4488
4489 void
4490 win32_create_message_window_class(void)
4491 {
4492     /* create the window class for "message only" windows */
4493     WNDCLASS wc;
4494
4495     Zero(&wc, 1, wc);
4496     wc.lpfnWndProc = win32_message_window_proc;
4497     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4498     wc.lpszClassName = "PerlMessageWindowClass";
4499
4500     /* second and subsequent calls will fail, but class
4501      * will already be registered */
4502     RegisterClass(&wc);
4503 }
4504
4505 HWND
4506 win32_create_message_window(void)
4507 {
4508     win32_create_message_window_class();
4509     return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4510                         0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4511 }
4512
4513 #ifdef HAVE_INTERP_INTERN
4514
4515 static void
4516 win32_csighandler(int sig)
4517 {
4518 #if 0
4519     dTHXa(PERL_GET_SIG_CONTEXT);
4520     Perl_warn(aTHX_ "Got signal %d",sig);
4521 #endif
4522     /* Does nothing */
4523 }
4524
4525 #if defined(__MINGW32__) && defined(__cplusplus)
4526 #define CAST_HWND__(x) (HWND__*)(x)
4527 #else
4528 #define CAST_HWND__(x) x
4529 #endif
4530
4531 void
4532 Perl_sys_intern_init(pTHX)
4533 {
4534     int i;
4535
4536     w32_perlshell_tokens        = NULL;
4537     w32_perlshell_vec           = (char**)NULL;
4538     w32_perlshell_items         = 0;
4539     w32_fdpid                   = newAV();
4540     Newx(w32_children, 1, child_tab);
4541     w32_num_children            = 0;
4542 #  ifdef USE_ITHREADS
4543     w32_pseudo_id               = 0;
4544     Newx(w32_pseudo_children, 1, pseudo_child_tab);
4545     w32_num_pseudo_children     = 0;
4546 #  endif
4547     w32_timerid                 = 0;
4548     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
4549     w32_poll_count              = 0;
4550     for (i=0; i < SIG_SIZE; i++) {
4551         w32_sighandler[i] = SIG_DFL;
4552     }
4553 #  ifdef MULTIPLICITY
4554     if (my_perl == PL_curinterp) {
4555 #  else
4556     {
4557 #  endif
4558         /* Force C runtime signal stuff to set its console handler */
4559         signal(SIGINT,win32_csighandler);
4560         signal(SIGBREAK,win32_csighandler);
4561
4562         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4563          * flag.  This has the side-effect of disabling Ctrl-C events in all
4564          * processes in this group.
4565          * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4566          * with a NULL handler.
4567          */
4568         SetConsoleCtrlHandler(NULL,FALSE);
4569
4570         /* Push our handler on top */
4571         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4572     }
4573 }
4574
4575 void
4576 Perl_sys_intern_clear(pTHX)
4577 {
4578     Safefree(w32_perlshell_tokens);
4579     Safefree(w32_perlshell_vec);
4580     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4581     Safefree(w32_children);
4582     if (w32_timerid) {
4583         KillTimer(w32_message_hwnd, w32_timerid);
4584         w32_timerid = 0;
4585     }
4586     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4587         DestroyWindow(w32_message_hwnd);
4588 #  ifdef MULTIPLICITY
4589     if (my_perl == PL_curinterp) {
4590 #  else
4591     {
4592 #  endif
4593         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4594     }
4595 #  ifdef USE_ITHREADS
4596     Safefree(w32_pseudo_children);
4597 #  endif
4598 }
4599
4600 #  ifdef USE_ITHREADS
4601
4602 void
4603 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4604 {
4605     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4606
4607     dst->perlshell_tokens       = NULL;
4608     dst->perlshell_vec          = (char**)NULL;
4609     dst->perlshell_items        = 0;
4610     dst->fdpid                  = newAV();
4611     Newxz(dst->children, 1, child_tab);
4612     dst->pseudo_id              = 0;
4613     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4614     dst->timerid                = 0;
4615     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
4616     dst->poll_count             = 0;
4617     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4618 }
4619 #  endif /* USE_ITHREADS */
4620 #endif /* HAVE_INTERP_INTERN */