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