win32/win32.c

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