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