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