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