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