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