win32/win32.c

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