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