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_ const char *cmd, int exectype);
  96 static BOOL             has_shell_metachars(const 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(const 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_ const char *cmd, const 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_ const 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++] = (char *)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_ const 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, (long)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     BY_HANDLE_FILE_INFORMATION bhfi;
2738 #if defined(WIN64) || defined(USE_LARGE_FILES)
2739     /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2740     struct stat tmp;
2741     int rc = fstat(fd,&tmp);
2742
2743     sbufptr->st_dev   = tmp.st_dev;
2744     sbufptr->st_ino   = tmp.st_ino;
2745     sbufptr->st_mode  = tmp.st_mode;
2746     sbufptr->st_nlink = tmp.st_nlink;
2747     sbufptr->st_uid   = tmp.st_uid;
2748     sbufptr->st_gid   = tmp.st_gid;
2749     sbufptr->st_rdev  = tmp.st_rdev;
2750     sbufptr->st_size  = tmp.st_size;
2751     sbufptr->st_atime = tmp.st_atime;
2752     sbufptr->st_mtime = tmp.st_mtime;
2753     sbufptr->st_ctime = tmp.st_ctime;
2754 #else
2755     int rc = fstat(fd,sbufptr);
2756 #endif
2757
2758     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2759 #if defined(WIN64) || defined(USE_LARGE_FILES)
2760         sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2761 #endif
2762         sbufptr->st_mode &= 0xFE00;
2763         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2764             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2765         else
2766             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2767               + ((S_IREAD|S_IWRITE) >> 6));
2768     }
2769     return rc;
2770 #else
2771     return my_fstat(fd,sbufptr);
2772 #endif
2773 }
2774
2775 DllExport int
2776 win32_pipe(int *pfd, unsigned int size, int mode)
2777 {
2778     return _pipe(pfd, size, mode);
2779 }
2780
2781 DllExport PerlIO*
2782 win32_popenlist(const char *mode, IV narg, SV **args)
2783 {
2784  dTHX;
2785  Perl_croak(aTHX_ "List form of pipe open not implemented");
2786  return NULL;
2787 }
2788
2789 /*
2790  * a popen() clone that respects PERL5SHELL
2791  *
2792  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2793  */
2794
2795 DllExport PerlIO*
2796 win32_popen(const char *command, const char *mode)
2797 {
2798 #ifdef USE_RTL_POPEN
2799     return _popen(command, mode);
2800 #else
2801     dTHX;
2802     int p[2];
2803     int parent, child;
2804     int stdfd, oldfd;
2805     int ourmode;
2806     int childpid;
2807     DWORD nhandle;
2808     HANDLE old_h;
2809     int lock_held = 0;
2810
2811     /* establish which ends read and write */
2812     if (strchr(mode,'w')) {
2813         stdfd = 0;              /* stdin */
2814         parent = 1;
2815         child = 0;
2816         nhandle = STD_INPUT_HANDLE;
2817     }
2818     else if (strchr(mode,'r')) {
2819         stdfd = 1;              /* stdout */
2820         parent = 0;
2821         child = 1;
2822         nhandle = STD_OUTPUT_HANDLE;
2823     }
2824     else
2825         return NULL;
2826
2827     /* set the correct mode */
2828     if (strchr(mode,'b'))
2829         ourmode = O_BINARY;
2830     else if (strchr(mode,'t'))
2831         ourmode = O_TEXT;
2832     else
2833         ourmode = _fmode & (O_TEXT | O_BINARY);
2834
2835     /* the child doesn't inherit handles */
2836     ourmode |= O_NOINHERIT;
2837
2838     if (win32_pipe(p, 512, ourmode) == -1)
2839         return NULL;
2840
2841     /* save current stdfd */
2842     if ((oldfd = win32_dup(stdfd)) == -1)
2843         goto cleanup;
2844
2845     /* save the old std handle (this needs to happen before the
2846      * dup2(), since that might call SetStdHandle() too) */
2847     OP_REFCNT_LOCK;
2848     lock_held = 1;
2849     old_h = GetStdHandle(nhandle);
2850
2851     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2852     /* stdfd will be inherited by the child */
2853     if (win32_dup2(p[child], stdfd) == -1)
2854         goto cleanup;
2855
2856     /* close the child end in parent */
2857     win32_close(p[child]);
2858
2859     /* set the new std handle (in case dup2() above didn't) */
2860     SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2861
2862     /* start the child */
2863     {
2864         dTHX;
2865         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2866             goto cleanup;
2867
2868         /* revert stdfd to whatever it was before */
2869         if (win32_dup2(oldfd, stdfd) == -1)
2870             goto cleanup;
2871
2872         /* restore the old std handle (this needs to happen after the
2873          * dup2(), since that might call SetStdHandle() too */
2874         if (lock_held) {
2875             SetStdHandle(nhandle, old_h);
2876             OP_REFCNT_UNLOCK;
2877             lock_held = 0;
2878         }
2879
2880         /* close saved handle */
2881         win32_close(oldfd);
2882
2883         LOCK_FDPID_MUTEX;
2884         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2885         UNLOCK_FDPID_MUTEX;
2886
2887         /* set process id so that it can be returned by perl's open() */
2888         PL_forkprocess = childpid;
2889     }
2890
2891     /* we have an fd, return a file stream */
2892     return (PerlIO_fdopen(p[parent], (char *)mode));
2893
2894 cleanup:
2895     /* we don't need to check for errors here */
2896     win32_close(p[0]);
2897     win32_close(p[1]);
2898     if (lock_held) {
2899         SetStdHandle(nhandle, old_h);
2900         OP_REFCNT_UNLOCK;
2901         lock_held = 0;
2902     }
2903     if (oldfd != -1) {
2904         win32_dup2(oldfd, stdfd);
2905         win32_close(oldfd);
2906     }
2907     return (NULL);
2908
2909 #endif /* USE_RTL_POPEN */
2910 }
2911
2912 /*
2913  * pclose() clone
2914  */
2915
2916 DllExport int
2917 win32_pclose(PerlIO *pf)
2918 {
2919 #ifdef USE_RTL_POPEN
2920     return _pclose(pf);
2921 #else
2922     dTHX;
2923     int childpid, status;
2924     SV *sv;
2925
2926     LOCK_FDPID_MUTEX;
2927     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2928
2929     if (SvIOK(sv))
2930         childpid = SvIVX(sv);
2931     else
2932         childpid = 0;
2933
2934     if (!childpid) {
2935         errno = EBADF;
2936         return -1;
2937     }
2938
2939 #ifdef USE_PERLIO
2940     PerlIO_close(pf);
2941 #else
2942     fclose(pf);
2943 #endif
2944     SvIVX(sv) = 0;
2945     UNLOCK_FDPID_MUTEX;
2946
2947     if (win32_waitpid(childpid, &status, 0) == -1)
2948         return -1;
2949
2950     return status;
2951
2952 #endif /* USE_RTL_POPEN */
2953 }
2954
2955 static BOOL WINAPI
2956 Nt4CreateHardLinkW(
2957     LPCWSTR lpFileName,
2958     LPCWSTR lpExistingFileName,
2959     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2960 {
2961     HANDLE handle;
2962     WCHAR wFullName[MAX_PATH+1];
2963     LPVOID lpContext = NULL;
2964     WIN32_STREAM_ID StreamId;
2965     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2966     DWORD dwWritten;
2967     DWORD dwLen;
2968     BOOL bSuccess;
2969
2970     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2971                                      BOOL, BOOL, LPVOID*) =
2972         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2973                             BOOL, BOOL, LPVOID*))
2974         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2975     if (pfnBackupWrite == NULL)
2976         return 0;
2977
2978     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2979     if (dwLen == 0)
2980         return 0;
2981     dwLen = (dwLen+1)*sizeof(WCHAR);
2982
2983     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2984                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2985                          NULL, OPEN_EXISTING, 0, NULL);
2986     if (handle == INVALID_HANDLE_VALUE)
2987         return 0;
2988
2989     StreamId.dwStreamId = BACKUP_LINK;
2990     StreamId.dwStreamAttributes = 0;
2991     StreamId.dwStreamNameSize = 0;
2992 #if defined(__BORLANDC__) \
2993  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2994     StreamId.Size.u.HighPart = 0;
2995     StreamId.Size.u.LowPart = dwLen;
2996 #else
2997     StreamId.Size.HighPart = 0;
2998     StreamId.Size.LowPart = dwLen;
2999 #endif
3000
3001     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3002                               FALSE, FALSE, &lpContext);
3003     if (bSuccess) {
3004         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3005                                   FALSE, FALSE, &lpContext);
3006         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3007     }
3008
3009     CloseHandle(handle);
3010     return bSuccess;
3011 }
3012
3013 DllExport int
3014 win32_link(const char *oldname, const char *newname)
3015 {
3016     dTHX;
3017     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3018     WCHAR wOldName[MAX_PATH+1];
3019     WCHAR wNewName[MAX_PATH+1];
3020
3021     if (IsWin95())
3022         Perl_croak(aTHX_ PL_no_func, "link");
3023
3024     pfnCreateHardLinkW =
3025         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3026         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3027     if (pfnCreateHardLinkW == NULL)
3028         pfnCreateHardLinkW = Nt4CreateHardLinkW;
3029
3030     if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
3031         (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
3032         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3033         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3034     {
3035         return 0;
3036     }
3037     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3038     return -1;
3039 }
3040
3041 DllExport int
3042 win32_rename(const char *oname, const char *newname)
3043 {
3044     WCHAR wOldName[MAX_PATH+1];
3045     WCHAR wNewName[MAX_PATH+1];
3046     char szOldName[MAX_PATH+1];
3047     char szNewName[MAX_PATH+1];
3048     BOOL bResult;
3049     dTHX;
3050
3051     /* XXX despite what the documentation says about MoveFileEx(),
3052      * it doesn't work under Windows95!
3053      */
3054     if (IsWinNT()) {
3055         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3056         if (USING_WIDE()) {
3057             A2WHELPER(oname, wOldName, sizeof(wOldName));
3058             A2WHELPER(newname, wNewName, sizeof(wNewName));
3059             if (wcsicmp(wNewName, wOldName))
3060                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3061             wcscpy(wOldName, PerlDir_mapW(wOldName));
3062             bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
3063         }
3064         else {
3065             if (stricmp(newname, oname))
3066                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3067             strcpy(szOldName, PerlDir_mapA(oname));
3068             bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3069         }
3070         if (!bResult) {
3071             DWORD err = GetLastError();
3072             switch (err) {
3073             case ERROR_BAD_NET_NAME:
3074             case ERROR_BAD_NETPATH:
3075             case ERROR_BAD_PATHNAME:
3076             case ERROR_FILE_NOT_FOUND:
3077             case ERROR_FILENAME_EXCED_RANGE:
3078             case ERROR_INVALID_DRIVE:
3079             case ERROR_NO_MORE_FILES:
3080             case ERROR_PATH_NOT_FOUND:
3081                 errno = ENOENT;
3082                 break;
3083             default:
3084                 errno = EACCES;
3085                 break;
3086             }
3087             return -1;
3088         }
3089         return 0;
3090     }
3091     else {
3092         int retval = 0;
3093         char szTmpName[MAX_PATH+1];
3094         char dname[MAX_PATH+1];
3095         char *endname = Nullch;
3096         STRLEN tmplen = 0;
3097         DWORD from_attr, to_attr;
3098
3099         strcpy(szOldName, PerlDir_mapA(oname));
3100         strcpy(szNewName, PerlDir_mapA(newname));
3101
3102         /* if oname doesn't exist, do nothing */
3103         from_attr = GetFileAttributes(szOldName);
3104         if (from_attr == 0xFFFFFFFF) {
3105             errno = ENOENT;
3106             return -1;
3107         }
3108
3109         /* if newname exists, rename it to a temporary name so that we
3110          * don't delete it in case oname happens to be the same file
3111          * (but perhaps accessed via a different path)
3112          */
3113         to_attr = GetFileAttributes(szNewName);
3114         if (to_attr != 0xFFFFFFFF) {
3115             /* if newname is a directory, we fail
3116              * XXX could overcome this with yet more convoluted logic */
3117             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3118                 errno = EACCES;
3119                 return -1;
3120             }
3121             tmplen = strlen(szNewName);
3122             strcpy(szTmpName,szNewName);
3123             endname = szTmpName+tmplen;
3124             for (; endname > szTmpName ; --endname) {
3125                 if (*endname == '/' || *endname == '\\') {
3126                     *endname = '\0';
3127                     break;
3128                 }
3129             }
3130             if (endname > szTmpName)
3131                 endname = strcpy(dname,szTmpName);
3132             else
3133                 endname = ".";
3134
3135             /* get a temporary filename in same directory
3136              * XXX is this really the best we can do? */
3137             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3138                 errno = ENOENT;
3139                 return -1;
3140             }
3141             DeleteFile(szTmpName);
3142
3143             retval = rename(szNewName, szTmpName);
3144             if (retval != 0) {
3145                 errno = EACCES;
3146                 return retval;
3147             }
3148         }
3149
3150         /* rename oname to newname */
3151         retval = rename(szOldName, szNewName);
3152
3153         /* if we created a temporary file before ... */
3154         if (endname != Nullch) {
3155             /* ...and rename succeeded, delete temporary file/directory */
3156             if (retval == 0)
3157                 DeleteFile(szTmpName);
3158             /* else restore it to what it was */
3159             else
3160                 (void)rename(szTmpName, szNewName);
3161         }
3162         return retval;
3163     }
3164 }
3165
3166 DllExport int
3167 win32_setmode(int fd, int mode)
3168 {
3169     return setmode(fd, mode);
3170 }
3171
3172 DllExport int
3173 win32_chsize(int fd, Off_t size)
3174 {
3175 #if defined(WIN64) || defined(USE_LARGE_FILES)
3176     int retval = 0;
3177     Off_t cur, end, extend;
3178
3179     cur = win32_tell(fd);
3180     if (cur < 0)
3181         return -1;
3182     end = win32_lseek(fd, 0, SEEK_END);
3183     if (end < 0)
3184         return -1;
3185     extend = size - end;
3186     if (extend == 0) {
3187         /* do nothing */
3188     }
3189     else if (extend > 0) {
3190         /* must grow the file, padding with nulls */
3191         char b[4096];
3192         int oldmode = win32_setmode(fd, O_BINARY);
3193         size_t count;
3194         memset(b, '\0', sizeof(b));
3195         do {
3196             count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3197             count = win32_write(fd, b, count);
3198             if ((int)count < 0) {
3199                 retval = -1;
3200                 break;
3201             }
3202         } while ((extend -= count) > 0);
3203         win32_setmode(fd, oldmode);
3204     }
3205     else {
3206         /* shrink the file */
3207         win32_lseek(fd, size, SEEK_SET);
3208         if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3209             errno = EACCES;
3210             retval = -1;
3211         }
3212     }
3213 finish:
3214     win32_lseek(fd, cur, SEEK_SET);
3215     return retval;
3216 #else
3217     return chsize(fd, (long)size);
3218 #endif
3219 }
3220
3221 DllExport Off_t
3222 win32_lseek(int fd, Off_t offset, int origin)
3223 {
3224 #if defined(WIN64) || defined(USE_LARGE_FILES)
3225 #if defined(__BORLANDC__) /* buk */
3226     LARGE_INTEGER pos;
3227     pos.QuadPart = offset;
3228     pos.LowPart = SetFilePointer(
3229         (HANDLE)_get_osfhandle(fd),
3230         pos.LowPart,
3231         &pos.HighPart,
3232         origin
3233     );
3234     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3235         pos.QuadPart = -1;
3236     }
3237
3238     return pos.QuadPart;
3239 #else
3240     return _lseeki64(fd, offset, origin);
3241 #endif
3242 #else
3243     return lseek(fd, (long)offset, origin);
3244 #endif
3245 }
3246
3247 DllExport Off_t
3248 win32_tell(int fd)
3249 {
3250 #if defined(WIN64) || defined(USE_LARGE_FILES)
3251 #if defined(__BORLANDC__) /* buk */
3252     LARGE_INTEGER pos;
3253     pos.QuadPart = 0;
3254     pos.LowPart = SetFilePointer(
3255         (HANDLE)_get_osfhandle(fd),
3256         pos.LowPart,
3257         &pos.HighPart,
3258         FILE_CURRENT
3259     );
3260     if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3261         pos.QuadPart = -1;
3262     }
3263
3264     return pos.QuadPart;
3265     /* return tell(fd); */
3266 #else
3267     return _telli64(fd);
3268 #endif
3269 #else
3270     return tell(fd);
3271 #endif
3272 }
3273
3274 DllExport int
3275 win32_open(const char *path, int flag, ...)
3276 {
3277     dTHX;
3278     va_list ap;
3279     int pmode;
3280     WCHAR wBuffer[MAX_PATH+1];
3281
3282     va_start(ap, flag);
3283     pmode = va_arg(ap, int);
3284     va_end(ap);
3285
3286     if (stricmp(path, "/dev/null")==0)
3287         path = "NUL";
3288
3289     if (USING_WIDE()) {
3290         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3291         return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3292     }
3293     return open(PerlDir_mapA(path), flag, pmode);
3294 }
3295
3296 /* close() that understands socket */
3297 extern int my_close(int);       /* in win32sck.c */
3298
3299 DllExport int
3300 win32_close(int fd)
3301 {
3302     return my_close(fd);
3303 }
3304
3305 DllExport int
3306 win32_eof(int fd)
3307 {
3308     return eof(fd);
3309 }
3310
3311 DllExport int
3312 win32_dup(int fd)
3313 {
3314     return dup(fd);
3315 }
3316
3317 DllExport int
3318 win32_dup2(int fd1,int fd2)
3319 {
3320     return dup2(fd1,fd2);
3321 }
3322
3323 #ifdef PERL_MSVCRT_READFIX
3324
3325 #define LF              10      /* line feed */
3326 #define CR              13      /* carriage return */
3327 #define CTRLZ           26      /* ctrl-z means eof for text */
3328 #define FOPEN           0x01    /* file handle open */
3329 #define FEOFLAG         0x02    /* end of file has been encountered */
3330 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3331 #define FPIPE           0x08    /* file handle refers to a pipe */
3332 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3333 #define FDEV            0x40    /* file handle refers to device */
3334 #define FTEXT           0x80    /* file handle is in text mode */
3335 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3336
3337 int __cdecl
3338 _fixed_read(int fh, void *buf, unsigned cnt)
3339 {
3340     int bytes_read;                 /* number of bytes read */
3341     char *buffer;                   /* buffer to read to */
3342     int os_read;                    /* bytes read on OS call */
3343     char *p, *q;                    /* pointers into buffer */
3344     char peekchr;                   /* peek-ahead character */
3345     ULONG filepos;                  /* file position after seek */
3346     ULONG dosretval;                /* o.s. return value */
3347
3348     /* validate handle */
3349     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3350          !(_osfile(fh) & FOPEN))
3351     {
3352         /* out of range -- return error */
3353         errno = EBADF;
3354         _doserrno = 0;  /* not o.s. error */
3355         return -1;
3356     }
3357
3358     /*
3359      * If lockinitflag is FALSE, assume fd is device
3360      * lockinitflag is set to TRUE by open.
3361      */
3362     if (_pioinfo(fh)->lockinitflag)
3363         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3364
3365     bytes_read = 0;                 /* nothing read yet */
3366     buffer = (char*)buf;
3367
3368     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3369         /* nothing to read or at EOF, so return 0 read */
3370         goto functionexit;
3371     }
3372
3373     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3374         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3375          * char */
3376         *buffer++ = _pipech(fh);
3377         ++bytes_read;
3378         --cnt;
3379         _pipech(fh) = LF;           /* mark as empty */
3380     }
3381
3382     /* read the data */
3383
3384     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3385     {
3386         /* ReadFile has reported an error. recognize two special cases.
3387          *
3388          *      1. map ERROR_ACCESS_DENIED to EBADF
3389          *
3390          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3391          *         means the handle is a read-handle on a pipe for which
3392          *         all write-handles have been closed and all data has been
3393          *         read. */
3394
3395         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3396             /* wrong read/write mode should return EBADF, not EACCES */
3397             errno = EBADF;
3398             _doserrno = dosretval;
3399             bytes_read = -1;
3400             goto functionexit;
3401         }
3402         else if (dosretval == ERROR_BROKEN_PIPE) {
3403             bytes_read = 0;
3404             goto functionexit;
3405         }
3406         else {
3407             bytes_read = -1;
3408             goto functionexit;
3409         }
3410     }
3411
3412     bytes_read += os_read;          /* update bytes read */
3413
3414     if (_osfile(fh) & FTEXT) {
3415         /* now must translate CR-LFs to LFs in the buffer */
3416
3417         /* set CRLF flag to indicate LF at beginning of buffer */
3418         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3419         /*    _osfile(fh) |= FCRLF;                      */
3420         /* else                                          */
3421         /*    _osfile(fh) &= ~FCRLF;                     */
3422
3423         _osfile(fh) &= ~FCRLF;
3424
3425         /* convert chars in the buffer: p is src, q is dest */
3426         p = q = (char*)buf;
3427         while (p < (char *)buf + bytes_read) {
3428             if (*p == CTRLZ) {
3429                 /* if fh is not a device, set ctrl-z flag */
3430                 if (!(_osfile(fh) & FDEV))
3431                     _osfile(fh) |= FEOFLAG;
3432                 break;              /* stop translating */
3433             }
3434             else if (*p != CR)
3435                 *q++ = *p++;
3436             else {
3437                 /* *p is CR, so must check next char for LF */
3438                 if (p < (char *)buf + bytes_read - 1) {
3439                     if (*(p+1) == LF) {
3440                         p += 2;
3441                         *q++ = LF;  /* convert CR-LF to LF */
3442                     }
3443                     else
3444                         *q++ = *p++;    /* store char normally */
3445                 }
3446                 else {
3447                     /* This is the hard part.  We found a CR at end of
3448                        buffer.  We must peek ahead to see if next char
3449                        is an LF. */
3450                     ++p;
3451
3452                     dosretval = 0;
3453                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3454                                     (LPDWORD)&os_read, NULL))
3455                         dosretval = GetLastError();
3456
3457                     if (dosretval != 0 || os_read == 0) {
3458                         /* couldn't read ahead, store CR */
3459                         *q++ = CR;
3460                     }
3461                     else {
3462                         /* peekchr now has the extra character -- we now
3463                            have several possibilities:
3464                            1. disk file and char is not LF; just seek back
3465                               and copy CR
3466                            2. disk file and char is LF; store LF, don't seek back
3467                            3. pipe/device and char is LF; store LF.
3468                            4. pipe/device and char isn't LF, store CR and
3469                               put char in pipe lookahead buffer. */
3470                         if (_osfile(fh) & (FDEV|FPIPE)) {
3471                             /* non-seekable device */
3472                             if (peekchr == LF)
3473                                 *q++ = LF;
3474                             else {
3475                                 *q++ = CR;
3476                                 _pipech(fh) = peekchr;
3477                             }
3478                         }
3479                         else {
3480                             /* disk file */
3481                             if (peekchr == LF) {
3482                                 /* nothing read yet; must make some
3483                                    progress */
3484                                 *q++ = LF;
3485                                 /* turn on this flag for tell routine */
3486                                 _osfile(fh) |= FCRLF;
3487                             }
3488                             else {
3489                                 HANDLE osHandle;        /* o.s. handle value */
3490                                 /* seek back */
3491                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3492                                 {
3493                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3494                                         dosretval = GetLastError();
3495                                 }
3496                                 if (peekchr != LF)
3497                                     *q++ = CR;
3498                             }
3499                         }
3500                     }
3501                 }
3502             }
3503         }
3504
3505         /* we now change bytes_read to reflect the true number of chars
3506            in the buffer */
3507         bytes_read = q - (char *)buf;
3508     }
3509
3510 functionexit:
3511     if (_pioinfo(fh)->lockinitflag)
3512         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3513
3514     return bytes_read;
3515 }
3516
3517 #endif  /* PERL_MSVCRT_READFIX */
3518
3519 DllExport int
3520 win32_read(int fd, void *buf, unsigned int cnt)
3521 {
3522 #ifdef PERL_MSVCRT_READFIX
3523     return _fixed_read(fd, buf, cnt);
3524 #else
3525     return read(fd, buf, cnt);
3526 #endif
3527 }
3528
3529 DllExport int
3530 win32_write(int fd, const void *buf, unsigned int cnt)
3531 {
3532     return write(fd, buf, cnt);
3533 }
3534
3535 DllExport int
3536 win32_mkdir(const char *dir, int mode)
3537 {
3538     dTHX;
3539     if (USING_WIDE()) {
3540         WCHAR wBuffer[MAX_PATH+1];
3541         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3542         return _wmkdir(PerlDir_mapW(wBuffer));
3543     }
3544     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3545 }
3546
3547 DllExport int
3548 win32_rmdir(const char *dir)
3549 {
3550     dTHX;
3551     if (USING_WIDE()) {
3552         WCHAR wBuffer[MAX_PATH+1];
3553         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3554         return _wrmdir(PerlDir_mapW(wBuffer));
3555     }
3556     return rmdir(PerlDir_mapA(dir));
3557 }
3558
3559 DllExport int
3560 win32_chdir(const char *dir)
3561 {
3562     dTHX;
3563     if (!dir) {
3564         errno = ENOENT;
3565         return -1;
3566     }
3567     if (USING_WIDE()) {
3568         WCHAR wBuffer[MAX_PATH+1];
3569         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3570         return _wchdir(wBuffer);
3571     }
3572     return chdir(dir);
3573 }
3574
3575 DllExport  int
3576 win32_access(const char *path, int mode)
3577 {
3578     dTHX;
3579     if (USING_WIDE()) {
3580         WCHAR wBuffer[MAX_PATH+1];
3581         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3582         return _waccess(PerlDir_mapW(wBuffer), mode);
3583     }
3584     return access(PerlDir_mapA(path), mode);
3585 }
3586
3587 DllExport  int
3588 win32_chmod(const char *path, int mode)
3589 {
3590     dTHX;
3591     if (USING_WIDE()) {
3592         WCHAR wBuffer[MAX_PATH+1];
3593         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3594         return _wchmod(PerlDir_mapW(wBuffer), mode);
3595     }
3596     return chmod(PerlDir_mapA(path), mode);
3597 }
3598
3599
3600 static char *
3601 create_command_line(char *cname, STRLEN clen, const char * const *args)
3602 {
3603     dTHX;
3604     int index, argc;
3605     char *cmd, *ptr;
3606     const char *arg;
3607     STRLEN len = 0;
3608     bool bat_file = FALSE;
3609     bool cmd_shell = FALSE;
3610     bool dumb_shell = FALSE;
3611     bool extra_quotes = FALSE;
3612     bool quote_next = FALSE;
3613
3614     if (!cname)
3615         cname = (char*)args[0];
3616
3617     /* The NT cmd.exe shell has the following peculiarity that needs to be
3618      * worked around.  It strips a leading and trailing dquote when any
3619      * of the following is true:
3620      *    1. the /S switch was used
3621      *    2. there are more than two dquotes
3622      *    3. there is a special character from this set: &<>()@^|
3623      *    4. no whitespace characters within the two dquotes
3624      *    5. string between two dquotes isn't an executable file
3625      * To work around this, we always add a leading and trailing dquote
3626      * to the string, if the first argument is either "cmd.exe" or "cmd",
3627      * and there were at least two or more arguments passed to cmd.exe
3628      * (not including switches).
3629      * XXX the above rules (from "cmd /?") don't seem to be applied
3630      * always, making for the convolutions below :-(
3631      */
3632     if (cname) {
3633         if (!clen)
3634             clen = strlen(cname);
3635
3636         if (clen > 4
3637             && (stricmp(&cname[clen-4], ".bat") == 0
3638                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3639         {
3640             bat_file = TRUE;
3641             if (!IsWin95())
3642                 len += 3;
3643         }
3644         else {
3645             char *exe = strrchr(cname, '/');
3646             char *exe2 = strrchr(cname, '\\');
3647             if (exe2 > exe)
3648                 exe = exe2;
3649             if (exe)
3650                 ++exe;
3651             else
3652                 exe = cname;
3653             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3654                 cmd_shell = TRUE;
3655                 len += 3;
3656             }
3657             else if (stricmp(exe, "command.com") == 0
3658                      || stricmp(exe, "command") == 0)
3659             {
3660                 dumb_shell = TRUE;
3661             }
3662         }
3663     }
3664
3665     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3666     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3667         STRLEN curlen = strlen(arg);
3668         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3669             len += 2;   /* assume quoting needed (worst case) */
3670         len += curlen + 1;
3671         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3672     }
3673     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3674
3675     argc = index;
3676     Newx(cmd, len, char);
3677     ptr = cmd;
3678
3679     if (bat_file && !IsWin95()) {
3680         *ptr++ = '"';
3681         extra_quotes = TRUE;
3682     }
3683
3684     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3685         bool do_quote = 0;
3686         STRLEN curlen = strlen(arg);
3687
3688         /* we want to protect empty arguments and ones with spaces with
3689          * dquotes, but only if they aren't already there */
3690         if (!dumb_shell) {
3691             if (!curlen) {
3692                 do_quote = 1;
3693             }
3694             else if (quote_next) {
3695                 /* see if it really is multiple arguments pretending to
3696                  * be one and force a set of quotes around it */
3697                 if (*find_next_space(arg))
3698                     do_quote = 1;
3699             }
3700             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3701                 STRLEN i = 0;
3702                 while (i < curlen) {
3703                     if (isSPACE(arg[i])) {
3704                         do_quote = 1;
3705                     }
3706                     else if (arg[i] == '"') {
3707                         do_quote = 0;
3708                         break;
3709                     }
3710                     i++;
3711                 }
3712             }
3713         }
3714
3715         if (do_quote)
3716             *ptr++ = '"';
3717
3718         strcpy(ptr, arg);
3719         ptr += curlen;
3720
3721         if (do_quote)
3722             *ptr++ = '"';
3723
3724         if (args[index+1])
3725             *ptr++ = ' ';
3726
3727         if (!extra_quotes
3728             && cmd_shell
3729             && curlen >= 2
3730             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3731             && stricmp(arg+curlen-2, "/c") == 0)
3732         {
3733             /* is there a next argument? */
3734             if (args[index+1]) {
3735                 /* are there two or more next arguments? */
3736                 if (args[index+2]) {
3737                     *ptr++ = '"';
3738                     extra_quotes = TRUE;
3739                 }
3740                 else {
3741                     /* single argument, force quoting if it has spaces */
3742                     quote_next = TRUE;
3743                 }
3744             }
3745         }
3746     }
3747
3748     if (extra_quotes)
3749         *ptr++ = '"';
3750
3751     *ptr = '\0';
3752
3753     return cmd;
3754 }
3755
3756 static char *
3757 qualified_path(const char *cmd)
3758 {
3759     dTHX;
3760     char *pathstr;
3761     char *fullcmd, *curfullcmd;
3762     STRLEN cmdlen = 0;
3763     int has_slash = 0;
3764
3765     if (!cmd)
3766         return Nullch;
3767     fullcmd = (char*)cmd;
3768     while (*fullcmd) {
3769         if (*fullcmd == '/' || *fullcmd == '\\')
3770             has_slash++;
3771         fullcmd++;
3772         cmdlen++;
3773     }
3774
3775     /* look in PATH */
3776     pathstr = PerlEnv_getenv("PATH");
3777
3778     /* worst case: PATH is a single directory; we need additional space
3779      * to append "/", ".exe" and trailing "\0" */
3780     Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3781     curfullcmd = fullcmd;
3782
3783     while (1) {
3784         DWORD res;
3785
3786         /* start by appending the name to the current prefix */
3787         strcpy(curfullcmd, cmd);
3788         curfullcmd += cmdlen;
3789
3790         /* if it doesn't end with '.', or has no extension, try adding
3791          * a trailing .exe first */
3792         if (cmd[cmdlen-1] != '.'
3793             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3794         {
3795             strcpy(curfullcmd, ".exe");
3796             res = GetFileAttributes(fullcmd);
3797             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3798                 return fullcmd;
3799             *curfullcmd = '\0';
3800         }
3801
3802         /* that failed, try the bare name */
3803         res = GetFileAttributes(fullcmd);
3804         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3805             return fullcmd;
3806
3807         /* quit if no other path exists, or if cmd already has path */
3808         if (!pathstr || !*pathstr || has_slash)
3809             break;
3810
3811         /* skip leading semis */
3812         while (*pathstr == ';')
3813             pathstr++;
3814
3815         /* build a new prefix from scratch */
3816         curfullcmd = fullcmd;
3817         while (*pathstr && *pathstr != ';') {
3818             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3819                 pathstr++;              /* skip initial '"' */
3820                 while (*pathstr && *pathstr != '"') {
3821                     *curfullcmd++ = *pathstr++;
3822                 }
3823                 if (*pathstr)
3824                     pathstr++;          /* skip trailing '"' */
3825             }
3826             else {
3827                 *curfullcmd++ = *pathstr++;
3828             }
3829         }
3830         if (*pathstr)
3831             pathstr++;                  /* skip trailing semi */
3832         if (curfullcmd > fullcmd        /* append a dir separator */
3833             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3834         {
3835             *curfullcmd++ = '\\';
3836         }
3837     }
3838
3839     Safefree(fullcmd);
3840     return Nullch;
3841 }
3842
3843 /* The following are just place holders.
3844  * Some hosts may provide and environment that the OS is
3845  * not tracking, therefore, these host must provide that
3846  * environment and the current directory to CreateProcess
3847  */
3848
3849 DllExport void*
3850 win32_get_childenv(void)
3851 {
3852     return NULL;
3853 }
3854
3855 DllExport void
3856 win32_free_childenv(void* d)
3857 {
3858 }
3859
3860 DllExport void
3861 win32_clearenv(void)
3862 {
3863     char *envv = GetEnvironmentStrings();
3864     char *cur = envv;
3865     STRLEN len;
3866     while (*cur) {
3867         char *end = strchr(cur,'=');
3868         if (end && end != cur) {
3869             *end = '\0';
3870             SetEnvironmentVariable(cur, NULL);
3871             *end = '=';
3872             cur = end + strlen(end+1)+2;
3873         }
3874         else if ((len = strlen(cur)))
3875             cur += len+1;
3876     }
3877     FreeEnvironmentStrings(envv);
3878 }
3879
3880 DllExport char*
3881 win32_get_childdir(void)
3882 {
3883     dTHX;
3884     char* ptr;
3885     char szfilename[(MAX_PATH+1)*2];
3886     if (USING_WIDE()) {
3887         WCHAR wfilename[MAX_PATH+1];
3888         GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3889         W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3890     }
3891     else {
3892         GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3893     }
3894
3895     Newx(ptr, strlen(szfilename)+1, char);
3896     strcpy(ptr, szfilename);
3897     return ptr;
3898 }
3899
3900 DllExport void
3901 win32_free_childdir(char* d)
3902 {
3903     dTHX;
3904     Safefree(d);
3905 }
3906
3907
3908 /* XXX this needs to be made more compatible with the spawnvp()
3909  * provided by the various RTLs.  In particular, searching for
3910  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3911  * This doesn't significantly affect perl itself, because we
3912  * always invoke things using PERL5SHELL if a direct attempt to
3913  * spawn the executable fails.
3914  *
3915  * XXX splitting and rejoining the commandline between do_aspawn()
3916  * and win32_spawnvp() could also be avoided.
3917  */
3918
3919 DllExport int
3920 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3921 {
3922 #ifdef USE_RTL_SPAWNVP
3923     return spawnvp(mode, cmdname, (char * const *)argv);
3924 #else
3925     dTHX;
3926     int ret;
3927     void* env;
3928     char* dir;
3929     child_IO_table tbl;
3930     STARTUPINFO StartupInfo;
3931     PROCESS_INFORMATION ProcessInformation;
3932     DWORD create = 0;
3933     char *cmd;
3934     char *fullcmd = Nullch;
3935     char *cname = (char *)cmdname;
3936     STRLEN clen = 0;
3937
3938     if (cname) {
3939         clen = strlen(cname);
3940         /* if command name contains dquotes, must remove them */
3941         if (strchr(cname, '"')) {
3942             cmd = cname;
3943             Newx(cname,clen+1,char);
3944             clen = 0;
3945             while (*cmd) {
3946                 if (*cmd != '"') {
3947                     cname[clen] = *cmd;
3948                     ++clen;
3949                 }
3950                 ++cmd;
3951             }
3952             cname[clen] = '\0';
3953         }
3954     }
3955
3956     cmd = create_command_line(cname, clen, argv);
3957
3958     env = PerlEnv_get_childenv();
3959     dir = PerlEnv_get_childdir();
3960
3961     switch(mode) {
3962     case P_NOWAIT:      /* asynch + remember result */
3963         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3964             errno = EAGAIN;
3965             ret = -1;
3966             goto RETVAL;
3967         }
3968         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3969          * in win32_kill()
3970          */
3971         create |= CREATE_NEW_PROCESS_GROUP;
3972         /* FALL THROUGH */
3973
3974     case P_WAIT:        /* synchronous execution */
3975         break;
3976     default:            /* invalid mode */
3977         errno = EINVAL;
3978         ret = -1;
3979         goto RETVAL;
3980     }
3981     memset(&StartupInfo,0,sizeof(StartupInfo));
3982     StartupInfo.cb = sizeof(StartupInfo);
3983     memset(&tbl,0,sizeof(tbl));
3984     PerlEnv_get_child_IO(&tbl);
3985     StartupInfo.dwFlags         = tbl.dwFlags;
3986     StartupInfo.dwX             = tbl.dwX;
3987     StartupInfo.dwY             = tbl.dwY;
3988     StartupInfo.dwXSize         = tbl.dwXSize;
3989     StartupInfo.dwYSize         = tbl.dwYSize;
3990     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3991     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3992     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3993     StartupInfo.wShowWindow     = tbl.wShowWindow;
3994     StartupInfo.hStdInput       = tbl.childStdIn;
3995     StartupInfo.hStdOutput      = tbl.childStdOut;
3996     StartupInfo.hStdError       = tbl.childStdErr;
3997     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3998         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3999         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4000     {
4001         create |= CREATE_NEW_CONSOLE;
4002     }
4003     else {
4004         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4005     }
4006     if (w32_use_showwindow) {
4007         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4008         StartupInfo.wShowWindow = w32_showwindow;
4009     }
4010
4011     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4012                           cname,cmd));
4013 RETRY:
4014     if (!CreateProcess(cname,           /* search PATH to find executable */
4015                        cmd,             /* executable, and its arguments */
4016                        NULL,            /* process attributes */
4017                        NULL,            /* thread attributes */
4018                        TRUE,            /* inherit handles */
4019                        create,          /* creation flags */
4020                        (LPVOID)env,     /* inherit environment */
4021                        dir,             /* inherit cwd */
4022                        &StartupInfo,
4023                        &ProcessInformation))
4024     {
4025         /* initial NULL argument to CreateProcess() does a PATH
4026          * search, but it always first looks in the directory
4027          * where the current process was started, which behavior
4028          * is undesirable for backward compatibility.  So we
4029          * jump through our own hoops by picking out the path
4030          * we really want it to use. */
4031         if (!fullcmd) {
4032             fullcmd = qualified_path(cname);
4033             if (fullcmd) {
4034                 if (cname != cmdname)
4035                     Safefree(cname);
4036                 cname = fullcmd;
4037                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4038                                       "Retrying [%s] with same args\n",
4039                                       cname));
4040                 goto RETRY;
4041             }
4042         }
4043         errno = ENOENT;
4044         ret = -1;
4045         goto RETVAL;
4046     }
4047
4048     if (mode == P_NOWAIT) {
4049         /* asynchronous spawn -- store handle, return PID */
4050         ret = (int)ProcessInformation.dwProcessId;
4051         if (IsWin95() && ret < 0)
4052             ret = -ret;
4053
4054         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4055         w32_child_pids[w32_num_children] = (DWORD)ret;
4056         ++w32_num_children;
4057     }
4058     else  {
4059         DWORD status;
4060         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4061         /* FIXME: if msgwait returned due to message perhaps forward the
4062            "signal" to the process
4063          */
4064         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4065         ret = (int)status;
4066         CloseHandle(ProcessInformation.hProcess);
4067     }
4068
4069     CloseHandle(ProcessInformation.hThread);
4070
4071 RETVAL:
4072     PerlEnv_free_childenv(env);
4073     PerlEnv_free_childdir(dir);
4074     Safefree(cmd);
4075     if (cname != cmdname)
4076         Safefree(cname);
4077     return ret;
4078 #endif
4079 }
4080
4081 DllExport int
4082 win32_execv(const char *cmdname, const char *const *argv)
4083 {
4084 #ifdef USE_ITHREADS
4085     dTHX;
4086     /* if this is a pseudo-forked child, we just want to spawn
4087      * the new program, and return */
4088     if (w32_pseudo_id)
4089 #  ifdef __BORLANDC__
4090         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4091 #  else
4092         return spawnv(P_WAIT, cmdname, argv);
4093 #  endif
4094 #endif
4095 #ifdef __BORLANDC__
4096     return execv(cmdname, (char *const *)argv);
4097 #else
4098     return execv(cmdname, argv);
4099 #endif
4100 }
4101
4102 DllExport int
4103 win32_execvp(const char *cmdname, const char *const *argv)
4104 {
4105 #ifdef USE_ITHREADS
4106     dTHX;
4107     /* if this is a pseudo-forked child, we just want to spawn
4108      * the new program, and return */
4109     if (w32_pseudo_id) {
4110         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4111         if (status != -1) {
4112             my_exit(status);
4113             return 0;
4114         }
4115         else
4116             return status;
4117     }
4118 #endif
4119 #ifdef __BORLANDC__
4120     return execvp(cmdname, (char *const *)argv);
4121 #else
4122     return execvp(cmdname, argv);
4123 #endif
4124 }
4125
4126 DllExport void
4127 win32_perror(const char *str)
4128 {
4129     perror(str);
4130 }
4131
4132 DllExport void
4133 win32_setbuf(FILE *pf, char *buf)
4134 {
4135     setbuf(pf, buf);
4136 }
4137
4138 DllExport int
4139 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4140 {
4141     return setvbuf(pf, buf, type, size);
4142 }
4143
4144 DllExport int
4145 win32_flushall(void)
4146 {
4147     return flushall();
4148 }
4149
4150 DllExport int
4151 win32_fcloseall(void)
4152 {
4153     return fcloseall();
4154 }
4155
4156 DllExport char*
4157 win32_fgets(char *s, int n, FILE *pf)
4158 {
4159     return fgets(s, n, pf);
4160 }
4161
4162 DllExport char*
4163 win32_gets(char *s)
4164 {
4165     return gets(s);
4166 }
4167
4168 DllExport int
4169 win32_fgetc(FILE *pf)
4170 {
4171     return fgetc(pf);
4172 }
4173
4174 DllExport int
4175 win32_putc(int c, FILE *pf)
4176 {
4177     return putc(c,pf);
4178 }
4179
4180 DllExport int
4181 win32_puts(const char *s)
4182 {
4183     return puts(s);
4184 }
4185
4186 DllExport int
4187 win32_getchar(void)
4188 {
4189     return getchar();
4190 }
4191
4192 DllExport int
4193 win32_putchar(int c)
4194 {
4195     return putchar(c);
4196 }
4197
4198 #ifdef MYMALLOC
4199
4200 #ifndef USE_PERL_SBRK
4201
4202 static char *committed = NULL;          /* XXX threadead */
4203 static char *base      = NULL;          /* XXX threadead */
4204 static char *reserved  = NULL;          /* XXX threadead */
4205 static char *brk       = NULL;          /* XXX threadead */
4206 static DWORD pagesize  = 0;             /* XXX threadead */
4207
4208 void *
4209 sbrk(ptrdiff_t need)
4210 {
4211  void *result;
4212  if (!pagesize)
4213   {SYSTEM_INFO info;
4214    GetSystemInfo(&info);
4215    /* Pretend page size is larger so we don't perpetually
4216     * call the OS to commit just one page ...
4217     */
4218    pagesize = info.dwPageSize << 3;
4219   }
4220  if (brk+need >= reserved)
4221   {
4222    DWORD size = brk+need-reserved;
4223    char *addr;
4224    char *prev_committed = NULL;
4225    if (committed && reserved && committed < reserved)
4226     {
4227      /* Commit last of previous chunk cannot span allocations */
4228      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4229      if (addr)
4230       {
4231       /* Remember where we committed from in case we want to decommit later */
4232       prev_committed = committed;
4233       committed = reserved;
4234       }
4235     }
4236    /* Reserve some (more) space
4237     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4238     * this is only address space not memory...
4239     * Note this is a little sneaky, 1st call passes NULL as reserved
4240     * so lets system choose where we start, subsequent calls pass
4241     * the old end address so ask for a contiguous block
4242     */
4243 sbrk_reserve:
4244    if (size < 64*1024*1024)
4245     size = 64*1024*1024;
4246    size = ((size + pagesize - 1) / pagesize) * pagesize;
4247    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4248    if (addr)
4249     {
4250      reserved = addr+size;
4251      if (!base)
4252       base = addr;
4253      if (!committed)
4254       committed = base;
4255      if (!brk)
4256       brk = committed;
4257     }
4258    else if (reserved)
4259     {
4260       /* The existing block could not be extended far enough, so decommit
4261        * anything that was just committed above and start anew */
4262       if (prev_committed)
4263        {
4264        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4265         return (void *) -1;
4266        }
4267       reserved = base = committed = brk = NULL;
4268       size = need;
4269       goto sbrk_reserve;
4270     }
4271    else
4272     {
4273      return (void *) -1;
4274     }
4275   }
4276  result = brk;
4277  brk += need;
4278  if (brk > committed)
4279   {
4280    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4281    char *addr;
4282    if (committed+size > reserved)
4283     size = reserved-committed;
4284    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4285    if (addr)
4286     committed += size;
4287    else
4288     return (void *) -1;
4289   }
4290  return result;
4291 }
4292
4293 #endif
4294 #endif
4295
4296 DllExport void*
4297 win32_malloc(size_t size)
4298 {
4299     return malloc(size);
4300 }
4301
4302 DllExport void*
4303 win32_calloc(size_t numitems, size_t size)
4304 {
4305     return calloc(numitems,size);
4306 }
4307
4308 DllExport void*
4309 win32_realloc(void *block, size_t size)
4310 {
4311     return realloc(block,size);
4312 }
4313
4314 DllExport void
4315 win32_free(void *block)
4316 {
4317     free(block);
4318 }
4319
4320
4321 DllExport int
4322 win32_open_osfhandle(intptr_t handle, int flags)
4323 {
4324 #ifdef USE_FIXED_OSFHANDLE
4325     if (IsWin95())
4326         return my_open_osfhandle(handle, flags);
4327 #endif
4328     return _open_osfhandle(handle, flags);
4329 }
4330
4331 DllExport intptr_t
4332 win32_get_osfhandle(int fd)
4333 {
4334     return (intptr_t)_get_osfhandle(fd);
4335 }
4336
4337 DllExport FILE *
4338 win32_fdupopen(FILE *pf)
4339 {
4340     FILE* pfdup;
4341     fpos_t pos;
4342     char mode[3];
4343     int fileno = win32_dup(win32_fileno(pf));
4344
4345     /* open the file in the same mode */
4346 #ifdef __BORLANDC__
4347     if((pf)->flags & _F_READ) {
4348         mode[0] = 'r';
4349         mode[1] = 0;
4350     }
4351     else if((pf)->flags & _F_WRIT) {
4352         mode[0] = 'a';
4353         mode[1] = 0;
4354     }
4355     else if((pf)->flags & _F_RDWR) {
4356         mode[0] = 'r';
4357         mode[1] = '+';
4358         mode[2] = 0;
4359     }
4360 #else
4361     if((pf)->_flag & _IOREAD) {
4362         mode[0] = 'r';
4363         mode[1] = 0;
4364     }
4365     else if((pf)->_flag & _IOWRT) {
4366         mode[0] = 'a';
4367         mode[1] = 0;
4368     }
4369     else if((pf)->_flag & _IORW) {
4370         mode[0] = 'r';
4371         mode[1] = '+';
4372         mode[2] = 0;
4373     }
4374 #endif
4375
4376     /* it appears that the binmode is attached to the
4377      * file descriptor so binmode files will be handled
4378      * correctly
4379      */
4380     pfdup = win32_fdopen(fileno, mode);
4381
4382     /* move the file pointer to the same position */
4383     if (!fgetpos(pf, &pos)) {
4384         fsetpos(pfdup, &pos);
4385     }
4386     return pfdup;
4387 }
4388
4389 DllExport void*
4390 win32_dynaload(const char* filename)
4391 {
4392     dTHX;
4393     HMODULE hModule;
4394     char buf[MAX_PATH+1];
4395     char *first;
4396
4397     /* LoadLibrary() doesn't recognize forward slashes correctly,
4398      * so turn 'em back. */
4399     first = strchr(filename, '/');
4400     if (first) {
4401         STRLEN len = strlen(filename);
4402         if (len <= MAX_PATH) {
4403             strcpy(buf, filename);
4404             filename = &buf[first - filename];
4405             while (*filename) {
4406                 if (*filename == '/')
4407                     *(char*)filename = '\\';
4408                 ++filename;
4409             }
4410             filename = buf;
4411         }
4412     }
4413     if (USING_WIDE()) {
4414         WCHAR wfilename[MAX_PATH+1];
4415         A2WHELPER(filename, wfilename, sizeof(wfilename));
4416         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4417     }
4418     else {
4419         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4420     }
4421     return hModule;
4422 }
4423
4424 /*
4425  * Extras.
4426  */
4427
4428 static
4429 XS(w32_SetChildShowWindow)
4430 {
4431     dXSARGS;
4432     BOOL use_showwindow = w32_use_showwindow;
4433     /* use "unsigned short" because Perl has redefined "WORD" */
4434     unsigned short showwindow = w32_showwindow;
4435
4436     if (items > 1)
4437         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4438
4439     if (items == 0 || !SvOK(ST(0)))
4440         w32_use_showwindow = FALSE;
4441     else {
4442         w32_use_showwindow = TRUE;
4443         w32_showwindow = (unsigned short)SvIV(ST(0));
4444     }
4445
4446     EXTEND(SP, 1);
4447     if (use_showwindow)
4448         ST(0) = sv_2mortal(newSViv(showwindow));
4449     else
4450         ST(0) = &PL_sv_undef;
4451     XSRETURN(1);
4452 }
4453
4454 static
4455 XS(w32_GetCwd)
4456 {
4457     dXSARGS;
4458     /* Make the host for current directory */
4459     char* ptr = PerlEnv_get_childdir();
4460     /*
4461      * If ptr != Nullch
4462      *   then it worked, set PV valid,
4463      *   else return 'undef'
4464      */
4465     if (ptr) {
4466         SV *sv = sv_newmortal();
4467         sv_setpv(sv, ptr);
4468         PerlEnv_free_childdir(ptr);
4469
4470 #ifndef INCOMPLETE_TAINTS
4471         SvTAINTED_on(sv);
4472 #endif
4473
4474         EXTEND(SP,1);
4475         SvPOK_on(sv);
4476         ST(0) = sv;
4477         XSRETURN(1);
4478     }
4479     XSRETURN_UNDEF;
4480 }
4481
4482 static
4483 XS(w32_SetCwd)
4484 {
4485     dXSARGS;
4486     if (items != 1)
4487         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4488     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4489         XSRETURN_YES;
4490
4491     XSRETURN_NO;
4492 }
4493
4494 static
4495 XS(w32_GetNextAvailDrive)
4496 {
4497     dXSARGS;
4498     char ix = 'C';
4499     char root[] = "_:\\";
4500
4501     EXTEND(SP,1);
4502     while (ix <= 'Z') {
4503         root[0] = ix++;
4504         if (GetDriveType(root) == 1) {
4505             root[2] = '\0';
4506             XSRETURN_PV(root);
4507         }
4508     }
4509     XSRETURN_UNDEF;
4510 }
4511
4512 static
4513 XS(w32_GetLastError)
4514 {
4515     dXSARGS;
4516     EXTEND(SP,1);
4517     XSRETURN_IV(GetLastError());
4518 }
4519
4520 static
4521 XS(w32_SetLastError)
4522 {
4523     dXSARGS;
4524     if (items != 1)
4525         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4526     SetLastError(SvIV(ST(0)));
4527     XSRETURN_EMPTY;
4528 }
4529
4530 static
4531 XS(w32_LoginName)
4532 {
4533     dXSARGS;
4534     char *name = w32_getlogin_buffer;
4535     DWORD size = sizeof(w32_getlogin_buffer);
4536     EXTEND(SP,1);
4537     if (GetUserName(name,&size)) {
4538         /* size includes NULL */
4539         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4540         XSRETURN(1);
4541     }
4542     XSRETURN_UNDEF;
4543 }
4544
4545 static
4546 XS(w32_NodeName)
4547 {
4548     dXSARGS;
4549     char name[MAX_COMPUTERNAME_LENGTH+1];
4550     DWORD size = sizeof(name);
4551     EXTEND(SP,1);
4552     if (GetComputerName(name,&size)) {
4553         /* size does NOT include NULL :-( */
4554         ST(0) = sv_2mortal(newSVpvn(name,size));
4555         XSRETURN(1);
4556     }
4557     XSRETURN_UNDEF;
4558 }
4559
4560
4561 static
4562 XS(w32_DomainName)
4563 {
4564     dXSARGS;
4565     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4566     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4567     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4568                                           void *bufptr);
4569
4570     if (hNetApi32) {
4571         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4572             GetProcAddress(hNetApi32, "NetApiBufferFree");
4573         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4574             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4575     }
4576     EXTEND(SP,1);
4577     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4578         /* this way is more reliable, in case user has a local account. */
4579         char dname[256];
4580         DWORD dnamelen = sizeof(dname);
4581         struct {
4582             DWORD   wki100_platform_id;
4583             LPWSTR  wki100_computername;
4584             LPWSTR  wki100_langroup;
4585             DWORD   wki100_ver_major;
4586             DWORD   wki100_ver_minor;
4587         } *pwi;
4588         /* NERR_Success *is* 0*/
4589         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4590             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4591                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4592                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4593             }
4594             else {
4595                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4596                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4597             }
4598             pfnNetApiBufferFree(pwi);
4599             FreeLibrary(hNetApi32);
4600             XSRETURN_PV(dname);
4601         }
4602         FreeLibrary(hNetApi32);
4603     }
4604     else {
4605         /* Win95 doesn't have NetWksta*(), so do it the old way */
4606         char name[256];
4607         DWORD size = sizeof(name);
4608         if (hNetApi32)
4609             FreeLibrary(hNetApi32);
4610         if (GetUserName(name,&size)) {
4611             char sid[ONE_K_BUFSIZE];
4612             DWORD sidlen = sizeof(sid);
4613             char dname[256];
4614             DWORD dnamelen = sizeof(dname);
4615             SID_NAME_USE snu;
4616             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4617                                   dname, &dnamelen, &snu)) {
4618                 XSRETURN_PV(dname);             /* all that for this */
4619             }
4620         }
4621     }
4622     XSRETURN_UNDEF;
4623 }
4624
4625 static
4626 XS(w32_FsType)
4627 {
4628     dXSARGS;
4629     char fsname[256];
4630     DWORD flags, filecomplen;
4631     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4632                          &flags, fsname, sizeof(fsname))) {
4633         if (GIMME_V == G_ARRAY) {
4634             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4635             XPUSHs(sv_2mortal(newSViv(flags)));
4636             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4637             PUTBACK;
4638             return;
4639         }
4640         EXTEND(SP,1);
4641         XSRETURN_PV(fsname);
4642     }
4643     XSRETURN_EMPTY;
4644 }
4645
4646 static
4647 XS(w32_GetOSVersion)
4648 {
4649     dXSARGS;
4650     /* Use explicit struct definition because wSuiteMask and
4651      * wProductType are not defined in the VC++ 6.0 headers.
4652      * WORD type has been replaced by unsigned short because
4653      * WORD is already used by Perl itself.
4654      */
4655     struct {
4656         DWORD dwOSVersionInfoSize;
4657         DWORD dwMajorVersion;
4658         DWORD dwMinorVersion;
4659         DWORD dwBuildNumber;
4660         DWORD dwPlatformId;
4661         CHAR  szCSDVersion[128];
4662         unsigned short wServicePackMajor;
4663         unsigned short wServicePackMinor;
4664         unsigned short wSuiteMask;
4665         BYTE  wProductType;
4666         BYTE  wReserved;
4667     }   osver;
4668     BOOL bEx = TRUE;
4669
4670     if (USING_WIDE()) {
4671         struct {
4672             DWORD dwOSVersionInfoSize;
4673             DWORD dwMajorVersion;
4674             DWORD dwMinorVersion;
4675             DWORD dwBuildNumber;
4676             DWORD dwPlatformId;
4677             WCHAR szCSDVersion[128];
4678             unsigned short wServicePackMajor;
4679             unsigned short wServicePackMinor;
4680             unsigned short wSuiteMask;
4681             BYTE  wProductType;
4682             BYTE  wReserved;
4683         } osverw;
4684         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4685         osverw.dwOSVersionInfoSize = sizeof(osverw);
4686         if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4687             bEx = FALSE;
4688             osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4689             if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4690                 XSRETURN_EMPTY;
4691             }
4692         }
4693         if (GIMME_V == G_SCALAR) {
4694             XSRETURN_IV(osverw.dwPlatformId);
4695         }
4696         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4697         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4698         osver.dwMajorVersion    = osverw.dwMajorVersion;
4699         osver.dwMinorVersion    = osverw.dwMinorVersion;
4700         osver.dwBuildNumber     = osverw.dwBuildNumber;
4701         osver.dwPlatformId      = osverw.dwPlatformId;
4702         osver.wServicePackMajor = osverw.wServicePackMajor;
4703         osver.wServicePackMinor = osverw.wServicePackMinor;
4704         osver.wSuiteMask        = osverw.wSuiteMask;
4705         osver.wProductType      = osverw.wProductType;
4706     }
4707     else {
4708         osver.dwOSVersionInfoSize = sizeof(osver);
4709         if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4710             bEx = FALSE;
4711             osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4712             if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4713                 XSRETURN_EMPTY;
4714             }
4715         }
4716         if (GIMME_V == G_SCALAR) {
4717             XSRETURN_IV(osver.dwPlatformId);
4718         }
4719         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4720     }
4721     XPUSHs(newSViv(osver.dwMajorVersion));
4722     XPUSHs(newSViv(osver.dwMinorVersion));
4723     XPUSHs(newSViv(osver.dwBuildNumber));
4724     XPUSHs(newSViv(osver.dwPlatformId));
4725     if (bEx) {
4726         XPUSHs(newSViv(osver.wServicePackMajor));
4727         XPUSHs(newSViv(osver.wServicePackMinor));
4728         XPUSHs(newSViv(osver.wSuiteMask));
4729         XPUSHs(newSViv(osver.wProductType));
4730     }
4731     PUTBACK;
4732 }
4733
4734 static
4735 XS(w32_IsWinNT)
4736 {
4737     dXSARGS;
4738     EXTEND(SP,1);
4739     XSRETURN_IV(IsWinNT());
4740 }
4741
4742 static
4743 XS(w32_IsWin95)
4744 {
4745     dXSARGS;
4746     EXTEND(SP,1);
4747     XSRETURN_IV(IsWin95());
4748 }
4749
4750 static
4751 XS(w32_FormatMessage)
4752 {
4753     dXSARGS;
4754     DWORD source = 0;
4755     char msgbuf[ONE_K_BUFSIZE];
4756
4757     if (items != 1)
4758         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4759
4760     if (USING_WIDE()) {
4761         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4762         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4763                           &source, SvIV(ST(0)), 0,
4764                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4765         {
4766             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4767             XSRETURN_PV(msgbuf);
4768         }
4769     }
4770     else {
4771         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4772                           &source, SvIV(ST(0)), 0,
4773                           msgbuf, sizeof(msgbuf)-1, NULL))
4774             XSRETURN_PV(msgbuf);
4775     }
4776
4777     XSRETURN_UNDEF;
4778 }
4779
4780 static
4781 XS(w32_Spawn)
4782 {
4783     dXSARGS;
4784     char *cmd, *args;
4785     void *env;
4786     char *dir;
4787     PROCESS_INFORMATION stProcInfo;
4788     STARTUPINFO stStartInfo;
4789     BOOL bSuccess = FALSE;
4790
4791     if (items != 3)
4792         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4793
4794     cmd = SvPV_nolen(ST(0));
4795     args = SvPV_nolen(ST(1));
4796
4797     env = PerlEnv_get_childenv();
4798     dir = PerlEnv_get_childdir();
4799
4800     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4801     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4802     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4803     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4804
4805     if (CreateProcess(
4806                 cmd,                    /* Image path */
4807                 args,                   /* Arguments for command line */
4808                 NULL,                   /* Default process security */
4809                 NULL,                   /* Default thread security */
4810                 FALSE,                  /* Must be TRUE to use std handles */
4811                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4812                 env,                    /* Inherit our environment block */
4813                 dir,                    /* Inherit our currrent directory */
4814                 &stStartInfo,           /* -> Startup info */
4815                 &stProcInfo))           /* <- Process info (if OK) */
4816     {
4817         int pid = (int)stProcInfo.dwProcessId;
4818         if (IsWin95() && pid < 0)
4819             pid = -pid;
4820         sv_setiv(ST(2), pid);
4821         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4822         bSuccess = TRUE;
4823     }
4824     PerlEnv_free_childenv(env);
4825     PerlEnv_free_childdir(dir);
4826     XSRETURN_IV(bSuccess);
4827 }
4828
4829 static
4830 XS(w32_GetTickCount)
4831 {
4832     dXSARGS;
4833     DWORD msec = GetTickCount();
4834     EXTEND(SP,1);
4835     if ((IV)msec > 0)
4836         XSRETURN_IV(msec);
4837     XSRETURN_NV(msec);
4838 }
4839
4840 static
4841 XS(w32_GetShortPathName)
4842 {
4843     dXSARGS;
4844     SV *shortpath;
4845     DWORD len;
4846
4847     if (items != 1)
4848         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4849
4850     shortpath = sv_mortalcopy(ST(0));
4851     SvUPGRADE(shortpath, SVt_PV);
4852     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4853         XSRETURN_UNDEF;
4854
4855     /* src == target is allowed */
4856     do {
4857         len = GetShortPathName(SvPVX(shortpath),
4858                                SvPVX(shortpath),
4859                                SvLEN(shortpath));
4860     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4861     if (len) {
4862         SvCUR_set(shortpath,len);
4863         *SvEND(shortpath) = '\0';
4864         ST(0) = shortpath;
4865         XSRETURN(1);
4866     }
4867     XSRETURN_UNDEF;
4868 }
4869
4870 static
4871 XS(w32_GetFullPathName)
4872 {
4873     dXSARGS;
4874     SV *filename;
4875     SV *fullpath;
4876     char *filepart;
4877     DWORD len;
4878     STRLEN filename_len;
4879     char *filename_p;
4880
4881     if (items != 1)
4882         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4883
4884     filename = ST(0);
4885     filename_p = SvPV(filename, filename_len);
4886     fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4887     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4888         XSRETURN_UNDEF;
4889
4890     do {
4891         len = GetFullPathName(SvPVX(filename),
4892                               SvLEN(fullpath),
4893                               SvPVX(fullpath),
4894                               &filepart);
4895     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4896     if (len) {
4897         if (GIMME_V == G_ARRAY) {
4898             EXTEND(SP,1);
4899             if (filepart) {
4900                 XST_mPV(1,filepart);
4901                 len = filepart - SvPVX(fullpath);
4902             }
4903             else {
4904                 XST_mPVN(1,"",0);
4905             }
4906             items = 2;
4907         }
4908         SvCUR_set(fullpath,len);
4909         *SvEND(fullpath) = '\0';
4910         ST(0) = fullpath;
4911         XSRETURN(items);
4912     }
4913     XSRETURN_EMPTY;
4914 }
4915
4916 static
4917 XS(w32_GetLongPathName)
4918 {
4919     dXSARGS;
4920     SV *path;
4921     char tmpbuf[MAX_PATH+1];
4922     char *pathstr;
4923     STRLEN len;
4924
4925     if (items != 1)
4926         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4927
4928     path = ST(0);
4929     pathstr = SvPV(path,len);
4930     strcpy(tmpbuf, pathstr);
4931     pathstr = win32_longpath(tmpbuf);
4932     if (pathstr) {
4933         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4934         XSRETURN(1);
4935     }
4936     XSRETURN_EMPTY;
4937 }
4938
4939 static
4940 XS(w32_Sleep)
4941 {
4942     dXSARGS;
4943     if (items != 1)
4944         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4945     Sleep(SvIV(ST(0)));
4946     XSRETURN_YES;
4947 }
4948
4949 static
4950 XS(w32_CopyFile)
4951 {
4952     dXSARGS;
4953     BOOL bResult;
4954     if (items != 3)
4955         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4956     if (USING_WIDE()) {
4957         WCHAR wSourceFile[MAX_PATH+1];
4958         WCHAR wDestFile[MAX_PATH+1];
4959         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4960         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4961         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4962         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4963     }
4964     else {
4965         char szSourceFile[MAX_PATH+1];
4966         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4967         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4968     }
4969
4970     if (bResult)
4971         XSRETURN_YES;
4972     XSRETURN_NO;
4973 }
4974
4975 void
4976 Perl_init_os_extras(void)
4977 {
4978     dTHX;
4979     char *file = __FILE__;
4980     dXSUB_SYS;
4981
4982     /* these names are Activeware compatible */
4983     newXS("Win32::GetCwd", w32_GetCwd, file);
4984     newXS("Win32::SetCwd", w32_SetCwd, file);
4985     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4986     newXS("Win32::GetLastError", w32_GetLastError, file);
4987     newXS("Win32::SetLastError", w32_SetLastError, file);
4988     newXS("Win32::LoginName", w32_LoginName, file);
4989     newXS("Win32::NodeName", w32_NodeName, file);
4990     newXS("Win32::DomainName", w32_DomainName, file);
4991     newXS("Win32::FsType", w32_FsType, file);
4992     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4993     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4994     newXS("Win32::IsWin95", w32_IsWin95, file);
4995     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4996     newXS("Win32::Spawn", w32_Spawn, file);
4997     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4998     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4999     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
5000     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
5001     newXS("Win32::CopyFile", w32_CopyFile, file);
5002     newXS("Win32::Sleep", w32_Sleep, file);
5003     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
5004
5005     /* XXX Bloat Alert! The following Activeware preloads really
5006      * ought to be part of Win32::Sys::*, so they're not included
5007      * here.
5008      */
5009     /* LookupAccountName
5010      * LookupAccountSID
5011      * InitiateSystemShutdown
5012      * AbortSystemShutdown
5013      * ExpandEnvrironmentStrings
5014      */
5015 }
5016
5017 void *
5018 win32_signal_context(void)
5019 {
5020     dTHX;
5021 #ifdef MULTIPLICITY
5022     if (!my_perl) {
5023         my_perl = PL_curinterp;
5024         PERL_SET_THX(my_perl);
5025     }
5026     return my_perl;
5027 #else
5028     return PL_curinterp;
5029 #endif
5030 }
5031
5032
5033 BOOL WINAPI
5034 win32_ctrlhandler(DWORD dwCtrlType)
5035 {
5036 #ifdef MULTIPLICITY
5037     dTHXa(PERL_GET_SIG_CONTEXT);
5038
5039     if (!my_perl)
5040         return FALSE;
5041 #endif
5042
5043     switch(dwCtrlType) {
5044     case CTRL_CLOSE_EVENT:
5045      /*  A signal that the system sends to all processes attached to a console when
5046          the user closes the console (either by choosing the Close command from the
5047          console window's System menu, or by choosing the End Task command from the
5048          Task List
5049       */
5050         if (do_raise(aTHX_ 1))        /* SIGHUP */
5051             sig_terminate(aTHX_ 1);
5052         return TRUE;
5053
5054     case CTRL_C_EVENT:
5055         /*  A CTRL+c signal was received */
5056         if (do_raise(aTHX_ SIGINT))
5057             sig_terminate(aTHX_ SIGINT);
5058         return TRUE;
5059
5060     case CTRL_BREAK_EVENT:
5061         /*  A CTRL+BREAK signal was received */
5062         if (do_raise(aTHX_ SIGBREAK))
5063             sig_terminate(aTHX_ SIGBREAK);
5064         return TRUE;
5065
5066     case CTRL_LOGOFF_EVENT:
5067       /*  A signal that the system sends to all console processes when a user is logging
5068           off. This signal does not indicate which user is logging off, so no
5069           assumptions can be made.
5070        */
5071         break;
5072     case CTRL_SHUTDOWN_EVENT:
5073       /*  A signal that the system sends to all console processes when the system is
5074           shutting down.
5075        */
5076         if (do_raise(aTHX_ SIGTERM))
5077             sig_terminate(aTHX_ SIGTERM);
5078         return TRUE;
5079     default:
5080         break;
5081     }
5082     return FALSE;
5083 }
5084
5085
5086 void
5087 Perl_win32_init(int *argcp, char ***argvp)
5088 {
5089     /* Disable floating point errors, Perl will trap the ones we
5090      * care about.  VC++ RTL defaults to switching these off
5091      * already, but the Borland RTL doesn't.  Since we don't
5092      * want to be at the vendor's whim on the default, we set
5093      * it explicitly here.
5094      */
5095 #if !defined(_ALPHA_) && !defined(__GNUC__)
5096     _control87(MCW_EM, MCW_EM);
5097 #endif
5098     MALLOC_INIT;
5099 }
5100
5101 void
5102 Perl_win32_term(void)
5103 {
5104     OP_REFCNT_TERM;
5105     MALLOC_TERM;
5106 }
5107
5108 void
5109 win32_get_child_IO(child_IO_table* ptbl)
5110 {
5111     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
5112     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
5113     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
5114 }
5115
5116 Sighandler_t
5117 win32_signal(int sig, Sighandler_t subcode)
5118 {
5119     dTHX;
5120     if (sig < SIG_SIZE) {
5121         int save_errno = errno;
5122         Sighandler_t result = signal(sig, subcode);
5123         if (result == SIG_ERR) {
5124             result = w32_sighandler[sig];
5125             errno = save_errno;
5126         }
5127         w32_sighandler[sig] = subcode;
5128         return result;
5129     }
5130     else {
5131         errno = EINVAL;
5132         return SIG_ERR;
5133     }
5134 }
5135
5136
5137 #ifdef HAVE_INTERP_INTERN
5138
5139
5140 static void
5141 win32_csighandler(int sig)
5142 {
5143 #if 0
5144     dTHXa(PERL_GET_SIG_CONTEXT);
5145     Perl_warn(aTHX_ "Got signal %d",sig);
5146 #endif
5147     /* Does nothing */
5148 }
5149
5150 void
5151 Perl_sys_intern_init(pTHX)
5152 {
5153     int i;
5154     w32_perlshell_tokens        = Nullch;
5155     w32_perlshell_vec           = (char**)NULL;
5156     w32_perlshell_items         = 0;
5157     w32_fdpid                   = newAV();
5158     Newx(w32_children, 1, child_tab);
5159     w32_num_children            = 0;
5160 #  ifdef USE_ITHREADS
5161     w32_pseudo_id               = 0;
5162     Newx(w32_pseudo_children, 1, child_tab);
5163     w32_num_pseudo_children     = 0;
5164 #  endif
5165     w32_timerid                 = 0;
5166     w32_poll_count              = 0;
5167     for (i=0; i < SIG_SIZE; i++) {
5168         w32_sighandler[i] = SIG_DFL;
5169     }
5170 #  ifdef MULTIPLICTY
5171     if (my_perl == PL_curinterp) {
5172 #  else
5173     {
5174 #  endif
5175         /* Force C runtime signal stuff to set its console handler */
5176         signal(SIGINT,win32_csighandler);
5177         signal(SIGBREAK,win32_csighandler);
5178         /* Push our handler on top */
5179         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5180     }
5181 }
5182
5183 void
5184 Perl_sys_intern_clear(pTHX)
5185 {
5186     Safefree(w32_perlshell_tokens);
5187     Safefree(w32_perlshell_vec);
5188     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5189     Safefree(w32_children);
5190     if (w32_timerid) {
5191         KillTimer(NULL,w32_timerid);
5192         w32_timerid=0;
5193     }
5194 #  ifdef MULTIPLICITY
5195     if (my_perl == PL_curinterp) {
5196 #  else
5197     {
5198 #  endif
5199         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5200     }
5201 #  ifdef USE_ITHREADS
5202     Safefree(w32_pseudo_children);
5203 #  endif
5204 }
5205
5206 #  ifdef USE_ITHREADS
5207
5208 void
5209 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5210 {
5211     dst->perlshell_tokens       = Nullch;
5212     dst->perlshell_vec          = (char**)NULL;
5213     dst->perlshell_items        = 0;
5214     dst->fdpid                  = newAV();
5215     Newxz(dst->children, 1, child_tab);
5216     dst->pseudo_id              = 0;
5217     Newxz(dst->pseudo_children, 1, child_tab);
5218     dst->timerid                 = 0;
5219     dst->poll_count              = 0;
5220     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5221 }
5222 #  endif /* USE_ITHREADS */
5223 #endif /* HAVE_INTERP_INTERN */
5224
5225 static void
5226 win32_free_argvw(pTHX_ void *ptr)
5227 {
5228     char** argv = (char**)ptr;
5229     while(*argv) {
5230         Safefree(*argv);
5231         *argv++ = Nullch;
5232     }
5233 }
5234
5235 void
5236 win32_argv2utf8(int argc, char** argv)
5237 {
5238     dTHX;
5239     char* psz;
5240     int length, wargc;
5241     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5242     if (lpwStr && argc) {
5243         while (argc--) {
5244             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5245             Newxz(psz, length, char);
5246             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5247             argv[argc] = psz;
5248         }
5249         call_atexit(win32_free_argvw, argv);
5250     }
5251     GlobalFree((HGLOBAL)lpwStr);
5252 }