win32/win32.c

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