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