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