win32/win32.c

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