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     DWORD last_err;
1697
1698     needlen = GetEnvironmentVariableA(name,NULL,0);
1699     if (needlen != 0) {
1700         curitem = sv_2mortal(newSVpvn("", 0));
1701         do {
1702             SvGROW(curitem, needlen+1);
1703             needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1704                                               needlen);
1705         } while (needlen >= SvLEN(curitem));
1706         SvCUR_set(curitem, needlen);
1707     }
1708     else {
1709         last_err = GetLastError();
1710         if (last_err == ERROR_NOT_ENOUGH_MEMORY) {
1711             /* It appears the variable is in the env, but the Win32 API
1712                doesn't have a canned way of getting it.  So we fall back to
1713                grabbing the whole env and pulling this value out if possible */
1714             char *envv = GetEnvironmentStrings();
1715             char *cur = envv;
1716             STRLEN len;
1717             while (*cur) {
1718                 char *end = strchr(cur,'=');
1719                 if (end && end != cur) {
1720                     *end = '\0';
1721                     if (!strcmp(cur,name)) {
1722                         curitem = sv_2mortal(newSVpv(end+1,0));
1723                         *end = '=';
1724                         break;
1725                     }
1726                     *end = '=';
1727                     cur = end + strlen(end+1)+2;
1728                 }
1729                 else if ((len = strlen(cur)))
1730                     cur += len+1;
1731             }
1732             FreeEnvironmentStrings(envv);
1733         }
1734         else {
1735             /* last ditch: allow any environment variables that begin with 'PERL'
1736                to be obtained from the registry, if found there */
1737             if (strncmp(name, "PERL", 4) == 0)
1738                 (void)get_regstr(name, &curitem);
1739         }
1740     }
1741     if (curitem && SvCUR(curitem))
1742         return SvPVX(curitem);
1743
1744     return NULL;
1745 }
1746
1747 DllExport int
1748 win32_putenv(const char *name)
1749 {
1750     dTHX;
1751     char* curitem;
1752     char* val;
1753     int relval = -1;
1754
1755     if (name) {
1756         Newx(curitem,strlen(name)+1,char);
1757         strcpy(curitem, name);
1758         val = strchr(curitem, '=');
1759         if (val) {
1760             /* The sane way to deal with the environment.
1761              * Has these advantages over putenv() & co.:
1762              *  * enables us to store a truly empty value in the
1763              *    environment (like in UNIX).
1764              *  * we don't have to deal with RTL globals, bugs and leaks
1765              *    (specifically, see http://support.microsoft.com/kb/235601).
1766              *  * Much faster.
1767              * Why you may want to use the RTL environment handling
1768              * (previously enabled by USE_WIN32_RTL_ENV):
1769              *  * environ[] and RTL functions will not reflect changes,
1770              *    which might be an issue if extensions want to access
1771              *    the env. via RTL.  This cuts both ways, since RTL will
1772              *    not see changes made by extensions that call the Win32
1773              *    functions directly, either.
1774              * GSAR 97-06-07
1775              */
1776             *val++ = '\0';
1777             if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1778                 relval = 0;
1779         }
1780         Safefree(curitem);
1781     }
1782     return relval;
1783 }
1784
1785 static long
1786 filetime_to_clock(PFILETIME ft)
1787 {
1788     __int64 qw = ft->dwHighDateTime;
1789     qw <<= 32;
1790     qw |= ft->dwLowDateTime;
1791     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1792     return (long) qw;
1793 }
1794
1795 DllExport int
1796 win32_times(struct tms *timebuf)
1797 {
1798     FILETIME user;
1799     FILETIME kernel;
1800     FILETIME dummy;
1801     clock_t process_time_so_far = clock();
1802     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1803                         &kernel,&user)) {
1804         timebuf->tms_utime = filetime_to_clock(&user);
1805         timebuf->tms_stime = filetime_to_clock(&kernel);
1806         timebuf->tms_cutime = 0;
1807         timebuf->tms_cstime = 0;
1808     } else {
1809         /* That failed - e.g. Win95 fallback to clock() */
1810         timebuf->tms_utime = process_time_so_far;
1811         timebuf->tms_stime = 0;
1812         timebuf->tms_cutime = 0;
1813         timebuf->tms_cstime = 0;
1814     }
1815     return process_time_so_far;
1816 }
1817
1818 /* fix utime() so it works on directories in NT */
1819 static BOOL
1820 filetime_from_time(PFILETIME pFileTime, time_t Time)
1821 {
1822     struct tm *pTM = localtime(&Time);
1823     SYSTEMTIME SystemTime;
1824     FILETIME LocalTime;
1825
1826     if (pTM == NULL)
1827         return FALSE;
1828
1829     SystemTime.wYear   = pTM->tm_year + 1900;
1830     SystemTime.wMonth  = pTM->tm_mon + 1;
1831     SystemTime.wDay    = pTM->tm_mday;
1832     SystemTime.wHour   = pTM->tm_hour;
1833     SystemTime.wMinute = pTM->tm_min;
1834     SystemTime.wSecond = pTM->tm_sec;
1835     SystemTime.wMilliseconds = 0;
1836
1837     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1838            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1839 }
1840
1841 DllExport int
1842 win32_unlink(const char *filename)
1843 {
1844     dTHX;
1845     int ret;
1846     DWORD attrs;
1847
1848     filename = PerlDir_mapA(filename);
1849     attrs = GetFileAttributesA(filename);
1850     if (attrs == 0xFFFFFFFF) {
1851         errno = ENOENT;
1852         return -1;
1853     }
1854     if (attrs & FILE_ATTRIBUTE_READONLY) {
1855         (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1856         ret = unlink(filename);
1857         if (ret == -1)
1858             (void)SetFileAttributesA(filename, attrs);
1859     }
1860     else
1861         ret = unlink(filename);
1862     return ret;
1863 }
1864
1865 DllExport int
1866 win32_utime(const char *filename, struct utimbuf *times)
1867 {
1868     dTHX;
1869     HANDLE handle;
1870     FILETIME ftCreate;
1871     FILETIME ftAccess;
1872     FILETIME ftWrite;
1873     struct utimbuf TimeBuffer;
1874     int rc;
1875
1876     filename = PerlDir_mapA(filename);
1877     rc = utime(filename, times);
1878
1879     /* EACCES: path specifies directory or readonly file */
1880     if (rc == 0 || errno != EACCES)
1881         return rc;
1882
1883     if (times == NULL) {
1884         times = &TimeBuffer;
1885         time(&times->actime);
1886         times->modtime = times->actime;
1887     }
1888
1889     /* This will (and should) still fail on readonly files */
1890     handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1891                          FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1892                          OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1893     if (handle == INVALID_HANDLE_VALUE)
1894         return rc;
1895
1896     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1897         filetime_from_time(&ftAccess, times->actime) &&
1898         filetime_from_time(&ftWrite, times->modtime) &&
1899         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1900     {
1901         rc = 0;
1902     }
1903
1904     CloseHandle(handle);
1905     return rc;
1906 }
1907
1908 typedef union {
1909     unsigned __int64    ft_i64;
1910     FILETIME            ft_val;
1911 } FT_t;
1912
1913 #ifdef __GNUC__
1914 #define Const64(x) x##LL
1915 #else
1916 #define Const64(x) x##i64
1917 #endif
1918 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1919 #define EPOCH_BIAS  Const64(116444736000000000)
1920
1921 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1922  * and appears to be unsupported even by glibc) */
1923 DllExport int
1924 win32_gettimeofday(struct timeval *tp, void *not_used)
1925 {
1926     FT_t ft;
1927
1928     /* this returns time in 100-nanosecond units  (i.e. tens of usecs) */
1929     GetSystemTimeAsFileTime(&ft.ft_val);
1930
1931     /* seconds since epoch */
1932     tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1933
1934     /* microseconds remaining */
1935     tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1936
1937     return 0;
1938 }
1939
1940 DllExport int
1941 win32_uname(struct utsname *name)
1942 {
1943     struct hostent *hep;
1944     STRLEN nodemax = sizeof(name->nodename)-1;
1945
1946     /* sysname */
1947     switch (g_osver.dwPlatformId) {
1948     case VER_PLATFORM_WIN32_WINDOWS:
1949         strcpy(name->sysname, "Windows");
1950         break;
1951     case VER_PLATFORM_WIN32_NT:
1952         strcpy(name->sysname, "Windows NT");
1953         break;
1954     case VER_PLATFORM_WIN32s:
1955         strcpy(name->sysname, "Win32s");
1956         break;
1957     default:
1958         strcpy(name->sysname, "Win32 Unknown");
1959         break;
1960     }
1961
1962     /* release */
1963     sprintf(name->release, "%d.%d",
1964             g_osver.dwMajorVersion, g_osver.dwMinorVersion);
1965
1966     /* version */
1967     sprintf(name->version, "Build %d",
1968             g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1969             ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff));
1970     if (g_osver.szCSDVersion[0]) {
1971         char *buf = name->version + strlen(name->version);
1972         sprintf(buf, " (%s)", g_osver.szCSDVersion);
1973     }
1974
1975     /* nodename */
1976     hep = win32_gethostbyname("localhost");
1977     if (hep) {
1978         STRLEN len = strlen(hep->h_name);
1979         if (len <= nodemax) {
1980             strcpy(name->nodename, hep->h_name);
1981         }
1982         else {
1983             strncpy(name->nodename, hep->h_name, nodemax);
1984             name->nodename[nodemax] = '\0';
1985         }
1986     }
1987     else {
1988         DWORD sz = nodemax;
1989         if (!GetComputerName(name->nodename, &sz))
1990             *name->nodename = '\0';
1991     }
1992
1993     /* machine (architecture) */
1994     {
1995         SYSTEM_INFO info;
1996         DWORD procarch;
1997         char *arch;
1998         GetSystemInfo(&info);
1999
2000 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
2001  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION))
2002         procarch = info.u.s.wProcessorArchitecture;
2003 #else
2004         procarch = info.wProcessorArchitecture;
2005 #endif
2006         switch (procarch) {
2007         case PROCESSOR_ARCHITECTURE_INTEL:
2008             arch = "x86"; break;
2009         case PROCESSOR_ARCHITECTURE_IA64:
2010             arch = "ia64"; break;
2011         case PROCESSOR_ARCHITECTURE_AMD64:
2012             arch = "amd64"; break;
2013         case PROCESSOR_ARCHITECTURE_UNKNOWN:
2014             arch = "unknown"; break;
2015         default:
2016             sprintf(name->machine, "unknown(0x%x)", procarch);
2017             arch = name->machine;
2018             break;
2019         }
2020         if (name->machine != arch)
2021             strcpy(name->machine, arch);
2022     }
2023     return 0;
2024 }
2025
2026 /* Timing related stuff */
2027
2028 int
2029 do_raise(pTHX_ int sig)
2030 {
2031     if (sig < SIG_SIZE) {
2032         Sighandler_t handler = w32_sighandler[sig];
2033         if (handler == SIG_IGN) {
2034             return 0;
2035         }
2036         else if (handler != SIG_DFL) {
2037             (*handler)(sig);
2038             return 0;
2039         }
2040         else {
2041             /* Choose correct default behaviour */
2042             switch (sig) {
2043 #ifdef SIGCLD
2044                 case SIGCLD:
2045 #endif
2046 #ifdef SIGCHLD
2047                 case SIGCHLD:
2048 #endif
2049                 case 0:
2050                     return 0;
2051                 case SIGTERM:
2052                 default:
2053                     break;
2054             }
2055         }
2056     }
2057     /* Tell caller to exit thread/process as approriate */
2058     return 1;
2059 }
2060
2061 void
2062 sig_terminate(pTHX_ int sig)
2063 {
2064     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
2065     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
2066        thread
2067      */
2068     exit(sig);
2069 }
2070
2071 DllExport int
2072 win32_async_check(pTHX)
2073 {
2074     MSG msg;
2075     HWND hwnd = w32_message_hwnd;
2076
2077     /* Reset w32_poll_count before doing anything else, incase we dispatch
2078      * messages that end up calling back into perl */
2079     w32_poll_count = 0;
2080
2081     if (hwnd != INVALID_HANDLE_VALUE) {
2082         /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages
2083         * and ignores window messages - should co-exist better with windows apps e.g. Tk
2084         */
2085         if (hwnd == NULL)
2086             hwnd = (HWND)-1;
2087
2088         while (PeekMessage(&msg, hwnd, WM_TIMER,    WM_TIMER,    PM_REMOVE|PM_NOYIELD) ||
2089                PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD))
2090         {
2091             /* re-post a WM_QUIT message (we'll mark it as read later) */
2092             if(msg.message == WM_QUIT) {
2093                 PostQuitMessage((int)msg.wParam);
2094                 break;
2095             }
2096
2097             if(!CallMsgFilter(&msg, MSGF_USER))
2098             {
2099                 TranslateMessage(&msg);
2100                 DispatchMessage(&msg);
2101             }
2102         }
2103     }
2104
2105     /* Call PeekMessage() to mark all pending messages in the queue as "old".
2106      * This is necessary when we are being called by win32_msgwait() to
2107      * make sure MsgWaitForMultipleObjects() stops reporting the same waiting
2108      * message over and over.  An example how this can happen is when
2109      * Perl is calling win32_waitpid() inside a GUI application and the GUI
2110      * is generating messages before the process terminated.
2111      */
2112     PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD);
2113
2114     /* Above or other stuff may have set a signal flag */
2115     if (PL_sig_pending)
2116         despatch_signals();
2117
2118     return 1;
2119 }
2120
2121 /* This function will not return until the timeout has elapsed, or until
2122  * one of the handles is ready. */
2123 DllExport DWORD
2124 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
2125 {
2126     /* We may need several goes at this - so compute when we stop */
2127     DWORD ticks = 0;
2128     if (timeout != INFINITE) {
2129         ticks = GetTickCount();
2130         timeout += ticks;
2131     }
2132     while (1) {
2133         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE);
2134         if (resultp)
2135            *resultp = result;
2136         if (result == WAIT_TIMEOUT) {
2137             /* Ran out of time - explicit return of zero to avoid -ve if we
2138                have scheduling issues
2139              */
2140             return 0;
2141         }
2142         if (timeout != INFINITE) {
2143             ticks = GetTickCount();
2144         }
2145         if (result == WAIT_OBJECT_0 + count) {
2146             /* Message has arrived - check it */
2147             (void)win32_async_check(aTHX);
2148         }
2149         else {
2150            /* Not timeout or message - one of handles is ready */
2151            break;
2152         }
2153     }
2154     /* compute time left to wait */
2155     ticks = timeout - ticks;
2156     /* If we are past the end say zero */
2157     return (ticks > 0) ? ticks : 0;
2158 }
2159
2160 int
2161 win32_internal_wait(int *status, DWORD timeout)
2162 {
2163     /* XXX this wait emulation only knows about processes
2164      * spawned via win32_spawnvp(P_NOWAIT, ...).
2165      */
2166     dTHX;
2167     int i, retval;
2168     DWORD exitcode, waitcode;
2169
2170 #ifdef USE_ITHREADS
2171     if (w32_num_pseudo_children) {
2172         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2173                       timeout, &waitcode);
2174         /* Time out here if there are no other children to wait for. */
2175         if (waitcode == WAIT_TIMEOUT) {
2176             if (!w32_num_children) {
2177                 return 0;
2178             }
2179         }
2180         else if (waitcode != WAIT_FAILED) {
2181             if (waitcode >= WAIT_ABANDONED_0
2182                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2183                 i = waitcode - WAIT_ABANDONED_0;
2184             else
2185                 i = waitcode - WAIT_OBJECT_0;
2186             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2187                 *status = (int)((exitcode & 0xff) << 8);
2188                 retval = (int)w32_pseudo_child_pids[i];
2189                 remove_dead_pseudo_process(i);
2190                 return -retval;
2191             }
2192         }
2193     }
2194 #endif
2195
2196     if (!w32_num_children) {
2197         errno = ECHILD;
2198         return -1;
2199     }
2200
2201     /* if a child exists, wait for it to die */
2202     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2203     if (waitcode == WAIT_TIMEOUT) {
2204         return 0;
2205     }
2206     if (waitcode != WAIT_FAILED) {
2207         if (waitcode >= WAIT_ABANDONED_0
2208             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2209             i = waitcode - WAIT_ABANDONED_0;
2210         else
2211             i = waitcode - WAIT_OBJECT_0;
2212         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2213             *status = (int)((exitcode & 0xff) << 8);
2214             retval = (int)w32_child_pids[i];
2215             remove_dead_process(i);
2216             return retval;
2217         }
2218     }
2219
2220     errno = GetLastError();
2221     return -1;
2222 }
2223
2224 DllExport int
2225 win32_waitpid(int pid, int *status, int flags)
2226 {
2227     dTHX;
2228     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2229     int retval = -1;
2230     long child;
2231     if (pid == -1)                              /* XXX threadid == 1 ? */
2232         return win32_internal_wait(status, timeout);
2233 #ifdef USE_ITHREADS
2234     else if (pid < 0) {
2235         child = find_pseudo_pid(-pid);
2236         if (child >= 0) {
2237             HANDLE hThread = w32_pseudo_child_handles[child];
2238             DWORD waitcode;
2239             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2240             if (waitcode == WAIT_TIMEOUT) {
2241                 return 0;
2242             }
2243             else if (waitcode == WAIT_OBJECT_0) {
2244                 if (GetExitCodeThread(hThread, &waitcode)) {
2245                     *status = (int)((waitcode & 0xff) << 8);
2246                     retval = (int)w32_pseudo_child_pids[child];
2247                     remove_dead_pseudo_process(child);
2248                     return -retval;
2249                 }
2250             }
2251             else
2252                 errno = ECHILD;
2253         }
2254     }
2255 #endif
2256     else {
2257         HANDLE hProcess;
2258         DWORD waitcode;
2259         child = find_pid(pid);
2260         if (child >= 0) {
2261             hProcess = w32_child_handles[child];
2262             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2263             if (waitcode == WAIT_TIMEOUT) {
2264                 return 0;
2265             }
2266             else if (waitcode == WAIT_OBJECT_0) {
2267                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2268                     *status = (int)((waitcode & 0xff) << 8);
2269                     retval = (int)w32_child_pids[child];
2270                     remove_dead_process(child);
2271                     return retval;
2272                 }
2273             }
2274             else
2275                 errno = ECHILD;
2276         }
2277         else {
2278             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
2279             if (hProcess) {
2280                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2281                 if (waitcode == WAIT_TIMEOUT) {
2282                     CloseHandle(hProcess);
2283                     return 0;
2284                 }
2285                 else if (waitcode == WAIT_OBJECT_0) {
2286                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2287                         *status = (int)((waitcode & 0xff) << 8);
2288                         CloseHandle(hProcess);
2289                         return pid;
2290                     }
2291                 }
2292                 CloseHandle(hProcess);
2293             }
2294             else
2295                 errno = ECHILD;
2296         }
2297     }
2298     return retval >= 0 ? pid : retval;
2299 }
2300
2301 DllExport int
2302 win32_wait(int *status)
2303 {
2304     return win32_internal_wait(status, INFINITE);
2305 }
2306
2307 DllExport unsigned int
2308 win32_sleep(unsigned int t)
2309 {
2310     dTHX;
2311     /* Win32 times are in ms so *1000 in and /1000 out */
2312     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2313 }
2314
2315 DllExport unsigned int
2316 win32_alarm(unsigned int sec)
2317 {
2318     /*
2319      * the 'obvious' implentation is SetTimer() with a callback
2320      * which does whatever receiving SIGALRM would do
2321      * we cannot use SIGALRM even via raise() as it is not
2322      * one of the supported codes in <signal.h>
2323      */
2324     dTHX;
2325
2326     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
2327         w32_message_hwnd = win32_create_message_window();
2328
2329     if (sec) {
2330         if (w32_message_hwnd == NULL)
2331             w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL);
2332         else {
2333             w32_timerid = 1;
2334             SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL);
2335         }
2336     }
2337     else {
2338         if (w32_timerid) {
2339             KillTimer(w32_message_hwnd, w32_timerid);
2340             w32_timerid = 0;
2341         }
2342     }
2343     return 0;
2344 }
2345
2346 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2347
2348 DllExport char *
2349 win32_crypt(const char *txt, const char *salt)
2350 {
2351     dTHX;
2352     return des_fcrypt(txt, salt, w32_crypt_buffer);
2353 }
2354
2355 /* simulate flock by locking a range on the file */
2356
2357 #define LK_LEN          0xffff0000
2358
2359 DllExport int
2360 win32_flock(int fd, int oper)
2361 {
2362     OVERLAPPED o;
2363     int i = -1;
2364     HANDLE fh;
2365
2366     fh = (HANDLE)_get_osfhandle(fd);
2367     if (fh == (HANDLE)-1)  /* _get_osfhandle() already sets errno to EBADF */
2368         return -1;
2369
2370     memset(&o, 0, sizeof(o));
2371
2372     switch(oper) {
2373     case LOCK_SH:               /* shared lock */
2374         if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o))
2375             i = 0;
2376         break;
2377     case LOCK_EX:               /* exclusive lock */
2378         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o))
2379             i = 0;
2380         break;
2381     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2382         if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o))
2383             i = 0;
2384         break;
2385     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2386         if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2387                        0, LK_LEN, 0, &o))
2388             i = 0;
2389         break;
2390     case LOCK_UN:               /* unlock lock */
2391         if (UnlockFileEx(fh, 0, LK_LEN, 0, &o))
2392             i = 0;
2393         break;
2394     default:                    /* unknown */
2395         errno = EINVAL;
2396         return -1;
2397     }
2398     if (i == -1) {
2399         if (GetLastError() == ERROR_LOCK_VIOLATION)
2400             errno = WSAEWOULDBLOCK;
2401         else
2402             errno = EINVAL;
2403     }
2404     return i;
2405 }
2406
2407 #undef LK_LEN
2408
2409 /*
2410  *  redirected io subsystem for all XS modules
2411  *
2412  */
2413
2414 DllExport int *
2415 win32_errno(void)
2416 {
2417     return (&errno);
2418 }
2419
2420 DllExport char ***
2421 win32_environ(void)
2422 {
2423     return (&(_environ));
2424 }
2425
2426 /* the rest are the remapped stdio routines */
2427 DllExport FILE *
2428 win32_stderr(void)
2429 {
2430     return (stderr);
2431 }
2432
2433 DllExport FILE *
2434 win32_stdin(void)
2435 {
2436     return (stdin);
2437 }
2438
2439 DllExport FILE *
2440 win32_stdout(void)
2441 {
2442     return (stdout);
2443 }
2444
2445 DllExport int
2446 win32_ferror(FILE *fp)
2447 {
2448     return (ferror(fp));
2449 }
2450
2451
2452 DllExport int
2453 win32_feof(FILE *fp)
2454 {
2455     return (feof(fp));
2456 }
2457
2458 /*
2459  * Since the errors returned by the socket error function
2460  * WSAGetLastError() are not known by the library routine strerror
2461  * we have to roll our own.
2462  */
2463
2464 DllExport char *
2465 win32_strerror(int e)
2466 {
2467 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2468     extern int sys_nerr;
2469 #endif
2470
2471     if (e < 0 || e > sys_nerr) {
2472         dTHX;
2473         if (e < 0)
2474             e = GetLastError();
2475
2476         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
2477                          |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0,
2478                           w32_strerror_buffer, sizeof(w32_strerror_buffer),
2479                           NULL) == 0)
2480         {
2481             strcpy(w32_strerror_buffer, "Unknown Error");
2482         }
2483         return w32_strerror_buffer;
2484     }
2485 #undef strerror
2486     return strerror(e);
2487 #define strerror win32_strerror
2488 }
2489
2490 DllExport void
2491 win32_str_os_error(void *sv, DWORD dwErr)
2492 {
2493     DWORD dwLen;
2494     char *sMsg;
2495     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2496                           |FORMAT_MESSAGE_IGNORE_INSERTS
2497                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2498                            dwErr, 0, (char *)&sMsg, 1, NULL);
2499     /* strip trailing whitespace and period */
2500     if (0 < dwLen) {
2501         do {
2502             --dwLen;    /* dwLen doesn't include trailing null */
2503         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2504         if ('.' != sMsg[dwLen])
2505             dwLen++;
2506         sMsg[dwLen] = '\0';
2507     }
2508     if (0 == dwLen) {
2509         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2510         if (sMsg)
2511             dwLen = sprintf(sMsg,
2512                             "Unknown error #0x%lX (lookup 0x%lX)",
2513                             dwErr, GetLastError());
2514     }
2515     if (sMsg) {
2516         dTHX;
2517         sv_setpvn((SV*)sv, sMsg, dwLen);
2518         LocalFree(sMsg);
2519     }
2520 }
2521
2522 DllExport int
2523 win32_fprintf(FILE *fp, const char *format, ...)
2524 {
2525     va_list marker;
2526     va_start(marker, format);     /* Initialize variable arguments. */
2527
2528     return (vfprintf(fp, format, marker));
2529 }
2530
2531 DllExport int
2532 win32_printf(const char *format, ...)
2533 {
2534     va_list marker;
2535     va_start(marker, format);     /* Initialize variable arguments. */
2536
2537     return (vprintf(format, marker));
2538 }
2539
2540 DllExport int
2541 win32_vfprintf(FILE *fp, const char *format, va_list args)
2542 {
2543     return (vfprintf(fp, format, args));
2544 }
2545
2546 DllExport int
2547 win32_vprintf(const char *format, va_list args)
2548 {
2549     return (vprintf(format, args));
2550 }
2551
2552 DllExport size_t
2553 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2554 {
2555     return fread(buf, size, count, fp);
2556 }
2557
2558 DllExport size_t
2559 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2560 {
2561     return fwrite(buf, size, count, fp);
2562 }
2563
2564 #define MODE_SIZE 10
2565
2566 DllExport FILE *
2567 win32_fopen(const char *filename, const char *mode)
2568 {
2569     dTHX;
2570     FILE *f;
2571
2572     if (!*filename)
2573         return NULL;
2574
2575     if (stricmp(filename, "/dev/null")==0)
2576         filename = "NUL";
2577
2578     f = fopen(PerlDir_mapA(filename), mode);
2579     /* avoid buffering headaches for child processes */
2580     if (f && *mode == 'a')
2581         win32_fseek(f, 0, SEEK_END);
2582     return f;
2583 }
2584
2585 #ifndef USE_SOCKETS_AS_HANDLES
2586 #undef fdopen
2587 #define fdopen my_fdopen
2588 #endif
2589
2590 DllExport FILE *
2591 win32_fdopen(int handle, const char *mode)
2592 {
2593     dTHX;
2594     FILE *f;
2595     f = fdopen(handle, (char *) mode);
2596     /* avoid buffering headaches for child processes */
2597     if (f && *mode == 'a')
2598         win32_fseek(f, 0, SEEK_END);
2599     return f;
2600 }
2601
2602 DllExport FILE *
2603 win32_freopen(const char *path, const char *mode, FILE *stream)
2604 {
2605     dTHX;
2606     if (stricmp(path, "/dev/null")==0)
2607         path = "NUL";
2608
2609     return freopen(PerlDir_mapA(path), mode, stream);
2610 }
2611
2612 DllExport int
2613 win32_fclose(FILE *pf)
2614 {
2615     return my_fclose(pf);       /* defined in win32sck.c */
2616 }
2617
2618 DllExport int
2619 win32_fputs(const char *s,FILE *pf)
2620 {
2621     return fputs(s, pf);
2622 }
2623
2624 DllExport int
2625 win32_fputc(int c,FILE *pf)
2626 {
2627     return fputc(c,pf);
2628 }
2629
2630 DllExport int
2631 win32_ungetc(int c,FILE *pf)
2632 {
2633     return ungetc(c,pf);
2634 }
2635
2636 DllExport int
2637 win32_getc(FILE *pf)
2638 {
2639     return getc(pf);
2640 }
2641
2642 DllExport int
2643 win32_fileno(FILE *pf)
2644 {
2645     return fileno(pf);
2646 }
2647
2648 DllExport void
2649 win32_clearerr(FILE *pf)
2650 {
2651     clearerr(pf);
2652     return;
2653 }
2654
2655 DllExport int
2656 win32_fflush(FILE *pf)
2657 {
2658     return fflush(pf);
2659 }
2660
2661 DllExport Off_t
2662 win32_ftell(FILE *pf)
2663 {
2664 #if defined(WIN64) || defined(USE_LARGE_FILES)
2665 #if defined(__BORLANDC__) /* buk */
2666     return win32_tell( fileno( pf ) );
2667 #else
2668     fpos_t pos;
2669     if (fgetpos(pf, &pos))
2670         return -1;
2671     return (Off_t)pos;
2672 #endif
2673 #else
2674     return ftell(pf);
2675 #endif
2676 }
2677
2678 DllExport int
2679 win32_fseek(FILE *pf, Off_t offset,int origin)
2680 {
2681 #if defined(WIN64) || defined(USE_LARGE_FILES)
2682 #if defined(__BORLANDC__) /* buk */
2683     return win32_lseek(
2684         fileno(pf),
2685         offset,
2686         origin
2687         );
2688 #else
2689     fpos_t pos;
2690     switch (origin) {
2691     case SEEK_CUR:
2692         if (fgetpos(pf, &pos))
2693             return -1;
2694         offset += pos;
2695         break;
2696     case SEEK_END:
2697         fseek(pf, 0, SEEK_END);
2698         pos = _telli64(fileno(pf));
2699         offset += pos;
2700         break;
2701     case SEEK_SET:
2702         break;
2703     default:
2704         errno = EINVAL;
2705         return -1;
2706     }
2707     return fsetpos(pf, &offset);
2708 #endif
2709 #else
2710     return fseek(pf, (long)offset, origin);
2711 #endif
2712 }
2713
2714 DllExport int
2715 win32_fgetpos(FILE *pf,fpos_t *p)
2716 {
2717 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2718     if( win32_tell(fileno(pf)) == -1L ) {
2719         errno = EBADF;
2720         return -1;
2721     }
2722     return 0;
2723 #else
2724     return fgetpos(pf, p);
2725 #endif
2726 }
2727
2728 DllExport int
2729 win32_fsetpos(FILE *pf,const fpos_t *p)
2730 {
2731 #if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2732     return win32_lseek(fileno(pf), *p, SEEK_CUR);
2733 #else
2734     return fsetpos(pf, p);
2735 #endif
2736 }
2737
2738 DllExport void
2739 win32_rewind(FILE *pf)
2740 {
2741     rewind(pf);
2742     return;
2743 }
2744
2745 DllExport int
2746 win32_tmpfd(void)
2747 {
2748     dTHX;
2749     char prefix[MAX_PATH+1];
2750     char filename[MAX_PATH+1];
2751     DWORD len = GetTempPath(MAX_PATH, prefix);
2752     if (len && len < MAX_PATH) {
2753         if (GetTempFileName(prefix, "plx", 0, filename)) {
2754             HANDLE fh = CreateFile(filename,
2755                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2756                                    0,
2757                                    NULL,
2758                                    CREATE_ALWAYS,
2759                                    FILE_ATTRIBUTE_NORMAL
2760                                    | FILE_FLAG_DELETE_ON_CLOSE,
2761                                    NULL);
2762             if (fh != INVALID_HANDLE_VALUE) {
2763                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2764                 if (fd >= 0) {
2765 #if defined(__BORLANDC__)
2766                     setmode(fd,O_BINARY);
2767 #endif
2768                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2769                                           "Created tmpfile=%s\n",filename));
2770                     return fd;
2771                 }
2772             }
2773         }
2774     }
2775     return -1;
2776 }
2777
2778 DllExport FILE*
2779 win32_tmpfile(void)
2780 {
2781     int fd = win32_tmpfd();
2782     if (fd >= 0)
2783         return win32_fdopen(fd, "w+b");
2784     return NULL;
2785 }
2786
2787 DllExport void
2788 win32_abort(void)
2789 {
2790     abort();
2791     return;
2792 }
2793
2794 DllExport int
2795 win32_fstat(int fd, Stat_t *sbufptr)
2796 {
2797 #ifdef __BORLANDC__
2798     /* A file designated by filehandle is not shown as accessible
2799      * for write operations, probably because it is opened for reading.
2800      * --Vadim Konovalov
2801      */
2802     BY_HANDLE_FILE_INFORMATION bhfi;
2803 #  if defined(WIN64) || defined(USE_LARGE_FILES)
2804     /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2805     struct stat tmp;
2806     int rc = fstat(fd,&tmp);
2807
2808     sbufptr->st_dev   = tmp.st_dev;
2809     sbufptr->st_ino   = tmp.st_ino;
2810     sbufptr->st_mode  = tmp.st_mode;
2811     sbufptr->st_nlink = tmp.st_nlink;
2812     sbufptr->st_uid   = tmp.st_uid;
2813     sbufptr->st_gid   = tmp.st_gid;
2814     sbufptr->st_rdev  = tmp.st_rdev;
2815     sbufptr->st_size  = tmp.st_size;
2816     sbufptr->st_atime = tmp.st_atime;
2817     sbufptr->st_mtime = tmp.st_mtime;
2818     sbufptr->st_ctime = tmp.st_ctime;
2819 #  else
2820     int rc = fstat(fd,sbufptr);
2821 #  endif
2822
2823     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2824 #  if defined(WIN64) || defined(USE_LARGE_FILES)
2825         sbufptr->st_size = ((__int64)bhfi.nFileSizeHigh << 32) | bhfi.nFileSizeLow ;
2826 #  endif
2827         sbufptr->st_mode &= 0xFE00;
2828         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2829             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2830         else
2831             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2832               + ((S_IREAD|S_IWRITE) >> 6));
2833     }
2834     return rc;
2835 #else
2836 #  if defined(WIN64) || defined(USE_LARGE_FILES)
2837     return _fstati64(fd, sbufptr);
2838 #  else
2839     return fstat(fd, sbufptr);
2840 #  endif
2841 #endif
2842 }
2843
2844 DllExport int
2845 win32_pipe(int *pfd, unsigned int size, int mode)
2846 {
2847     return _pipe(pfd, size, mode);
2848 }
2849
2850 DllExport PerlIO*
2851 win32_popenlist(const char *mode, IV narg, SV **args)
2852 {
2853  dTHX;
2854  Perl_croak(aTHX_ "List form of pipe open not implemented");
2855  return NULL;
2856 }
2857
2858 /*
2859  * a popen() clone that respects PERL5SHELL
2860  *
2861  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2862  */
2863
2864 DllExport PerlIO*
2865 win32_popen(const char *command, const char *mode)
2866 {
2867 #ifdef USE_RTL_POPEN
2868     return _popen(command, mode);
2869 #else
2870     dTHX;
2871     int p[2];
2872     int parent, child;
2873     int stdfd, oldfd;
2874     int ourmode;
2875     int childpid;
2876     DWORD nhandle;
2877     HANDLE old_h;
2878     int lock_held = 0;
2879
2880     /* establish which ends read and write */
2881     if (strchr(mode,'w')) {
2882         stdfd = 0;              /* stdin */
2883         parent = 1;
2884         child = 0;
2885         nhandle = STD_INPUT_HANDLE;
2886     }
2887     else if (strchr(mode,'r')) {
2888         stdfd = 1;              /* stdout */
2889         parent = 0;
2890         child = 1;
2891         nhandle = STD_OUTPUT_HANDLE;
2892     }
2893     else
2894         return NULL;
2895
2896     /* set the correct mode */
2897     if (strchr(mode,'b'))
2898         ourmode = O_BINARY;
2899     else if (strchr(mode,'t'))
2900         ourmode = O_TEXT;
2901     else
2902         ourmode = _fmode & (O_TEXT | O_BINARY);
2903
2904     /* the child doesn't inherit handles */
2905     ourmode |= O_NOINHERIT;
2906
2907     if (win32_pipe(p, 512, ourmode) == -1)
2908         return NULL;
2909
2910     /* save the old std handle (this needs to happen before the
2911      * dup2(), since that might call SetStdHandle() too) */
2912     OP_REFCNT_LOCK;
2913     lock_held = 1;
2914     old_h = GetStdHandle(nhandle);
2915
2916     /* save current stdfd */
2917     if ((oldfd = win32_dup(stdfd)) == -1)
2918         goto cleanup;
2919
2920     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2921     /* stdfd will be inherited by the child */
2922     if (win32_dup2(p[child], stdfd) == -1)
2923         goto cleanup;
2924
2925     /* close the child end in parent */
2926     win32_close(p[child]);
2927
2928     /* set the new std handle (in case dup2() above didn't) */
2929     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2930
2931     /* start the child */
2932     {
2933         dTHX;
2934         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2935             goto cleanup;
2936
2937         /* revert stdfd to whatever it was before */
2938         if (win32_dup2(oldfd, stdfd) == -1)
2939             goto cleanup;
2940
2941         /* close saved handle */
2942         win32_close(oldfd);
2943
2944         /* restore the old std handle (this needs to happen after the
2945          * dup2(), since that might call SetStdHandle() too */
2946         if (lock_held) {
2947             SetStdHandle(nhandle, old_h);
2948             OP_REFCNT_UNLOCK;
2949             lock_held = 0;
2950         }
2951
2952         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2953
2954         /* set process id so that it can be returned by perl's open() */
2955         PL_forkprocess = childpid;
2956     }
2957
2958     /* we have an fd, return a file stream */
2959     return (PerlIO_fdopen(p[parent], (char *)mode));
2960
2961 cleanup:
2962     /* we don't need to check for errors here */
2963     win32_close(p[0]);
2964     win32_close(p[1]);
2965     if (oldfd != -1) {
2966         win32_dup2(oldfd, stdfd);
2967         win32_close(oldfd);
2968     }
2969     if (lock_held) {
2970         SetStdHandle(nhandle, old_h);
2971         OP_REFCNT_UNLOCK;
2972         lock_held = 0;
2973     }
2974     return (NULL);
2975
2976 #endif /* USE_RTL_POPEN */
2977 }
2978
2979 /*
2980  * pclose() clone
2981  */
2982
2983 DllExport int
2984 win32_pclose(PerlIO *pf)
2985 {
2986 #ifdef USE_RTL_POPEN
2987     return _pclose(pf);
2988 #else
2989     dTHX;
2990     int childpid, status;
2991     SV *sv;
2992
2993     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2994
2995     if (SvIOK(sv))
2996         childpid = SvIVX(sv);
2997     else
2998         childpid = 0;
2999
3000     if (!childpid) {
3001         errno = EBADF;
3002         return -1;
3003     }
3004
3005 #ifdef USE_PERLIO
3006     PerlIO_close(pf);
3007 #else
3008     fclose(pf);
3009 #endif
3010     SvIVX(sv) = 0;
3011
3012     if (win32_waitpid(childpid, &status, 0) == -1)
3013         return -1;
3014
3015     return status;
3016
3017 #endif /* USE_RTL_POPEN */
3018 }
3019
3020 DllExport int
3021 win32_link(const char *oldname, const char *newname)
3022 {
3023     dTHX;
3024     WCHAR wOldName[MAX_PATH+1];
3025     WCHAR wNewName[MAX_PATH+1];
3026
3027     if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) &&
3028         MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) &&
3029         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3030         CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3031     {
3032         return 0;
3033     }
3034     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3035     return -1;
3036 }
3037
3038 DllExport int
3039 win32_rename(const char *oname, const char *newname)
3040 {
3041     char szOldName[MAX_PATH+1];
3042     BOOL bResult;
3043     DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3044     dTHX;
3045
3046     if (stricmp(newname, oname))
3047         dwFlags |= MOVEFILE_REPLACE_EXISTING;
3048     strcpy(szOldName, PerlDir_mapA(oname));
3049
3050     bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3051     if (!bResult) {
3052         DWORD err = GetLastError();
3053         switch (err) {
3054         case ERROR_BAD_NET_NAME:
3055         case ERROR_BAD_NETPATH:
3056         case ERROR_BAD_PATHNAME:
3057         case ERROR_FILE_NOT_FOUND:
3058         case ERROR_FILENAME_EXCED_RANGE:
3059         case ERROR_INVALID_DRIVE:
3060         case ERROR_NO_MORE_FILES:
3061         case ERROR_PATH_NOT_FOUND:
3062             errno = ENOENT;
3063             break;
3064         default:
3065             errno = EACCES;
3066             break;
3067         }
3068         return -1;
3069     }
3070     return 0;
3071 }
3072
3073 DllExport int
3074 win32_setmode(int fd, int mode)
3075 {
3076     return setmode(fd, mode);
3077 }
3078
3079 DllExport int
3080 win32_chsize(int fd, Off_t size)
3081 {
3082 #if defined(WIN64) || defined(USE_LARGE_FILES)
3083     int retval = 0;
3084     Off_t cur, end, extend;
3085
3086     cur = win32_tell(fd);
3087     if (cur < 0)
3088         return -1;
3089     end = win32_lseek(fd, 0, SEEK_END);
3090     if (end < 0)
3091         return -1;
3092     extend = size - end;
3093     if (extend == 0) {
3094         /* do nothing */
3095     }
3096     else if (extend > 0) {
3097         /* must grow the file, padding with nulls */
3098         char b[4096];
3099         int oldmode = win32_setmode(fd, O_BINARY);
3100         size_t count;
3101         memset(b, '\0', sizeof(b));
3102         do {
3103             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3104             count = win32_write(fd, b, count);
3105             if ((int)count < 0) {
3106                 retval = -1;
3107                 break;
3108             }
3109         } while ((extend -= count) > 0);
3110         win32_setmode(fd, oldmode);
3111     }
3112     else {
3113         /* shrink the file */
3114         win32_lseek(fd, size, SEEK_SET);
3115         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3116             errno = EACCES;
3117             retval = -1;
3118         }
3119     }
3120 finish:
3121     win32_lseek(fd, cur, SEEK_SET);
3122     return retval;
3123 #else
3124     return chsize(fd, (long)size);
3125 #endif
3126 }
3127
3128 DllExport Off_t
3129 win32_lseek(int fd, Off_t offset, int origin)
3130 {
3131 #if defined(WIN64) || defined(USE_LARGE_FILES)
3132 #if defined(__BORLANDC__) /* buk */
3133     LARGE_INTEGER pos;
3134     pos.QuadPart = offset;
3135     pos.LowPart = SetFilePointer(
3136         (HANDLE)_get_osfhandle(fd),
3137         pos.LowPart,
3138         &pos.HighPart,
3139         origin
3140     );
3141     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3142         pos.QuadPart = -1;
3143     }
3144
3145     return pos.QuadPart;
3146 #else
3147     return _lseeki64(fd, offset, origin);
3148 #endif
3149 #else
3150     return lseek(fd, (long)offset, origin);
3151 #endif
3152 }
3153
3154 DllExport Off_t
3155 win32_tell(int fd)
3156 {
3157 #if defined(WIN64) || defined(USE_LARGE_FILES)
3158 #if defined(__BORLANDC__) /* buk */
3159     LARGE_INTEGER pos;
3160     pos.QuadPart = 0;
3161     pos.LowPart = SetFilePointer(
3162         (HANDLE)_get_osfhandle(fd),
3163         pos.LowPart,
3164         &pos.HighPart,
3165         FILE_CURRENT
3166     );
3167     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3168         pos.QuadPart = -1;
3169     }
3170
3171     return pos.QuadPart;
3172     /* return tell(fd); */
3173 #else
3174     return _telli64(fd);
3175 #endif
3176 #else
3177     return tell(fd);
3178 #endif
3179 }
3180
3181 DllExport int
3182 win32_open(const char *path, int flag, ...)
3183 {
3184     dTHX;
3185     va_list ap;
3186     int pmode;
3187
3188     va_start(ap, flag);
3189     pmode = va_arg(ap, int);
3190     va_end(ap);
3191
3192     if (stricmp(path, "/dev/null")==0)
3193         path = "NUL";
3194
3195     return open(PerlDir_mapA(path), flag, pmode);
3196 }
3197
3198 /* close() that understands socket */
3199 extern int my_close(int);       /* in win32sck.c */
3200
3201 DllExport int
3202 win32_close(int fd)
3203 {
3204     return my_close(fd);
3205 }
3206
3207 DllExport int
3208 win32_eof(int fd)
3209 {
3210     return eof(fd);
3211 }
3212
3213 DllExport int
3214 win32_isatty(int fd)
3215 {
3216     /* The Microsoft isatty() function returns true for *all*
3217      * character mode devices, including "nul".  Our implementation
3218      * should only return true if the handle has a console buffer.
3219      */
3220     DWORD mode;
3221     HANDLE fh = (HANDLE)_get_osfhandle(fd);
3222     if (fh == (HANDLE)-1) {
3223         /* errno is already set to EBADF */
3224         return 0;
3225     }
3226
3227     if (GetConsoleMode(fh, &mode))
3228         return 1;
3229
3230     errno = ENOTTY;
3231     return 0;
3232 }
3233
3234 DllExport int
3235 win32_dup(int fd)
3236 {
3237     return dup(fd);
3238 }
3239
3240 DllExport int
3241 win32_dup2(int fd1,int fd2)
3242 {
3243     return dup2(fd1,fd2);
3244 }
3245
3246 DllExport int
3247 win32_read(int fd, void *buf, unsigned int cnt)
3248 {
3249     return read(fd, buf, cnt);
3250 }
3251
3252 DllExport int
3253 win32_write(int fd, const void *buf, unsigned int cnt)
3254 {
3255     return write(fd, buf, cnt);
3256 }
3257
3258 DllExport int
3259 win32_mkdir(const char *dir, int mode)
3260 {
3261     dTHX;
3262     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3263 }
3264
3265 DllExport int
3266 win32_rmdir(const char *dir)
3267 {
3268     dTHX;
3269     return rmdir(PerlDir_mapA(dir));
3270 }
3271
3272 DllExport int
3273 win32_chdir(const char *dir)
3274 {
3275     dTHX;
3276     if (!dir) {
3277         errno = ENOENT;
3278         return -1;
3279     }
3280     return chdir(dir);
3281 }
3282
3283 DllExport  int
3284 win32_access(const char *path, int mode)
3285 {
3286     dTHX;
3287     return access(PerlDir_mapA(path), mode);
3288 }
3289
3290 DllExport  int
3291 win32_chmod(const char *path, int mode)
3292 {
3293     dTHX;
3294     return chmod(PerlDir_mapA(path), mode);
3295 }
3296
3297
3298 static char *
3299 create_command_line(char *cname, STRLEN clen, const char * const *args)
3300 {
3301     dTHX;
3302     int index, argc;
3303     char *cmd, *ptr;
3304     const char *arg;
3305     STRLEN len = 0;
3306     bool bat_file = FALSE;
3307     bool cmd_shell = FALSE;
3308     bool dumb_shell = FALSE;
3309     bool extra_quotes = FALSE;
3310     bool quote_next = FALSE;
3311
3312     if (!cname)
3313         cname = (char*)args[0];
3314
3315     /* The NT cmd.exe shell has the following peculiarity that needs to be
3316      * worked around.  It strips a leading and trailing dquote when any
3317      * of the following is true:
3318      *    1. the /S switch was used
3319      *    2. there are more than two dquotes
3320      *    3. there is a special character from this set: &<>()@^|
3321      *    4. no whitespace characters within the two dquotes
3322      *    5. string between two dquotes isn't an executable file
3323      * To work around this, we always add a leading and trailing dquote
3324      * to the string, if the first argument is either "cmd.exe" or "cmd",
3325      * and there were at least two or more arguments passed to cmd.exe
3326      * (not including switches).
3327      * XXX the above rules (from "cmd /?") don't seem to be applied
3328      * always, making for the convolutions below :-(
3329      */
3330     if (cname) {
3331         if (!clen)
3332             clen = strlen(cname);
3333
3334         if (clen > 4
3335             && (stricmp(&cname[clen-4], ".bat") == 0
3336                 || (stricmp(&cname[clen-4], ".cmd") == 0)))
3337         {
3338             bat_file = TRUE;
3339             len += 3;
3340         }
3341         else {
3342             char *exe = strrchr(cname, '/');
3343             char *exe2 = strrchr(cname, '\\');
3344             if (exe2 > exe)
3345                 exe = exe2;
3346             if (exe)
3347                 ++exe;
3348             else
3349                 exe = cname;
3350             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3351                 cmd_shell = TRUE;
3352                 len += 3;
3353             }
3354             else if (stricmp(exe, "command.com") == 0
3355                      || stricmp(exe, "command") == 0)
3356             {
3357                 dumb_shell = TRUE;
3358             }
3359         }
3360     }
3361
3362     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3363     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3364         STRLEN curlen = strlen(arg);
3365         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3366             len += 2;   /* assume quoting needed (worst case) */
3367         len += curlen + 1;
3368         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3369     }
3370     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3371
3372     argc = index;
3373     Newx(cmd, len, char);
3374     ptr = cmd;
3375
3376     if (bat_file) {
3377         *ptr++ = '"';
3378         extra_quotes = TRUE;
3379     }
3380
3381     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3382         bool do_quote = 0;
3383         STRLEN curlen = strlen(arg);
3384
3385         /* we want to protect empty arguments and ones with spaces with
3386          * dquotes, but only if they aren't already there */
3387         if (!dumb_shell) {
3388             if (!curlen) {
3389                 do_quote = 1;
3390             }
3391             else if (quote_next) {
3392                 /* see if it really is multiple arguments pretending to
3393                  * be one and force a set of quotes around it */
3394                 if (*find_next_space(arg))
3395                     do_quote = 1;
3396             }
3397             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3398                 STRLEN i = 0;
3399                 while (i < curlen) {
3400                     if (isSPACE(arg[i])) {
3401                         do_quote = 1;
3402                     }
3403                     else if (arg[i] == '"') {
3404                         do_quote = 0;
3405                         break;
3406                     }
3407                     i++;
3408                 }
3409             }
3410         }
3411
3412         if (do_quote)
3413             *ptr++ = '"';
3414
3415         strcpy(ptr, arg);
3416         ptr += curlen;
3417
3418         if (do_quote)
3419             *ptr++ = '"';
3420
3421         if (args[index+1])
3422             *ptr++ = ' ';
3423
3424         if (!extra_quotes
3425             && cmd_shell
3426             && curlen >= 2
3427             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3428             && stricmp(arg+curlen-2, "/c") == 0)
3429         {
3430             /* is there a next argument? */
3431             if (args[index+1]) {
3432                 /* are there two or more next arguments? */
3433                 if (args[index+2]) {
3434                     *ptr++ = '"';
3435                     extra_quotes = TRUE;
3436                 }
3437                 else {
3438                     /* single argument, force quoting if it has spaces */
3439                     quote_next = TRUE;
3440                 }
3441             }
3442         }
3443     }
3444
3445     if (extra_quotes)
3446         *ptr++ = '"';
3447
3448     *ptr = '\0';
3449
3450     return cmd;
3451 }
3452
3453 static char *
3454 qualified_path(const char *cmd)
3455 {
3456     dTHX;
3457     char *pathstr;
3458     char *fullcmd, *curfullcmd;
3459     STRLEN cmdlen = 0;
3460     int has_slash = 0;
3461
3462     if (!cmd)
3463         return NULL;
3464     fullcmd = (char*)cmd;
3465     while (*fullcmd) {
3466         if (*fullcmd == '/' || *fullcmd == '\\')
3467             has_slash++;
3468         fullcmd++;
3469         cmdlen++;
3470     }
3471
3472     /* look in PATH */
3473     pathstr = PerlEnv_getenv("PATH");
3474
3475     /* worst case: PATH is a single directory; we need additional space
3476      * to append "/", ".exe" and trailing "\0" */
3477     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3478     curfullcmd = fullcmd;
3479
3480     while (1) {
3481         DWORD res;
3482
3483         /* start by appending the name to the current prefix */
3484         strcpy(curfullcmd, cmd);
3485         curfullcmd += cmdlen;
3486
3487         /* if it doesn't end with '.', or has no extension, try adding
3488          * a trailing .exe first */
3489         if (cmd[cmdlen-1] != '.'
3490             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3491         {
3492             strcpy(curfullcmd, ".exe");
3493             res = GetFileAttributes(fullcmd);
3494             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3495                 return fullcmd;
3496             *curfullcmd = '\0';
3497         }
3498
3499         /* that failed, try the bare name */
3500         res = GetFileAttributes(fullcmd);
3501         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3502             return fullcmd;
3503
3504         /* quit if no other path exists, or if cmd already has path */
3505         if (!pathstr || !*pathstr || has_slash)
3506             break;
3507
3508         /* skip leading semis */
3509         while (*pathstr == ';')
3510             pathstr++;
3511
3512         /* build a new prefix from scratch */
3513         curfullcmd = fullcmd;
3514         while (*pathstr && *pathstr != ';') {
3515             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3516                 pathstr++;              /* skip initial '"' */
3517                 while (*pathstr && *pathstr != '"') {
3518                     *curfullcmd++ = *pathstr++;
3519                 }
3520                 if (*pathstr)
3521                     pathstr++;          /* skip trailing '"' */
3522             }
3523             else {
3524                 *curfullcmd++ = *pathstr++;
3525             }
3526         }
3527         if (*pathstr)
3528             pathstr++;                  /* skip trailing semi */
3529         if (curfullcmd > fullcmd        /* append a dir separator */
3530             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3531         {
3532             *curfullcmd++ = '\\';
3533         }
3534     }
3535
3536     Safefree(fullcmd);
3537     return NULL;
3538 }
3539
3540 /* The following are just place holders.
3541  * Some hosts may provide and environment that the OS is
3542  * not tracking, therefore, these host must provide that
3543  * environment and the current directory to CreateProcess
3544  */
3545
3546 DllExport void*
3547 win32_get_childenv(void)
3548 {
3549     return NULL;
3550 }
3551
3552 DllExport void
3553 win32_free_childenv(void* d)
3554 {
3555 }
3556
3557 DllExport void
3558 win32_clearenv(void)
3559 {
3560     char *envv = GetEnvironmentStrings();
3561     char *cur = envv;
3562     STRLEN len;
3563     while (*cur) {
3564         char *end = strchr(cur,'=');
3565         if (end && end != cur) {
3566             *end = '\0';
3567             SetEnvironmentVariable(cur, NULL);
3568             *end = '=';
3569             cur = end + strlen(end+1)+2;
3570         }
3571         else if ((len = strlen(cur)))
3572             cur += len+1;
3573     }
3574     FreeEnvironmentStrings(envv);
3575 }
3576
3577 DllExport char*
3578 win32_get_childdir(void)
3579 {
3580     dTHX;
3581     char* ptr;
3582     char szfilename[MAX_PATH+1];
3583
3584     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3585     Newx(ptr, strlen(szfilename)+1, char);
3586     strcpy(ptr, szfilename);
3587     return ptr;
3588 }
3589
3590 DllExport void
3591 win32_free_childdir(char* d)
3592 {
3593     dTHX;
3594     Safefree(d);
3595 }
3596
3597
3598 /* XXX this needs to be made more compatible with the spawnvp()
3599  * provided by the various RTLs.  In particular, searching for
3600  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3601  * This doesn't significantly affect perl itself, because we
3602  * always invoke things using PERL5SHELL if a direct attempt to
3603  * spawn the executable fails.
3604  *
3605  * XXX splitting and rejoining the commandline between do_aspawn()
3606  * and win32_spawnvp() could also be avoided.
3607  */
3608
3609 DllExport int
3610 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3611 {
3612 #ifdef USE_RTL_SPAWNVP
3613     return spawnvp(mode, cmdname, (char * const *)argv);
3614 #else
3615     dTHX;
3616     int ret;
3617     void* env;
3618     char* dir;
3619     child_IO_table tbl;
3620     STARTUPINFO StartupInfo;
3621     PROCESS_INFORMATION ProcessInformation;
3622     DWORD create = 0;
3623     char *cmd;
3624     char *fullcmd = NULL;
3625     char *cname = (char *)cmdname;
3626     STRLEN clen = 0;
3627
3628     if (cname) {
3629         clen = strlen(cname);
3630         /* if command name contains dquotes, must remove them */
3631         if (strchr(cname, '"')) {
3632             cmd = cname;
3633             Newx(cname,clen+1,char);
3634             clen = 0;
3635             while (*cmd) {
3636                 if (*cmd != '"') {
3637                     cname[clen] = *cmd;
3638                     ++clen;
3639                 }
3640                 ++cmd;
3641             }
3642             cname[clen] = '\0';
3643         }
3644     }
3645
3646     cmd = create_command_line(cname, clen, argv);
3647
3648     env = PerlEnv_get_childenv();
3649     dir = PerlEnv_get_childdir();
3650
3651     switch(mode) {
3652     case P_NOWAIT:      /* asynch + remember result */
3653         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3654             errno = EAGAIN;
3655             ret = -1;
3656             goto RETVAL;
3657         }
3658         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3659          * in win32_kill()
3660          */
3661         create |= CREATE_NEW_PROCESS_GROUP;
3662         /* FALL THROUGH */
3663
3664     case P_WAIT:        /* synchronous execution */
3665         break;
3666     default:            /* invalid mode */
3667         errno = EINVAL;
3668         ret = -1;
3669         goto RETVAL;
3670     }
3671     memset(&StartupInfo,0,sizeof(StartupInfo));
3672     StartupInfo.cb = sizeof(StartupInfo);
3673     memset(&tbl,0,sizeof(tbl));
3674     PerlEnv_get_child_IO(&tbl);
3675     StartupInfo.dwFlags         = tbl.dwFlags;
3676     StartupInfo.dwX             = tbl.dwX;
3677     StartupInfo.dwY             = tbl.dwY;
3678     StartupInfo.dwXSize         = tbl.dwXSize;
3679     StartupInfo.dwYSize         = tbl.dwYSize;
3680     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3681     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3682     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3683     StartupInfo.wShowWindow     = tbl.wShowWindow;
3684     StartupInfo.hStdInput       = tbl.childStdIn;
3685     StartupInfo.hStdOutput      = tbl.childStdOut;
3686     StartupInfo.hStdError       = tbl.childStdErr;
3687     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3688         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3689         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3690     {
3691         create |= CREATE_NEW_CONSOLE;
3692     }
3693     else {
3694         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3695     }
3696     if (w32_use_showwindow) {
3697         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3698         StartupInfo.wShowWindow = w32_showwindow;
3699     }
3700
3701     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3702                           cname,cmd));
3703 RETRY:
3704     if (!CreateProcess(cname,           /* search PATH to find executable */
3705                        cmd,             /* executable, and its arguments */
3706                        NULL,            /* process attributes */
3707                        NULL,            /* thread attributes */
3708                        TRUE,            /* inherit handles */
3709                        create,          /* creation flags */
3710                        (LPVOID)env,     /* inherit environment */
3711                        dir,             /* inherit cwd */
3712                        &StartupInfo,
3713                        &ProcessInformation))
3714     {
3715         /* initial NULL argument to CreateProcess() does a PATH
3716          * search, but it always first looks in the directory
3717          * where the current process was started, which behavior
3718          * is undesirable for backward compatibility.  So we
3719          * jump through our own hoops by picking out the path
3720          * we really want it to use. */
3721         if (!fullcmd) {
3722             fullcmd = qualified_path(cname);
3723             if (fullcmd) {
3724                 if (cname != cmdname)
3725                     Safefree(cname);
3726                 cname = fullcmd;
3727                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3728                                       "Retrying [%s] with same args\n",
3729                                       cname));
3730                 goto RETRY;
3731             }
3732         }
3733         errno = ENOENT;
3734         ret = -1;
3735         goto RETVAL;
3736     }
3737
3738     if (mode == P_NOWAIT) {
3739         /* asynchronous spawn -- store handle, return PID */
3740         ret = (int)ProcessInformation.dwProcessId;
3741
3742         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3743         w32_child_pids[w32_num_children] = (DWORD)ret;
3744         ++w32_num_children;
3745     }
3746     else  {
3747         DWORD status;
3748         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3749         /* FIXME: if msgwait returned due to message perhaps forward the
3750            "signal" to the process
3751          */
3752         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3753         ret = (int)status;
3754         CloseHandle(ProcessInformation.hProcess);
3755     }
3756
3757     CloseHandle(ProcessInformation.hThread);
3758
3759 RETVAL:
3760     PerlEnv_free_childenv(env);
3761     PerlEnv_free_childdir(dir);
3762     Safefree(cmd);
3763     if (cname != cmdname)
3764         Safefree(cname);
3765     return ret;
3766 #endif
3767 }
3768
3769 DllExport int
3770 win32_execv(const char *cmdname, const char *const *argv)
3771 {
3772 #ifdef USE_ITHREADS
3773     dTHX;
3774     /* if this is a pseudo-forked child, we just want to spawn
3775      * the new program, and return */
3776     if (w32_pseudo_id)
3777 #  ifdef __BORLANDC__
3778         return spawnv(P_WAIT, cmdname, (char *const *)argv);
3779 #  else
3780         return spawnv(P_WAIT, cmdname, argv);
3781 #  endif
3782 #endif
3783 #ifdef __BORLANDC__
3784     return execv(cmdname, (char *const *)argv);
3785 #else
3786     return execv(cmdname, argv);
3787 #endif
3788 }
3789
3790 DllExport int
3791 win32_execvp(const char *cmdname, const char *const *argv)
3792 {
3793 #ifdef USE_ITHREADS
3794     dTHX;
3795     /* if this is a pseudo-forked child, we just want to spawn
3796      * the new program, and return */
3797     if (w32_pseudo_id) {
3798         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
3799         if (status != -1) {
3800             my_exit(status);
3801             return 0;
3802         }
3803         else
3804             return status;
3805     }
3806 #endif
3807 #ifdef __BORLANDC__
3808     return execvp(cmdname, (char *const *)argv);
3809 #else
3810     return execvp(cmdname, argv);
3811 #endif
3812 }
3813
3814 DllExport void
3815 win32_perror(const char *str)
3816 {
3817     perror(str);
3818 }
3819
3820 DllExport void
3821 win32_setbuf(FILE *pf, char *buf)
3822 {
3823     setbuf(pf, buf);
3824 }
3825
3826 DllExport int
3827 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3828 {
3829     return setvbuf(pf, buf, type, size);
3830 }
3831
3832 DllExport int
3833 win32_flushall(void)
3834 {
3835     return flushall();
3836 }
3837
3838 DllExport int
3839 win32_fcloseall(void)
3840 {
3841     return fcloseall();
3842 }
3843
3844 DllExport char*
3845 win32_fgets(char *s, int n, FILE *pf)
3846 {
3847     return fgets(s, n, pf);
3848 }
3849
3850 DllExport char*
3851 win32_gets(char *s)
3852 {
3853     return gets(s);
3854 }
3855
3856 DllExport int
3857 win32_fgetc(FILE *pf)
3858 {
3859     return fgetc(pf);
3860 }
3861
3862 DllExport int
3863 win32_putc(int c, FILE *pf)
3864 {
3865     return putc(c,pf);
3866 }
3867
3868 DllExport int
3869 win32_puts(const char *s)
3870 {
3871     return puts(s);
3872 }
3873
3874 DllExport int
3875 win32_getchar(void)
3876 {
3877     return getchar();
3878 }
3879
3880 DllExport int
3881 win32_putchar(int c)
3882 {
3883     return putchar(c);
3884 }
3885
3886 #ifdef MYMALLOC
3887
3888 #ifndef USE_PERL_SBRK
3889
3890 static char *committed = NULL;          /* XXX threadead */
3891 static char *base      = NULL;          /* XXX threadead */
3892 static char *reserved  = NULL;          /* XXX threadead */
3893 static char *brk       = NULL;          /* XXX threadead */
3894 static DWORD pagesize  = 0;             /* XXX threadead */
3895
3896 void *
3897 sbrk(ptrdiff_t need)
3898 {
3899  void *result;
3900  if (!pagesize)
3901   {SYSTEM_INFO info;
3902    GetSystemInfo(&info);
3903    /* Pretend page size is larger so we don't perpetually
3904     * call the OS to commit just one page ...
3905     */
3906    pagesize = info.dwPageSize << 3;
3907   }
3908  if (brk+need >= reserved)
3909   {
3910    DWORD size = brk+need-reserved;
3911    char *addr;
3912    char *prev_committed = NULL;
3913    if (committed && reserved && committed < reserved)
3914     {
3915      /* Commit last of previous chunk cannot span allocations */
3916      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3917      if (addr)
3918       {
3919       /* Remember where we committed from in case we want to decommit later */
3920       prev_committed = committed;
3921       committed = reserved;
3922       }
3923     }
3924    /* Reserve some (more) space
3925     * Contiguous blocks give us greater efficiency, so reserve big blocks -
3926     * this is only address space not memory...
3927     * Note this is a little sneaky, 1st call passes NULL as reserved
3928     * so lets system choose where we start, subsequent calls pass
3929     * the old end address so ask for a contiguous block
3930     */
3931 sbrk_reserve:
3932    if (size < 64*1024*1024)
3933     size = 64*1024*1024;
3934    size = ((size + pagesize - 1) / pagesize) * pagesize;
3935    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3936    if (addr)
3937     {
3938      reserved = addr+size;
3939      if (!base)
3940       base = addr;
3941      if (!committed)
3942       committed = base;
3943      if (!brk)
3944       brk = committed;
3945     }
3946    else if (reserved)
3947     {
3948       /* The existing block could not be extended far enough, so decommit
3949        * anything that was just committed above and start anew */
3950       if (prev_committed)
3951        {
3952        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
3953         return (void *) -1;
3954        }
3955       reserved = base = committed = brk = NULL;
3956       size = need;
3957       goto sbrk_reserve;
3958     }
3959    else
3960     {
3961      return (void *) -1;
3962     }
3963   }
3964  result = brk;
3965  brk += need;
3966  if (brk > committed)
3967   {
3968    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3969    char *addr;
3970    if (committed+size > reserved)
3971     size = reserved-committed;
3972    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3973    if (addr)
3974     committed += size;
3975    else
3976     return (void *) -1;
3977   }
3978  return result;
3979 }
3980
3981 #endif
3982 #endif
3983
3984 DllExport void*
3985 win32_malloc(size_t size)
3986 {
3987     return malloc(size);
3988 }
3989
3990 DllExport void*
3991 win32_calloc(size_t numitems, size_t size)
3992 {
3993     return calloc(numitems,size);
3994 }
3995
3996 DllExport void*
3997 win32_realloc(void *block, size_t size)
3998 {
3999     return realloc(block,size);
4000 }
4001
4002 DllExport void
4003 win32_free(void *block)
4004 {
4005     free(block);
4006 }
4007
4008
4009 DllExport int
4010 win32_open_osfhandle(intptr_t handle, int flags)
4011 {
4012     return _open_osfhandle(handle, flags);
4013 }
4014
4015 DllExport intptr_t
4016 win32_get_osfhandle(int fd)
4017 {
4018     return (intptr_t)_get_osfhandle(fd);
4019 }
4020
4021 DllExport FILE *
4022 win32_fdupopen(FILE *pf)
4023 {
4024     FILE* pfdup;
4025     fpos_t pos;
4026     char mode[3];
4027     int fileno = win32_dup(win32_fileno(pf));
4028
4029     /* open the file in the same mode */
4030 #ifdef __BORLANDC__
4031     if((pf)->flags & _F_READ) {
4032         mode[0] = 'r';
4033         mode[1] = 0;
4034     }
4035     else if((pf)->flags & _F_WRIT) {
4036         mode[0] = 'a';
4037         mode[1] = 0;
4038     }
4039     else if((pf)->flags & _F_RDWR) {
4040         mode[0] = 'r';
4041         mode[1] = '+';
4042         mode[2] = 0;
4043     }
4044 #else
4045     if((pf)->_flag & _IOREAD) {
4046         mode[0] = 'r';
4047         mode[1] = 0;
4048     }
4049     else if((pf)->_flag & _IOWRT) {
4050         mode[0] = 'a';
4051         mode[1] = 0;
4052     }
4053     else if((pf)->_flag & _IORW) {
4054         mode[0] = 'r';
4055         mode[1] = '+';
4056         mode[2] = 0;
4057     }
4058 #endif
4059
4060     /* it appears that the binmode is attached to the
4061      * file descriptor so binmode files will be handled
4062      * correctly
4063      */
4064     pfdup = win32_fdopen(fileno, mode);
4065
4066     /* move the file pointer to the same position */
4067     if (!fgetpos(pf, &pos)) {
4068         fsetpos(pfdup, &pos);
4069     }
4070     return pfdup;
4071 }
4072
4073 DllExport void*
4074 win32_dynaload(const char* filename)
4075 {
4076     dTHX;
4077     char buf[MAX_PATH+1];
4078     char *first;
4079
4080     /* LoadLibrary() doesn't recognize forward slashes correctly,
4081      * so turn 'em back. */
4082     first = strchr(filename, '/');
4083     if (first) {
4084         STRLEN len = strlen(filename);
4085         if (len <= MAX_PATH) {
4086             strcpy(buf, filename);
4087             filename = &buf[first - filename];
4088             while (*filename) {
4089                 if (*filename == '/')
4090                     *(char*)filename = '\\';
4091                 ++filename;
4092             }
4093             filename = buf;
4094         }
4095     }
4096     return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4097 }
4098
4099 XS(w32_SetChildShowWindow)
4100 {
4101     dXSARGS;
4102     BOOL use_showwindow = w32_use_showwindow;
4103     /* use "unsigned short" because Perl has redefined "WORD" */
4104     unsigned short showwindow = w32_showwindow;
4105
4106     if (items > 1)
4107         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4108
4109     if (items == 0 || !SvOK(ST(0)))
4110         w32_use_showwindow = FALSE;
4111     else {
4112         w32_use_showwindow = TRUE;
4113         w32_showwindow = (unsigned short)SvIV(ST(0));
4114     }
4115
4116     EXTEND(SP, 1);
4117     if (use_showwindow)
4118         ST(0) = sv_2mortal(newSViv(showwindow));
4119     else
4120         ST(0) = &PL_sv_undef;
4121     XSRETURN(1);
4122 }
4123
4124 void
4125 Perl_init_os_extras(void)
4126 {
4127     dTHX;
4128     char *file = __FILE__;
4129
4130     /* Initialize Win32CORE if it has been statically linked. */
4131     void (*pfn_init)(pTHX);
4132 #if defined(__BORLANDC__)
4133     /* makedef.pl seems to have given up on fixing this issue in the .def file */
4134     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "_init_Win32CORE");
4135 #else
4136     pfn_init = (void (*)(pTHX))GetProcAddress((HMODULE)w32_perldll_handle, "init_Win32CORE");
4137 #endif
4138     if (pfn_init)
4139         pfn_init(aTHX);
4140
4141     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4142 }
4143
4144 void *
4145 win32_signal_context(void)
4146 {
4147     dTHX;
4148 #ifdef MULTIPLICITY
4149     if (!my_perl) {
4150         my_perl = PL_curinterp;
4151         PERL_SET_THX(my_perl);
4152     }
4153     return my_perl;
4154 #else
4155     return PL_curinterp;
4156 #endif
4157 }
4158
4159
4160 BOOL WINAPI
4161 win32_ctrlhandler(DWORD dwCtrlType)
4162 {
4163 #ifdef MULTIPLICITY
4164     dTHXa(PERL_GET_SIG_CONTEXT);
4165
4166     if (!my_perl)
4167         return FALSE;
4168 #endif
4169
4170     switch(dwCtrlType) {
4171     case CTRL_CLOSE_EVENT:
4172      /*  A signal that the system sends to all processes attached to a console when
4173          the user closes the console (either by choosing the Close command from the
4174          console window's System menu, or by choosing the End Task command from the
4175          Task List
4176       */
4177         if (do_raise(aTHX_ 1))        /* SIGHUP */
4178             sig_terminate(aTHX_ 1);
4179         return TRUE;
4180
4181     case CTRL_C_EVENT:
4182         /*  A CTRL+c signal was received */
4183         if (do_raise(aTHX_ SIGINT))
4184             sig_terminate(aTHX_ SIGINT);
4185         return TRUE;
4186
4187     case CTRL_BREAK_EVENT:
4188         /*  A CTRL+BREAK signal was received */
4189         if (do_raise(aTHX_ SIGBREAK))
4190             sig_terminate(aTHX_ SIGBREAK);
4191         return TRUE;
4192
4193     case CTRL_LOGOFF_EVENT:
4194       /*  A signal that the system sends to all console processes when a user is logging
4195           off. This signal does not indicate which user is logging off, so no
4196           assumptions can be made.
4197        */
4198         break;
4199     case CTRL_SHUTDOWN_EVENT:
4200       /*  A signal that the system sends to all console processes when the system is
4201           shutting down.
4202        */
4203         if (do_raise(aTHX_ SIGTERM))
4204             sig_terminate(aTHX_ SIGTERM);
4205         return TRUE;
4206     default:
4207         break;
4208     }
4209     return FALSE;
4210 }
4211
4212
4213 #ifdef SET_INVALID_PARAMETER_HANDLER
4214 #  include <crtdbg.h>
4215 #endif
4216
4217 static void
4218 ansify_path(void)
4219 {
4220     size_t len;
4221     char *ansi_path;
4222     WCHAR *wide_path;
4223     WCHAR *wide_dir;
4224
4225     /* fetch Unicode version of PATH */
4226     len = 2000;
4227     wide_path = win32_malloc(len*sizeof(WCHAR));
4228     while (wide_path) {
4229         size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len);
4230         if (newlen < len)
4231             break;
4232         len = newlen;
4233         wide_path = win32_realloc(wide_path, len*sizeof(WCHAR));
4234     }
4235     if (!wide_path)
4236         return;
4237
4238     /* convert to ANSI pathnames */
4239     wide_dir = wide_path;
4240     ansi_path = NULL;
4241     while (wide_dir) {
4242         WCHAR *sep = wcschr(wide_dir, ';');
4243         char *ansi_dir;
4244         size_t ansi_len;
4245         size_t wide_len;
4246
4247         if (sep)
4248             *sep++ = '\0';
4249
4250         /* remove quotes around pathname */
4251         if (*wide_dir == '"')
4252             ++wide_dir;
4253         wide_len = wcslen(wide_dir);
4254         if (wide_len && wide_dir[wide_len-1] == '"')
4255             wide_dir[wide_len-1] = '\0';
4256
4257         /* append ansi_dir to ansi_path */
4258         ansi_dir = win32_ansipath(wide_dir);
4259         ansi_len = strlen(ansi_dir);
4260         if (ansi_path) {
4261             size_t newlen = len + 1 + ansi_len;
4262             ansi_path = win32_realloc(ansi_path, newlen+1);
4263             if (!ansi_path)
4264                 break;
4265             ansi_path[len] = ';';
4266             memcpy(ansi_path+len+1, ansi_dir, ansi_len+1);
4267             len = newlen;
4268         }
4269         else {
4270             len = ansi_len;
4271             ansi_path = win32_malloc(5+len+1);
4272             if (!ansi_path)
4273                 break;
4274             memcpy(ansi_path, "PATH=", 5);
4275             memcpy(ansi_path+5, ansi_dir, len+1);
4276             len += 5;
4277         }
4278         win32_free(ansi_dir);
4279         wide_dir = sep;
4280     }
4281
4282     if (ansi_path) {
4283         /* Update C RTL environ array.  This will only have full effect if
4284          * perl_parse() is later called with `environ` as the `env` argument.
4285          * Otherwise S_init_postdump_symbols() will overwrite PATH again.
4286          *
4287          * We do have to ansify() the PATH before Perl has been fully
4288          * initialized because S_find_script() uses the PATH when perl
4289          * is being invoked with the -S option.  This happens before %ENV
4290          * is initialized in S_init_postdump_symbols().
4291          *
4292          * XXX Is this a bug? Should S_find_script() use the environment
4293          * XXX passed in the `env` arg to parse_perl()?
4294          */
4295         putenv(ansi_path);
4296         /* Keep system environment in sync because S_init_postdump_symbols()
4297          * will not call mg_set() if it initializes %ENV from `environ`.
4298          */
4299         SetEnvironmentVariableA("PATH", ansi_path+5);
4300         /* We are intentionally leaking the ansi_path string here because
4301          * the Borland runtime library puts it directly into the environ
4302          * array.  The Microsoft runtime library seems to make a copy,
4303          * but will leak the copy should it be replaced again later.
4304          * Since this code is only called once during PERL_SYS_INIT this
4305          * shouldn't really matter.
4306          */
4307     }
4308     win32_free(wide_path);
4309 }
4310
4311 void
4312 Perl_win32_init(int *argcp, char ***argvp)
4313 {
4314 #ifdef SET_INVALID_PARAMETER_HANDLER
4315     _invalid_parameter_handler oldHandler, newHandler;
4316     newHandler = my_invalid_parameter_handler;
4317     oldHandler = _set_invalid_parameter_handler(newHandler);
4318     _CrtSetReportMode(_CRT_ASSERT, 0);
4319 #endif
4320     /* Disable floating point errors, Perl will trap the ones we
4321      * care about.  VC++ RTL defaults to switching these off
4322      * already, but the Borland RTL doesn't.  Since we don't
4323      * want to be at the vendor's whim on the default, we set
4324      * it explicitly here.
4325      */
4326 #if !defined(__GNUC__)
4327     _control87(MCW_EM, MCW_EM);
4328 #endif
4329     MALLOC_INIT;
4330
4331     /* When the manifest resource requests Common-Controls v6 then
4332      * user32.dll no longer registers all the Windows classes used for
4333      * standard controls but leaves some of them to be registered by
4334      * comctl32.dll.  InitCommonControls() doesn't do anything but calling
4335      * it makes sure comctl32.dll gets loaded into the process and registers
4336      * the standard control classes.  Without this even normal Windows APIs
4337      * like MessageBox() can fail under some versions of Windows XP.
4338      */
4339     InitCommonControls();
4340
4341     g_osver.dwOSVersionInfoSize = sizeof(g_osver);
4342     GetVersionEx(&g_osver);
4343
4344     ansify_path();
4345 }
4346
4347 void
4348 Perl_win32_term(void)
4349 {
4350     dTHX;
4351     HINTS_REFCNT_TERM;
4352     OP_REFCNT_TERM;
4353     PERLIO_TERM;
4354     MALLOC_TERM;
4355 }
4356
4357 void
4358 win32_get_child_IO(child_IO_table* ptbl)
4359 {
4360     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4361     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4362     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4363 }
4364
4365 Sighandler_t
4366 win32_signal(int sig, Sighandler_t subcode)
4367 {
4368     dTHX;
4369     if (sig < SIG_SIZE) {
4370         int save_errno = errno;
4371         Sighandler_t result = signal(sig, subcode);
4372         if (result == SIG_ERR) {
4373             result = w32_sighandler[sig];
4374             errno = save_errno;
4375         }
4376         w32_sighandler[sig] = subcode;
4377         return result;
4378     }
4379     else {
4380         errno = EINVAL;
4381         return SIG_ERR;
4382     }
4383 }
4384
4385 /* The PerlMessageWindowClass's WindowProc */
4386 LRESULT CALLBACK
4387 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4388 {
4389     return win32_process_message(hwnd, msg, wParam, lParam) ?
4390         0 : DefWindowProc(hwnd, msg, wParam, lParam);
4391 }
4392
4393 /* The real message handler. Can be called with
4394  * hwnd == NULL to process our thread messages. Returns TRUE for any messages
4395  * that it processes */
4396 static LRESULT
4397 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam)
4398 {
4399     /* BEWARE. The context retrieved using dTHX; is the context of the
4400      * 'parent' thread during the CreateWindow() phase - i.e. for all messages
4401      * up to and including WM_CREATE.  If it ever happens that you need the
4402      * 'child' context before this, then it needs to be passed into
4403      * win32_create_message_window(), and passed to the WM_NCCREATE handler
4404      * from the lparam of CreateWindow().  It could then be stored/retrieved
4405      * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating
4406      * the dTHX calls here. */
4407     /* XXX For now it is assumed that the overhead of the dTHX; for what
4408      * are relativley infrequent code-paths, is better than the added
4409      * complexity of getting the correct context passed into
4410      * win32_create_message_window() */
4411
4412     switch(msg) {
4413
4414 #ifdef USE_ITHREADS
4415         case WM_USER_MESSAGE: {
4416             long child = find_pseudo_pid((int)wParam);
4417             if (child >= 0) {
4418                 dTHX;
4419                 w32_pseudo_child_message_hwnds[child] = (HWND)lParam;
4420                 return 1;
4421             }
4422             break;
4423         }
4424 #endif
4425
4426         case WM_USER_KILL: {
4427             dTHX;
4428             /* We use WM_USER_KILL to fake kill() with other signals */
4429             int sig = (int)wParam;
4430             if (do_raise(aTHX_ sig))
4431                 sig_terminate(aTHX_ sig);
4432
4433             return 1;
4434         }
4435
4436         case WM_TIMER: {
4437             dTHX;
4438             /* alarm() is a one-shot but SetTimer() repeats so kill it */
4439             if (w32_timerid && w32_timerid==(UINT)wParam) {
4440                 KillTimer(w32_message_hwnd, w32_timerid);
4441                 w32_timerid=0;
4442
4443                 /* Now fake a call to signal handler */
4444                 if (do_raise(aTHX_ 14))
4445                     sig_terminate(aTHX_ 14);
4446
4447                 return 1;
4448             }
4449             break;
4450         }
4451
4452         default:
4453             break;
4454
4455     } /* switch */
4456
4457     /* Above or other stuff may have set a signal flag, and we may not have
4458      * been called from win32_async_check() (e.g. some other GUI's message
4459      * loop.  BUT DON'T dispatch signals here: If someone has set a SIGALRM
4460      * handler that die's, and the message loop that calls here is wrapped
4461      * in an eval, then you may well end up with orphaned windows - signals
4462      * are dispatched by win32_async_check() */
4463
4464     return 0;
4465 }
4466
4467 void
4468 win32_create_message_window_class(void)
4469 {
4470     /* create the window class for "message only" windows */
4471     WNDCLASS wc;
4472
4473     Zero(&wc, 1, wc);
4474     wc.lpfnWndProc = win32_message_window_proc;
4475     wc.hInstance = (HINSTANCE)GetModuleHandle(NULL);
4476     wc.lpszClassName = "PerlMessageWindowClass";
4477
4478     /* second and subsequent calls will fail, but class
4479      * will already be registered */
4480     RegisterClass(&wc);
4481 }
4482
4483 HWND
4484 win32_create_message_window(void)
4485 {
4486     win32_create_message_window_class();
4487     return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow",
4488                         0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL);
4489 }
4490
4491 #ifdef HAVE_INTERP_INTERN
4492
4493 static void
4494 win32_csighandler(int sig)
4495 {
4496 #if 0
4497     dTHXa(PERL_GET_SIG_CONTEXT);
4498     Perl_warn(aTHX_ "Got signal %d",sig);
4499 #endif
4500     /* Does nothing */
4501 }
4502
4503 #if defined(__MINGW32__) && defined(__cplusplus)
4504 #define CAST_HWND__(x) (HWND__*)(x)
4505 #else
4506 #define CAST_HWND__(x) x
4507 #endif
4508
4509 void
4510 Perl_sys_intern_init(pTHX)
4511 {
4512     int i;
4513
4514     w32_perlshell_tokens        = NULL;
4515     w32_perlshell_vec           = (char**)NULL;
4516     w32_perlshell_items         = 0;
4517     w32_fdpid                   = newAV();
4518     Newx(w32_children, 1, child_tab);
4519     w32_num_children            = 0;
4520 #  ifdef USE_ITHREADS
4521     w32_pseudo_id               = 0;
4522     Newx(w32_pseudo_children, 1, pseudo_child_tab);
4523     w32_num_pseudo_children     = 0;
4524 #  endif
4525     w32_timerid                 = 0;
4526     w32_message_hwnd            = CAST_HWND__(INVALID_HANDLE_VALUE);
4527     w32_poll_count              = 0;
4528     for (i=0; i < SIG_SIZE; i++) {
4529         w32_sighandler[i] = SIG_DFL;
4530     }
4531 #  ifdef MULTIPLICITY
4532     if (my_perl == PL_curinterp) {
4533 #  else
4534     {
4535 #  endif
4536         /* Force C runtime signal stuff to set its console handler */
4537         signal(SIGINT,win32_csighandler);
4538         signal(SIGBREAK,win32_csighandler);
4539
4540         /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP
4541          * flag.  This has the side-effect of disabling Ctrl-C events in all
4542          * processes in this group.
4543          * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler()
4544          * with a NULL handler.
4545          */
4546         SetConsoleCtrlHandler(NULL,FALSE);
4547
4548         /* Push our handler on top */
4549         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4550     }
4551 }
4552
4553 void
4554 Perl_sys_intern_clear(pTHX)
4555 {
4556     Safefree(w32_perlshell_tokens);
4557     Safefree(w32_perlshell_vec);
4558     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4559     Safefree(w32_children);
4560     if (w32_timerid) {
4561         KillTimer(w32_message_hwnd, w32_timerid);
4562         w32_timerid = 0;
4563     }
4564     if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE)
4565         DestroyWindow(w32_message_hwnd);
4566 #  ifdef MULTIPLICITY
4567     if (my_perl == PL_curinterp) {
4568 #  else
4569     {
4570 #  endif
4571         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4572     }
4573 #  ifdef USE_ITHREADS
4574     Safefree(w32_pseudo_children);
4575 #  endif
4576 }
4577
4578 #  ifdef USE_ITHREADS
4579
4580 void
4581 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4582 {
4583     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
4584
4585     dst->perlshell_tokens       = NULL;
4586     dst->perlshell_vec          = (char**)NULL;
4587     dst->perlshell_items        = 0;
4588     dst->fdpid                  = newAV();
4589     Newxz(dst->children, 1, child_tab);
4590     dst->pseudo_id              = 0;
4591     Newxz(dst->pseudo_children, 1, pseudo_child_tab);
4592     dst->timerid                = 0;
4593     dst->message_hwnd           = CAST_HWND__(INVALID_HANDLE_VALUE);
4594     dst->poll_count             = 0;
4595     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4596 }
4597 #  endif /* USE_ITHREADS */
4598 #endif /* HAVE_INTERP_INTERN */