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 message queue */
1098                 if (PostThreadMessage(-pid,WM_USER,sig,0)) {
1099                     /* It might be us ... */
1100                     PERL_ASYNC_CHECK();
1101                     return 0;
1102                 }
1103                 break;
1104             }
1105         }
1106         else if (IsWin95()) {
1107             pid = -pid;
1108             goto alien_process;
1109         }
1110     }
1111     else
1112 #endif
1113     {
1114         child = find_pid(pid);
1115         if (child >= 0) {
1116             hProcess = w32_child_handles[child];
1117             switch(sig) {
1118             case 0:
1119                 /* "Does process exist?" use of kill */
1120                 return 0;
1121             case 2:
1122                 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1123                     return 0;
1124                 break;
1125             default: /* For now be backwards compatible with perl5.6 */
1126             case 9:
1127                 if (TerminateProcess(hProcess, sig)) {
1128                     remove_dead_process(child);
1129                     return 0;
1130                 }
1131                 break;
1132             }
1133         }
1134         else {
1135 alien_process:
1136             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1137                                    (IsWin95() ? -pid : pid));
1138             if (hProcess) {
1139                 switch(sig) {
1140                 case 0:
1141                     /* "Does process exist?" use of kill */
1142                     return 0;
1143                 case 2:
1144                     if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1145                         return 0;
1146                     break;
1147                 default: /* For now be backwards compatible with perl5.6 */
1148                 case 9:
1149                     if (TerminateProcess(hProcess, sig)) {
1150                         CloseHandle(hProcess);
1151                         return 0;
1152                     }
1153                 }
1154             }
1155         }
1156     }
1157     errno = EINVAL;
1158     return -1;
1159 }
1160
1161 DllExport int
1162 win32_stat(const char *path, struct stat *sbuf)
1163 {
1164     dTHX;
1165     char        buffer[MAX_PATH+1];
1166     int         l = strlen(path);
1167     int         res;
1168     WCHAR       wbuffer[MAX_PATH+1];
1169     WCHAR*      pwbuffer;
1170     HANDLE      handle;
1171     int         nlink = 1;
1172
1173     if (l > 1) {
1174         switch(path[l - 1]) {
1175         /* FindFirstFile() and stat() are buggy with a trailing
1176          * backslash, so change it to a forward slash :-( */
1177         case '\\':
1178             strncpy(buffer, path, l-1);
1179             buffer[l - 1] = '/';
1180             buffer[l] = '\0';
1181             path = buffer;
1182             break;
1183         /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1184         case ':':
1185             if (l == 2 && isALPHA(path[0])) {
1186                 buffer[0] = path[0];
1187                 buffer[1] = ':';
1188                 buffer[2] = '.';
1189                 buffer[3] = '\0';
1190                 l = 3;
1191                 path = buffer;
1192             }
1193             break;
1194         }
1195     }
1196
1197     /* We *must* open & close the file once; otherwise file attribute changes */
1198     /* might not yet have propagated to "other" hard links of the same file.  */
1199     /* This also gives us an opportunity to determine the number of links.    */
1200     if (USING_WIDE()) {
1201         A2WHELPER(path, wbuffer, sizeof(wbuffer));
1202         pwbuffer = PerlDir_mapW(wbuffer);
1203         handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1204     }
1205     else {
1206         path = PerlDir_mapA(path);
1207         l = strlen(path);
1208         handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1209     }
1210     if (handle != INVALID_HANDLE_VALUE) {
1211         BY_HANDLE_FILE_INFORMATION bhi;
1212         if (GetFileInformationByHandle(handle, &bhi))
1213             nlink = bhi.nNumberOfLinks;
1214         CloseHandle(handle);
1215     }
1216
1217     /* pwbuffer or path will be mapped correctly above */
1218     if (USING_WIDE()) {
1219         res = _wstat(pwbuffer, (struct _stat *)sbuf);
1220     }
1221     else {
1222         res = stat(path, sbuf);
1223     }
1224     sbuf->st_nlink = nlink;
1225
1226     if (res < 0) {
1227         /* CRT is buggy on sharenames, so make sure it really isn't.
1228          * XXX using GetFileAttributesEx() will enable us to set
1229          * sbuf->st_*time (but note that's not available on the
1230          * Windows of 1995) */
1231         DWORD r;
1232         if (USING_WIDE()) {
1233             r = GetFileAttributesW(pwbuffer);
1234         }
1235         else {
1236             r = GetFileAttributesA(path);
1237         }
1238         if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1239             /* sbuf may still contain old garbage since stat() failed */
1240             Zero(sbuf, 1, struct stat);
1241             sbuf->st_mode = S_IFDIR | S_IREAD;
1242             errno = 0;
1243             if (!(r & FILE_ATTRIBUTE_READONLY))
1244                 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1245             return 0;
1246         }
1247     }
1248     else {
1249         if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1250             && (path[2] == '\\' || path[2] == '/'))
1251         {
1252             /* The drive can be inaccessible, some _stat()s are buggy */
1253             if (USING_WIDE()
1254                 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1255                 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1256                 errno = ENOENT;
1257                 return -1;
1258             }
1259         }
1260 #ifdef __BORLANDC__
1261         if (S_ISDIR(sbuf->st_mode))
1262             sbuf->st_mode |= S_IWRITE | S_IEXEC;
1263         else if (S_ISREG(sbuf->st_mode)) {
1264             int perms;
1265             if (l >= 4 && path[l-4] == '.') {
1266                 const char *e = path + l - 3;
1267                 if (strnicmp(e,"exe",3)
1268                     && strnicmp(e,"bat",3)
1269                     && strnicmp(e,"com",3)
1270                     && (IsWin95() || strnicmp(e,"cmd",3)))
1271                     sbuf->st_mode &= ~S_IEXEC;
1272                 else
1273                     sbuf->st_mode |= S_IEXEC;
1274             }
1275             else
1276                 sbuf->st_mode &= ~S_IEXEC;
1277             /* Propagate permissions to _group_ and _others_ */
1278             perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1279             sbuf->st_mode |= (perms>>3) | (perms>>6);
1280         }
1281 #endif
1282     }
1283     return res;
1284 }
1285
1286 /* Find the longname of a given path.  path is destructively modified.
1287  * It should have space for at least MAX_PATH characters. */
1288 DllExport char *
1289 win32_longpath(char *path)
1290 {
1291     WIN32_FIND_DATA fdata;
1292     HANDLE fhand;
1293     char tmpbuf[MAX_PATH+1];
1294     char *tmpstart = tmpbuf;
1295     char *start = path;
1296     char sep;
1297     if (!path)
1298         return Nullch;
1299
1300     /* drive prefix */
1301     if (isALPHA(path[0]) && path[1] == ':' &&
1302         (path[2] == '/' || path[2] == '\\'))
1303     {
1304         start = path + 2;
1305         *tmpstart++ = path[0];
1306         *tmpstart++ = ':';
1307     }
1308     /* UNC prefix */
1309     else if ((path[0] == '/' || path[0] == '\\') &&
1310              (path[1] == '/' || path[1] == '\\'))
1311     {
1312         start = path + 2;
1313         *tmpstart++ = path[0];
1314         *tmpstart++ = path[1];
1315         /* copy machine name */
1316         while (*start && *start != '/' && *start != '\\')
1317             *tmpstart++ = *start++;
1318         if (*start) {
1319             *tmpstart++ = *start;
1320             start++;
1321             /* copy share name */
1322             while (*start && *start != '/' && *start != '\\')
1323                 *tmpstart++ = *start++;
1324         }
1325     }
1326     sep = *start++;
1327     if (sep == '/' || sep == '\\')
1328         *tmpstart++ = sep;
1329     *tmpstart = '\0';
1330     while (sep) {
1331         /* walk up to slash */
1332         while (*start && *start != '/' && *start != '\\')
1333             ++start;
1334
1335         /* discard doubled slashes */
1336         while (*start && (start[1] == '/' || start[1] == '\\'))
1337             ++start;
1338         sep = *start;
1339
1340         /* stop and find full name of component */
1341         *start = '\0';
1342         fhand = FindFirstFile(path,&fdata);
1343         if (fhand != INVALID_HANDLE_VALUE) {
1344             strcpy(tmpstart, fdata.cFileName);
1345             tmpstart += strlen(fdata.cFileName);
1346             if (sep)
1347                 *tmpstart++ = sep;
1348             *tmpstart = '\0';
1349             *start++ = sep;
1350             FindClose(fhand);
1351         }
1352         else {
1353             /* failed a step, just return without side effects */
1354             /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1355             *start = sep;
1356             return Nullch;
1357         }
1358     }
1359     strcpy(path,tmpbuf);
1360     return path;
1361 }
1362
1363 DllExport char *
1364 win32_getenv(const char *name)
1365 {
1366     dTHX;
1367     WCHAR wBuffer[MAX_PATH+1];
1368     DWORD needlen;
1369     SV *curitem = Nullsv;
1370
1371     if (USING_WIDE()) {
1372         A2WHELPER(name, wBuffer, sizeof(wBuffer));
1373         needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1374     }
1375     else
1376         needlen = GetEnvironmentVariableA(name,NULL,0);
1377     if (needlen != 0) {
1378         curitem = sv_2mortal(newSVpvn("", 0));
1379         if (USING_WIDE()) {
1380             SV *acuritem;
1381             do {
1382                 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1383                 needlen = GetEnvironmentVariableW(wBuffer,
1384                                                   (WCHAR*)SvPVX(curitem),
1385                                                   needlen);
1386             } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1387             SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1388             acuritem = sv_2mortal(newSVsv(curitem));
1389             W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1390         }
1391         else {
1392             do {
1393                 SvGROW(curitem, needlen+1);
1394                 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1395                                                   needlen);
1396             } while (needlen >= SvLEN(curitem));
1397             SvCUR_set(curitem, needlen);
1398         }
1399     }
1400     else {
1401         /* allow any environment variables that begin with 'PERL'
1402            to be stored in the registry */
1403         if (strncmp(name, "PERL", 4) == 0)
1404             (void)get_regstr(name, &curitem);
1405     }
1406     if (curitem && SvCUR(curitem))
1407         return SvPVX(curitem);
1408
1409     return Nullch;
1410 }
1411
1412 DllExport int
1413 win32_putenv(const char *name)
1414 {
1415     dTHX;
1416     char* curitem;
1417     char* val;
1418     WCHAR* wCuritem;
1419     WCHAR* wVal;
1420     int length, relval = -1;
1421
1422     if (name) {
1423         if (USING_WIDE()) {
1424             length = strlen(name)+1;
1425             New(1309,wCuritem,length,WCHAR);
1426             A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1427             wVal = wcschr(wCuritem, '=');
1428             if (wVal) {
1429                 *wVal++ = '\0';
1430                 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1431                     relval = 0;
1432             }
1433             Safefree(wCuritem);
1434         }
1435         else {
1436             New(1309,curitem,strlen(name)+1,char);
1437             strcpy(curitem, name);
1438             val = strchr(curitem, '=');
1439             if (val) {
1440                 /* The sane way to deal with the environment.
1441                  * Has these advantages over putenv() & co.:
1442                  *  * enables us to store a truly empty value in the
1443                  *    environment (like in UNIX).
1444                  *  * we don't have to deal with RTL globals, bugs and leaks.
1445                  *  * Much faster.
1446                  * Why you may want to enable USE_WIN32_RTL_ENV:
1447                  *  * environ[] and RTL functions will not reflect changes,
1448                  *    which might be an issue if extensions want to access
1449                  *    the env. via RTL.  This cuts both ways, since RTL will
1450                  *    not see changes made by extensions that call the Win32
1451                  *    functions directly, either.
1452                  * GSAR 97-06-07
1453                  */
1454                 *val++ = '\0';
1455                 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1456                     relval = 0;
1457             }
1458             Safefree(curitem);
1459         }
1460     }
1461     return relval;
1462 }
1463
1464 static long
1465 filetime_to_clock(PFILETIME ft)
1466 {
1467     __int64 qw = ft->dwHighDateTime;
1468     qw <<= 32;
1469     qw |= ft->dwLowDateTime;
1470     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
1471     return (long) qw;
1472 }
1473
1474 DllExport int
1475 win32_times(struct tms *timebuf)
1476 {
1477     FILETIME user;
1478     FILETIME kernel;
1479     FILETIME dummy;
1480     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1481                         &kernel,&user)) {
1482         timebuf->tms_utime = filetime_to_clock(&user);
1483         timebuf->tms_stime = filetime_to_clock(&kernel);
1484         timebuf->tms_cutime = 0;
1485         timebuf->tms_cstime = 0;
1486
1487     } else {
1488         /* That failed - e.g. Win95 fallback to clock() */
1489         clock_t t = clock();
1490         timebuf->tms_utime = t;
1491         timebuf->tms_stime = 0;
1492         timebuf->tms_cutime = 0;
1493         timebuf->tms_cstime = 0;
1494     }
1495     return 0;
1496 }
1497
1498 /* fix utime() so it works on directories in NT */
1499 static BOOL
1500 filetime_from_time(PFILETIME pFileTime, time_t Time)
1501 {
1502     struct tm *pTM = localtime(&Time);
1503     SYSTEMTIME SystemTime;
1504     FILETIME LocalTime;
1505
1506     if (pTM == NULL)
1507         return FALSE;
1508
1509     SystemTime.wYear   = pTM->tm_year + 1900;
1510     SystemTime.wMonth  = pTM->tm_mon + 1;
1511     SystemTime.wDay    = pTM->tm_mday;
1512     SystemTime.wHour   = pTM->tm_hour;
1513     SystemTime.wMinute = pTM->tm_min;
1514     SystemTime.wSecond = pTM->tm_sec;
1515     SystemTime.wMilliseconds = 0;
1516
1517     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1518            LocalFileTimeToFileTime(&LocalTime, pFileTime);
1519 }
1520
1521 DllExport int
1522 win32_unlink(const char *filename)
1523 {
1524     dTHX;
1525     int ret;
1526     DWORD attrs;
1527
1528     if (USING_WIDE()) {
1529         WCHAR wBuffer[MAX_PATH+1];
1530         WCHAR* pwBuffer;
1531
1532         A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1533         pwBuffer = PerlDir_mapW(wBuffer);
1534         attrs = GetFileAttributesW(pwBuffer);
1535         if (attrs == 0xFFFFFFFF)
1536             goto fail;
1537         if (attrs & FILE_ATTRIBUTE_READONLY) {
1538             (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1539             ret = _wunlink(pwBuffer);
1540             if (ret == -1)
1541                 (void)SetFileAttributesW(pwBuffer, attrs);
1542         }
1543         else
1544             ret = _wunlink(pwBuffer);
1545     }
1546     else {
1547         filename = PerlDir_mapA(filename);
1548         attrs = GetFileAttributesA(filename);
1549         if (attrs == 0xFFFFFFFF)
1550             goto fail;
1551         if (attrs & FILE_ATTRIBUTE_READONLY) {
1552             (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1553             ret = unlink(filename);
1554             if (ret == -1)
1555                 (void)SetFileAttributesA(filename, attrs);
1556         }
1557         else
1558             ret = unlink(filename);
1559     }
1560     return ret;
1561 fail:
1562     errno = ENOENT;
1563     return -1;
1564 }
1565
1566 DllExport int
1567 win32_utime(const char *filename, struct utimbuf *times)
1568 {
1569     dTHX;
1570     HANDLE handle;
1571     FILETIME ftCreate;
1572     FILETIME ftAccess;
1573     FILETIME ftWrite;
1574     struct utimbuf TimeBuffer;
1575     WCHAR wbuffer[MAX_PATH+1];
1576     WCHAR* pwbuffer;
1577
1578     int rc;
1579     if (USING_WIDE()) {
1580         A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1581         pwbuffer = PerlDir_mapW(wbuffer);
1582         rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1583     }
1584     else {
1585         filename = PerlDir_mapA(filename);
1586         rc = utime(filename, times);
1587     }
1588     /* EACCES: path specifies directory or readonly file */
1589     if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1590         return rc;
1591
1592     if (times == NULL) {
1593         times = &TimeBuffer;
1594         time(&times->actime);
1595         times->modtime = times->actime;
1596     }
1597
1598     /* This will (and should) still fail on readonly files */
1599     if (USING_WIDE()) {
1600         handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1601                             FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1602                             OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1603     }
1604     else {
1605         handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1606                             FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1607                             OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1608     }
1609     if (handle == INVALID_HANDLE_VALUE)
1610         return rc;
1611
1612     if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1613         filetime_from_time(&ftAccess, times->actime) &&
1614         filetime_from_time(&ftWrite, times->modtime) &&
1615         SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1616     {
1617         rc = 0;
1618     }
1619
1620     CloseHandle(handle);
1621     return rc;
1622 }
1623
1624 DllExport int
1625 win32_uname(struct utsname *name)
1626 {
1627     struct hostent *hep;
1628     STRLEN nodemax = sizeof(name->nodename)-1;
1629     OSVERSIONINFO osver;
1630
1631     memset(&osver, 0, sizeof(OSVERSIONINFO));
1632     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1633     if (GetVersionEx(&osver)) {
1634         /* sysname */
1635         switch (osver.dwPlatformId) {
1636         case VER_PLATFORM_WIN32_WINDOWS:
1637             strcpy(name->sysname, "Windows");
1638             break;
1639         case VER_PLATFORM_WIN32_NT:
1640             strcpy(name->sysname, "Windows NT");
1641             break;
1642         case VER_PLATFORM_WIN32s:
1643             strcpy(name->sysname, "Win32s");
1644             break;
1645         default:
1646             strcpy(name->sysname, "Win32 Unknown");
1647             break;
1648         }
1649
1650         /* release */
1651         sprintf(name->release, "%d.%d",
1652                 osver.dwMajorVersion, osver.dwMinorVersion);
1653
1654         /* version */
1655         sprintf(name->version, "Build %d",
1656                 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1657                 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1658         if (osver.szCSDVersion[0]) {
1659             char *buf = name->version + strlen(name->version);
1660             sprintf(buf, " (%s)", osver.szCSDVersion);
1661         }
1662     }
1663     else {
1664         *name->sysname = '\0';
1665         *name->version = '\0';
1666         *name->release = '\0';
1667     }
1668
1669     /* nodename */
1670     hep = win32_gethostbyname("localhost");
1671     if (hep) {
1672         STRLEN len = strlen(hep->h_name);
1673         if (len <= nodemax) {
1674             strcpy(name->nodename, hep->h_name);
1675         }
1676         else {
1677             strncpy(name->nodename, hep->h_name, nodemax);
1678             name->nodename[nodemax] = '\0';
1679         }
1680     }
1681     else {
1682         DWORD sz = nodemax;
1683         if (!GetComputerName(name->nodename, &sz))
1684             *name->nodename = '\0';
1685     }
1686
1687     /* machine (architecture) */
1688     {
1689         SYSTEM_INFO info;
1690         char *arch;
1691         GetSystemInfo(&info);
1692
1693 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1694  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1695         switch (info.u.s.wProcessorArchitecture) {
1696 #else
1697         switch (info.wProcessorArchitecture) {
1698 #endif
1699         case PROCESSOR_ARCHITECTURE_INTEL:
1700             arch = "x86"; break;
1701         case PROCESSOR_ARCHITECTURE_MIPS:
1702             arch = "mips"; break;
1703         case PROCESSOR_ARCHITECTURE_ALPHA:
1704             arch = "alpha"; break;
1705         case PROCESSOR_ARCHITECTURE_PPC:
1706             arch = "ppc"; break;
1707         default:
1708             arch = "unknown"; break;
1709         }
1710         strcpy(name->machine, arch);
1711     }
1712     return 0;
1713 }
1714
1715 /* Timing related stuff */
1716
1717 DllExport int
1718 win32_async_check(pTHX)
1719 {
1720     MSG msg;
1721     int ours = 1;
1722     /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1723      * and ignores window messages - should co-exist better with windows apps e.g. Tk
1724      */
1725     while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE)) {
1726         switch(msg.message) {
1727
1728 #if 0
1729     /* Perhaps some other messages could map to signals ? ... */
1730         case WM_CLOSE:
1731         case WM_QUIT:
1732             /* Treat WM_QUIT like SIGHUP?  */
1733             CALL_FPTR(PL_sighandlerp)(1);
1734             break;
1735 #endif
1736
1737         /* We use WM_USER to fake kill() with other signals */
1738         case WM_USER: {
1739             CALL_FPTR(PL_sighandlerp)(msg.wParam);
1740             break;
1741         }
1742
1743         case WM_TIMER: {
1744             /* alarm() is a one-shot but SetTimer() repeats so kill it */
1745             KillTimer(NULL,w32_timerid);
1746             w32_timerid=0;
1747             /* Now fake a call to signal handler */
1748             CALL_FPTR(PL_sighandlerp)(14);
1749             break;
1750         }
1751
1752         /* Otherwise do normal Win32 thing - in case it is useful */
1753         default:
1754             TranslateMessage(&msg);
1755             DispatchMessage(&msg);
1756             ours = 0;
1757             break;
1758         }
1759     }
1760
1761     /* Above or other stuff may have set a signal flag */
1762     if (PL_sig_pending) {
1763         despatch_signals();
1764     }
1765     return ours;
1766 }
1767
1768 DllExport DWORD
1769 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1770 {
1771     /* We may need several goes at this - so compute when we stop */
1772     DWORD ticks = 0;
1773     if (timeout != INFINITE) {
1774         ticks = GetTickCount();
1775         timeout += ticks;
1776     }
1777     while (1) {
1778         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1779         if (resultp)
1780            *resultp = result;
1781         if (result == WAIT_TIMEOUT) {
1782             /* Ran out of time - explicit return of zero to avoid -ve if we
1783                have scheduling issues
1784              */
1785             return 0;
1786         }
1787         if (timeout != INFINITE) {
1788             ticks = GetTickCount();
1789         }
1790         if (result == WAIT_OBJECT_0 + count) {
1791             /* Message has arrived - check it */
1792             if (win32_async_check(aTHX)) {
1793                 /* was one of ours */
1794                 break;
1795             }
1796         }
1797         else {
1798            /* Not timeout or message - one of handles is ready */
1799            break;
1800         }
1801     }
1802     /* compute time left to wait */
1803     ticks = timeout - ticks;
1804     /* If we are past the end say zero */
1805     return (ticks > 0) ? ticks : 0;
1806 }
1807
1808 int
1809 win32_internal_wait(int *status, DWORD timeout)
1810 {
1811     /* XXX this wait emulation only knows about processes
1812      * spawned via win32_spawnvp(P_NOWAIT, ...).
1813      */
1814     dTHX;
1815     int i, retval;
1816     DWORD exitcode, waitcode;
1817
1818 #ifdef USE_ITHREADS
1819     if (w32_num_pseudo_children) {
1820         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1821                       timeout, &waitcode);
1822         /* Time out here if there are no other children to wait for. */
1823         if (waitcode == WAIT_TIMEOUT) {
1824             if (!w32_num_children) {
1825                 return 0;
1826             }
1827         }
1828         else if (waitcode != WAIT_FAILED) {
1829             if (waitcode >= WAIT_ABANDONED_0
1830                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1831                 i = waitcode - WAIT_ABANDONED_0;
1832             else
1833                 i = waitcode - WAIT_OBJECT_0;
1834             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1835                 *status = (int)((exitcode & 0xff) << 8);
1836                 retval = (int)w32_pseudo_child_pids[i];
1837                 remove_dead_pseudo_process(i);
1838                 return -retval;
1839             }
1840         }
1841     }
1842 #endif
1843
1844     if (!w32_num_children) {
1845         errno = ECHILD;
1846         return -1;
1847     }
1848
1849     /* if a child exists, wait for it to die */
1850     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1851     if (waitcode == WAIT_TIMEOUT) {
1852         return 0;
1853     }
1854     if (waitcode != WAIT_FAILED) {
1855         if (waitcode >= WAIT_ABANDONED_0
1856             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1857             i = waitcode - WAIT_ABANDONED_0;
1858         else
1859             i = waitcode - WAIT_OBJECT_0;
1860         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1861             *status = (int)((exitcode & 0xff) << 8);
1862             retval = (int)w32_child_pids[i];
1863             remove_dead_process(i);
1864             return retval;
1865         }
1866     }
1867
1868 FAILED:
1869     errno = GetLastError();
1870     return -1;
1871 }
1872
1873 DllExport int
1874 win32_waitpid(int pid, int *status, int flags)
1875 {
1876     dTHX;
1877     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1878     int retval = -1;
1879     long child;
1880     if (pid == -1)                              /* XXX threadid == 1 ? */
1881         return win32_internal_wait(status, timeout);
1882 #ifdef USE_ITHREADS
1883     else if (pid < 0) {
1884         child = find_pseudo_pid(-pid);
1885         if (child >= 0) {
1886             HANDLE hThread = w32_pseudo_child_handles[child];
1887             DWORD waitcode;
1888             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1889             if (waitcode == WAIT_TIMEOUT) {
1890                 return 0;
1891             }
1892             else if (waitcode == WAIT_OBJECT_0) {
1893                 if (GetExitCodeThread(hThread, &waitcode)) {
1894                     *status = (int)((waitcode & 0xff) << 8);
1895                     retval = (int)w32_pseudo_child_pids[child];
1896                     remove_dead_pseudo_process(child);
1897                     return -retval;
1898                 }
1899             }
1900             else
1901                 errno = ECHILD;
1902         }
1903         else if (IsWin95()) {
1904             pid = -pid;
1905             goto alien_process;
1906         }
1907     }
1908 #endif
1909     else {
1910         HANDLE hProcess;
1911         DWORD waitcode;
1912         child = find_pid(pid);
1913         if (child >= 0) {
1914             hProcess = w32_child_handles[child];
1915             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1916             if (waitcode == WAIT_TIMEOUT) {
1917                 return 0;
1918             }
1919             else if (waitcode == WAIT_OBJECT_0) {
1920                 if (GetExitCodeProcess(hProcess, &waitcode)) {
1921                     *status = (int)((waitcode & 0xff) << 8);
1922                     retval = (int)w32_child_pids[child];
1923                     remove_dead_process(child);
1924                     return retval;
1925                 }
1926             }
1927             else
1928                 errno = ECHILD;
1929         }
1930         else {
1931 alien_process:
1932             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1933                                    (IsWin95() ? -pid : pid));
1934             if (hProcess) {
1935                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
1936                 if (waitcode == WAIT_TIMEOUT) {
1937                     return 0;
1938                 }
1939                 else if (waitcode == WAIT_OBJECT_0) {
1940                     if (GetExitCodeProcess(hProcess, &waitcode)) {
1941                         *status = (int)((waitcode & 0xff) << 8);
1942                         CloseHandle(hProcess);
1943                         return pid;
1944                     }
1945                 }
1946                 CloseHandle(hProcess);
1947             }
1948             else
1949                 errno = ECHILD;
1950         }
1951     }
1952     return retval >= 0 ? pid : retval;
1953 }
1954
1955 DllExport int
1956 win32_wait(int *status)
1957 {
1958     return win32_internal_wait(status, INFINITE);
1959 }
1960
1961 DllExport unsigned int
1962 win32_sleep(unsigned int t)
1963 {
1964     dTHX;
1965     /* Win32 times are in ms so *1000 in and /1000 out */
1966     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
1967 }
1968
1969 DllExport unsigned int
1970 win32_alarm(unsigned int sec)
1971 {
1972     /*
1973      * the 'obvious' implentation is SetTimer() with a callback
1974      * which does whatever receiving SIGALRM would do
1975      * we cannot use SIGALRM even via raise() as it is not
1976      * one of the supported codes in <signal.h>
1977      */
1978     dTHX;
1979     if (sec) {
1980         w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
1981     }
1982     else {
1983         if (w32_timerid) {
1984             KillTimer(NULL,w32_timerid);
1985             w32_timerid=0;
1986         }
1987     }
1988     return 0;
1989 }
1990
1991 #ifdef HAVE_DES_FCRYPT
1992 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
1993 #endif
1994
1995 DllExport char *
1996 win32_crypt(const char *txt, const char *salt)
1997 {
1998     dTHX;
1999 #ifdef HAVE_DES_FCRYPT
2000     return des_fcrypt(txt, salt, w32_crypt_buffer);
2001 #else
2002     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2003     return Nullch;
2004 #endif
2005 }
2006
2007 #ifdef USE_FIXED_OSFHANDLE
2008
2009 #define FOPEN                   0x01    /* file handle open */
2010 #define FNOINHERIT              0x10    /* file handle opened O_NOINHERIT */
2011 #define FAPPEND                 0x20    /* file handle opened O_APPEND */
2012 #define FDEV                    0x40    /* file handle refers to device */
2013 #define FTEXT                   0x80    /* file handle is in text mode */
2014
2015 /***
2016 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
2017 *
2018 *Purpose:
2019 *       This function allocates a free C Runtime file handle and associates
2020 *       it with the Win32 HANDLE specified by the first parameter. This is a
2021 *       temperary fix for WIN95's brain damage GetFileType() error on socket
2022 *       we just bypass that call for socket
2023 *
2024 *       This works with MSVC++ 4.0+ or GCC/Mingw32
2025 *
2026 *Entry:
2027 *       long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2028 *       int flags      - flags to associate with C Runtime file handle.
2029 *
2030 *Exit:
2031 *       returns index of entry in fh, if successful
2032 *       return -1, if no free entry is found
2033 *
2034 *Exceptions:
2035 *
2036 *******************************************************************************/
2037
2038 /*
2039  * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2040  * this lets sockets work on Win9X with GCC and should fix the problems
2041  * with perl95.exe
2042  *      -- BKS, 1-23-2000
2043 */
2044
2045 /* create an ioinfo entry, kill its handle, and steal the entry */
2046
2047 static int
2048 _alloc_osfhnd(void)
2049 {
2050     HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2051     int fh = _open_osfhandle((long)hF, 0);
2052     CloseHandle(hF);
2053     if (fh == -1)
2054         return fh;
2055     EnterCriticalSection(&(_pioinfo(fh)->lock));
2056     return fh;
2057 }
2058
2059 static int
2060 my_open_osfhandle(long osfhandle, int flags)
2061 {
2062     int fh;
2063     char fileflags;             /* _osfile flags */
2064
2065     /* copy relevant flags from second parameter */
2066     fileflags = FDEV;
2067
2068     if (flags & O_APPEND)
2069         fileflags |= FAPPEND;
2070
2071     if (flags & O_TEXT)
2072         fileflags |= FTEXT;
2073
2074     if (flags & O_NOINHERIT)
2075         fileflags |= FNOINHERIT;
2076
2077     /* attempt to allocate a C Runtime file handle */
2078     if ((fh = _alloc_osfhnd()) == -1) {
2079         errno = EMFILE;         /* too many open files */
2080         _doserrno = 0L;         /* not an OS error */
2081         return -1;              /* return error to caller */
2082     }
2083
2084     /* the file is open. now, set the info in _osfhnd array */
2085     _set_osfhnd(fh, osfhandle);
2086
2087     fileflags |= FOPEN;         /* mark as open */
2088
2089     _osfile(fh) = fileflags;    /* set osfile entry */
2090     LeaveCriticalSection(&_pioinfo(fh)->lock);
2091
2092     return fh;                  /* return handle */
2093 }
2094
2095 #endif  /* USE_FIXED_OSFHANDLE */
2096
2097 /* simulate flock by locking a range on the file */
2098
2099 #define LK_ERR(f,i)     ((f) ? (i = 0) : (errno = GetLastError()))
2100 #define LK_LEN          0xffff0000
2101
2102 DllExport int
2103 win32_flock(int fd, int oper)
2104 {
2105     OVERLAPPED o;
2106     int i = -1;
2107     HANDLE fh;
2108
2109     if (!IsWinNT()) {
2110         dTHX;
2111         Perl_croak_nocontext("flock() unimplemented on this platform");
2112         return -1;
2113     }
2114     fh = (HANDLE)_get_osfhandle(fd);
2115     memset(&o, 0, sizeof(o));
2116
2117     switch(oper) {
2118     case LOCK_SH:               /* shared lock */
2119         LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2120         break;
2121     case LOCK_EX:               /* exclusive lock */
2122         LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2123         break;
2124     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2125         LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2126         break;
2127     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2128         LK_ERR(LockFileEx(fh,
2129                        LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2130                        0, LK_LEN, 0, &o),i);
2131         break;
2132     case LOCK_UN:               /* unlock lock */
2133         LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2134         break;
2135     default:                    /* unknown */
2136         errno = EINVAL;
2137         break;
2138     }
2139     return i;
2140 }
2141
2142 #undef LK_ERR
2143 #undef LK_LEN
2144
2145 /*
2146  *  redirected io subsystem for all XS modules
2147  *
2148  */
2149
2150 DllExport int *
2151 win32_errno(void)
2152 {
2153     return (&errno);
2154 }
2155
2156 DllExport char ***
2157 win32_environ(void)
2158 {
2159     return (&(_environ));
2160 }
2161
2162 /* the rest are the remapped stdio routines */
2163 DllExport FILE *
2164 win32_stderr(void)
2165 {
2166     return (stderr);
2167 }
2168
2169 DllExport FILE *
2170 win32_stdin(void)
2171 {
2172     return (stdin);
2173 }
2174
2175 DllExport FILE *
2176 win32_stdout()
2177 {
2178     return (stdout);
2179 }
2180
2181 DllExport int
2182 win32_ferror(FILE *fp)
2183 {
2184     return (ferror(fp));
2185 }
2186
2187
2188 DllExport int
2189 win32_feof(FILE *fp)
2190 {
2191     return (feof(fp));
2192 }
2193
2194 /*
2195  * Since the errors returned by the socket error function
2196  * WSAGetLastError() are not known by the library routine strerror
2197  * we have to roll our own.
2198  */
2199
2200 DllExport char *
2201 win32_strerror(int e)
2202 {
2203 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2204     extern int sys_nerr;
2205 #endif
2206     DWORD source = 0;
2207
2208     if (e < 0 || e > sys_nerr) {
2209         dTHX;
2210         if (e < 0)
2211             e = GetLastError();
2212
2213         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2214                           w32_strerror_buffer,
2215                           sizeof(w32_strerror_buffer), NULL) == 0)
2216             strcpy(w32_strerror_buffer, "Unknown Error");
2217
2218         return w32_strerror_buffer;
2219     }
2220     return strerror(e);
2221 }
2222
2223 DllExport void
2224 win32_str_os_error(void *sv, DWORD dwErr)
2225 {
2226     DWORD dwLen;
2227     char *sMsg;
2228     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2229                           |FORMAT_MESSAGE_IGNORE_INSERTS
2230                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2231                            dwErr, 0, (char *)&sMsg, 1, NULL);
2232     /* strip trailing whitespace and period */
2233     if (0 < dwLen) {
2234         do {
2235             --dwLen;    /* dwLen doesn't include trailing null */
2236         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2237         if ('.' != sMsg[dwLen])
2238             dwLen++;
2239         sMsg[dwLen] = '\0';
2240     }
2241     if (0 == dwLen) {
2242         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2243         if (sMsg)
2244             dwLen = sprintf(sMsg,
2245                             "Unknown error #0x%lX (lookup 0x%lX)",
2246                             dwErr, GetLastError());
2247     }
2248     if (sMsg) {
2249         dTHX;
2250         sv_setpvn((SV*)sv, sMsg, dwLen);
2251         LocalFree(sMsg);
2252     }
2253 }
2254
2255 DllExport int
2256 win32_fprintf(FILE *fp, const char *format, ...)
2257 {
2258     va_list marker;
2259     va_start(marker, format);     /* Initialize variable arguments. */
2260
2261     return (vfprintf(fp, format, marker));
2262 }
2263
2264 DllExport int
2265 win32_printf(const char *format, ...)
2266 {
2267     va_list marker;
2268     va_start(marker, format);     /* Initialize variable arguments. */
2269
2270     return (vprintf(format, marker));
2271 }
2272
2273 DllExport int
2274 win32_vfprintf(FILE *fp, const char *format, va_list args)
2275 {
2276     return (vfprintf(fp, format, args));
2277 }
2278
2279 DllExport int
2280 win32_vprintf(const char *format, va_list args)
2281 {
2282     return (vprintf(format, args));
2283 }
2284
2285 DllExport size_t
2286 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2287 {
2288     return fread(buf, size, count, fp);
2289 }
2290
2291 DllExport size_t
2292 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2293 {
2294     return fwrite(buf, size, count, fp);
2295 }
2296
2297 #define MODE_SIZE 10
2298
2299 DllExport FILE *
2300 win32_fopen(const char *filename, const char *mode)
2301 {
2302     dTHX;
2303     WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2304     FILE *f;
2305
2306     if (!*filename)
2307         return NULL;
2308
2309     if (stricmp(filename, "/dev/null")==0)
2310         filename = "NUL";
2311
2312     if (USING_WIDE()) {
2313         A2WHELPER(mode, wMode, sizeof(wMode));
2314         A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2315         f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2316     }
2317     else
2318         f = fopen(PerlDir_mapA(filename), mode);
2319     /* avoid buffering headaches for child processes */
2320     if (f && *mode == 'a')
2321         win32_fseek(f, 0, SEEK_END);
2322     return f;
2323 }
2324
2325 #ifndef USE_SOCKETS_AS_HANDLES
2326 #undef fdopen
2327 #define fdopen my_fdopen
2328 #endif
2329
2330 DllExport FILE *
2331 win32_fdopen(int handle, const char *mode)
2332 {
2333     dTHX;
2334     WCHAR wMode[MODE_SIZE];
2335     FILE *f;
2336     if (USING_WIDE()) {
2337         A2WHELPER(mode, wMode, sizeof(wMode));
2338         f = _wfdopen(handle, wMode);
2339     }
2340     else
2341         f = fdopen(handle, (char *) mode);
2342     /* avoid buffering headaches for child processes */
2343     if (f && *mode == 'a')
2344         win32_fseek(f, 0, SEEK_END);
2345     return f;
2346 }
2347
2348 DllExport FILE *
2349 win32_freopen(const char *path, const char *mode, FILE *stream)
2350 {
2351     dTHX;
2352     WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2353     if (stricmp(path, "/dev/null")==0)
2354         path = "NUL";
2355
2356     if (USING_WIDE()) {
2357         A2WHELPER(mode, wMode, sizeof(wMode));
2358         A2WHELPER(path, wBuffer, sizeof(wBuffer));
2359         return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2360     }
2361     return freopen(PerlDir_mapA(path), mode, stream);
2362 }
2363
2364 DllExport int
2365 win32_fclose(FILE *pf)
2366 {
2367     return my_fclose(pf);       /* defined in win32sck.c */
2368 }
2369
2370 DllExport int
2371 win32_fputs(const char *s,FILE *pf)
2372 {
2373     return fputs(s, pf);
2374 }
2375
2376 DllExport int
2377 win32_fputc(int c,FILE *pf)
2378 {
2379     return fputc(c,pf);
2380 }
2381
2382 DllExport int
2383 win32_ungetc(int c,FILE *pf)
2384 {
2385     return ungetc(c,pf);
2386 }
2387
2388 DllExport int
2389 win32_getc(FILE *pf)
2390 {
2391     return getc(pf);
2392 }
2393
2394 DllExport int
2395 win32_fileno(FILE *pf)
2396 {
2397     return fileno(pf);
2398 }
2399
2400 DllExport void
2401 win32_clearerr(FILE *pf)
2402 {
2403     clearerr(pf);
2404     return;
2405 }
2406
2407 DllExport int
2408 win32_fflush(FILE *pf)
2409 {
2410     return fflush(pf);
2411 }
2412
2413 DllExport long
2414 win32_ftell(FILE *pf)
2415 {
2416     return ftell(pf);
2417 }
2418
2419 DllExport int
2420 win32_fseek(FILE *pf,long offset,int origin)
2421 {
2422     return fseek(pf, offset, origin);
2423 }
2424
2425 DllExport int
2426 win32_fgetpos(FILE *pf,fpos_t *p)
2427 {
2428     return fgetpos(pf, p);
2429 }
2430
2431 DllExport int
2432 win32_fsetpos(FILE *pf,const fpos_t *p)
2433 {
2434     return fsetpos(pf, p);
2435 }
2436
2437 DllExport void
2438 win32_rewind(FILE *pf)
2439 {
2440     rewind(pf);
2441     return;
2442 }
2443
2444 DllExport FILE*
2445 win32_tmpfile(void)
2446 {
2447     dTHX;
2448     char prefix[MAX_PATH+1];
2449     char filename[MAX_PATH+1];
2450     DWORD len = GetTempPath(MAX_PATH, prefix);
2451     if (len && len < MAX_PATH) {
2452         if (GetTempFileName(prefix, "plx", 0, filename)) {
2453             HANDLE fh = CreateFile(filename,
2454                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2455                                    0,
2456                                    NULL,
2457                                    CREATE_ALWAYS,
2458                                    FILE_ATTRIBUTE_NORMAL
2459                                    | FILE_FLAG_DELETE_ON_CLOSE,
2460                                    NULL);
2461             if (fh != INVALID_HANDLE_VALUE) {
2462                 int fd = win32_open_osfhandle((long)fh, 0);
2463                 if (fd >= 0) {
2464                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2465                                           "Created tmpfile=%s\n",filename));
2466                     return fdopen(fd, "w+b");
2467                 }
2468             }
2469         }
2470     }
2471     return NULL;
2472 }
2473
2474 DllExport void
2475 win32_abort(void)
2476 {
2477     abort();
2478     return;
2479 }
2480
2481 DllExport int
2482 win32_fstat(int fd,struct stat *sbufptr)
2483 {
2484 #ifdef __BORLANDC__
2485     /* A file designated by filehandle is not shown as accessible
2486      * for write operations, probably because it is opened for reading.
2487      * --Vadim Konovalov
2488      */
2489     int rc = fstat(fd,sbufptr);
2490     BY_HANDLE_FILE_INFORMATION bhfi;
2491     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2492         sbufptr->st_mode &= 0xFE00;
2493         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2494             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2495         else
2496             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2497               + ((S_IREAD|S_IWRITE) >> 6));
2498     }
2499     return rc;
2500 #else
2501     return my_fstat(fd,sbufptr);
2502 #endif
2503 }
2504
2505 DllExport int
2506 win32_pipe(int *pfd, unsigned int size, int mode)
2507 {
2508     return _pipe(pfd, size, mode);
2509 }
2510
2511 DllExport PerlIO*
2512 win32_popenlist(const char *mode, IV narg, SV **args)
2513 {
2514  dTHX;
2515  Perl_croak(aTHX_ "List form of pipe open not implemented");
2516  return NULL;
2517 }
2518
2519 /*
2520  * a popen() clone that respects PERL5SHELL
2521  *
2522  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2523  */
2524
2525 DllExport PerlIO*
2526 win32_popen(const char *command, const char *mode)
2527 {
2528 #ifdef USE_RTL_POPEN
2529     return _popen(command, mode);
2530 #else
2531     int p[2];
2532     int parent, child;
2533     int stdfd, oldfd;
2534     int ourmode;
2535     int childpid;
2536
2537     /* establish which ends read and write */
2538     if (strchr(mode,'w')) {
2539         stdfd = 0;              /* stdin */
2540         parent = 1;
2541         child = 0;
2542     }
2543     else if (strchr(mode,'r')) {
2544         stdfd = 1;              /* stdout */
2545         parent = 0;
2546         child = 1;
2547     }
2548     else
2549         return NULL;
2550
2551     /* set the correct mode */
2552     if (strchr(mode,'b'))
2553         ourmode = O_BINARY;
2554     else if (strchr(mode,'t'))
2555         ourmode = O_TEXT;
2556     else
2557         ourmode = _fmode & (O_TEXT | O_BINARY);
2558
2559     /* the child doesn't inherit handles */
2560     ourmode |= O_NOINHERIT;
2561
2562     if (win32_pipe( p, 512, ourmode) == -1)
2563         return NULL;
2564
2565     /* save current stdfd */
2566     if ((oldfd = win32_dup(stdfd)) == -1)
2567         goto cleanup;
2568
2569     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2570     /* stdfd will be inherited by the child */
2571     if (win32_dup2(p[child], stdfd) == -1)
2572         goto cleanup;
2573
2574     /* close the child end in parent */
2575     win32_close(p[child]);
2576
2577     /* start the child */
2578     {
2579         dTHX;
2580         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2581             goto cleanup;
2582
2583         /* revert stdfd to whatever it was before */
2584         if (win32_dup2(oldfd, stdfd) == -1)
2585             goto cleanup;
2586
2587         /* close saved handle */
2588         win32_close(oldfd);
2589
2590         LOCK_FDPID_MUTEX;
2591         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2592         UNLOCK_FDPID_MUTEX;
2593
2594         /* set process id so that it can be returned by perl's open() */
2595         PL_forkprocess = childpid;
2596     }
2597
2598     /* we have an fd, return a file stream */
2599     return (PerlIO_fdopen(p[parent], (char *)mode));
2600
2601 cleanup:
2602     /* we don't need to check for errors here */
2603     win32_close(p[0]);
2604     win32_close(p[1]);
2605     if (oldfd != -1) {
2606         win32_dup2(oldfd, stdfd);
2607         win32_close(oldfd);
2608     }
2609     return (NULL);
2610
2611 #endif /* USE_RTL_POPEN */
2612 }
2613
2614 /*
2615  * pclose() clone
2616  */
2617
2618 DllExport int
2619 win32_pclose(PerlIO *pf)
2620 {
2621 #ifdef USE_RTL_POPEN
2622     return _pclose(pf);
2623 #else
2624     dTHX;
2625     int childpid, status;
2626     SV *sv;
2627
2628     LOCK_FDPID_MUTEX;
2629     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2630
2631     if (SvIOK(sv))
2632         childpid = SvIVX(sv);
2633     else
2634         childpid = 0;
2635
2636     if (!childpid) {
2637         errno = EBADF;
2638         return -1;
2639     }
2640
2641 #ifdef USE_PERLIO
2642     PerlIO_close(pf);
2643 #else
2644     fclose(pf);
2645 #endif
2646     SvIVX(sv) = 0;
2647     UNLOCK_FDPID_MUTEX;
2648
2649     if (win32_waitpid(childpid, &status, 0) == -1)
2650         return -1;
2651
2652     return status;
2653
2654 #endif /* USE_RTL_POPEN */
2655 }
2656
2657 static BOOL WINAPI
2658 Nt4CreateHardLinkW(
2659     LPCWSTR lpFileName,
2660     LPCWSTR lpExistingFileName,
2661     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2662 {
2663     HANDLE handle;
2664     WCHAR wFullName[MAX_PATH+1];
2665     LPVOID lpContext = NULL;
2666     WIN32_STREAM_ID StreamId;
2667     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2668     DWORD dwWritten;
2669     DWORD dwLen;
2670     BOOL bSuccess;
2671
2672     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2673                                      BOOL, BOOL, LPVOID*) =
2674         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2675                             BOOL, BOOL, LPVOID*))
2676         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2677     if (pfnBackupWrite == NULL)
2678         return 0;
2679
2680     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2681     if (dwLen == 0)
2682         return 0;
2683     dwLen = (dwLen+1)*sizeof(WCHAR);
2684
2685     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2686                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2687                          NULL, OPEN_EXISTING, 0, NULL);
2688     if (handle == INVALID_HANDLE_VALUE)
2689         return 0;
2690
2691     StreamId.dwStreamId = BACKUP_LINK;
2692     StreamId.dwStreamAttributes = 0;
2693     StreamId.dwStreamNameSize = 0;
2694 #if defined(__BORLANDC__) \
2695  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2696     StreamId.Size.u.HighPart = 0;
2697     StreamId.Size.u.LowPart = dwLen;
2698 #else
2699     StreamId.Size.HighPart = 0;
2700     StreamId.Size.LowPart = dwLen;
2701 #endif
2702
2703     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2704                               FALSE, FALSE, &lpContext);
2705     if (bSuccess) {
2706         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2707                                   FALSE, FALSE, &lpContext);
2708         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2709     }
2710
2711     CloseHandle(handle);
2712     return bSuccess;
2713 }
2714
2715 DllExport int
2716 win32_link(const char *oldname, const char *newname)
2717 {
2718     dTHX;
2719     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2720     WCHAR wOldName[MAX_PATH+1];
2721     WCHAR wNewName[MAX_PATH+1];
2722
2723     if (IsWin95())
2724         Perl_croak(aTHX_ PL_no_func, "link");
2725
2726     pfnCreateHardLinkW =
2727         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2728         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2729     if (pfnCreateHardLinkW == NULL)
2730         pfnCreateHardLinkW = Nt4CreateHardLinkW;
2731
2732     if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2733         (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2734         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2735         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2736     {
2737         return 0;
2738     }
2739     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2740     return -1;
2741 }
2742
2743 DllExport int
2744 win32_rename(const char *oname, const char *newname)
2745 {
2746     WCHAR wOldName[MAX_PATH+1];
2747     WCHAR wNewName[MAX_PATH+1];
2748     char szOldName[MAX_PATH+1];
2749     char szNewName[MAX_PATH+1];
2750     BOOL bResult;
2751     dTHX;
2752
2753     /* XXX despite what the documentation says about MoveFileEx(),
2754      * it doesn't work under Windows95!
2755      */
2756     if (IsWinNT()) {
2757         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2758         if (USING_WIDE()) {
2759             A2WHELPER(oname, wOldName, sizeof(wOldName));
2760             A2WHELPER(newname, wNewName, sizeof(wNewName));
2761             if (wcsicmp(wNewName, wOldName))
2762                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2763             wcscpy(wOldName, PerlDir_mapW(wOldName));
2764             bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2765         }
2766         else {
2767             if (stricmp(newname, oname))
2768                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2769             strcpy(szOldName, PerlDir_mapA(oname));
2770             bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2771         }
2772         if (!bResult) {
2773             DWORD err = GetLastError();
2774             switch (err) {
2775             case ERROR_BAD_NET_NAME:
2776             case ERROR_BAD_NETPATH:
2777             case ERROR_BAD_PATHNAME:
2778             case ERROR_FILE_NOT_FOUND:
2779             case ERROR_FILENAME_EXCED_RANGE:
2780             case ERROR_INVALID_DRIVE:
2781             case ERROR_NO_MORE_FILES:
2782             case ERROR_PATH_NOT_FOUND:
2783                 errno = ENOENT;
2784                 break;
2785             default:
2786                 errno = EACCES;
2787                 break;
2788             }
2789             return -1;
2790         }
2791         return 0;
2792     }
2793     else {
2794         int retval = 0;
2795         char szTmpName[MAX_PATH+1];
2796         char dname[MAX_PATH+1];
2797         char *endname = Nullch;
2798         STRLEN tmplen = 0;
2799         DWORD from_attr, to_attr;
2800
2801         strcpy(szOldName, PerlDir_mapA(oname));
2802         strcpy(szNewName, PerlDir_mapA(newname));
2803
2804         /* if oname doesn't exist, do nothing */
2805         from_attr = GetFileAttributes(szOldName);
2806         if (from_attr == 0xFFFFFFFF) {
2807             errno = ENOENT;
2808             return -1;
2809         }
2810
2811         /* if newname exists, rename it to a temporary name so that we
2812          * don't delete it in case oname happens to be the same file
2813          * (but perhaps accessed via a different path)
2814          */
2815         to_attr = GetFileAttributes(szNewName);
2816         if (to_attr != 0xFFFFFFFF) {
2817             /* if newname is a directory, we fail
2818              * XXX could overcome this with yet more convoluted logic */
2819             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2820                 errno = EACCES;
2821                 return -1;
2822             }
2823             tmplen = strlen(szNewName);
2824             strcpy(szTmpName,szNewName);
2825             endname = szTmpName+tmplen;
2826             for (; endname > szTmpName ; --endname) {
2827                 if (*endname == '/' || *endname == '\\') {
2828                     *endname = '\0';
2829                     break;
2830                 }
2831             }
2832             if (endname > szTmpName)
2833                 endname = strcpy(dname,szTmpName);
2834             else
2835                 endname = ".";
2836
2837             /* get a temporary filename in same directory
2838              * XXX is this really the best we can do? */
2839             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2840                 errno = ENOENT;
2841                 return -1;
2842             }
2843             DeleteFile(szTmpName);
2844
2845             retval = rename(szNewName, szTmpName);
2846             if (retval != 0) {
2847                 errno = EACCES;
2848                 return retval;
2849             }
2850         }
2851
2852         /* rename oname to newname */
2853         retval = rename(szOldName, szNewName);
2854
2855         /* if we created a temporary file before ... */
2856         if (endname != Nullch) {
2857             /* ...and rename succeeded, delete temporary file/directory */
2858             if (retval == 0)
2859                 DeleteFile(szTmpName);
2860             /* else restore it to what it was */
2861             else
2862                 (void)rename(szTmpName, szNewName);
2863         }
2864         return retval;
2865     }
2866 }
2867
2868 DllExport int
2869 win32_setmode(int fd, int mode)
2870 {
2871     return setmode(fd, mode);
2872 }
2873
2874 DllExport long
2875 win32_lseek(int fd, long offset, int origin)
2876 {
2877     return lseek(fd, offset, origin);
2878 }
2879
2880 DllExport long
2881 win32_tell(int fd)
2882 {
2883     return tell(fd);
2884 }
2885
2886 DllExport int
2887 win32_open(const char *path, int flag, ...)
2888 {
2889     dTHX;
2890     va_list ap;
2891     int pmode;
2892     WCHAR wBuffer[MAX_PATH+1];
2893
2894     va_start(ap, flag);
2895     pmode = va_arg(ap, int);
2896     va_end(ap);
2897
2898     if (stricmp(path, "/dev/null")==0)
2899         path = "NUL";
2900
2901     if (USING_WIDE()) {
2902         A2WHELPER(path, wBuffer, sizeof(wBuffer));
2903         return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2904     }
2905     return open(PerlDir_mapA(path), flag, pmode);
2906 }
2907
2908 /* close() that understands socket */
2909 extern int my_close(int);       /* in win32sck.c */
2910
2911 DllExport int
2912 win32_close(int fd)
2913 {
2914     return my_close(fd);
2915 }
2916
2917 DllExport int
2918 win32_eof(int fd)
2919 {
2920     return eof(fd);
2921 }
2922
2923 DllExport int
2924 win32_dup(int fd)
2925 {
2926     return dup(fd);
2927 }
2928
2929 DllExport int
2930 win32_dup2(int fd1,int fd2)
2931 {
2932     return dup2(fd1,fd2);
2933 }
2934
2935 #ifdef PERL_MSVCRT_READFIX
2936
2937 #define LF              10      /* line feed */
2938 #define CR              13      /* carriage return */
2939 #define CTRLZ           26      /* ctrl-z means eof for text */
2940 #define FOPEN           0x01    /* file handle open */
2941 #define FEOFLAG         0x02    /* end of file has been encountered */
2942 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
2943 #define FPIPE           0x08    /* file handle refers to a pipe */
2944 #define FAPPEND         0x20    /* file handle opened O_APPEND */
2945 #define FDEV            0x40    /* file handle refers to device */
2946 #define FTEXT           0x80    /* file handle is in text mode */
2947 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
2948
2949 int __cdecl
2950 _fixed_read(int fh, void *buf, unsigned cnt)
2951 {
2952     int bytes_read;                 /* number of bytes read */
2953     char *buffer;                   /* buffer to read to */
2954     int os_read;                    /* bytes read on OS call */
2955     char *p, *q;                    /* pointers into buffer */
2956     char peekchr;                   /* peek-ahead character */
2957     ULONG filepos;                  /* file position after seek */
2958     ULONG dosretval;                /* o.s. return value */
2959
2960     /* validate handle */
2961     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
2962          !(_osfile(fh) & FOPEN))
2963     {
2964         /* out of range -- return error */
2965         errno = EBADF;
2966         _doserrno = 0;  /* not o.s. error */
2967         return -1;
2968     }
2969
2970     /*
2971      * If lockinitflag is FALSE, assume fd is device
2972      * lockinitflag is set to TRUE by open.
2973      */
2974     if (_pioinfo(fh)->lockinitflag)
2975         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
2976
2977     bytes_read = 0;                 /* nothing read yet */
2978     buffer = (char*)buf;
2979
2980     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
2981         /* nothing to read or at EOF, so return 0 read */
2982         goto functionexit;
2983     }
2984
2985     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
2986         /* a pipe/device and pipe lookahead non-empty: read the lookahead
2987          * char */
2988         *buffer++ = _pipech(fh);
2989         ++bytes_read;
2990         --cnt;
2991         _pipech(fh) = LF;           /* mark as empty */
2992     }
2993
2994     /* read the data */
2995
2996     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
2997     {
2998         /* ReadFile has reported an error. recognize two special cases.
2999          *
3000          *      1. map ERROR_ACCESS_DENIED to EBADF
3001          *
3002          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3003          *         means the handle is a read-handle on a pipe for which
3004          *         all write-handles have been closed and all data has been
3005          *         read. */
3006
3007         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3008             /* wrong read/write mode should return EBADF, not EACCES */
3009             errno = EBADF;
3010             _doserrno = dosretval;
3011             bytes_read = -1;
3012             goto functionexit;
3013         }
3014         else if (dosretval == ERROR_BROKEN_PIPE) {
3015             bytes_read = 0;
3016             goto functionexit;
3017         }
3018         else {
3019             bytes_read = -1;
3020             goto functionexit;
3021         }
3022     }
3023
3024     bytes_read += os_read;          /* update bytes read */
3025
3026     if (_osfile(fh) & FTEXT) {
3027         /* now must translate CR-LFs to LFs in the buffer */
3028
3029         /* set CRLF flag to indicate LF at beginning of buffer */
3030         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3031         /*    _osfile(fh) |= FCRLF;                      */
3032         /* else                                          */
3033         /*    _osfile(fh) &= ~FCRLF;                     */
3034
3035         _osfile(fh) &= ~FCRLF;
3036
3037         /* convert chars in the buffer: p is src, q is dest */
3038         p = q = (char*)buf;
3039         while (p < (char *)buf + bytes_read) {
3040             if (*p == CTRLZ) {
3041                 /* if fh is not a device, set ctrl-z flag */
3042                 if (!(_osfile(fh) & FDEV))
3043                     _osfile(fh) |= FEOFLAG;
3044                 break;              /* stop translating */
3045             }
3046             else if (*p != CR)
3047                 *q++ = *p++;
3048             else {
3049                 /* *p is CR, so must check next char for LF */
3050                 if (p < (char *)buf + bytes_read - 1) {
3051                     if (*(p+1) == LF) {
3052                         p += 2;
3053                         *q++ = LF;  /* convert CR-LF to LF */
3054                     }
3055                     else
3056                         *q++ = *p++;    /* store char normally */
3057                 }
3058                 else {
3059                     /* This is the hard part.  We found a CR at end of
3060                        buffer.  We must peek ahead to see if next char
3061                        is an LF. */
3062                     ++p;
3063
3064                     dosretval = 0;
3065                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3066                                     (LPDWORD)&os_read, NULL))
3067                         dosretval = GetLastError();
3068
3069                     if (dosretval != 0 || os_read == 0) {
3070                         /* couldn't read ahead, store CR */
3071                         *q++ = CR;
3072                     }
3073                     else {
3074                         /* peekchr now has the extra character -- we now
3075                            have several possibilities:
3076                            1. disk file and char is not LF; just seek back
3077                               and copy CR
3078                            2. disk file and char is LF; store LF, don't seek back
3079                            3. pipe/device and char is LF; store LF.
3080                            4. pipe/device and char isn't LF, store CR and
3081                               put char in pipe lookahead buffer. */
3082                         if (_osfile(fh) & (FDEV|FPIPE)) {
3083                             /* non-seekable device */
3084                             if (peekchr == LF)
3085                                 *q++ = LF;
3086                             else {
3087                                 *q++ = CR;
3088                                 _pipech(fh) = peekchr;
3089                             }
3090                         }
3091                         else {
3092                             /* disk file */
3093                             if (peekchr == LF) {
3094                                 /* nothing read yet; must make some
3095                                    progress */
3096                                 *q++ = LF;
3097                                 /* turn on this flag for tell routine */
3098                                 _osfile(fh) |= FCRLF;
3099                             }
3100                             else {
3101                                 HANDLE osHandle;        /* o.s. handle value */
3102                                 /* seek back */
3103                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3104                                 {
3105                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3106                                         dosretval = GetLastError();
3107                                 }
3108                                 if (peekchr != LF)
3109                                     *q++ = CR;
3110                             }
3111                         }
3112                     }
3113                 }
3114             }
3115         }
3116
3117         /* we now change bytes_read to reflect the true number of chars
3118            in the buffer */
3119         bytes_read = q - (char *)buf;
3120     }
3121
3122 functionexit:
3123     if (_pioinfo(fh)->lockinitflag)
3124         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3125
3126     return bytes_read;
3127 }
3128
3129 #endif  /* PERL_MSVCRT_READFIX */
3130
3131 DllExport int
3132 win32_read(int fd, void *buf, unsigned int cnt)
3133 {
3134 #ifdef PERL_MSVCRT_READFIX
3135     return _fixed_read(fd, buf, cnt);
3136 #else
3137     return read(fd, buf, cnt);
3138 #endif
3139 }
3140
3141 DllExport int
3142 win32_write(int fd, const void *buf, unsigned int cnt)
3143 {
3144     return write(fd, buf, cnt);
3145 }
3146
3147 DllExport int
3148 win32_mkdir(const char *dir, int mode)
3149 {
3150     dTHX;
3151     if (USING_WIDE()) {
3152         WCHAR wBuffer[MAX_PATH+1];
3153         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3154         return _wmkdir(PerlDir_mapW(wBuffer));
3155     }
3156     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3157 }
3158
3159 DllExport int
3160 win32_rmdir(const char *dir)
3161 {
3162     dTHX;
3163     if (USING_WIDE()) {
3164         WCHAR wBuffer[MAX_PATH+1];
3165         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3166         return _wrmdir(PerlDir_mapW(wBuffer));
3167     }
3168     return rmdir(PerlDir_mapA(dir));
3169 }
3170
3171 DllExport int
3172 win32_chdir(const char *dir)
3173 {
3174     dTHX;
3175     if (!dir) {
3176         errno = ENOENT;
3177         return -1;
3178     }
3179     if (USING_WIDE()) {
3180         WCHAR wBuffer[MAX_PATH+1];
3181         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3182         return _wchdir(wBuffer);
3183     }
3184     return chdir(dir);
3185 }
3186
3187 DllExport  int
3188 win32_access(const char *path, int mode)
3189 {
3190     dTHX;
3191     if (USING_WIDE()) {
3192         WCHAR wBuffer[MAX_PATH+1];
3193         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3194         return _waccess(PerlDir_mapW(wBuffer), mode);
3195     }
3196     return access(PerlDir_mapA(path), mode);
3197 }
3198
3199 DllExport  int
3200 win32_chmod(const char *path, int mode)
3201 {
3202     dTHX;
3203     if (USING_WIDE()) {
3204         WCHAR wBuffer[MAX_PATH+1];
3205         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3206         return _wchmod(PerlDir_mapW(wBuffer), mode);
3207     }
3208     return chmod(PerlDir_mapA(path), mode);
3209 }
3210
3211
3212 static char *
3213 create_command_line(char *cname, STRLEN clen, const char * const *args)
3214 {
3215     dTHX;
3216     int index, argc;
3217     char *cmd, *ptr;
3218     const char *arg;
3219     STRLEN len = 0;
3220     bool bat_file = FALSE;
3221     bool cmd_shell = FALSE;
3222     bool dumb_shell = FALSE;
3223     bool extra_quotes = FALSE;
3224     bool quote_next = FALSE;
3225
3226     if (!cname)
3227         cname = (char*)args[0];
3228
3229     /* The NT cmd.exe shell has the following peculiarity that needs to be
3230      * worked around.  It strips a leading and trailing dquote when any
3231      * of the following is true:
3232      *    1. the /S switch was used
3233      *    2. there are more than two dquotes
3234      *    3. there is a special character from this set: &<>()@^|
3235      *    4. no whitespace characters within the two dquotes
3236      *    5. string between two dquotes isn't an executable file
3237      * To work around this, we always add a leading and trailing dquote
3238      * to the string, if the first argument is either "cmd.exe" or "cmd",
3239      * and there were at least two or more arguments passed to cmd.exe
3240      * (not including switches).
3241      * XXX the above rules (from "cmd /?") don't seem to be applied
3242      * always, making for the convolutions below :-(
3243      */
3244     if (cname) {
3245         if (!clen)
3246             clen = strlen(cname);
3247
3248         if (clen > 4
3249             && (stricmp(&cname[clen-4], ".bat") == 0
3250                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3251         {
3252             bat_file = TRUE;
3253             len += 3;
3254         }
3255         else {
3256             char *exe = strrchr(cname, '/');
3257             char *exe2 = strrchr(cname, '\\');
3258             if (exe2 > exe)
3259                 exe = exe2;
3260             if (exe)
3261                 ++exe;
3262             else
3263                 exe = cname;
3264             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3265                 cmd_shell = TRUE;
3266                 len += 3;
3267             }
3268             else if (stricmp(exe, "command.com") == 0
3269                      || stricmp(exe, "command") == 0)
3270             {
3271                 dumb_shell = TRUE;
3272             }
3273         }
3274     }
3275
3276     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3277     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3278         STRLEN curlen = strlen(arg);
3279         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3280             len += 2;   /* assume quoting needed (worst case) */
3281         len += curlen + 1;
3282         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3283     }
3284     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3285
3286     argc = index;
3287     New(1310, cmd, len, char);
3288     ptr = cmd;
3289
3290     if (bat_file) {
3291         *ptr++ = '"';
3292         extra_quotes = TRUE;
3293     }
3294
3295     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3296         bool do_quote = 0;
3297         STRLEN curlen = strlen(arg);
3298
3299         /* we want to protect empty arguments and ones with spaces with
3300          * dquotes, but only if they aren't already there */
3301         if (!dumb_shell) {
3302             if (!curlen) {
3303                 do_quote = 1;
3304             }
3305             else if (quote_next) {
3306                 /* see if it really is multiple arguments pretending to
3307                  * be one and force a set of quotes around it */
3308                 if (*find_next_space(arg))
3309                     do_quote = 1;
3310             }
3311             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3312                 STRLEN i = 0;
3313                 while (i < curlen) {
3314                     if (isSPACE(arg[i])) {
3315                         do_quote = 1;
3316                     }
3317                     else if (arg[i] == '"') {
3318                         do_quote = 0;
3319                         break;
3320                     }
3321                     i++;
3322                 }
3323             }
3324         }
3325
3326         if (do_quote)
3327             *ptr++ = '"';
3328
3329         strcpy(ptr, arg);
3330         ptr += curlen;
3331
3332         if (do_quote)
3333             *ptr++ = '"';
3334
3335         if (args[index+1])
3336             *ptr++ = ' ';
3337
3338         if (!extra_quotes
3339             && cmd_shell
3340             && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3341         {
3342             /* is there a next argument? */
3343             if (args[index+1]) {
3344                 /* are there two or more next arguments? */
3345                 if (args[index+2]) {
3346                     *ptr++ = '"';
3347                     extra_quotes = TRUE;
3348                 }
3349                 else {
3350                     /* single argument, force quoting if it has spaces */
3351                     quote_next = TRUE;
3352                 }
3353             }
3354         }
3355     }
3356
3357     if (extra_quotes)
3358         *ptr++ = '"';
3359
3360     *ptr = '\0';
3361
3362     return cmd;
3363 }
3364
3365 static char *
3366 qualified_path(const char *cmd)
3367 {
3368     dTHX;
3369     char *pathstr;
3370     char *fullcmd, *curfullcmd;
3371     STRLEN cmdlen = 0;
3372     int has_slash = 0;
3373
3374     if (!cmd)
3375         return Nullch;
3376     fullcmd = (char*)cmd;
3377     while (*fullcmd) {
3378         if (*fullcmd == '/' || *fullcmd == '\\')
3379             has_slash++;
3380         fullcmd++;
3381         cmdlen++;
3382     }
3383
3384     /* look in PATH */
3385     pathstr = PerlEnv_getenv("PATH");
3386     New(0, fullcmd, MAX_PATH+1, char);
3387     curfullcmd = fullcmd;
3388
3389     while (1) {
3390         DWORD res;
3391
3392         /* start by appending the name to the current prefix */
3393         strcpy(curfullcmd, cmd);
3394         curfullcmd += cmdlen;
3395
3396         /* if it doesn't end with '.', or has no extension, try adding
3397          * a trailing .exe first */
3398         if (cmd[cmdlen-1] != '.'
3399             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3400         {
3401             strcpy(curfullcmd, ".exe");
3402             res = GetFileAttributes(fullcmd);
3403             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3404                 return fullcmd;
3405             *curfullcmd = '\0';
3406         }
3407
3408         /* that failed, try the bare name */
3409         res = GetFileAttributes(fullcmd);
3410         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3411             return fullcmd;
3412
3413         /* quit if no other path exists, or if cmd already has path */
3414         if (!pathstr || !*pathstr || has_slash)
3415             break;
3416
3417         /* skip leading semis */
3418         while (*pathstr == ';')
3419             pathstr++;
3420
3421         /* build a new prefix from scratch */
3422         curfullcmd = fullcmd;
3423         while (*pathstr && *pathstr != ';') {
3424             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3425                 pathstr++;              /* skip initial '"' */
3426                 while (*pathstr && *pathstr != '"') {
3427                     if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3428                         *curfullcmd++ = *pathstr;
3429                     pathstr++;
3430                 }
3431                 if (*pathstr)
3432                     pathstr++;          /* skip trailing '"' */
3433             }
3434             else {
3435                 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3436                     *curfullcmd++ = *pathstr;
3437                 pathstr++;
3438             }
3439         }
3440         if (*pathstr)
3441             pathstr++;                  /* skip trailing semi */
3442         if (curfullcmd > fullcmd        /* append a dir separator */
3443             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3444         {
3445             *curfullcmd++ = '\\';
3446         }
3447     }
3448 GIVE_UP:
3449     Safefree(fullcmd);
3450     return Nullch;
3451 }
3452
3453 /* The following are just place holders.
3454  * Some hosts may provide and environment that the OS is
3455  * not tracking, therefore, these host must provide that
3456  * environment and the current directory to CreateProcess
3457  */
3458
3459 DllExport void*
3460 win32_get_childenv(void)
3461 {
3462     return NULL;
3463 }
3464
3465 DllExport void
3466 win32_free_childenv(void* d)
3467 {
3468 }
3469
3470 DllExport void
3471 win32_clearenv(void)
3472 {
3473     char *envv = GetEnvironmentStrings();
3474     char *cur = envv;
3475     STRLEN len;
3476     while (*cur) {
3477         char *end = strchr(cur,'=');
3478         if (end && end != cur) {
3479             *end = '\0';
3480             SetEnvironmentVariable(cur, NULL);
3481             *end = '=';
3482             cur = end + strlen(end+1)+2;
3483         }
3484         else if ((len = strlen(cur)))
3485             cur += len+1;
3486     }
3487     FreeEnvironmentStrings(envv);
3488 }
3489
3490 DllExport char*
3491 win32_get_childdir(void)
3492 {
3493     dTHX;
3494     char* ptr;
3495     char szfilename[(MAX_PATH+1)*2];
3496     if (USING_WIDE()) {
3497         WCHAR wfilename[MAX_PATH+1];
3498         GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3499         W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3500     }
3501     else {
3502         GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3503     }
3504
3505     New(0, ptr, strlen(szfilename)+1, char);
3506     strcpy(ptr, szfilename);
3507     return ptr;
3508 }
3509
3510 DllExport void
3511 win32_free_childdir(char* d)
3512 {
3513     dTHX;
3514     Safefree(d);
3515 }
3516
3517
3518 /* XXX this needs to be made more compatible with the spawnvp()
3519  * provided by the various RTLs.  In particular, searching for
3520  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3521  * This doesn't significantly affect perl itself, because we
3522  * always invoke things using PERL5SHELL if a direct attempt to
3523  * spawn the executable fails.
3524  *
3525  * XXX splitting and rejoining the commandline between do_aspawn()
3526  * and win32_spawnvp() could also be avoided.
3527  */
3528
3529 DllExport int
3530 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3531 {
3532 #ifdef USE_RTL_SPAWNVP
3533     return spawnvp(mode, cmdname, (char * const *)argv);
3534 #else
3535     dTHX;
3536     int ret;
3537     void* env;
3538     char* dir;
3539     child_IO_table tbl;
3540     STARTUPINFO StartupInfo;
3541     PROCESS_INFORMATION ProcessInformation;
3542     DWORD create = 0;
3543     char *cmd;
3544     char *fullcmd = Nullch;
3545     char *cname = (char *)cmdname;
3546     STRLEN clen = 0;
3547
3548     if (cname) {
3549         clen = strlen(cname);
3550         /* if command name contains dquotes, must remove them */
3551         if (strchr(cname, '"')) {
3552             cmd = cname;
3553             New(0,cname,clen+1,char);
3554             clen = 0;
3555             while (*cmd) {
3556                 if (*cmd != '"') {
3557                     cname[clen] = *cmd;
3558                     ++clen;
3559                 }
3560                 ++cmd;
3561             }
3562             cname[clen] = '\0';
3563         }
3564     }
3565
3566     cmd = create_command_line(cname, clen, argv);
3567
3568     env = PerlEnv_get_childenv();
3569     dir = PerlEnv_get_childdir();
3570
3571     switch(mode) {
3572     case P_NOWAIT:      /* asynch + remember result */
3573         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3574             errno = EAGAIN;
3575             ret = -1;
3576             goto RETVAL;
3577         }
3578         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3579          * in win32_kill()
3580          */
3581         create |= CREATE_NEW_PROCESS_GROUP;
3582         /* FALL THROUGH */
3583
3584     case P_WAIT:        /* synchronous execution */
3585         break;
3586     default:            /* invalid mode */
3587         errno = EINVAL;
3588         ret = -1;
3589         goto RETVAL;
3590     }
3591     memset(&StartupInfo,0,sizeof(StartupInfo));
3592     StartupInfo.cb = sizeof(StartupInfo);
3593     memset(&tbl,0,sizeof(tbl));
3594     PerlEnv_get_child_IO(&tbl);
3595     StartupInfo.dwFlags         = tbl.dwFlags;
3596     StartupInfo.dwX             = tbl.dwX;
3597     StartupInfo.dwY             = tbl.dwY;
3598     StartupInfo.dwXSize         = tbl.dwXSize;
3599     StartupInfo.dwYSize         = tbl.dwYSize;
3600     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3601     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3602     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3603     StartupInfo.wShowWindow     = tbl.wShowWindow;
3604     StartupInfo.hStdInput       = tbl.childStdIn;
3605     StartupInfo.hStdOutput      = tbl.childStdOut;
3606     StartupInfo.hStdError       = tbl.childStdErr;
3607     if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3608         StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3609         StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3610     {
3611         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3612     }
3613     else {
3614         create |= CREATE_NEW_CONSOLE;
3615     }
3616
3617     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3618                           cname,cmd));
3619 RETRY:
3620     if (!CreateProcess(cname,           /* search PATH to find executable */
3621                        cmd,             /* executable, and its arguments */
3622                        NULL,            /* process attributes */
3623                        NULL,            /* thread attributes */
3624                        TRUE,            /* inherit handles */
3625                        create,          /* creation flags */
3626                        (LPVOID)env,     /* inherit environment */
3627                        dir,             /* inherit cwd */
3628                        &StartupInfo,
3629                        &ProcessInformation))
3630     {
3631         /* initial NULL argument to CreateProcess() does a PATH
3632          * search, but it always first looks in the directory
3633          * where the current process was started, which behavior
3634          * is undesirable for backward compatibility.  So we
3635          * jump through our own hoops by picking out the path
3636          * we really want it to use. */
3637         if (!fullcmd) {
3638             fullcmd = qualified_path(cname);
3639             if (fullcmd) {
3640                 if (cname != cmdname)
3641                     Safefree(cname);
3642                 cname = fullcmd;
3643                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3644                                       "Retrying [%s] with same args\n",
3645                                       cname));
3646                 goto RETRY;
3647             }
3648         }
3649         errno = ENOENT;
3650         ret = -1;
3651         goto RETVAL;
3652     }
3653
3654     if (mode == P_NOWAIT) {
3655         /* asynchronous spawn -- store handle, return PID */
3656         ret = (int)ProcessInformation.dwProcessId;
3657         if (IsWin95() && ret < 0)
3658             ret = -ret;
3659
3660         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3661         w32_child_pids[w32_num_children] = (DWORD)ret;
3662         ++w32_num_children;
3663     }
3664     else  {
3665         DWORD status;
3666         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3667         /* FIXME: if msgwait returned due to message perhaps forward the
3668            "signal" to the process
3669          */
3670         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3671         ret = (int)status;
3672         CloseHandle(ProcessInformation.hProcess);
3673     }
3674
3675     CloseHandle(ProcessInformation.hThread);
3676
3677 RETVAL:
3678     PerlEnv_free_childenv(env);
3679     PerlEnv_free_childdir(dir);
3680     Safefree(cmd);
3681     if (cname != cmdname)
3682         Safefree(cname);
3683     return ret;
3684 #endif
3685 }
3686
3687 DllExport int
3688 win32_execv(const char *cmdname, const char *const *argv)
3689 {
3690 #ifdef USE_ITHREADS
3691     dTHX;
3692     /* if this is a pseudo-forked child, we just want to spawn
3693      * the new program, and return */
3694     if (w32_pseudo_id)
3695         return spawnv(P_WAIT, cmdname, (char *const *)argv);
3696 #endif
3697     return execv(cmdname, (char *const *)argv);
3698 }
3699
3700 DllExport int
3701 win32_execvp(const char *cmdname, const char *const *argv)
3702 {
3703 #ifdef USE_ITHREADS
3704     dTHX;
3705     /* if this is a pseudo-forked child, we just want to spawn
3706      * the new program, and return */
3707     if (w32_pseudo_id) {
3708         int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3709         if (status != -1) {
3710             my_exit(status);
3711             return 0;
3712         }
3713         else
3714             return status;
3715     }
3716 #endif
3717     return execvp(cmdname, (char *const *)argv);
3718 }
3719
3720 DllExport void
3721 win32_perror(const char *str)
3722 {
3723     perror(str);
3724 }
3725
3726 DllExport void
3727 win32_setbuf(FILE *pf, char *buf)
3728 {
3729     setbuf(pf, buf);
3730 }
3731
3732 DllExport int
3733 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3734 {
3735     return setvbuf(pf, buf, type, size);
3736 }
3737
3738 DllExport int
3739 win32_flushall(void)
3740 {
3741     return flushall();
3742 }
3743
3744 DllExport int
3745 win32_fcloseall(void)
3746 {
3747     return fcloseall();
3748 }
3749
3750 DllExport char*
3751 win32_fgets(char *s, int n, FILE *pf)
3752 {
3753     return fgets(s, n, pf);
3754 }
3755
3756 DllExport char*
3757 win32_gets(char *s)
3758 {
3759     return gets(s);
3760 }
3761
3762 DllExport int
3763 win32_fgetc(FILE *pf)
3764 {
3765     return fgetc(pf);
3766 }
3767
3768 DllExport int
3769 win32_putc(int c, FILE *pf)
3770 {
3771     return putc(c,pf);
3772 }
3773
3774 DllExport int
3775 win32_puts(const char *s)
3776 {
3777     return puts(s);
3778 }
3779
3780 DllExport int
3781 win32_getchar(void)
3782 {
3783     return getchar();
3784 }
3785
3786 DllExport int
3787 win32_putchar(int c)
3788 {
3789     return putchar(c);
3790 }
3791
3792 #ifdef MYMALLOC
3793
3794 #ifndef USE_PERL_SBRK
3795
3796 static char *committed = NULL;          /* XXX threadead */
3797 static char *base      = NULL;          /* XXX threadead */
3798 static char *reserved  = NULL;          /* XXX threadead */
3799 static char *brk       = NULL;          /* XXX threadead */
3800 static DWORD pagesize  = 0;             /* XXX threadead */
3801 static DWORD allocsize = 0;             /* XXX threadead */
3802
3803 void *
3804 sbrk(int need)
3805 {
3806  void *result;
3807  if (!pagesize)
3808   {SYSTEM_INFO info;
3809    GetSystemInfo(&info);
3810    /* Pretend page size is larger so we don't perpetually
3811     * call the OS to commit just one page ...
3812     */
3813    pagesize = info.dwPageSize << 3;
3814    allocsize = info.dwAllocationGranularity;
3815   }
3816  /* This scheme fails eventually if request for contiguous
3817   * block is denied so reserve big blocks - this is only
3818   * address space not memory ...
3819   */
3820  if (brk+need >= reserved)
3821   {
3822    DWORD size = 64*1024*1024;
3823    char *addr;
3824    if (committed && reserved && committed < reserved)
3825     {
3826      /* Commit last of previous chunk cannot span allocations */
3827      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3828      if (addr)
3829       committed = reserved;
3830     }
3831    /* Reserve some (more) space
3832     * Note this is a little sneaky, 1st call passes NULL as reserved
3833     * so lets system choose where we start, subsequent calls pass
3834     * the old end address so ask for a contiguous block
3835     */
3836    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3837    if (addr)
3838     {
3839      reserved = addr+size;
3840      if (!base)
3841       base = addr;
3842      if (!committed)
3843       committed = base;
3844      if (!brk)
3845       brk = committed;
3846     }
3847    else
3848     {
3849      return (void *) -1;
3850     }
3851   }
3852  result = brk;
3853  brk += need;
3854  if (brk > committed)
3855   {
3856    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3857    char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3858    if (addr)
3859     {
3860      committed += size;
3861     }
3862    else
3863     return (void *) -1;
3864   }
3865  return result;
3866 }
3867
3868 #endif
3869 #endif
3870
3871 DllExport void*
3872 win32_malloc(size_t size)
3873 {
3874     return malloc(size);
3875 }
3876
3877 DllExport void*
3878 win32_calloc(size_t numitems, size_t size)
3879 {
3880     return calloc(numitems,size);
3881 }
3882
3883 DllExport void*
3884 win32_realloc(void *block, size_t size)
3885 {
3886     return realloc(block,size);
3887 }
3888
3889 DllExport void
3890 win32_free(void *block)
3891 {
3892     free(block);
3893 }
3894
3895
3896 int
3897 win32_open_osfhandle(long handle, int flags)
3898 {
3899 #ifdef USE_FIXED_OSFHANDLE
3900     if (IsWin95())
3901         return my_open_osfhandle(handle, flags);
3902 #endif
3903     return _open_osfhandle(handle, flags);
3904 }
3905
3906 long
3907 win32_get_osfhandle(int fd)
3908 {
3909     return _get_osfhandle(fd);
3910 }
3911
3912 DllExport void*
3913 win32_dynaload(const char* filename)
3914 {
3915     dTHX;
3916     HMODULE hModule;
3917     char buf[MAX_PATH+1];
3918     char *first;
3919
3920     /* LoadLibrary() doesn't recognize forward slashes correctly,
3921      * so turn 'em back. */
3922     first = strchr(filename, '/');
3923     if (first) {
3924         STRLEN len = strlen(filename);
3925         if (len <= MAX_PATH) {
3926             strcpy(buf, filename);
3927             filename = &buf[first - filename];
3928             while (*filename) {
3929                 if (*filename == '/')
3930                     *(char*)filename = '\\';
3931                 ++filename;
3932             }
3933             filename = buf;
3934         }
3935     }
3936     if (USING_WIDE()) {
3937         WCHAR wfilename[MAX_PATH+1];
3938         A2WHELPER(filename, wfilename, sizeof(wfilename));
3939         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3940     }
3941     else {
3942         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
3943     }
3944     return hModule;
3945 }
3946
3947 /*
3948  * Extras.
3949  */
3950
3951 static
3952 XS(w32_GetCwd)
3953 {
3954     dXSARGS;
3955     /* Make the host for current directory */
3956     char* ptr = PerlEnv_get_childdir();
3957     /*
3958      * If ptr != Nullch
3959      *   then it worked, set PV valid,
3960      *   else return 'undef'
3961      */
3962     if (ptr) {
3963         SV *sv = sv_newmortal();
3964         sv_setpv(sv, ptr);
3965         PerlEnv_free_childdir(ptr);
3966
3967 #ifndef INCOMPLETE_TAINTS
3968         SvTAINTED_on(sv);
3969 #endif
3970
3971         EXTEND(SP,1);
3972         SvPOK_on(sv);
3973         ST(0) = sv;
3974         XSRETURN(1);
3975     }
3976     XSRETURN_UNDEF;
3977 }
3978
3979 static
3980 XS(w32_SetCwd)
3981 {
3982     dXSARGS;
3983     if (items != 1)
3984         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
3985     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
3986         XSRETURN_YES;
3987
3988     XSRETURN_NO;
3989 }
3990
3991 static
3992 XS(w32_GetNextAvailDrive)
3993 {
3994     dXSARGS;
3995     char ix = 'C';
3996     char root[] = "_:\\";
3997
3998     EXTEND(SP,1);
3999     while (ix <= 'Z') {
4000         root[0] = ix++;
4001         if (GetDriveType(root) == 1) {
4002             root[2] = '\0';
4003             XSRETURN_PV(root);
4004         }
4005     }
4006     XSRETURN_UNDEF;
4007 }
4008
4009 static
4010 XS(w32_GetLastError)
4011 {
4012     dXSARGS;
4013     EXTEND(SP,1);
4014     XSRETURN_IV(GetLastError());
4015 }
4016
4017 static
4018 XS(w32_SetLastError)
4019 {
4020     dXSARGS;
4021     if (items != 1)
4022         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4023     SetLastError(SvIV(ST(0)));
4024     XSRETURN_EMPTY;
4025 }
4026
4027 static
4028 XS(w32_LoginName)
4029 {
4030     dXSARGS;
4031     char *name = w32_getlogin_buffer;
4032     DWORD size = sizeof(w32_getlogin_buffer);
4033     EXTEND(SP,1);
4034     if (GetUserName(name,&size)) {
4035         /* size includes NULL */
4036         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4037         XSRETURN(1);
4038     }
4039     XSRETURN_UNDEF;
4040 }
4041
4042 static
4043 XS(w32_NodeName)
4044 {
4045     dXSARGS;
4046     char name[MAX_COMPUTERNAME_LENGTH+1];
4047     DWORD size = sizeof(name);
4048     EXTEND(SP,1);
4049     if (GetComputerName(name,&size)) {
4050         /* size does NOT include NULL :-( */
4051         ST(0) = sv_2mortal(newSVpvn(name,size));
4052         XSRETURN(1);
4053     }
4054     XSRETURN_UNDEF;
4055 }
4056
4057
4058 static
4059 XS(w32_DomainName)
4060 {
4061     dXSARGS;
4062     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4063     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4064     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4065                                           void *bufptr);
4066
4067     if (hNetApi32) {
4068         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4069             GetProcAddress(hNetApi32, "NetApiBufferFree");
4070         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4071             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4072     }
4073     EXTEND(SP,1);
4074     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4075         /* this way is more reliable, in case user has a local account. */
4076         char dname[256];
4077         DWORD dnamelen = sizeof(dname);
4078         struct {
4079             DWORD   wki100_platform_id;
4080             LPWSTR  wki100_computername;
4081             LPWSTR  wki100_langroup;
4082             DWORD   wki100_ver_major;
4083             DWORD   wki100_ver_minor;
4084         } *pwi;
4085         /* NERR_Success *is* 0*/
4086         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4087             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4088                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4089                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4090             }
4091             else {
4092                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4093                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4094             }
4095             pfnNetApiBufferFree(pwi);
4096             FreeLibrary(hNetApi32);
4097             XSRETURN_PV(dname);
4098         }
4099         FreeLibrary(hNetApi32);
4100     }
4101     else {
4102         /* Win95 doesn't have NetWksta*(), so do it the old way */
4103         char name[256];
4104         DWORD size = sizeof(name);
4105         if (hNetApi32)
4106             FreeLibrary(hNetApi32);
4107         if (GetUserName(name,&size)) {
4108             char sid[ONE_K_BUFSIZE];
4109             DWORD sidlen = sizeof(sid);
4110             char dname[256];
4111             DWORD dnamelen = sizeof(dname);
4112             SID_NAME_USE snu;
4113             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4114                                   dname, &dnamelen, &snu)) {
4115                 XSRETURN_PV(dname);             /* all that for this */
4116             }
4117         }
4118     }
4119     XSRETURN_UNDEF;
4120 }
4121
4122 static
4123 XS(w32_FsType)
4124 {
4125     dXSARGS;
4126     char fsname[256];
4127     DWORD flags, filecomplen;
4128     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4129                          &flags, fsname, sizeof(fsname))) {
4130         if (GIMME_V == G_ARRAY) {
4131             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4132             XPUSHs(sv_2mortal(newSViv(flags)));
4133             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4134             PUTBACK;
4135             return;
4136         }
4137         EXTEND(SP,1);
4138         XSRETURN_PV(fsname);
4139     }
4140     XSRETURN_EMPTY;
4141 }
4142
4143 static
4144 XS(w32_GetOSVersion)
4145 {
4146     dXSARGS;
4147     OSVERSIONINFOA osver;
4148
4149     if (USING_WIDE()) {
4150         OSVERSIONINFOW osverw;
4151         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4152         osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4153         if (!GetVersionExW(&osverw)) {
4154             XSRETURN_EMPTY;
4155         }
4156         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4157         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4158         osver.dwMajorVersion = osverw.dwMajorVersion;
4159         osver.dwMinorVersion = osverw.dwMinorVersion;
4160         osver.dwBuildNumber = osverw.dwBuildNumber;
4161         osver.dwPlatformId = osverw.dwPlatformId;
4162     }
4163     else {
4164         osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4165         if (!GetVersionExA(&osver)) {
4166             XSRETURN_EMPTY;
4167         }
4168         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4169     }
4170     XPUSHs(newSViv(osver.dwMajorVersion));
4171     XPUSHs(newSViv(osver.dwMinorVersion));
4172     XPUSHs(newSViv(osver.dwBuildNumber));
4173     XPUSHs(newSViv(osver.dwPlatformId));
4174     PUTBACK;
4175 }
4176
4177 static
4178 XS(w32_IsWinNT)
4179 {
4180     dXSARGS;
4181     EXTEND(SP,1);
4182     XSRETURN_IV(IsWinNT());
4183 }
4184
4185 static
4186 XS(w32_IsWin95)
4187 {
4188     dXSARGS;
4189     EXTEND(SP,1);
4190     XSRETURN_IV(IsWin95());
4191 }
4192
4193 static
4194 XS(w32_FormatMessage)
4195 {
4196     dXSARGS;
4197     DWORD source = 0;
4198     char msgbuf[ONE_K_BUFSIZE];
4199
4200     if (items != 1)
4201         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4202
4203     if (USING_WIDE()) {
4204         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4205         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4206                           &source, SvIV(ST(0)), 0,
4207                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4208         {
4209             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4210             XSRETURN_PV(msgbuf);
4211         }
4212     }
4213     else {
4214         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4215                           &source, SvIV(ST(0)), 0,
4216                           msgbuf, sizeof(msgbuf)-1, NULL))
4217             XSRETURN_PV(msgbuf);
4218     }
4219
4220     XSRETURN_UNDEF;
4221 }
4222
4223 static
4224 XS(w32_Spawn)
4225 {
4226     dXSARGS;
4227     char *cmd, *args;
4228     void *env;
4229     char *dir;
4230     PROCESS_INFORMATION stProcInfo;
4231     STARTUPINFO stStartInfo;
4232     BOOL bSuccess = FALSE;
4233
4234     if (items != 3)
4235         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4236
4237     cmd = SvPV_nolen(ST(0));
4238     args = SvPV_nolen(ST(1));
4239
4240     env = PerlEnv_get_childenv();
4241     dir = PerlEnv_get_childdir();
4242
4243     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4244     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4245     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4246     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4247
4248     if (CreateProcess(
4249                 cmd,                    /* Image path */
4250                 args,                   /* Arguments for command line */
4251                 NULL,                   /* Default process security */
4252                 NULL,                   /* Default thread security */
4253                 FALSE,                  /* Must be TRUE to use std handles */
4254                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4255                 env,                    /* Inherit our environment block */
4256                 dir,                    /* Inherit our currrent directory */
4257                 &stStartInfo,           /* -> Startup info */
4258                 &stProcInfo))           /* <- Process info (if OK) */
4259     {
4260         int pid = (int)stProcInfo.dwProcessId;
4261         if (IsWin95() && pid < 0)
4262             pid = -pid;
4263         sv_setiv(ST(2), pid);
4264         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4265         bSuccess = TRUE;
4266     }
4267     PerlEnv_free_childenv(env);
4268     PerlEnv_free_childdir(dir);
4269     XSRETURN_IV(bSuccess);
4270 }
4271
4272 static
4273 XS(w32_GetTickCount)
4274 {
4275     dXSARGS;
4276     DWORD msec = GetTickCount();
4277     EXTEND(SP,1);
4278     if ((IV)msec > 0)
4279         XSRETURN_IV(msec);
4280     XSRETURN_NV(msec);
4281 }
4282
4283 static
4284 XS(w32_GetShortPathName)
4285 {
4286     dXSARGS;
4287     SV *shortpath;
4288     DWORD len;
4289
4290     if (items != 1)
4291         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4292
4293     shortpath = sv_mortalcopy(ST(0));
4294     SvUPGRADE(shortpath, SVt_PV);
4295     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4296         XSRETURN_UNDEF;
4297
4298     /* src == target is allowed */
4299     do {
4300         len = GetShortPathName(SvPVX(shortpath),
4301                                SvPVX(shortpath),
4302                                SvLEN(shortpath));
4303     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4304     if (len) {
4305         SvCUR_set(shortpath,len);
4306         ST(0) = shortpath;
4307         XSRETURN(1);
4308     }
4309     XSRETURN_UNDEF;
4310 }
4311
4312 static
4313 XS(w32_GetFullPathName)
4314 {
4315     dXSARGS;
4316     SV *filename;
4317     SV *fullpath;
4318     char *filepart;
4319     DWORD len;
4320
4321     if (items != 1)
4322         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4323
4324     filename = ST(0);
4325     fullpath = sv_mortalcopy(filename);
4326     SvUPGRADE(fullpath, SVt_PV);
4327     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4328         XSRETURN_UNDEF;
4329
4330     do {
4331         len = GetFullPathName(SvPVX(filename),
4332                               SvLEN(fullpath),
4333                               SvPVX(fullpath),
4334                               &filepart);
4335     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4336     if (len) {
4337         if (GIMME_V == G_ARRAY) {
4338             EXTEND(SP,1);
4339             XST_mPV(1,filepart);
4340             len = filepart - SvPVX(fullpath);
4341             items = 2;
4342         }
4343         SvCUR_set(fullpath,len);
4344         ST(0) = fullpath;
4345         XSRETURN(items);
4346     }
4347     XSRETURN_EMPTY;
4348 }
4349
4350 static
4351 XS(w32_GetLongPathName)
4352 {
4353     dXSARGS;
4354     SV *path;
4355     char tmpbuf[MAX_PATH+1];
4356     char *pathstr;
4357     STRLEN len;
4358
4359     if (items != 1)
4360         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4361
4362     path = ST(0);
4363     pathstr = SvPV(path,len);
4364     strcpy(tmpbuf, pathstr);
4365     pathstr = win32_longpath(tmpbuf);
4366     if (pathstr) {
4367         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4368         XSRETURN(1);
4369     }
4370     XSRETURN_EMPTY;
4371 }
4372
4373 static
4374 XS(w32_Sleep)
4375 {
4376     dXSARGS;
4377     if (items != 1)
4378         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4379     Sleep(SvIV(ST(0)));
4380     XSRETURN_YES;
4381 }
4382
4383 static
4384 XS(w32_CopyFile)
4385 {
4386     dXSARGS;
4387     BOOL bResult;
4388     if (items != 3)
4389         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4390     if (USING_WIDE()) {
4391         WCHAR wSourceFile[MAX_PATH+1];
4392         WCHAR wDestFile[MAX_PATH+1];
4393         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4394         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4395         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4396         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4397     }
4398     else {
4399         char szSourceFile[MAX_PATH+1];
4400         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4401         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4402     }
4403
4404     if (bResult)
4405         XSRETURN_YES;
4406     XSRETURN_NO;
4407 }
4408
4409 void
4410 Perl_init_os_extras(void)
4411 {
4412     dTHX;
4413     char *file = __FILE__;
4414     dXSUB_SYS;
4415
4416     /* these names are Activeware compatible */
4417     newXS("Win32::GetCwd", w32_GetCwd, file);
4418     newXS("Win32::SetCwd", w32_SetCwd, file);
4419     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4420     newXS("Win32::GetLastError", w32_GetLastError, file);
4421     newXS("Win32::SetLastError", w32_SetLastError, file);
4422     newXS("Win32::LoginName", w32_LoginName, file);
4423     newXS("Win32::NodeName", w32_NodeName, file);
4424     newXS("Win32::DomainName", w32_DomainName, file);
4425     newXS("Win32::FsType", w32_FsType, file);
4426     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4427     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4428     newXS("Win32::IsWin95", w32_IsWin95, file);
4429     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4430     newXS("Win32::Spawn", w32_Spawn, file);
4431     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4432     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4433     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4434     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4435     newXS("Win32::CopyFile", w32_CopyFile, file);
4436     newXS("Win32::Sleep", w32_Sleep, file);
4437
4438     /* XXX Bloat Alert! The following Activeware preloads really
4439      * ought to be part of Win32::Sys::*, so they're not included
4440      * here.
4441      */
4442     /* LookupAccountName
4443      * LookupAccountSID
4444      * InitiateSystemShutdown
4445      * AbortSystemShutdown
4446      * ExpandEnvrironmentStrings
4447      */
4448 }
4449
4450 static PerlInterpreter* win32_process_perl = NULL;
4451
4452 BOOL WINAPI
4453 win32_ctrlhandler(DWORD dwCtrlType)
4454 {
4455     dTHX;
4456     if (!my_perl) {
4457         my_perl = win32_process_perl;
4458         if (!my_perl) {
4459             return FALSE;
4460         }
4461         PERL_SET_THX(my_perl);
4462     }
4463
4464     switch(dwCtrlType) {
4465     case CTRL_CLOSE_EVENT:
4466      /*  A signal that the system sends to all processes attached to a console when
4467          the user closes the console (either by choosing the Close command from the
4468          console window's System menu, or by choosing the End Task command from the
4469          Task List
4470       */
4471         CALL_FPTR(PL_sighandlerp)(1); /* SIGHUP */
4472         return TRUE;
4473
4474     case CTRL_C_EVENT:
4475         /*  A CTRL+c signal was received */
4476         CALL_FPTR(PL_sighandlerp)(2); /* SIGINT */
4477         return TRUE;
4478
4479     case CTRL_BREAK_EVENT:
4480         /*  A CTRL+BREAK signal was received */
4481         CALL_FPTR(PL_sighandlerp)(3); /* SIGQUIT */
4482         return TRUE;
4483
4484     case CTRL_LOGOFF_EVENT:
4485       /*  A signal that the system sends to all console processes when a user is logging
4486           off. This signal does not indicate which user is logging off, so no
4487           assumptions can be made.
4488        */
4489         break;
4490     case CTRL_SHUTDOWN_EVENT:
4491       /*  A signal that the system sends to all console processes when the system is
4492           shutting down.
4493        */
4494         break;
4495     default:
4496         break;
4497     }
4498     return FALSE;
4499 }
4500
4501
4502
4503 void
4504 Perl_win32_init(int *argcp, char ***argvp)
4505 {
4506     /* Disable floating point errors, Perl will trap the ones we
4507      * care about.  VC++ RTL defaults to switching these off
4508      * already, but the Borland RTL doesn't.  Since we don't
4509      * want to be at the vendor's whim on the default, we set
4510      * it explicitly here.
4511      */
4512 #if !defined(_ALPHA_) && !defined(__GNUC__)
4513     _control87(MCW_EM, MCW_EM);
4514 #endif
4515     MALLOC_INIT;
4516 }
4517
4518 void
4519 win32_get_child_IO(child_IO_table* ptbl)
4520 {
4521     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4522     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4523     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4524 }
4525
4526 #ifdef HAVE_INTERP_INTERN
4527
4528
4529
4530 void
4531 Perl_sys_intern_init(pTHX)
4532 {
4533     w32_perlshell_tokens        = Nullch;
4534     w32_perlshell_vec           = (char**)NULL;
4535     w32_perlshell_items         = 0;
4536     w32_fdpid                   = newAV();
4537     New(1313, w32_children, 1, child_tab);
4538     w32_num_children            = 0;
4539 #  ifdef USE_ITHREADS
4540     w32_pseudo_id               = 0;
4541     New(1313, w32_pseudo_children, 1, child_tab);
4542     w32_num_pseudo_children     = 0;
4543 #  endif
4544     w32_init_socktype           = 0;
4545     if (!win32_process_perl) {
4546         win32_process_perl = my_perl;
4547         /* Force C runtime signal stuff to set its console handler */
4548         signal(SIGINT,SIG_DFL);
4549         /* Push our handler on top */
4550         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4551     }
4552 }
4553
4554 void
4555 Perl_sys_intern_clear(pTHX)
4556 {
4557     Safefree(w32_perlshell_tokens);
4558     Safefree(w32_perlshell_vec);
4559     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4560     Safefree(w32_children);
4561     if (my_perl == win32_process_perl) {
4562         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4563         win32_process_perl = NULL;
4564     }
4565 #  ifdef USE_ITHREADS
4566     Safefree(w32_pseudo_children);
4567 #  endif
4568 }
4569
4570 #  ifdef USE_ITHREADS
4571
4572 void
4573 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4574 {
4575     dst->perlshell_tokens       = Nullch;
4576     dst->perlshell_vec          = (char**)NULL;
4577     dst->perlshell_items        = 0;
4578     dst->fdpid                  = newAV();
4579     Newz(1313, dst->children, 1, child_tab);
4580     dst->pseudo_id              = 0;
4581     Newz(1313, dst->pseudo_children, 1, child_tab);
4582     dst->thr_intern.Winit_socktype = 0;
4583 }
4584 #  endif /* USE_ITHREADS */
4585 #endif /* HAVE_INTERP_INTERN */
4586
4587 static void
4588 win32_free_argvw(pTHX_ void *ptr)
4589 {
4590     char** argv = (char**)ptr;
4591     while(*argv) {
4592         Safefree(*argv);
4593         *argv++ = Nullch;
4594     }
4595 }
4596
4597 void
4598 win32_argv2utf8(int argc, char** argv)
4599 {
4600     dTHX;
4601     char* psz;
4602     int length, wargc;
4603     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4604     if (lpwStr && argc) {
4605         while (argc--) {
4606             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4607             Newz(0, psz, length, char);
4608             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4609             argv[argc] = psz;
4610         }
4611         call_atexit(win32_free_argvw, argv);
4612     }
4613     GlobalFree((HGLOBAL)lpwStr);
4614 }
4615
4616
4617
4618