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         Newx(ret, slen+2, char);
 476         Newx(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     Newx(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         Newx(argv, strlen(cmd) / 2 + 2, char*);
 634         Newx(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         Newx(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     Newxz(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     Newx(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             Newx(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             Newx(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     Newx(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     Newx(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     Newx(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             Newx(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 &n