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