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 static int
1498 win32_stat_low(HANDLE handle, const char *path, STRLEN len, Stat_t *sbuf) {
1499     DWORD type = GetFileType(handle);
1500     BY_HANDLE_FILE_INFORMATION bhi;
1501
1502     Zero(sbuf, 1, Stat_t);
1503
1504     type &= ~FILE_TYPE_REMOTE;
1505
1506     switch (type) {
1507     case FILE_TYPE_DISK:
1508         if (GetFileInformationByHandle(handle, &bhi)) {
1509             sbuf->st_dev = bhi.dwVolumeSerialNumber;
1510             sbuf->st_ino = bhi.nFileIndexHigh;
1511             sbuf->st_ino <<= 32;
1512             sbuf->st_ino |= bhi.nFileIndexLow;
1513             sbuf->st_nlink = bhi.nNumberOfLinks;
1514             sbuf->st_uid = 0;
1515             sbuf->st_gid = 0;
1516             /* ucrt sets this to the drive letter for
1517                stat(), lets not reproduce that mistake */
1518             sbuf->st_rdev = 0;
1519             sbuf->st_size = bhi.nFileSizeHigh;
1520             sbuf->st_size <<= 32;
1521             sbuf->st_size |= bhi.nFileSizeLow;
1522
1523             sbuf->st_atime = translate_ft_to_time_t(bhi.ftLastAccessTime);
1524             sbuf->st_mtime = translate_ft_to_time_t(bhi.ftLastWriteTime);
1525             sbuf->st_ctime = translate_ft_to_time_t(bhi.ftCreationTime);
1526
1527             if (bhi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
1528                 sbuf->st_mode = _S_IFDIR | _S_IREAD | _S_IEXEC;
1529                 /* duplicate the logic from the end of the old win32_stat() */
1530                 if (!(bhi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) {
1531                     sbuf->st_mode |= S_IWRITE;
1532                 }
1533             }
1534             else {
1535                 char path_buf[MAX_PATH+1];
1536                 sbuf->st_mode = _S_IFREG;
1537
1538                 if (!path) {
1539                     len = GetFinalPathNameByHandleA(handle, path_buf, sizeof(path_buf), 0);
1540                     /* < to ensure there's space for the \0 */
1541                     if (len && len < sizeof(path_buf)) {
1542                         path = path_buf;
1543                     }
1544                 }
1545
1546                 if (path && len > 4 &&
1547                     (_stricmp(path + len - 4, ".exe") == 0 ||
1548                      _stricmp(path + len - 4, ".bat") == 0 ||
1549                      _stricmp(path + len - 4, ".cmd") == 0 ||
1550                      _stricmp(path + len - 4, ".com") == 0)) {
1551                     sbuf->st_mode |= _S_IEXEC;
1552                 }
1553                 if (!(bhi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)) {
1554                     sbuf->st_mode |= _S_IWRITE;
1555                 }
1556                 sbuf->st_mode |= _S_IREAD;
1557             }
1558         }
1559         else {
1560             translate_to_errno();
1561             return -1;
1562         }
1563         break;
1564
1565     case FILE_TYPE_CHAR:
1566     case FILE_TYPE_PIPE:
1567         sbuf->st_mode = (type == FILE_TYPE_CHAR) ? _S_IFCHR : _S_IFIFO;
1568         if (handle == GetStdHandle(STD_INPUT_HANDLE) ||
1569             handle == GetStdHandle(STD_OUTPUT_HANDLE) ||
1570             handle == GetStdHandle(STD_ERROR_HANDLE)) {
1571             sbuf->st_mode |= _S_IWRITE | _S_IREAD;
1572         }
1573         break;
1574
1575     default:
1576         return -1;
1577     }
1578
1579     /* owner == user == group */
1580     sbuf->st_mode |= (sbuf->st_mode & 0700) >> 3;
1581     sbuf->st_mode |= (sbuf->st_mode & 0700) >> 6;
1582
1583     return 0;
1584 }
1585
1586 DllExport int
1587 win32_stat(const char *path, Stat_t *sbuf)
1588 {
1589     size_t      l = strlen(path);
1590     dTHX;
1591     BOOL        expect_dir = FALSE;
1592     int result;
1593     HANDLE handle;
1594
1595     path = PerlDir_mapA(path);
1596     l = strlen(path);
1597
1598     handle =
1599         CreateFileA(path, FILE_READ_ATTRIBUTES,
1600                     FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
1601                     NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1602     if (handle != INVALID_HANDLE_VALUE) {
1603         result = win32_stat_low(handle, path, l, sbuf);
1604         CloseHandle(handle);
1605     }
1606     else {
1607         translate_to_errno();
1608         result = -1;
1609     }
1610
1611     return result;
1612 }
1613
1614 static void
1615 translate_to_errno(void)
1616 {
1617     /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for
1618        both permissions errors and if the source is a directory, while
1619        POSIX wants EACCES and EPERM respectively.
1620     */
1621     switch (GetLastError()) {
1622     case ERROR_BAD_NET_NAME:
1623     case ERROR_BAD_NETPATH:
1624     case ERROR_BAD_PATHNAME:
1625     case ERROR_FILE_NOT_FOUND:
1626     case ERROR_FILENAME_EXCED_RANGE:
1627     case ERROR_INVALID_DRIVE:
1628     case ERROR_PATH_NOT_FOUND:
1629       errno = ENOENT;
1630       break;
1631     case ERROR_ALREADY_EXISTS:
1632       errno = EEXIST;
1633       break;
1634     case ERROR_ACCESS_DENIED:
1635       errno = EACCES;
1636       break;
1637     case ERROR_PRIVILEGE_NOT_HELD:
1638       errno = EPERM;
1639       break;
1640     case ERROR_NOT_SAME_DEVICE:
1641       errno = EXDEV;
1642       break;
1643     case ERROR_DISK_FULL:
1644       errno = ENOSPC;
1645       break;
1646     case ERROR_NOT_ENOUGH_QUOTA:
1647       errno = EDQUOT;
1648       break;
1649     default:
1650       /* ERROR_INVALID_FUNCTION - eg. symlink on a FAT volume */
1651       errno = EINVAL;
1652       break;
1653     }
1654 }
1655
1656 /* Adapted from:
1657
1658 https://docs.microsoft.com/en-us/windows-hardware/drivers/ddi/ntifs/ns-ntifs-_reparse_data_buffer
1659
1660 Renamed to avoid conflicts, apparently some SDKs define this
1661 structure.
1662
1663 Hoisted the symlink data into a new type to allow us to make a pointer
1664 to it, and to avoid C++ scoping issues.
1665
1666 */
1667
1668 typedef struct {
1669     USHORT SubstituteNameOffset;
1670     USHORT SubstituteNameLength;
1671     USHORT PrintNameOffset;
1672     USHORT PrintNameLength;
1673     ULONG  Flags;
1674     WCHAR  PathBuffer[MAX_PATH*3];
1675 } MY_SYMLINK_REPARSE_BUFFER, *PMY_SYMLINK_REPARSE_BUFFER;
1676
1677 typedef struct {
1678   ULONG  ReparseTag;
1679   USHORT ReparseDataLength;
1680   USHORT Reserved;
1681   union {
1682     MY_SYMLINK_REPARSE_BUFFER SymbolicLinkReparseBuffer;
1683     struct {
1684       USHORT SubstituteNameOffset;
1685       USHORT SubstituteNameLength;
1686       USHORT PrintNameOffset;
1687       USHORT PrintNameLength;
1688       WCHAR  PathBuffer[1];
1689     } MountPointReparseBuffer;
1690     struct {
1691       UCHAR DataBuffer[1];
1692     } GenericReparseBuffer;
1693   } Data;
1694 } MY_REPARSE_DATA_BUFFER, *PMY_REPARSE_DATA_BUFFER;
1695
1696 static BOOL
1697 is_symlink(HANDLE h) {
1698     MY_REPARSE_DATA_BUFFER linkdata;
1699     const MY_SYMLINK_REPARSE_BUFFER * const sd =
1700         &linkdata.Data.SymbolicLinkReparseBuffer;
1701     DWORD linkdata_returned;
1702
1703     if (!DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, &linkdata, sizeof(linkdata), &linkdata_returned, NULL)) {
1704         return FALSE;
1705     }
1706
1707     if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.SymbolicLinkReparseBuffer.PathBuffer)
1708         || linkdata.ReparseTag != IO_REPARSE_TAG_SYMLINK) {
1709         /* some other type of reparse point */
1710         return FALSE;
1711     }
1712
1713     return TRUE;
1714 }
1715
1716 static BOOL
1717 is_symlink_name(const char *name) {
1718     HANDLE f = CreateFileA(name, GENERIC_READ, 0, NULL, OPEN_EXISTING,
1719                            FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
1720     BOOL result;
1721
1722     if (f == INVALID_HANDLE_VALUE) {
1723         return FALSE;
1724     }
1725     result = is_symlink(f);
1726     CloseHandle(f);
1727
1728     return result;
1729 }
1730
1731 DllExport int
1732 win32_readlink(const char *pathname, char *buf, size_t bufsiz) {
1733     MY_REPARSE_DATA_BUFFER linkdata;
1734     const MY_SYMLINK_REPARSE_BUFFER * const sd =
1735         &linkdata.Data.SymbolicLinkReparseBuffer;
1736     HANDLE hlink;
1737     DWORD fileattr = GetFileAttributes(pathname);
1738     DWORD linkdata_returned;
1739     int bytes_out;
1740     BOOL used_default;
1741
1742     if (fileattr == INVALID_FILE_ATTRIBUTES) {
1743         translate_to_errno();
1744         return -1;
1745     }
1746
1747     if (!(fileattr & FILE_ATTRIBUTE_REPARSE_POINT)) {
1748         /* not a symbolic link */
1749         errno = EINVAL;
1750         return -1;
1751     }
1752
1753     hlink =
1754         CreateFileA(pathname, GENERIC_READ, 0, NULL, OPEN_EXISTING,
1755                     FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
1756     if (hlink == INVALID_HANDLE_VALUE) {
1757         translate_to_errno();
1758         return -1;
1759     }
1760
1761     if (!DeviceIoControl(hlink, FSCTL_GET_REPARSE_POINT, NULL, 0, &linkdata, sizeof(linkdata), &linkdata_returned, NULL)) {
1762         translate_to_errno();
1763         CloseHandle(hlink);
1764         return -1;
1765     }
1766     CloseHandle(hlink);
1767
1768     if (linkdata_returned < offsetof(MY_REPARSE_DATA_BUFFER, Data.SymbolicLinkReparseBuffer.PathBuffer)
1769         || linkdata.ReparseTag != IO_REPARSE_TAG_SYMLINK) {
1770         errno = EINVAL;
1771         return -1;
1772     }
1773
1774     bytes_out = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
1775                                     sd->PathBuffer+sd->SubstituteNameOffset/2,
1776                                     sd->SubstituteNameLength/2,
1777                                     buf, bufsiz, NULL, &used_default);
1778     if (bytes_out == 0 || used_default) {
1779         /* failed conversion from unicode to ANSI or otherwise failed */
1780         errno = EINVAL;
1781         return -1;
1782     }
1783     if ((size_t)bytes_out > bufsiz) {
1784         errno = EINVAL;
1785         return -1;
1786     }
1787
1788     return bytes_out;
1789 }
1790
1791 DllExport int
1792 win32_lstat(const char *path, Stat_t *sbuf)
1793 {
1794     HANDLE f;
1795     int result;
1796     DWORD attr = GetFileAttributes(path); /* doesn't follow symlinks */
1797
1798     if (attr == INVALID_FILE_ATTRIBUTES) {
1799         translate_to_errno();
1800         return -1;
1801     }
1802
1803     if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
1804         return win32_stat(path, sbuf);
1805     }
1806
1807     f = CreateFileA(path, GENERIC_READ, 0, NULL, OPEN_EXISTING,
1808                            FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, 0);
1809     if (f == INVALID_HANDLE_VALUE) {
1810         translate_to_errno();
1811         return -1;
1812     }
1813
1814     if (!is_symlink(f)) {
1815         CloseHandle(f);
1816         return win32_stat(path, sbuf);
1817     }
1818
1819     result = win32_stat_low(f, NULL, 0, sbuf);
1820     CloseHandle(f);
1821
1822     if (result != -1){
1823         sbuf->st_mode = (sbuf->st_mode & ~_S_IFMT) | _S_IFLNK;
1824     }
1825
1826     return result;
1827 }
1828
1829 #define isSLASH(c) ((c) == '/' || (c) == '\\')
1830 #define SKIP_SLASHES(s) \
1831     STMT_START {                                \
1832         while (*(s) && isSLASH(*(s)))           \
1833             ++(s);                              \
1834     } STMT_END
1835 #define COPY_NONSLASHES(d,s) \
1836     STMT_START {                                \
1837         while (*(s) && !isSLASH(*(s)))          \
1838             *(d)++ = *(s)++;                    \
1839     } STMT_END
1840
1841 /* Find the longname of a given path.  path is destructively modified.
1842  * It should have space for at least MAX_PATH characters. */
1843 DllExport char *
1844 win32_longpath(char *path)
1845 {
1846     WIN32_FIND_DATA fdata;
1847     HANDLE fhand;
1848     char tmpbuf[MAX_PATH+1];
1849     char *tmpstart = tmpbuf;
1850     char *start = path;
1851     char sep;
1852     if (!path)
1853         return NULL;
1854
1855     /* drive prefix */
1856     if (isALPHA(path[0]) && path[1] == ':') {
1857         start = path + 2;
1858         *tmpstart++ = path[0];
1859         *tmpstart++ = ':';
1860     }
1861     /* UNC prefix */
1862     else if (isSLASH(path[0]) && isSLASH(path[1])) {
1863         start = path + 2;
1864         *tmpstart++ = path[0];
1865         *tmpstart++ = path[1];
1866         SKIP_SLASHES(start);
1867         COPY_NONSLASHES(tmpstart,start);        /* copy machine name */
1868         if (*start) {
1869             *tmpstart++ = *start++;
1870             SKIP_SLASHES(start);
1871             COPY_NONSLASHES(tmpstart,start);    /* copy share name */
1872         }
1873     }
1874     *tmpstart = '\0';
1875     while (*start) {
1876         /* copy initial slash, if any */
1877         if (isSLASH(*start)) {
1878             *tmpstart++ = *start++;
1879             *tmpstart = '\0';
1880             SKIP_SLASHES(start);
1881         }
1882
1883         /* FindFirstFile() expands "." and "..", so we need to pass
1884          * those through unmolested */
1885         if (*start == '.'
1886             && (!start[1] || isSLASH(start[1])
1887                 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1888         {
1889             COPY_NONSLASHES(tmpstart,start);    /* copy "." or ".." */
1890             *tmpstart = '\0';
1891             continue;
1892         }
1893
1894         /* if this is the end, bust outta here */
1895         if (!*start)
1896             break;
1897
1898         /* now we're at a non-slash; walk up to next slash */
1899         while (*start && !isSLASH(*start))
1900             ++start;
1901
1902         /* stop and find full name of component */
1903         sep = *start;
1904         *start = '\0';
1905         fhand = FindFirstFile(path,&fdata);
1906         *start = sep;
1907         if (fhand != INVALID_HANDLE_VALUE) {
1908             STRLEN len = strlen(fdata.cFileName);
1909             if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1910                 strcpy(tmpstart, fdata.cFileName);
1911                 tmpstart += len;
1912                 FindClose(fhand);
1913             }
1914             else {
1915                 FindClose(fhand);
1916                 errno = ERANGE;
1917                 return NULL;
1918             }
1919         }
1920         else {
1921             /* failed a step, just return without side effects */
1922             errno = EINVAL;
1923             return NULL;
1924         }
1925     }
1926     strcpy(path,tmpbuf);
1927     return path;
1928 }
1929
1930 static void
1931 out_of_memory(void)
1932 {
1933
1934     if (PL_curinterp)
1935         croak_no_mem();
1936     exit(1);
1937 }
1938
1939 void
1940 win32_croak_not_implemented(const char * fname)
1941 {
1942     PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED;
1943
1944     Perl_croak_nocontext("%s not implemented!\n", fname);
1945 }
1946
1947 /* Converts a wide character (UTF-16) string to the Windows ANSI code page,
1948  * potentially using the system's default replacement character for any
1949  * unrepresentable characters. The caller must free() the returned string. */
1950 static char*
1951 wstr_to_str(const wchar_t* wstr)
1952 {
1953     BOOL used_default = FALSE;
1954     size_t wlen = wcslen(wstr) + 1;
1955     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1956                                    NULL, 0, NULL, NULL);
1957     char* str = (char*)malloc(len);
1958     if (!str)
1959         out_of_memory();
1960     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen,
1961                         str, len, NULL, &used_default);
1962     return str;
1963 }
1964
1965 /* The win32_ansipath() function takes a Unicode filename and converts it
1966  * into the current Windows codepage. If some characters cannot be mapped,
1967  * then it will convert the short name instead.
1968  *
1969  * The buffer to the ansi pathname must be freed with win32_free() when it
1970  * is no longer needed.
1971  *
1972  * The argument to win32_ansipath() must exist before this function is
1973  * called; otherwise there is no way to determine the short path name.
1974  *
1975  * Ideas for future refinement:
1976  * - Only convert those segments of the path that are not in the current
1977  *   codepage, but leave the other segments in their long form.
1978  * - If the resulting name is longer than MAX_PATH, start converting
1979  *   additional path segments into short names until the full name
1980  *   is shorter than MAX_PATH.  Shorten the filename part last!
1981  */
1982 DllExport char *
1983 win32_ansipath(const WCHAR *widename)
1984 {
1985     char *name;
1986     BOOL use_default = FALSE;
1987     size_t widelen = wcslen(widename)+1;
1988     int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1989                                   NULL, 0, NULL, NULL);
1990     name = (char*)win32_malloc(len);
1991     if (!name)
1992         out_of_memory();
1993
1994     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
1995                         name, len, NULL, &use_default);
1996     if (use_default) {
1997         DWORD shortlen = GetShortPathNameW(widename, NULL, 0);
1998         if (shortlen) {
1999             WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR));
2000             if (!shortname)
2001                 out_of_memory();
2002             shortlen = GetShortPathNameW(widename, shortname, shortlen)+1;
2003
2004             len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
2005                                       NULL, 0, NULL, NULL);
2006             name = (char*)win32_realloc(name, len);
2007             if (!name)
2008                 out_of_memory();
2009             WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen,
2010                                 name, len, NULL, NULL);
2011             win32_free(shortname);
2012         }
2013     }
2014     return name;
2015 }
2016
2017 /* the returned string must be freed with win32_freeenvironmentstrings which is
2018  * implemented as a macro
2019  * void win32_freeenvironmentstrings(void* block)
2020  */
2021 DllExport char *
2022 win32_getenvironmentstrings(void)
2023 {
2024     LPWSTR lpWStr, lpWTmp;
2025     LPSTR lpStr, lpTmp;
2026     DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0;
2027
2028     /* Get the process environment strings */
2029     lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW();
2030     for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) {
2031         env_len = wcslen(lpWTmp);
2032         /* calculate the size of the environment strings */
2033         wenvstrings_len += env_len + 1;
2034     }
2035
2036     /* Get the number of bytes required to store the ACP encoded string */
2037     aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS,
2038                                           lpWStr, wenvstrings_len, NULL, 0, NULL, NULL);
2039     lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char));
2040     if(!lpTmp)
2041         out_of_memory();
2042
2043     /* Convert the string from UTF-16 encoding to ACP encoding */
2044     WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr,
2045                         aenvstrings_len, NULL, NULL);
2046
2047     FreeEnvironmentStringsW(lpWStr);
2048
2049     return(lpStr);
2050 }
2051
2052 DllExport char *
2053 win32_getenv(const char *name)
2054 {
2055     dTHX;
2056     DWORD needlen;
2057     SV *curitem = NULL;
2058     DWORD last_err;
2059
2060     needlen = GetEnvironmentVariableA(name,NULL,0);
2061     if (needlen != 0) {
2062         curitem = sv_2mortal(newSVpvs(""));
2063         do {
2064             SvGROW(curitem, needlen+1);
2065             needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
2066                                               needlen);
2067         } while (needlen >= SvLEN(curitem));
2068         SvCUR_set(curitem, needlen);
2069     }
2070     else {
2071         last_err = GetLastError();
2072         if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
2073             /* It appears the variable is in the env, but the Win32 API
2074                doesn't have a canned way of getting it.  So we fall back to
2075                grabbing the whole env and pulling this value out if possible */
2076             char *envv = GetEnvironmentStrings();
2077             char *cur = envv;
2078             STRLEN len;
2079             while (*cur) {
2080                 char *end = strchr(cur,'=');
2081                 if (end && end != cur) {
2082                     *end = '\0';
2083                     if (strEQ(cur,name)) {
2084                         curitem = sv_2mortal(newSVpv(end+1,0));
2085                         *end = '=';
2086                         break;
2087                     }
2088                     *end = '=';
2089                     cur = end + strlen(end+1)+2;
2090                 }
2091                 else if ((len = strlen(cur)))
2092                     cur += len+1;
2093             }
2094             FreeEnvironmentStrings(envv);
2095         }
2096 #ifndef WIN32_NO_REGISTRY
2097         else {
2098             /* last ditch: allow any environment variables that begin with 'PERL'
2099                to be obtained from the registry, if found there */
2100             if (strBEGINs(name, "PERL"))
2101                 (void)get_regstr(name, &curitem);
2102         }
2103 #endif
2104     }
2105     if (curitem && SvCUR(curitem))
2106         return SvPVX(curitem);
2107
2108     return NULL;
2109 }
2110
2111 DllExport int
2112 win32_putenv(const char *name)
2113 {
2114     char* curitem;
2115     char* val;
2116     int relval = -1;
2117
2118     if (name) {
2119         curitem = (char *) win32_malloc(strlen(name)+1);
2120         strcpy(curitem, name);
2121         val = strchr(curitem, '=');
2122         if (val) {
2123             /* The sane way to deal with the environment.
2124              * Has these advantages over putenv() & co.:
2125              *  * enables us to store a truly empty value in the
2126              *    environment (like in UNIX).
2127              *  * we don't have to deal with RTL globals, bugs and leaks
2128              *    (specifically, see http://support.microsoft.com/kb/235601).
2129              *  * Much faster.
2130              * Why you may want to use the RTL environment handling
2131              * (previously enabled by USE_WIN32_RTL_ENV):
2132              *  * environ[] and RTL functions will not reflect changes,
2133              *    which might be an issue if extensions want to access
2134              *    the env. via RTL.  This cuts both ways, since RTL will
2135              *    not see changes made by extensions that call the Win32
2136              *    functions directly, either.
2137              * GSAR 97-06-07
2138              */
2139             *val++ = '\0';
2140             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
2141                 relval = 0;
2142         }
2143         win32_free(curitem);
2144     }
2145     return relval;
2146 }
2147
2148 static long
2149 filetime_to_clock(PFILETIME ft)
2150 {
2151     __int64 qw = ft->dwHighDateTime;
2152     qw <<= 32;
2153     qw |= ft->dwLowDateTime;
2154     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
2155     return (long) qw;
2156 }
2157
2158 DllExport int
2159 win32_times(struct tms *timebuf)
2160 {
2161     FILETIME user;
2162     FILETIME kernel;
2163     FILETIME dummy;
2164     clock_t process_time_so_far = clock();
2165     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
2166                         &kernel,&user)) {
2167         timebuf->tms_utime = filetime_to_clock(&user);
2168         timebuf->tms_stime = filetime_to_clock(&kernel);
2169         timebuf->tms_cutime = 0;
2170         timebuf->tms_cstime = 0;
2171     } else {
2172         /* That failed - e.g. Win95 fallback to clock() */
2173         timebuf->tms_utime = process_time_so_far;
2174         timebuf->tms_stime = 0;
2175         timebuf->tms_cutime = 0;
2176         timebuf->tms_cstime = 0;
2177     }
2178     return process_time_so_far;
2179 }
2180
2181 static BOOL
2182 filetime_from_time(PFILETIME pFileTime, time_t Time)
2183 {
2184     struct tm *pt;
2185     SYSTEMTIME st;
2186
2187     pt = gmtime(&Time);
2188     if (!pt) {
2189         pFileTime->dwLowDateTime = 0;
2190         pFileTime->dwHighDateTime = 0;
2191         fprintf(stderr, "fail bad gmtime\n");
2192         return FALSE;
2193     }
2194
2195     st.wYear = pt->tm_year + 1900;
2196     st.wMonth = pt->tm_mon + 1;
2197     st.wDay = pt->tm_mday;
2198     st.wHour = pt->tm_hour;
2199     st.wMinute = pt->tm_min;
2200     st.wSecond = pt->tm_sec;
2201     st.wMilliseconds = 0;
2202
2203     if (!SystemTimeToFileTime(&st, pFileTime)) {
2204         pFileTime->dwLowDateTime = 0;
2205         pFileTime->dwHighDateTime = 0;
2206         return FALSE;
2207     }
2208
2209     return TRUE;
2210 }
2211
2212 DllExport int
2213 win32_unlink(const char *filename)
2214 {
2215     dTHX;
2216     int ret;
2217     DWORD attrs;
2218
2219     filename = PerlDir_mapA(filename);
2220     attrs = GetFileAttributesA(filename);
2221     if (attrs == 0xFFFFFFFF) {
2222         errno = ENOENT;
2223         return -1;
2224     }
2225     if (attrs & FILE_ATTRIBUTE_READONLY) {
2226         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
2227         ret = unlink(filename);
2228         if (ret == -1)
2229             (void)SetFileAttributesA(filename, attrs);
2230     }
2231     else if ((attrs & (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY))
2232         == (FILE_ATTRIBUTE_REPARSE_POINT | FILE_ATTRIBUTE_DIRECTORY)
2233              && is_symlink_name(filename)) {
2234         ret = rmdir(filename);
2235     }
2236     else {
2237         ret = unlink(filename);
2238     }
2239     return ret;
2240 }
2241
2242 DllExport int
2243 win32_utime(const char *filename, struct utimbuf *times)
2244 {
2245     dTHX;
2246     HANDLE handle;
2247     FILETIME ftAccess;
2248     FILETIME ftWrite;
2249     struct utimbuf TimeBuffer;
2250     int rc = -1;
2251
2252     filename = PerlDir_mapA(filename);
2253     /* This will (and should) still fail on readonly files */
2254     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
2255                          FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
2256                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
2257     if (handle == INVALID_HANDLE_VALUE) {
2258         translate_to_errno();
2259         return -1;
2260     }
2261
2262     if (times == NULL) {
2263         times = &TimeBuffer;
2264         time(&times->actime);
2265         times->modtime = times->actime;
2266     }
2267
2268     if (filetime_from_time(&ftAccess, times->actime) &&
2269         filetime_from_time(&ftWrite, times->modtime)) {
2270         if (SetFileTime(handle, NULL, &ftAccess, &ftWrite)) {
2271             rc = 0;
2272         }
2273         else {
2274             translate_to_errno();
2275         }
2276     }
2277     else {
2278         errno = EINVAL; /* bad time? */
2279     }
2280
2281     CloseHandle(handle);
2282     return rc;
2283 }
2284
2285 typedef union {
2286     unsigned __int64    ft_i64;
2287     FILETIME            ft_val;
2288 } FT_t;
2289
2290 #ifdef __GNUC__
2291 #define Const64(x) x##LL
2292 #else
2293 #define Const64(x) x##i64
2294 #endif
2295 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
2296 #define EPOCH_BIAS  Const64(116444736000000000)
2297
2298 /* NOTE: This does not compute the timezone info (doing so can be expensive,
2299  * and appears to be unsupported even by glibc) */
2300 DllExport int
2301 win32_gettimeofday(struct timeval *tp, void *not_used)
2302 {
2303     FT_t ft;
2304
2305     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
2306     GetSystemTimeAsFileTime(&ft.ft_val);
2307
2308     /* seconds since epoch */
2309     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
2310
2311     /* microseconds remaining */
2312     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
2313
2314     return 0;
2315 }
2316
2317 DllExport int
2318 win32_uname(struct utsname *name)
2319 {
2320     struct hostent *hep;
2321     STRLEN nodemax = sizeof(name->nodename)-1;
2322
2323     /* sysname */
2324     switch (g_osver.dwPlatformId) {
2325     case VER_PLATFORM_WIN32_WINDOWS:
2326         strcpy(name->sysname, "Windows");
2327         break;
2328     case VER_PLATFORM_WIN32_NT:
2329         strcpy(name->sysname, "Windows NT");
2330         break;
2331     case VER_PLATFORM_WIN32s:
2332         strcpy(name->sysname, "Win32s");
2333         break;
2334     default:
2335         strcpy(name->sysname, "Win32 Unknown");
2336         break;
2337     }
2338
2339     /* release */
2340     sprintf(name->release, "%d.%d",
2341             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
2342
2343     /* version */
2344     sprintf(name->version, "Build %d",
2345             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
2346             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
2347     if (g_osver.szCSDVersion[0]) {
2348         char *buf = name->version + strlen(name->version);
2349         sprintf(buf, " (%s)", g_osver.szCSDVersion);
2350     }
2351
2352     /* nodename */
2353     hep = win32_gethostbyname("localhost");
2354     if (hep) {
2355         STRLEN len = strlen(hep->h_name);
2356         if (len <= nodemax) {
2357             strcpy(name->nodename, hep->h_name);
2358         }
2359         else {
2360             strncpy(name->nodename, hep->h_name, nodemax);
2361             name->nodename[nodemax] = '\0';
2362         }
2363     }
2364     else {
2365         DWORD sz = nodemax;
2366         if (!GetComputerName(name->nodename, &sz))
2367             *name->nodename = '\0';
2368     }
2369
2370     /* machine (architecture) */
2371     {
2372         SYSTEM_INFO info;
2373         DWORD procarch;
2374         char *arch;
2375         GetSystemInfo(&info);
2376
2377 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2378         procarch = info.u.s.wProcessorArchitecture;
2379 #else
2380         procarch = info.wProcessorArchitecture;
2381 #endif
2382         switch (procarch) {
2383         case PROCESSOR_ARCHITECTURE_INTEL:
2384             arch = "x86"; break;
2385         case PROCESSOR_ARCHITECTURE_IA64:
2386             arch = "ia64"; break;
2387         case PROCESSOR_ARCHITECTURE_AMD64:
2388             arch = "amd64"; break;
2389         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2390             arch = "unknown"; break;
2391         default:
2392             sprintf(name->machine, "unknown(0x%x)", procarch);
2393             arch = name->machine;
2394             break;
2395         }
2396         if (name->machine != arch)
2397             strcpy(name->machine, arch);
2398     }
2399     return 0;
2400 }
2401
2402 /* Timing related stuff */
2403
2404 int
2405 do_raise(pTHX_ int sig)
2406 {
2407     if (sig < SIG_SIZE) {
2408         Sighandler_t handler = w32_sighandler[sig];
2409         if (handler == SIG_IGN) {
2410             return 0;
2411         }
2412         else if (handler != SIG_DFL) {
2413             (*handler)(sig);
2414             return 0;
2415         }
2416         else {
2417             /* Choose correct default behaviour */
2418             switch (sig) {
2419 #ifdef SIGCLD
2420                 case SIGCLD:
2421 #endif
2422 #ifdef SIGCHLD
2423                 case SIGCHLD:
2424 #endif
2425                 case 0:
2426                     return 0;
2427                 case SIGTERM:
2428                 default:
2429                     break;
2430             }
2431         }
2432     }
2433     /* Tell caller to exit thread/process as appropriate */
2434     return 1;
2435 }
2436
2437 void
2438 sig_terminate(pTHX_ int sig)
2439 {
2440     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2441     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2442        thread
2443      */
2444     exit(sig);
2445 }
2446
2447 DllExport int
2448 win32_async_check(pTHX)
2449 {
2450     MSG msg;
2451     HWND hwnd = w32_message_hwnd;
2452
2453     /* Reset w32_poll_count before doing anything else, incase we dispatch
2454      * messages that end up calling back into perl */
2455     w32_poll_count = 0;
2456
2457     if (hwnd != INVALID_HANDLE_VALUE) {
2458         /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2459         * and ignores window messages - should co-exist better with windows apps e.g. Tk
2460         */
2461         if (hwnd == NULL)
2462             hwnd = (HWND)-1;
2463
2464         while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2465                PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2466         {
2467             /* re-post a WM_QUIT message (we'll mark it as read later) */
2468             if(msg.message == WM_QUIT) {
2469                 PostQuitMessage((int)msg.wParam);
2470                 break;
2471             }
2472
2473             if(!CallMsgFilter(&msg, MSGF_USER))
2474             {
2475                 TranslateMessage(&msg);
2476                 DispatchMessage(&msg);
2477             }
2478         }
2479     }
2480
2481     /* Call PeekMessage() to mark all pending messages in the queue as "old".
2482      * This is necessary when we are being called by win32_msgwait() to
2483      * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2484      * message over and over.  An example how this can happen is when
2485      * Perl is calling win32_waitpid() inside a GUI application and the GUI
2486      * is generating messages before the process terminated.
2487      */
2488     PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2489
2490     /* Above or other stuff may have set a signal flag */
2491     if (PL_sig_pending)
2492         despatch_signals();
2493
2494     return 1;
2495 }
2496
2497 /* This function will not return until the timeout has elapsed, or until
2498  * one of the handles is ready. */
2499 DllExport DWORD
2500 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2501 {
2502     /* We may need several goes at this - so compute when we stop */
2503     FT_t ticks = {0};
2504     unsigned __int64 endtime = timeout;
2505     if (timeout != INFINITE) {
2506         GetSystemTimeAsFileTime(&ticks.ft_val);
2507         ticks.ft_i64 /= 10000;
2508         endtime += ticks.ft_i64;
2509     }
2510     /* This was a race condition. Do not let a non INFINITE timeout to
2511      * MsgWaitForMultipleObjects roll under 0 creating a near
2512      * infinity/~(UINT32)0 timeout which will appear as a deadlock to the
2513      * user who did a CORE perl function with a non infinity timeout,
2514      * sleep for example.  This is 64 to 32 truncation minefield.
2515      *
2516      * This scenario can only be created if the timespan from the return of
2517      * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To
2518      * generate the scenario, manual breakpoints in a C debugger are required,
2519      * or a context switch occurred in win32_async_check in PeekMessage, or random
2520      * messages are delivered to the *thread* message queue of the Perl thread
2521      * from another process (msctf.dll doing IPC among its instances, VS debugger
2522      * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096].
2523      */
2524     while (ticks.ft_i64 <= endtime) {
2525         /* if timeout's type is lengthened, remember to split 64b timeout
2526          * into multiple non-infinity runs of MWFMO */
2527         DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE,
2528                                                 (DWORD)(endtime - ticks.ft_i64),
2529                                                 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2530         if (resultp)
2531            *resultp = result;
2532         if (result == WAIT_TIMEOUT) {
2533             /* Ran out of time - explicit return of zero to avoid -ve if we
2534                have scheduling issues
2535              */
2536             return 0;
2537         }
2538         if (timeout != INFINITE) {
2539             GetSystemTimeAsFileTime(&ticks.ft_val);
2540             ticks.ft_i64 /= 10000;
2541         }
2542         if (result == WAIT_OBJECT_0 + count) {
2543             /* Message has arrived - check it */
2544             (void)win32_async_check(aTHX);
2545
2546             /* retry */
2547             if (ticks.ft_i64 > endtime)
2548                 endtime = ticks.ft_i64;
2549
2550             continue;
2551         }
2552         else {
2553            /* Not timeout or message - one of handles is ready */
2554            break;
2555         }
2556     }
2557     /* If we are past the end say zero */
2558     if (!ticks.ft_i64 || ticks.ft_i64 > endtime)
2559         return 0;
2560     /* compute time left to wait */
2561     ticks.ft_i64 = endtime - ticks.ft_i64;
2562     /* if more ms than DWORD, then return max DWORD */
2563     return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX;
2564 }
2565
2566 int
2567 win32_internal_wait(pTHX_ int *status, DWORD timeout)
2568 {
2569     /* XXX this wait emulation only knows about processes
2570      * spawned via win32_spawnvp(P_NOWAIT, ...).
2571      */
2572     int i, retval;
2573     DWORD exitcode, waitcode;
2574
2575 #ifdef USE_ITHREADS
2576     if (w32_num_pseudo_children) {
2577         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2578                       timeout, &waitcode);
2579         /* Time out here if there are no other children to wait for. */
2580         if (waitcode == WAIT_TIMEOUT) {
2581             if (!w32_num_children) {
2582                 return 0;
2583             }
2584         }
2585         else if (waitcode != WAIT_FAILED) {
2586             if (waitcode >= WAIT_ABANDONED_0
2587                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2588                 i = waitcode - WAIT_ABANDONED_0;
2589             else
2590                 i = waitcode - WAIT_OBJECT_0;
2591             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2592                 *status = (int)((exitcode & 0xff) << 8);
2593                 retval = (int)w32_pseudo_child_pids[i];
2594                 remove_dead_pseudo_process(i);
2595                 return -retval;
2596             }
2597         }
2598     }
2599 #endif
2600
2601     if (!w32_num_children) {
2602         errno = ECHILD;
2603         return -1;
2604     }
2605
2606     /* if a child exists, wait for it to die */
2607     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2608     if (waitcode == WAIT_TIMEOUT) {
2609         return 0;
2610     }
2611     if (waitcode != WAIT_FAILED) {
2612         if (waitcode >= WAIT_ABANDONED_0
2613             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2614             i = waitcode - WAIT_ABANDONED_0;
2615         else
2616             i = waitcode - WAIT_OBJECT_0;
2617         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2618             *status = (int)((exitcode & 0xff) << 8);
2619             retval = (int)w32_child_pids[i];
2620             remove_dead_process(i);
2621             return retval;
2622         }
2623     }
2624
2625     errno = GetLastError();
2626     return -1;
2627 }
2628
2629 DllExport int
2630 win32_waitpid(int pid, int *status, int flags)
2631 {
2632     dTHX;
2633     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2634     int retval = -1;
2635     long child;
2636     if (pid == -1)                              /* XXX threadid == 1 ? */
2637         return win32_internal_wait(aTHX_ status, timeout);
2638 #ifdef USE_ITHREADS
2639     else if (pid < 0) {
2640         child = find_pseudo_pid(aTHX_ -pid);
2641         if (child >= 0) {
2642             HANDLE hThread = w32_pseudo_child_handles[child];
2643             DWORD waitcode;
2644             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2645             if (waitcode == WAIT_TIMEOUT) {
2646                 return 0;
2647             }
2648             else if (waitcode == WAIT_OBJECT_0) {
2649                 if (GetExitCodeThread(hThread, &waitcode)) {
2650                     *status = (int)((waitcode & 0xff) << 8);
2651                     retval = (int)w32_pseudo_child_pids[child];
2652                     remove_dead_pseudo_process(child);
2653                     return -retval;
2654                 }
2655             }
2656             else
2657                 errno = ECHILD;
2658         }
2659     }
2660 #endif
2661     else {
2662         HANDLE hProcess;
2663         DWORD waitcode;
2664         child = find_pid(aTHX_ pid);
2665         if (child >= 0) {
2666             hProcess = w32_child_handles[child];
2667             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2668             if (waitcode == WAIT_TIMEOUT) {
2669                 return 0;
2670             }
2671             else if (waitcode == WAIT_OBJECT_0) {
2672                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2673                     *status = (int)((waitcode & 0xff) << 8);
2674                     retval = (int)w32_child_pids[child];
2675                     remove_dead_process(child);
2676                     return retval;
2677                 }
2678             }
2679             else
2680                 errno = ECHILD;
2681         }
2682         else {
2683             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2684             if (hProcess) {
2685                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2686                 if (waitcode == WAIT_TIMEOUT) {
2687                     CloseHandle(hProcess);
2688                     return 0;
2689                 }
2690                 else if (waitcode == WAIT_OBJECT_0) {
2691                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2692                         *status = (int)((waitcode & 0xff) << 8);
2693                         CloseHandle(hProcess);
2694                         return pid;
2695                     }
2696                 }
2697                 CloseHandle(hProcess);
2698             }
2699             else
2700                 errno = ECHILD;
2701         }
2702     }
2703     return retval >= 0 ? pid : retval;
2704 }
2705
2706 DllExport int
2707 win32_wait(int *status)
2708 {
2709     dTHX;
2710     return win32_internal_wait(aTHX_ status, INFINITE);
2711 }
2712
2713 DllExport unsigned int
2714 win32_sleep(unsigned int t)
2715 {
2716     dTHX;
2717     /* Win32 times are in ms so *1000 in and /1000 out */
2718     if (t > UINT_MAX / 1000) {
2719         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
2720                         "sleep(%lu) too large", t);
2721     }
2722     return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000;
2723 }
2724
2725 DllExport int
2726 win32_pause(void)
2727 {
2728     dTHX;
2729     win32_msgwait(aTHX_ 0, NULL, INFINITE, NULL);
2730     return -1;
2731 }
2732
2733 DllExport unsigned int
2734 win32_alarm(unsigned int sec)
2735 {
2736     /*
2737      * the 'obvious' implentation is SetTimer() with a callback
2738      * which does whatever receiving SIGALRM would do
2739      * we cannot use SIGALRM even via raise() as it is not
2740      * one of the supported codes in <signal.h>
2741      */
2742     dTHX;
2743
2744     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2745         w32_message_hwnd = win32_create_message_window();
2746
2747     if (sec) {
2748         if (w32_message_hwnd == NULL)
2749             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2750         else {
2751             w32_timerid = 1;
2752             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2753         }
2754     }
2755     else {
2756         if (w32_timerid) {
2757             KillTimer(w32_message_hwnd, w32_timerid);
2758             w32_timerid = 0;
2759         }
2760     }
2761     return 0;
2762 }
2763
2764 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2765
2766 DllExport char *
2767 win32_crypt(const char *txt, const char *salt)
2768 {
2769     dTHX;
2770     return des_fcrypt(txt, salt, w32_crypt_buffer);
2771 }
2772
2773 /* simulate flock by locking a range on the file */
2774
2775 #define LK_LEN          0xffff0000
2776
2777 DllExport int
2778 win32_flock(int fd, int oper)
2779 {
2780     OVERLAPPED o;
2781     int i = -1;
2782     HANDLE fh;
2783
2784     fh = (HANDLE)_get_osfhandle(fd);
2785     if (fh == (HANDLE)-1)  /* _get_osfhandle() already sets errno to EBADF */
2786         return -1;
2787
2788     memset(&o, 0, sizeof(o));
2789
2790     switch(oper) {
2791     case LOCK_SH:               /* shared lock */
2792         if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2793             i = 0;
2794         break;
2795     case LOCK_EX:               /* exclusive lock */
2796         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2797             i = 0;
2798         break;
2799     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2800         if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2801             i = 0;
2802         break;
2803     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2804         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2805                        0, LK_LEN, 0, &o))
2806             i = 0;
2807         break;
2808     case LOCK_UN:               /* unlock lock */
2809         if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2810             i = 0;
2811         break;
2812     default:                    /* unknown */
2813         errno = EINVAL;
2814         return -1;
2815     }
2816     if (i == -1) {
2817         if (GetLastError() == ERROR_LOCK_VIOLATION)
2818             errno = EWOULDBLOCK;
2819         else
2820             errno = EINVAL;
2821     }
2822     return i;
2823 }
2824
2825 #undef LK_LEN
2826
2827 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */
2828
2829 /* Get the errno value corresponding to the given err. This function is not
2830  * intended to handle conversion of general GetLastError() codes. It only exists
2831  * to translate Windows sockets error codes from WSAGetLastError(). Such codes
2832  * used to be assigned to errno/$! in earlier versions of perl; this function is
2833  * used to catch any old Perl code which is still trying to assign such values
2834  * to $! and convert them to errno values instead.
2835  */
2836 int
2837 win32_get_errno(int err)
2838 {
2839     return convert_wsa_error_to_errno(err);
2840 }
2841
2842 /*
2843  *  redirected io subsystem for all XS modules
2844  *
2845  */
2846
2847 DllExport int *
2848 win32_errno(void)
2849 {
2850     return (&errno);
2851 }
2852
2853 DllExport char ***
2854 win32_environ(void)
2855 {
2856     return (&(_environ));
2857 }
2858
2859 /* the rest are the remapped stdio routines */
2860 DllExport FILE *
2861 win32_stderr(void)
2862 {
2863     return (stderr);
2864 }
2865
2866 DllExport FILE *
2867 win32_stdin(void)
2868 {
2869     return (stdin);
2870 }
2871
2872 DllExport FILE *
2873 win32_stdout(void)
2874 {
2875     return (stdout);
2876 }
2877
2878 DllExport int
2879 win32_ferror(FILE *fp)
2880 {
2881     return (ferror(fp));
2882 }
2883
2884
2885 DllExport int
2886 win32_feof(FILE *fp)
2887 {
2888     return (feof(fp));
2889 }
2890
2891 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2892 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */
2893 #endif
2894
2895 /*
2896  * Since the errors returned by the socket error function
2897  * WSAGetLastError() are not known by the library routine strerror
2898  * we have to roll our own to cover the case of socket errors
2899  * that could not be converted to regular errno values by
2900  * get_last_socket_error() in win32/win32sck.c.
2901  */
2902
2903 DllExport char *
2904 win32_strerror(int e)
2905 {
2906 #if !defined __MINGW32__      /* compiler intolerance */
2907     extern int sys_nerr;
2908 #endif
2909
2910     if (e < 0 || e > sys_nerr) {
2911         dTHXa(NULL);
2912         if (e < 0)
2913             e = GetLastError();
2914 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT
2915         /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno
2916          * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but
2917          * sys_nerr is still 43 and strerror() returns "Unknown error" for them.
2918          * We must therefore still roll our own messages for these codes, and
2919          * additionally map them to corresponding Windows (sockets) error codes
2920          * first to avoid getting the wrong system message.
2921          */
2922         else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) {
2923             e = convert_errno_to_wsa_error(e);
2924         }
2925 #endif
2926
2927         aTHXa(PERL_GET_THX);
2928         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2929                          |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2930                           w32_strerror_buffer, sizeof(w32_strerror_buffer),
2931                           NULL) == 0)
2932         {
2933             strcpy(w32_strerror_buffer, "Unknown Error");
2934         }
2935         return w32_strerror_buffer;
2936     }
2937 #undef strerror
2938     return strerror(e);
2939 #define strerror win32_strerror
2940 }
2941
2942 DllExport void
2943 win32_str_os_error(void *sv, DWORD dwErr)
2944 {
2945     DWORD dwLen;
2946     char *sMsg;
2947     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2948                           |FORMAT_MESSAGE_IGNORE_INSERTS
2949                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2950                            dwErr, 0, (char *)&sMsg, 1, NULL);
2951     /* strip trailing whitespace and period */
2952     if (0 < dwLen) {
2953         do {
2954             --dwLen;    /* dwLen doesn't include trailing null */
2955         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2956         if ('.' != sMsg[dwLen])
2957             dwLen++;
2958         sMsg[dwLen] = '\0';
2959     }
2960     if (0 == dwLen) {
2961         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2962         if (sMsg)
2963             dwLen = sprintf(sMsg,
2964                             "Unknown error #0x%lX (lookup 0x%lX)",
2965                             dwErr, GetLastError());
2966     }
2967     if (sMsg) {
2968         dTHX;
2969         sv_setpvn((SV*)sv, sMsg, dwLen);
2970         LocalFree(sMsg);
2971     }
2972 }
2973
2974 DllExport int
2975 win32_fprintf(FILE *fp, const char *format, ...)
2976 {
2977     va_list marker;
2978     va_start(marker, format);     /* Initialize variable arguments. */
2979
2980     return (vfprintf(fp, format, marker));
2981 }
2982
2983 DllExport int
2984 win32_printf(const char *format, ...)
2985 {
2986     va_list marker;
2987     va_start(marker, format);     /* Initialize variable arguments. */
2988
2989     return (vprintf(format, marker));
2990 }
2991
2992 DllExport int
2993 win32_vfprintf(FILE *fp, const char *format, va_list args)
2994 {
2995     return (vfprintf(fp, format, args));
2996 }
2997
2998 DllExport int
2999 win32_vprintf(const char *format, va_list args)
3000 {
3001     return (vprintf(format, args));
3002 }
3003
3004 DllExport size_t
3005 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
3006 {
3007     return fread(buf, size, count, fp);
3008 }
3009
3010 DllExport size_t
3011 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
3012 {
3013     return fwrite(buf, size, count, fp);
3014 }
3015
3016 #define MODE_SIZE 10
3017
3018 DllExport FILE *
3019 win32_fopen(const char *filename, const char *mode)
3020 {
3021     dTHXa(NULL);
3022     FILE *f;
3023
3024     if (!*filename)
3025         return NULL;
3026
3027     if (stricmp(filename, "/dev/null")==0)
3028         filename = "NUL";
3029
3030     aTHXa(PERL_GET_THX);
3031     f = fopen(PerlDir_mapA(filename), mode);
3032     /* avoid buffering headaches for child processes */
3033     if (f && *mode == 'a')
3034         win32_fseek(f, 0, SEEK_END);
3035     return f;
3036 }
3037
3038 DllExport FILE *
3039 win32_fdopen(int handle, const char *mode)
3040 {
3041     FILE *f;
3042     f = fdopen(handle, (char *) mode);
3043     /* avoid buffering headaches for child processes */
3044     if (f && *mode == 'a')
3045         win32_fseek(f, 0, SEEK_END);
3046     return f;
3047 }
3048
3049 DllExport FILE *
3050 win32_freopen(const char *path, const char *mode, FILE *stream)
3051 {
3052     dTHXa(NULL);
3053     if (stricmp(path, "/dev/null")==0)
3054         path = "NUL";
3055
3056     aTHXa(PERL_GET_THX);
3057     return freopen(PerlDir_mapA(path), mode, stream);
3058 }
3059
3060 DllExport int
3061 win32_fclose(FILE *pf)
3062 {
3063 #ifdef WIN32_NO_SOCKETS
3064     return fclose(pf);
3065 #else
3066     return my_fclose(pf);       /* defined in win32sck.c */
3067 #endif
3068 }
3069
3070 DllExport int
3071 win32_fputs(const char *s,FILE *pf)
3072 {
3073     return fputs(s, pf);
3074 }
3075
3076 DllExport int
3077 win32_fputc(int c,FILE *pf)
3078 {
3079     return fputc(c,pf);
3080 }
3081
3082 DllExport int
3083 win32_ungetc(int c,FILE *pf)
3084 {
3085     return ungetc(c,pf);
3086 }
3087
3088 DllExport int
3089 win32_getc(FILE *pf)
3090 {
3091     return getc(pf);
3092 }
3093
3094 DllExport int
3095 win32_fileno(FILE *pf)
3096 {
3097     return fileno(pf);
3098 }
3099
3100 DllExport void
3101 win32_clearerr(FILE *pf)
3102 {
3103     clearerr(pf);
3104     return;
3105 }
3106
3107 DllExport int
3108 win32_fflush(FILE *pf)
3109 {
3110     return fflush(pf);
3111 }
3112
3113 DllExport Off_t
3114 win32_ftell(FILE *pf)
3115 {
3116     fpos_t pos;
3117     if (fgetpos(pf, &pos))
3118         return -1;
3119     return (Off_t)pos;
3120 }
3121
3122 DllExport int
3123 win32_fseek(FILE *pf, Off_t offset,int origin)
3124 {
3125     fpos_t pos;
3126     switch (origin) {
3127     case SEEK_CUR:
3128         if (fgetpos(pf, &pos))
3129             return -1;
3130         offset += pos;
3131         break;
3132     case SEEK_END:
3133         fseek(pf, 0, SEEK_END);
3134         pos = _telli64(fileno(pf));
3135         offset += pos;
3136         break;
3137     case SEEK_SET:
3138         break;
3139     default:
3140         errno = EINVAL;
3141         return -1;
3142     }
3143     return fsetpos(pf, &offset);
3144 }
3145
3146 DllExport int
3147 win32_fgetpos(FILE *pf,fpos_t *p)
3148 {
3149     return fgetpos(pf, p);
3150 }
3151
3152 DllExport int
3153 win32_fsetpos(FILE *pf,const fpos_t *p)
3154 {
3155     return fsetpos(pf, p);
3156 }
3157
3158 DllExport void
3159 win32_rewind(FILE *pf)
3160 {
3161     rewind(pf);
3162     return;
3163 }
3164
3165 DllExport int
3166 win32_tmpfd(void)
3167 {
3168     return win32_tmpfd_mode(0);
3169 }
3170
3171 DllExport int
3172 win32_tmpfd_mode(int mode)
3173 {
3174     char prefix[MAX_PATH+1];
3175     char filename[MAX_PATH+1];
3176     DWORD len = GetTempPath(MAX_PATH, prefix);
3177     mode &= ~( O_ACCMODE | O_CREAT | O_EXCL );
3178     mode |= O_RDWR;
3179     if (len && len < MAX_PATH) {
3180         if (GetTempFileName(prefix, "plx", 0, filename)) {
3181             HANDLE fh = CreateFile(filename,
3182                                    DELETE | GENERIC_READ | GENERIC_WRITE,
3183                                    0,
3184                                    NULL,
3185                                    CREATE_ALWAYS,
3186                                    FILE_ATTRIBUTE_NORMAL
3187                                    | FILE_FLAG_DELETE_ON_CLOSE,
3188                                    NULL);
3189             if (fh != INVALID_HANDLE_VALUE) {
3190                 int fd = win32_open_osfhandle((intptr_t)fh, mode);
3191                 if (fd >= 0) {
3192                     PERL_DEB(dTHX;)
3193                     DEBUG_p(PerlIO_printf(Perl_debug_log,
3194                                           "Created tmpfile=%s\n",filename));
3195                     return fd;
3196                 }
3197             }
3198         }
3199     }
3200     return -1;
3201 }
3202
3203 DllExport FILE*
3204 win32_tmpfile(void)
3205 {
3206     int fd = win32_tmpfd();
3207     if (fd >= 0)
3208         return win32_fdopen(fd, "w+b");
3209     return NULL;
3210 }
3211
3212 DllExport void
3213 win32_abort(void)
3214 {
3215     abort();
3216     return;
3217 }
3218
3219 DllExport int
3220 win32_fstat(int fd, Stat_t *sbufptr)
3221 {
3222     HANDLE handle = (HANDLE)win32_get_osfhandle(fd);
3223
3224     return win32_stat_low(handle, NULL, 0, sbufptr);
3225 }
3226
3227 DllExport int
3228 win32_pipe(int *pfd, unsigned int size, int mode)
3229 {
3230     return _pipe(pfd, size, mode);
3231 }
3232
3233 DllExport PerlIO*
3234 win32_popenlist(const char *mode, IV narg, SV **args)
3235 {
3236     get_shell();
3237
3238     return do_popen(mode, NULL, narg, args);
3239 }
3240
3241 STATIC PerlIO*
3242 do_popen(const char *mode, const char *command, IV narg, SV **args) {
3243     int p[2];
3244     int handles[3];
3245     int parent, child;
3246     int stdfd;
3247     int ourmode;
3248     int childpid;
3249     DWORD nhandle;
3250     int lock_held = 0;
3251     const char **args_pvs = NULL;
3252
3253     /* establish which ends read and write */
3254     if (strchr(mode,'w')) {
3255         stdfd = 0;              /* stdin */
3256         parent = 1;
3257         child = 0;
3258         nhandle = STD_INPUT_HANDLE;
3259     }
3260     else if (strchr(mode,'r')) {
3261         stdfd = 1;              /* stdout */
3262         parent = 0;
3263         child = 1;
3264         nhandle = STD_OUTPUT_HANDLE;
3265     }
3266     else
3267         return NULL;
3268
3269     /* set the correct mode */
3270     if (strchr(mode,'b'))
3271         ourmode = O_BINARY;
3272     else if (strchr(mode,'t'))
3273         ourmode = O_TEXT;
3274     else
3275         ourmode = _fmode & (O_TEXT | O_BINARY);
3276
3277     /* the child doesn't inherit handles */
3278     ourmode |= O_NOINHERIT;
3279
3280     if (win32_pipe(p, 512, ourmode) == -1)
3281         return NULL;
3282
3283     /* Previously this code redirected stdin/out temporarily so the
3284        child process inherited those handles, this caused race
3285        conditions when another thread was writing/reading those
3286        handles.
3287
3288        To avoid that we just feed the handles to CreateProcess() so
3289        the handles are redirected only in the child.
3290      */
3291     handles[child] = p[child];
3292     handles[parent] = -1;
3293     handles[2] = -1;
3294
3295     /* CreateProcess() requires inheritable handles */
3296     if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT,
3297                               HANDLE_FLAG_INHERIT)) {
3298         goto cleanup;
3299     }
3300
3301     /* start the child */
3302     {
3303         dTHX;
3304
3305         if (command) {
3306             if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
3307                 goto cleanup;
3308
3309         }
3310         else {
3311             int i;
3312             const char *exe_name;
3313
3314             Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
3315             SAVEFREEPV(args_pvs);
3316             for (i = 0; i < narg; ++i)
3317                 args_pvs[i] = SvPV_nolen(args[i]);
3318             args_pvs[i] = NULL;
3319             exe_name = qualified_path(args_pvs[0], TRUE);
3320             if (!exe_name)
3321                 /* let CreateProcess() try to find it instead */
3322                 exe_name = args_pvs[0];
3323
3324             if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) {
3325                 goto cleanup;
3326             }
3327         }
3328
3329         win32_close(p[child]);
3330
3331         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
3332
3333         /* set process id so that it can be returned by perl's open() */
3334         PL_forkprocess = childpid;
3335     }
3336
3337     /* we have an fd, return a file stream */
3338     return (PerlIO_fdopen(p[parent], (char *)mode));
3339
3340 cleanup:
3341     /* we don't need to check for errors here */
3342     win32_close(p[0]);
3343     win32_close(p[1]);
3344
3345     return (NULL);
3346 }
3347
3348 /*
3349  * a popen() clone that respects PERL5SHELL
3350  *
3351  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
3352  */
3353
3354 DllExport PerlIO*
3355 win32_popen(const char *command, const char *mode)
3356 {
3357 #ifdef USE_RTL_POPEN
3358     return _popen(command, mode);
3359 #else
3360     return do_popen(mode, command, 0, NULL);
3361 #endif /* USE_RTL_POPEN */
3362 }
3363
3364 /*
3365  * pclose() clone
3366  */
3367
3368 DllExport int
3369 win32_pclose(PerlIO *pf)
3370 {
3371 #ifdef USE_RTL_POPEN
3372     return _pclose(pf);
3373 #else
3374     dTHX;
3375     int childpid, status;
3376     SV *sv;
3377
3378     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
3379
3380     if (SvIOK(sv))
3381         childpid = SvIVX(sv);
3382     else
3383         childpid = 0;
3384
3385     if (!childpid) {
3386         errno = EBADF;
3387         return -1;
3388     }
3389
3390 #ifdef USE_PERLIO
3391     PerlIO_close(pf);
3392 #else
3393     fclose(pf);
3394 #endif
3395     SvIVX(sv) = 0;
3396
3397     if (win32_waitpid(childpid, &status, 0) == -1)
3398         return -1;
3399
3400     return status;
3401
3402 #endif /* USE_RTL_POPEN */
3403 }
3404
3405 DllExport int
3406 win32_link(const char *oldname, const char *newname)
3407 {
3408     dTHXa(NULL);
3409     WCHAR wOldName[MAX_PATH+1];
3410     WCHAR wNewName[MAX_PATH+1];
3411
3412     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3413         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3414         ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)),
3415         CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3416     {
3417         return 0;
3418     }
3419     translate_to_errno();
3420     return -1;
3421 }
3422
3423 #ifndef SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
3424 #  define SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE 0x2
3425 #endif
3426
3427 DllExport int
3428 win32_symlink(const char *oldfile, const char *newfile)
3429 {
3430     dTHX;
3431     const char *dest_path = oldfile;
3432     char szTargetName[MAX_PATH+1];
3433     size_t oldfile_len = strlen(oldfile);
3434     DWORD dest_attr;
3435     DWORD create_flags = 0;
3436
3437     /* this flag can be used only on Windows 10 1703 or newer */
3438     if (g_osver.dwMajorVersion > 10 ||
3439         (g_osver.dwMajorVersion == 10 &&
3440          (g_osver.dwMinorVersion > 0 || g_osver.dwBuildNumber > 15063)))
3441     {
3442         create_flags |= SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE;
3443     }
3444
3445     /* oldfile might be relative and we don't want to change that,
3446        so don't map that.
3447     */
3448     newfile = PerlDir_mapA(newfile);
3449
3450     /* are we linking to a directory?
3451        CreateSymlinkA() needs to know if the target is a directory,
3452        if the oldfile is relative we need to make a relative path
3453        based on the newfile
3454     */
3455     if (oldfile_len >= 3 && oldfile[1] == ':' && oldfile[2] != '\\' && oldfile[2] != '/') {
3456         /* relative to current directory on a drive */
3457         /* dest_path = oldfile; already done */
3458     }
3459     else if (oldfile[0] != '\\' && oldfile[0] != '/') {
3460         size_t newfile_len = strlen(newfile);
3461         char *last_slash = strrchr(newfile, '/');
3462         char *last_bslash = strrchr(newfile, '\\');
3463         char *end_dir = last_slash && last_bslash
3464             ? ( last_slash > last_bslash ? last_slash : last_bslash)
3465             : last_slash ? last_slash : last_bslash ? last_bslash : NULL;
3466
3467         if (end_dir) {
3468             if ((end_dir - newfile + 1) + oldfile_len > MAX_PATH) {
3469                 /* too long */
3470                 errno = EINVAL;
3471                 return -1;
3472             }
3473
3474             memcpy(szTargetName, newfile, end_dir - newfile + 1);
3475             strcpy(szTargetName + (end_dir - newfile + 1), oldfile);
3476             dest_path = szTargetName;
3477         }
3478         else {
3479             /* newpath is just a filename */
3480             /* dest_path = oldfile; */
3481         }
3482     }
3483
3484     dest_attr = GetFileAttributes(dest_path);
3485     if (dest_attr != (DWORD)-1 && (dest_attr & FILE_ATTRIBUTE_DIRECTORY)) {
3486         create_flags |= SYMBOLIC_LINK_FLAG_DIRECTORY;
3487     }
3488
3489     if (!CreateSymbolicLinkA(newfile, oldfile, create_flags)) {
3490         translate_to_errno();
3491         return -1;
3492     }
3493
3494     return 0;
3495 }
3496
3497 DllExport int
3498 win32_rename(const char *oname, const char *newname)
3499 {
3500     char szOldName[MAX_PATH+1];
3501     BOOL bResult;
3502     DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3503     dTHX;
3504
3505     if (stricmp(newname, oname))
3506         dwFlags |= MOVEFILE_REPLACE_EXISTING;
3507     strcpy(szOldName, PerlDir_mapA(oname));
3508
3509     bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3510     if (!bResult) {
3511         DWORD err = GetLastError();
3512         switch (err) {
3513         case ERROR_BAD_NET_NAME:
3514         case ERROR_BAD_NETPATH:
3515         case ERROR_BAD_PATHNAME:
3516         case ERROR_FILE_NOT_FOUND:
3517         case ERROR_FILENAME_EXCED_RANGE:
3518         case ERROR_INVALID_DRIVE:
3519         case ERROR_NO_MORE_FILES:
3520         case ERROR_PATH_NOT_FOUND:
3521             errno = ENOENT;
3522             break;
3523         case ERROR_DISK_FULL:
3524             errno = ENOSPC;
3525             break;
3526         case ERROR_NOT_ENOUGH_QUOTA:
3527             errno = EDQUOT;
3528             break;
3529         default:
3530             errno = EACCES;
3531             break;
3532         }
3533         return -1;
3534     }
3535     return 0;
3536 }
3537
3538 DllExport int
3539 win32_setmode(int fd, int mode)
3540 {
3541     return setmode(fd, mode);
3542 }
3543
3544 DllExport int
3545 win32_chsize(int fd, Off_t size)
3546 {
3547     int retval = 0;
3548     Off_t cur, end, extend;
3549
3550     cur = win32_tell(fd);
3551     if (cur < 0)
3552         return -1;
3553     end = win32_lseek(fd, 0, SEEK_END);
3554     if (end < 0)
3555         return -1;
3556     extend = size - end;
3557     if (extend == 0) {
3558         /* do nothing */
3559     }
3560     else if (extend > 0) {
3561         /* must grow the file, padding with nulls */
3562         char b[4096];
3563         int oldmode = win32_setmode(fd, O_BINARY);
3564         size_t count;
3565         memset(b, '\0', sizeof(b));
3566         do {
3567             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3568             count = win32_write(fd, b, count);
3569             if ((int)count < 0) {
3570                 retval = -1;
3571                 break;
3572             }
3573         } while ((extend -= count) > 0);
3574         win32_setmode(fd, oldmode);
3575     }
3576     else {
3577         /* shrink the file */
3578         win32_lseek(fd, size, SEEK_SET);
3579         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3580             errno = EACCES;
3581             retval = -1;
3582         }
3583     }
3584     win32_lseek(fd, cur, SEEK_SET);
3585     return retval;
3586 }
3587
3588 DllExport Off_t
3589 win32_lseek(int fd, Off_t offset, int origin)
3590 {
3591     return _lseeki64(fd, offset, origin);
3592 }
3593
3594 DllExport Off_t
3595 win32_tell(int fd)
3596 {
3597     return _telli64(fd);
3598 }
3599
3600 DllExport int
3601 win32_open(const char *path, int flag, ...)
3602 {
3603     dTHXa(NULL);
3604     va_list ap;
3605     int pmode;
3606
3607     va_start(ap, flag);
3608     pmode = va_arg(ap, int);
3609     va_end(ap);
3610
3611     if (stricmp(path, "/dev/null")==0)
3612         path = "NUL";
3613
3614     aTHXa(PERL_GET_THX);
3615     return open(PerlDir_mapA(path), flag, pmode);
3616 }
3617
3618 /* close() that understands socket */
3619 extern int my_close(int);       /* in win32sck.c */
3620
3621 DllExport int
3622 win32_close(int fd)
3623 {
3624 #ifdef WIN32_NO_SOCKETS
3625     return close(fd);
3626 #else
3627     return my_close(fd);
3628 #endif
3629 }
3630
3631 DllExport int
3632 win32_eof(int fd)
3633 {
3634     return eof(fd);
3635 }
3636
3637 DllExport int
3638 win32_isatty(int fd)
3639 {
3640     /* The Microsoft isatty() function returns true for *all*
3641      * character mode devices, including "nul".  Our implementation
3642      * should only return true if the handle has a console buffer.
3643      */
3644     DWORD mode;
3645     HANDLE fh = (HANDLE)_get_osfhandle(fd);
3646     if (fh == (HANDLE)-1) {
3647         /* errno is already set to EBADF */
3648         return 0;
3649     }
3650
3651     if (GetConsoleMode(fh, &mode))
3652         return 1;
3653
3654     errno = ENOTTY;
3655     return 0;
3656 }
3657
3658 DllExport int
3659 win32_dup(int fd)
3660 {
3661     return dup(fd);
3662 }
3663
3664 DllExport int
3665 win32_dup2(int fd1,int fd2)
3666 {
3667     return dup2(fd1,fd2);
3668 }
3669
3670 DllExport int
3671 win32_read(int fd, void *buf, unsigned int cnt)
3672 {
3673     return read(fd, buf, cnt);
3674 }
3675
3676 DllExport int
3677 win32_write(int fd, const void *buf, unsigned int cnt)
3678 {
3679     return write(fd, buf, cnt);
3680 }
3681
3682 DllExport int
3683 win32_mkdir(const char *dir, int mode)
3684 {
3685     dTHX;
3686     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3687 }
3688
3689 DllExport int
3690 win32_rmdir(const char *dir)
3691 {
3692     dTHX;
3693     return rmdir(PerlDir_mapA(dir));
3694 }
3695
3696 DllExport int
3697 win32_chdir(const char *dir)
3698 {
3699     if (!dir || !*dir) {
3700         errno = ENOENT;
3701         return -1;
3702     }
3703     return chdir(dir);
3704 }
3705
3706 DllExport  int
3707 win32_access(const char *path, int mode)
3708 {
3709     dTHX;
3710     return access(PerlDir_mapA(path), mode);
3711 }
3712
3713 DllExport  int
3714 win32_chmod(const char *path, int mode)
3715 {
3716     dTHX;
3717     return chmod(PerlDir_mapA(path), mode);
3718 }
3719
3720
3721 static char *
3722 create_command_line(char *cname, STRLEN clen, const char * const *args)
3723 {
3724     PERL_DEB(dTHX;)
3725     int index, argc;
3726     char *cmd, *ptr;
3727     const char *arg;
3728     STRLEN len = 0;
3729     bool bat_file = FALSE;
3730     bool cmd_shell = FALSE;
3731     bool dumb_shell = FALSE;
3732     bool extra_quotes = FALSE;
3733     bool quote_next = FALSE;
3734
3735     if (!cname)
3736         cname = (char*)args[0];
3737
3738     /* The NT cmd.exe shell has the following peculiarity that needs to be
3739      * worked around.  It strips a leading and trailing dquote when any
3740      * of the following is true:
3741      *    1. the /S switch was used
3742      *    2. there are more than two dquotes
3743      *    3. there is a special character from this set: &<>()@^|
3744      *    4. no whitespace characters within the two dquotes
3745      *    5. string between two dquotes isn't an executable file
3746      * To work around this, we always add a leading and trailing dquote
3747      * to the string, if the first argument is either "cmd.exe" or "cmd",
3748      * and there were at least two or more arguments passed to cmd.exe
3749      * (not including switches).
3750      * XXX the above rules (from "cmd /?") don't seem to be applied
3751      * always, making for the convolutions below :-(
3752      */
3753     if (cname) {
3754         if (!clen)
3755             clen = strlen(cname);
3756
3757         if (clen > 4
3758             && (stricmp(&cname[clen-4], ".bat") == 0
3759                 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3760         {
3761             bat_file = TRUE;
3762             len += 3;
3763         }
3764         else {
3765             char *exe = strrchr(cname, '/');
3766             char *exe2 = strrchr(cname, '\\');
3767             if (exe2 > exe)
3768                 exe = exe2;
3769             if (exe)
3770                 ++exe;
3771             else
3772                 exe = cname;
3773             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3774                 cmd_shell = TRUE;
3775                 len += 3;
3776             }
3777             else if (stricmp(exe, "command.com") == 0
3778                      || stricmp(exe, "command") == 0)
3779             {
3780                 dumb_shell = TRUE;
3781             }
3782         }
3783     }
3784
3785     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3786     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3787         STRLEN curlen = strlen(arg);
3788         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3789             len += 2;   /* assume quoting needed (worst case) */
3790         len += curlen + 1;
3791         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3792     }
3793     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3794
3795     argc = index;
3796     Newx(cmd, len, char);
3797     ptr = cmd;
3798
3799     if (bat_file) {
3800         *ptr++ = '"';
3801         extra_quotes = TRUE;
3802     }
3803
3804     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3805         bool do_quote = 0;
3806         STRLEN curlen = strlen(arg);
3807
3808         /* we want to protect empty arguments and ones with spaces with
3809          * dquotes, but only if they aren't already there */
3810         if (!dumb_shell) {
3811             if (!curlen) {
3812                 do_quote = 1;
3813             }
3814             else if (quote_next) {
3815                 /* see if it really is multiple arguments pretending to
3816                  * be one and force a set of quotes around it */
3817                 if (*find_next_space(arg))
3818                     do_quote = 1;
3819             }
3820             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3821                 STRLEN i = 0;
3822                 while (i < curlen) {
3823                     if (isSPACE(arg[i])) {
3824                         do_quote = 1;
3825                     }
3826                     else if (arg[i] == '"') {
3827                         do_quote = 0;
3828                         break;
3829                     }
3830                     i++;
3831                 }
3832             }
3833         }
3834
3835         if (do_quote)
3836             *ptr++ = '"';
3837
3838         strcpy(ptr, arg);
3839         ptr += curlen;
3840
3841         if (do_quote)
3842             *ptr++ = '"';
3843
3844         if (args[index+1])
3845             *ptr++ = ' ';
3846
3847         if (!extra_quotes
3848             && cmd_shell
3849             && curlen >= 2
3850             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3851             && stricmp(arg+curlen-2, "/c") == 0)
3852         {
3853             /* is there a next argument? */
3854             if (args[index+1]) {
3855                 /* are there two or more next arguments? */
3856                 if (args[index+2]) {
3857                     *ptr++ = '"';
3858                     extra_quotes = TRUE;
3859                 }
3860                 else {
3861                     /* single argument, force quoting if it has spaces */
3862                     quote_next = TRUE;
3863                 }
3864             }
3865         }
3866     }
3867
3868     if (extra_quotes)
3869         *ptr++ = '"';
3870
3871     *ptr = '\0';
3872
3873     return cmd;
3874 }
3875
3876 static const char *exe_extensions[] =
3877   {
3878     ".exe", /* this must be first */
3879     ".cmd",
3880     ".bat"
3881   };
3882
3883 static char *
3884 qualified_path(const char *cmd, bool other_exts)
3885 {
3886     char *pathstr;
3887     char *fullcmd, *curfullcmd;
3888     STRLEN cmdlen = 0;
3889     int has_slash = 0;
3890
3891     if (!cmd)
3892         return NULL;
3893     fullcmd = (char*)cmd;
3894     while (*fullcmd) {
3895         if (*fullcmd == '/' || *fullcmd == '\\')
3896             has_slash++;
3897         fullcmd++;
3898         cmdlen++;
3899     }
3900
3901     /* look in PATH */
3902     {
3903         dTHX;
3904         pathstr = PerlEnv_getenv("PATH");
3905     }
3906     /* worst case: PATH is a single directory; we need additional space
3907      * to append "/", ".exe" and trailing "\0" */
3908     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3909     curfullcmd = fullcmd;
3910
3911     while (1) {
3912         DWORD res;
3913
3914         /* start by appending the name to the current prefix */
3915         strcpy(curfullcmd, cmd);
3916         curfullcmd += cmdlen;
3917
3918         /* if it doesn't end with '.', or has no extension, try adding
3919          * a trailing .exe first */
3920         if (cmd[cmdlen-1] != '.'
3921             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3922         {
3923             int i;
3924             /* first extension is .exe */
3925             int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1;
3926             for (i = 0; i < ext_limit; ++i) {
3927                 strcpy(curfullcmd, exe_extensions[i]);
3928                 res = GetFileAttributes(fullcmd);
3929                 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3930                     return fullcmd;
3931             }
3932
3933             *curfullcmd = '\0';
3934         }
3935
3936         /* that failed, try the bare name */
3937         res = GetFileAttributes(fullcmd);
3938         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3939             return fullcmd;
3940
3941         /* quit if no other path exists, or if cmd already has path */
3942         if (!pathstr || !*pathstr || has_slash)
3943             break;
3944
3945         /* skip leading semis */
3946         while (*pathstr == ';')
3947             pathstr++;
3948
3949         /* build a new prefix from scratch */
3950         curfullcmd = fullcmd;
3951         while (*pathstr && *pathstr != ';') {
3952             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3953                 pathstr++;              /* skip initial '"' */
3954                 while (*pathstr && *pathstr != '"') {
3955                     *curfullcmd++ = *pathstr++;
3956                 }
3957                 if (*pathstr)
3958                     pathstr++;          /* skip trailing '"' */
3959             }
3960             else {
3961                 *curfullcmd++ = *pathstr++;
3962             }
3963         }
3964         if (*pathstr)
3965             pathstr++;                  /* skip trailing semi */
3966         if (curfullcmd > fullcmd        /* append a dir separator */
3967             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3968         {
3969             *curfullcmd++ = '\\';
3970         }
3971     }
3972
3973     Safefree(fullcmd);
3974     return NULL;
3975 }
3976
3977 /* The following are just place holders.
3978  * Some hosts may provide and environment that the OS is
3979  * not tracking, therefore, these host must provide that
3980  * environment and the current directory to CreateProcess
3981  */
3982
3983 DllExport void*
3984 win32_get_childenv(void)
3985 {
3986     return NULL;
3987 }
3988
3989 DllExport void
3990 win32_free_childenv(void* d)
3991 {
3992 }
3993
3994 DllExport void
3995 win32_clearenv(void)
3996 {
3997     char *envv = GetEnvironmentStrings();
3998     char *cur = envv;
3999     STRLEN len;
4000     while (*cur) {
4001         char *end = strchr(cur,'=');
4002         if (end && end != cur) {
4003             *end = '\0';
4004             SetEnvironmentVariable(cur, NULL);
4005             *end = '=';
4006             cur = end + strlen(end+1)+2;
4007         }
4008         else if ((len = strlen(cur)))
4009             cur += len+1;
4010     }
4011     FreeEnvironmentStrings(envv);
4012 }
4013
4014 DllExport char*
4015 win32_get_childdir(void)
4016 {
4017     char* ptr;
4018     char szfilename[MAX_PATH+1];
4019
4020     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
4021     Newx(ptr, strlen(szfilename)+1, char);
4022     strcpy(ptr, szfilename);
4023     return ptr;
4024 }
4025
4026 DllExport void
4027 win32_free_childdir(char* d)
4028 {
4029     Safefree(d);
4030 }
4031
4032
4033 /* XXX this needs to be made more compatible with the spawnvp()
4034  * provided by the various RTLs.  In particular, searching for
4035  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
4036  * This doesn't significantly affect perl itself, because we
4037  * always invoke things using PERL5SHELL if a direct attempt to
4038  * spawn the executable fails.
4039  *
4040  * XXX splitting and rejoining the commandline between do_aspawn()
4041  * and win32_spawnvp() could also be avoided.
4042  */
4043
4044 DllExport int
4045 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
4046 {
4047 #ifdef USE_RTL_SPAWNVP
4048     return _spawnvp(mode, cmdname, (char * const *)argv);
4049 #else
4050     return do_spawnvp_handles(mode, cmdname, argv, NULL);
4051 #endif
4052 }
4053
4054 static int
4055 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv,
4056                 const int *handles) {
4057     dTHXa(NULL);
4058     int ret;
4059     void* env;
4060     char* dir;
4061     child_IO_table tbl;
4062     STARTUPINFO StartupInfo;
4063     PROCESS_INFORMATION ProcessInformation;
4064     DWORD create = 0;
4065     char *cmd;
4066     char *fullcmd = NULL;
4067     char *cname = (char *)cmdname;
4068     STRLEN clen = 0;
4069
4070     if (cname) {
4071         clen = strlen(cname);
4072         /* if command name contains dquotes, must remove them */
4073         if (strchr(cname, '"')) {
4074             cmd = cname;
4075             Newx(cname,clen+1,char);
4076             clen = 0;
4077             while (*cmd) {
4078                 if (*cmd != '"') {
4079                     cname[clen] = *cmd;
4080                     ++clen;
4081                 }
4082                 ++cmd;
4083             }
4084             cname[clen] = '\0';
4085         }
4086     }
4087
4088     cmd = create_command_line(cname, clen, argv);
4089
4090     aTHXa(PERL_GET_THX);
4091     env = PerlEnv_get_childenv();
4092     dir = PerlEnv_get_childdir();
4093
4094     switch(mode) {
4095     case P_NOWAIT:      /* asynch + remember result */
4096         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
4097             errno = EAGAIN;
4098             ret = -1;
4099             goto RETVAL;
4100         }
4101         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
4102          * in win32_kill()
4103          */
4104         create |= CREATE_NEW_PROCESS_GROUP;
4105         /* FALL THROUGH */
4106
4107     case P_WAIT:        /* synchronous execution */
4108         break;
4109     default:            /* invalid mode */
4110         errno = EINVAL;
4111         ret = -1;
4112         goto RETVAL;
4113     }
4114
4115     memset(&StartupInfo,0,sizeof(StartupInfo));
4116     StartupInfo.cb = sizeof(StartupInfo);
4117     memset(&tbl,0,sizeof(tbl));
4118     PerlEnv_get_child_IO(&tbl);
4119     StartupInfo.dwFlags         = tbl.dwFlags;
4120     StartupInfo.dwX             = tbl.dwX;
4121     StartupInfo.dwY             = tbl.dwY;
4122     StartupInfo.dwXSize         = tbl.dwXSize;
4123     StartupInfo.dwYSize         = tbl.dwYSize;
4124     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
4125     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
4126     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
4127     StartupInfo.wShowWindow     = tbl.wShowWindow;
4128     StartupInfo.hStdInput       = handles && handles[0] != -1 ?
4129             (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn;
4130     StartupInfo.hStdOutput      = handles && handles[1] != -1 ?
4131             (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut;
4132     StartupInfo.hStdError       = handles && handles[2] != -1 ?
4133             (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr;
4134     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
4135         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
4136         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4137     {
4138         create |= CREATE_NEW_CONSOLE;
4139     }
4140     else {
4141         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4142     }
4143     if (w32_use_showwindow) {
4144         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4145         StartupInfo.wShowWindow = w32_showwindow;
4146     }
4147
4148     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4149                           cname,cmd));
4150 RETRY:
4151     if (!CreateProcess(cname,           /* search PATH to find executable */
4152                        cmd,             /* executable, and its arguments */
4153                        NULL,            /* process attributes */
4154                        NULL,            /* thread attributes */
4155                        TRUE,            /* inherit handles */
4156                        create,          /* creation flags */
4157                        (LPVOID)env,     /* inherit environment */
4158                        dir,             /* inherit cwd */
4159                        &StartupInfo,
4160                        &ProcessInformation))
4161     {
4162         /* initial NULL argument to CreateProcess() does a PATH
4163          * search, but it always first looks in the directory
4164          * where the current process was started, which behavior
4165          * is undesirable for backward compatibility.  So we
4166          * jump through our own hoops by picking out the path
4167          * we really want it to use. */
4168         if (!fullcmd) {
4169             fullcmd = qualified_path(cname, FALSE);
4170             if (fullcmd) {
4171                 if (cname != cmdname)
4172                     Safefree(cname);
4173                 cname = fullcmd;
4174                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4175                                       "Retrying [%s] with same args\n",
4176                                       cname));
4177                 goto RETRY;
4178             }
4179         }
4180         errno = ENOENT;
4181         ret = -1;
4182         goto RETVAL;
4183     }
4184
4185     if (mode == P_NOWAIT) {
4186         /* asynchronous spawn -- store handle, return PID */
4187         ret = (int)ProcessInformation.dwProcessId;
4188
4189         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4190         w32_child_pids[w32_num_children] = (DWORD)ret;
4191         ++w32_num_children;
4192     }
4193     else {
4194         DWORD status;
4195         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4196         /* FIXME: if msgwait returned due to message perhaps forward the
4197            "signal" to the process
4198          */
4199         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4200         ret = (int)status;
4201         CloseHandle(ProcessInformation.hProcess);
4202     }
4203
4204     CloseHandle(ProcessInformation.hThread);
4205
4206 RETVAL:
4207     PerlEnv_free_childenv(env);
4208     PerlEnv_free_childdir(dir);
4209     Safefree(cmd);
4210     if (cname != cmdname)
4211         Safefree(cname);
4212     return ret;
4213 }
4214
4215 DllExport int
4216 win32_execv(const char *cmdname, const char *const *argv)
4217 {
4218 #ifdef USE_ITHREADS
4219     dTHX;
4220     /* if this is a pseudo-forked child, we just want to spawn
4221      * the new program, and return */
4222     if (w32_pseudo_id)
4223         return _spawnv(P_WAIT, cmdname, argv);
4224 #endif
4225     return _execv(cmdname, argv);
4226 }
4227
4228 DllExport int
4229 win32_execvp(const char *cmdname, const char *const *argv)
4230 {
4231 #ifdef USE_ITHREADS
4232     dTHX;
4233     /* if this is a pseudo-forked child, we just want to spawn
4234      * the new program, and return */
4235     if (w32_pseudo_id) {
4236         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4237         if (status != -1) {
4238             my_exit(status);
4239             return 0;
4240         }
4241         else
4242             return status;
4243     }
4244 #endif
4245     return _execvp(cmdname, argv);
4246 }
4247
4248 DllExport void
4249 win32_perror(const char *str)
4250 {
4251     perror(str);
4252 }
4253
4254 DllExport void
4255 win32_setbuf(FILE *pf, char *buf)
4256 {
4257     setbuf(pf, buf);
4258 }
4259
4260 DllExport int
4261 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4262 {
4263     return setvbuf(pf, buf, type, size);
4264 }
4265
4266 DllExport int
4267 win32_flushall(void)
4268 {
4269     return flushall();
4270 }
4271
4272 DllExport int
4273 win32_fcloseall(void)
4274 {
4275     return fcloseall();
4276 }
4277
4278 DllExport char*
4279 win32_fgets(char *s, int n, FILE *pf)
4280 {
4281     return fgets(s, n, pf);
4282 }
4283
4284 DllExport char*
4285 win32_gets(char *s)
4286 {
4287     return gets(s);
4288 }
4289
4290 DllExport int
4291 win32_fgetc(FILE *pf)
4292 {
4293     return fgetc(pf);
4294 }
4295
4296 DllExport int
4297 win32_putc(int c, FILE *pf)
4298 {
4299     return putc(c,pf);
4300 }
4301
4302 DllExport int
4303 win32_puts(const char *s)
4304 {
4305     return puts(s);
4306 }
4307
4308 DllExport int
4309 win32_getchar(void)
4310 {
4311     return getchar();
4312 }
4313
4314 DllExport int
4315 win32_putchar(int c)
4316 {
4317     return putchar(c);
4318 }
4319
4320 #ifdef MYMALLOC
4321
4322 #ifndef USE_PERL_SBRK
4323
4324 static char *committed = NULL;          /* XXX threadead */
4325 static char *base      = NULL;          /* XXX threadead */
4326 static char *reserved  = NULL;          /* XXX threadead */
4327 static char *brk       = NULL;          /* XXX threadead */
4328 static DWORD pagesize  = 0;             /* XXX threadead */
4329
4330 void *
4331 sbrk(ptrdiff_t need)
4332 {
4333  void *result;
4334  if (!pagesize)
4335   {SYSTEM_INFO info;
4336    GetSystemInfo(&info);
4337    /* Pretend page size is larger so we don't perpetually
4338     * call the OS to commit just one page ...
4339     */
4340    pagesize = info.dwPageSize << 3;
4341   }
4342  if (brk+need >= reserved)
4343   {
4344    DWORD size = brk+need-reserved;
4345    char *addr;
4346    char *prev_committed = NULL;
4347    if (committed && reserved && committed < reserved)
4348     {
4349      /* Commit last of previous chunk cannot span allocations */
4350      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4351      if (addr)
4352       {
4353       /* Remember where we committed from in case we want to decommit later */
4354       prev_committed = committed;
4355       committed = reserved;
4356       }
4357     }
4358    /* Reserve some (more) space
4359     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4360     * this is only address space not memory...
4361     * Note this is a little sneaky, 1st call passes NULL as reserved
4362     * so lets system choose where we start, subsequent calls pass
4363     * the old end address so ask for a contiguous block
4364     */
4365 sbrk_reserve:
4366    if (size < 64*1024*1024)
4367     size = 64*1024*1024;
4368    size = ((size + pagesize - 1) / pagesize) * pagesize;
4369    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4370    if (addr)
4371     {
4372      reserved = addr+size;
4373      if (!base)
4374       base = addr;
4375      if (!committed)
4376       committed = base;
4377      if (!brk)
4378       brk = committed;
4379     }
4380    else if (reserved)
4381     {
4382       /* The existing block could not be extended far enough, so decommit
4383        * anything that was just committed above and start anew */
4384       if (prev_committed)
4385        {
4386        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4387         return (void *) -1;
4388        }
4389       reserved = base = committed = brk = NULL;
4390       size = need;
4391       goto sbrk_reserve;
4392     }
4393    else
4394     {
4395      return (void *) -1;
4396     }
4397   }
4398  result = brk;
4399  brk += need;
4400  if (brk > committed)
4401   {
4402    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4403    char *addr;
4404    if (committed+size > reserved)
4405     size = reserved-committed;
4406    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4407    if (addr)
4408     committed += size;
4409    else
4410     return (void *) -1;
4411   }
4412  return result;
4413 }
4414
4415 #endif
4416 #endif
4417
4418 DllExport void*
4419 win32_malloc(size_t size)
4420 {
4421     return malloc(size);
4422 }
4423
4424 DllExport void*
4425 win32_calloc(size_t numitems, size_t size)
4426 {
4427     return calloc(numitems,size);
4428 }
4429
4430 DllExport void*
4431 win32_realloc(void *block, size_t size)
4432 {
4433     return realloc(block,size);
4434 }
4435
4436 DllExport void
4437 win32_free(void *block)
4438 {
4439     free(block);
4440 }
4441
4442
4443 DllExport int
4444 win32_open_osfhandle(intptr_t handle, int flags)
4445 {
4446     return _open_osfhandle(handle, flags);
4447 }
4448
4449 DllExport intptr_t
4450 win32_get_osfhandle(int fd)
4451 {
4452     return (intptr_t)_get_osfhandle(fd);
4453 }
4454
4455 DllExport FILE *
4456 win32_fdupopen(FILE *pf)
4457 {
4458     FILE* pfdup;
4459     fpos_t pos;
4460     char mode[3];
4461     int fileno = win32_dup(win32_fileno(pf));
4462
4463     /* open the file in the same mode */
4464     if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) {
4465         mode[0] = 'r';
4466         mode[1] = 0;
4467     }
4468     else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) {
4469         mode[0] = 'a';
4470         mode[1] = 0;
4471     }
4472     else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) {
4473         mode[0] = 'r';
4474         mode[1] = '+';
4475         mode[2] = 0;
4476     }
4477
4478     /* it appears that the binmode is attached to the
4479      * file descriptor so binmode files will be handled
4480      * correctly
4481      */
4482     pfdup = win32_fdopen(fileno, mode);
4483
4484     /* move the file pointer to the same position */
4485     if (!fgetpos(pf, &pos)) {
4486         fsetpos(pfdup, &pos);
4487     }
4488     return pfdup;
4489 }
4490
4491 DllExport void*
4492 win32_dynaload(const char* filename)
4493 {
4494     dTHXa(NULL);
4495     char buf[MAX_PATH+1];
4496     const char *first;
4497
4498     /* LoadLibrary() doesn't recognize forward slashes correctly,
4499      * so turn 'em back. */
4500     first = strchr(filename, '/');
4501     if (first) {
4502         STRLEN len = strlen(filename);
4503         if (len <= MAX_PATH) {
4504             strcpy(buf, filename);
4505             filename = &buf[first - filename];
4506             while (*filename) {
4507                 if (*filename == '/')
4508                     *(char*)filename = '\\';
4509                 ++filename;
4510             }
4511             filename = buf;
4512         }
4513     }
4514     aTHXa(PERL_GET_THX);
4515     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4516 }
4517
4518 XS(w32_SetChildShowWindow)
4519 {
4520     dXSARGS;
4521     BOOL use_showwindow = w32_use_showwindow;
4522     /* use "unsigned short" because Perl has redefined "WORD" */
4523     unsigned short showwindow = w32_showwindow;
4524
4525     if (items > 1)
4526         croak_xs_usage(cv, "[showwindow]");
4527
4528     if (items == 0 || !SvOK(ST(0)))
4529         w32_use_showwindow = FALSE;
4530     else {
4531         w32_use_showwindow = TRUE;
4532         w32_showwindow = (unsigned short)SvIV(ST(0));
4533     }
4534
4535     EXTEND(SP, 1);
4536     if (use_showwindow)
4537         ST(0) = sv_2mortal(newSViv(showwindow));
4538     else
4539         ST(0) = &PL_sv_undef;
4540     XSRETURN(1);
4541 }
4542
4543
4544 #ifdef PERL_IS_MINIPERL
4545 /* shelling out is much slower, full perl uses Win32.pm */
4546 XS(w32_GetCwd)
4547 {
4548     dXSARGS;
4549     /* Make the host for current directory */
4550     char* ptr = PerlEnv_get_childdir();
4551     /*
4552      * If ptr != Nullch
4553      *   then it worked, set PV valid,
4554      *   else return 'undef'
4555      */
4556     if (ptr) {
4557         SV *sv = sv_newmortal();
4558         sv_setpv(sv, ptr);
4559         PerlEnv_free_childdir(ptr);
4560
4561 #ifndef INCOMPLETE_TAINTS
4562         SvTAINTED_on(sv);
4563 #endif
4564
4565         ST(0) = sv;
4566         XSRETURN(1);
4567     }
4568     XSRETURN_UNDEF;
4569 }
4570 #endif
4571
4572 void
4573 Perl_init_os_extras(void)
4574 {
4575     dTHXa(NULL);
4576     char *file = __FILE__;
4577
4578     /* Initialize Win32CORE if it has been statically linked. */
4579 #ifndef PERL_IS_MINIPERL
4580     void (*pfn_init)(pTHX);
4581     HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
4582                                ? GetModuleHandle(NULL)
4583                                : w32_perldll_handle);
4584     pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE");
4585     aTHXa(PERL_GET_THX);
4586     if (pfn_init)
4587         pfn_init(aTHX);
4588 #else
4589     aTHXa(PERL_GET_THX);
4590 #endif
4591
4592     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4593 #ifdef PERL_IS_MINIPERL
4594     newXS("Win32::GetCwd", w32_GetCwd, file);
4595 #endif
4596 }
4597
4598 void *
4599 win32_signal_context(void)
4600 {
4601     dTHX;
4602 #ifdef MULTIPLICITY
4603     if (!my_perl) {
4604         my_perl = PL_curinterp;
4605         PERL_SET_THX(my_perl);
4606     }
4607     return my_perl;
4608 #else
4609     return PL_curinterp;
4610 #endif
4611 }
4612
4613
4614 BOOL WINAPI
4615 win32_ctrlhandler(DWORD dwCtrlType)
4616 {
4617 #ifdef MULTIPLICITY
4618     dTHXa(PERL_GET_SIG_CONTEXT);
4619
4620     if (!my_perl)
4621         return FALSE;
4622 #endif
4623
4624     switch(dwCtrlType) {
4625     case CTRL_CLOSE_EVENT:
4626      /*  A signal that the system sends to all processes attached to a console when
4627          the user closes the console (either by choosing the Close command from the
4628          console window's System menu, or by choosing the End Task command from the
4629          Task List
4630       */
4631         if (do_raise(aTHX_ 1))        /* SIGHUP */
4632             sig_terminate(aTHX_ 1);
4633         return TRUE;
4634
4635     case CTRL_C_EVENT:
4636         /*  A CTRL+c signal was received */
4637         if (do_raise(aTHX_ SIGINT))
4638             sig_terminate(aTHX_ SIGINT);
4639         return TRUE;
4640
4641     case CTRL_BREAK_EVENT:
4642         /*  A CTRL+BREAK signal was received */
4643         if (do_raise(aTHX_ SIGBREAK))
4644             sig_terminate(aTHX_ SIGBREAK);
4645         return TRUE;
4646
4647     case CTRL_LOGOFF_EVENT:
4648       /*  A signal that the system sends to all console processes when a user is logging
4649           off. This signal does not indicate which user is logging off, so no
4650           assumptions can be made.
4651        */
4652         break;
4653     case CTRL_SHUTDOWN_EVENT:
4654       /*  A signal that the system sends to all console processes when the system is
4655           shutting down.
4656        */
4657         if (do_raise(aTHX_ SIGTERM))
4658             sig_terminate(aTHX_ SIGTERM);
4659         return TRUE;
4660     default:
4661         break;
4662     }
4663     return FALSE;
4664 }
4665
4666
4667 #ifdef SET_INVALID_PARAMETER_HANDLER
4668 #  include <crtdbg.h>
4669 #endif
4670
4671 static void
4672 ansify_path(void)
4673 {
4674     size_t len;
4675     char *ansi_path;
4676     WCHAR *wide_path;
4677     WCHAR *wide_dir;
4678
4679     /* fetch Unicode version of PATH */
4680     len = 2000;
4681     wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR));
4682     while (wide_path) {
4683         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4684         if (newlen == 0) {
4685             win32_free(wide_path);
4686             return;
4687         }
4688         if (newlen < len)
4689             break;
4690         len = newlen;
4691         wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR));
4692     }
4693     if (!wide_path)
4694         return;
4695
4696     /* convert to ANSI pathnames */
4697     wide_dir = wide_path;
4698     ansi_path = NULL;
4699     while (wide_dir) {
4700         WCHAR *sep = wcschr(wide_dir, ';');
4701         char *ansi_dir;
4702         size_t ansi_len;
4703         size_t wide_len;
4704
4705         if (sep)
4706             *sep++ = '\0';
4707
4708         /* remove quotes around pathname */
4709         if (*wide_dir == '"')
4710             ++wide_dir;
4711         wide_len = wcslen(wide_dir);
4712         if (wide_len && wide_dir[wide_len-1] == '"')
4713             wide_dir[wide_len-1] = '\0';
4714
4715         /* append ansi_dir to ansi_path */
4716         ansi_dir = win32_ansipath(wide_dir);
4717         ansi_len = strlen(ansi_dir);
4718         if (ansi_path) {
4719             size_t newlen = len + 1 + ansi_len;
4720             ansi_path = (char*)win32_realloc(ansi_path, newlen+1);
4721             if (!ansi_path)
4722                 break;
4723             ansi_path[len] = ';';
4724             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4725             len = newlen;
4726         }
4727         else {
4728             len = ansi_len;
4729             ansi_path = (char*)win32_malloc(5+len+1);
4730             if (!ansi_path)
4731                 break;
4732             memcpy(ansi_path, "PATH=", 5);
4733             memcpy(ansi_path+5, ansi_dir, len+1);
4734             len += 5;
4735         }
4736         win32_free(ansi_dir);
4737         wide_dir = sep;
4738     }
4739
4740     if (ansi_path) {
4741         /* Update C RTL environ array.  This will only have full effect if
4742          * perl_parse() is later called with `environ` as the `env` argument.
4743          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4744          *
4745          * We do have to ansify() the PATH before Perl has been fully
4746          * initialized because S_find_script() uses the PATH when perl
4747          * is being invoked with the -S option.  This happens before %ENV
4748          * is initialized in S_init_postdump_symbols().
4749          *
4750          * XXX Is this a bug? Should S_find_script() use the environment
4751          * XXX passed in the `env` arg to parse_perl()?
4752          */
4753         putenv(ansi_path);
4754         /* Keep system environment in sync because S_init_postdump_symbols()
4755          * will not call mg_set() if it initializes %ENV from `environ`.
4756          */
4757         SetEnvironmentVariableA("PATH", ansi_path+5);
4758         win32_free(ansi_path);
4759     }
4760     win32_free(wide_path);
4761 }
4762
4763 void
4764 Perl_win32_init(int *argcp, char ***argvp)
4765 {
4766 #ifdef SET_INVALID_PARAMETER_HANDLER
4767     _invalid_parameter_handler oldHandler, newHandler;
4768     newHandler = my_invalid_parameter_handler;
4769     oldHandler = _set_invalid_parameter_handler(newHandler);
4770     _CrtSetReportMode(_CRT_ASSERT, 0);
4771 #endif
4772     /* Disable floating point errors, Perl will trap the ones we
4773      * care about.  VC++ RTL defaults to switching these off
4774      * already, but some RTLs don't.  Since we don't
4775      * want to be at the vendor's whim on the default, we set
4776      * it explicitly here.
4777      */
4778 #if !defined(__GNUC__)
4779     _control87(MCW_EM, MCW_EM);
4780 #endif
4781     MALLOC_INIT;
4782
4783     /* When the manifest resource requests Common-Controls v6 then
4784      * user32.dll no longer registers all the Windows classes used for
4785      * standard controls but leaves some of them to be registered by
4786      * comctl32.dll.  InitCommonControls() doesn't do anything but calling
4787      * it makes sure comctl32.dll gets loaded into the process and registers
4788      * the standard control classes.  Without this even normal Windows APIs
4789      * like MessageBox() can fail under some versions of Windows XP.
4790      */
4791     InitCommonControls();
4792
4793     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4794     GetVersionEx(&g_osver);
4795
4796 #ifdef WIN32_DYN_IOINFO_SIZE
4797     {
4798         Size_t ioinfo_size = _msize((void*)__pioinfo[0]);;
4799         if((SSize_t)ioinfo_size <= 0) { /* -1 is err */
4800             fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */
4801             exit(1);
4802         }
4803         ioinfo_size /= IOINFO_ARRAY_ELTS;
4804         w32_ioinfo_size = ioinfo_size;
4805     }
4806 #endif
4807
4808     ansify_path();
4809
4810 #ifndef WIN32_NO_REGISTRY
4811     {
4812         LONG retval;
4813         retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd);
4814         if (retval != ERROR_SUCCESS) {
4815             HKCU_Perl_hnd = NULL;
4816         }
4817         retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd);
4818         if (retval != ERROR_SUCCESS) {
4819             HKLM_Perl_hnd = NULL;
4820         }
4821     }
4822 #endif
4823
4824     {
4825         FILETIME ft;
4826         if (!SystemTimeToFileTime(&time_t_epoch_base_systemtime,
4827                                   &ft)) {
4828             fprintf(stderr, "panic: cannot convert base system time to filetime\n"); /* no interp */
4829             exit(1);
4830         }
4831         time_t_epoch_base_filetime.LowPart  = ft.dwLowDateTime;
4832         time_t_epoch_base_filetime.HighPart = ft.dwHighDateTime;
4833     }
4834 }
4835
4836 void
4837 Perl_win32_term(void)
4838 {
4839     HINTS_REFCNT_TERM;
4840     OP_REFCNT_TERM;
4841     PERLIO_TERM;
4842     MALLOC_TERM;
4843     LOCALE_TERM;
4844     ENV_TERM;
4845 #ifndef WIN32_NO_REGISTRY
4846     /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE
4847        but no point of checking and we can't die() at this point */
4848     RegCloseKey(HKLM_Perl_hnd);
4849     RegCloseKey(HKCU_Perl_hnd);
4850     /* the handles are in an undefined state until the next PERL_SYS_INIT3 */
4851 #endif
4852 }
4853
4854 void
4855 win32_get_child_IO(child_IO_table* ptbl)
4856 {
4857     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4858     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4859     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4860 }
4861
4862 Sighandler_t
4863 win32_signal(int sig, Sighandler_t subcode)
4864 {
4865     dTHXa(NULL);
4866     if (sig < SIG_SIZE) {
4867         int save_errno = errno;
4868         Sighandler_t result;
4869 #ifdef SET_INVALID_PARAMETER_HANDLER
4870         /* Silence our invalid parameter handler since we expect to make some
4871          * calls with invalid signal numbers giving a SIG_ERR result. */
4872         BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE);
4873 #endif
4874         result = signal(sig, subcode);
4875 #ifdef SET_INVALID_PARAMETER_HANDLER
4876         set_silent_invalid_parameter_handler(oldvalue);
4877 #endif
4878         aTHXa(PERL_GET_THX);
4879         if (result == SIG_ERR) {
4880             result = w32_sighandler[sig];
4881             errno = save_errno;
4882         }
4883         w32_sighandler[sig] = subcode;
4884         return result;
4885     }
4886     else {
4887         errno = EINVAL;
4888         return SIG_ERR;
4889     }
4890 }
4891
4892 /* The PerlMessageWindowClass's WindowProc */
4893 LRESULT CALLBACK
4894 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4895 {
4896     return win32_process_message(hwnd, msg, wParam, lParam) ?
4897         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4898 }
4899
4900 /* The real message handler. Can be called with
4901  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4902  * that it processes */
4903 static LRESULT
4904 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4905 {
4906     /* BEWARE. The context retrieved using dTHX; is the context of the
4907      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4908      * up to and including WM_CREATE.  If it ever happens that you need the
4909      * 'child' context before this, then it needs to be passed into
4910      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4911      * from the lparam of CreateWindow().  It could then be stored/retrieved
4912     &