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