win32/win32.c

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