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