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