win32/win32.c

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