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