win32/win32.c

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