win32/win32.c

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