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