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