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 #if defined(__BORLANDC__)
2545                     setmode(fd,O_BINARY);
2546 #endif
2547                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2548                                           "Created tmpfile=%s\n",filename));
2549                     return fdopen(fd, "w+b");
2550                 }
2551             }
2552         }
2553     }
2554     return NULL;
2555 }
2556
2557 DllExport void
2558 win32_abort(void)
2559 {
2560     abort();
2561     return;
2562 }
2563
2564 DllExport int
2565 win32_fstat(int fd,struct stat *sbufptr)
2566 {
2567 #ifdef __BORLANDC__
2568     /* A file designated by filehandle is not shown as accessible
2569      * for write operations, probably because it is opened for reading.
2570      * --Vadim Konovalov
2571      */
2572     int rc = fstat(fd,sbufptr);
2573     BY_HANDLE_FILE_INFORMATION bhfi;
2574     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2575         sbufptr->st_mode &= 0xFE00;
2576         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2577             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2578         else
2579             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2580               + ((S_IREAD|S_IWRITE) >> 6));
2581     }
2582     return rc;
2583 #else
2584     return my_fstat(fd,sbufptr);
2585 #endif
2586 }
2587
2588 DllExport int
2589 win32_pipe(int *pfd, unsigned int size, int mode)
2590 {
2591     return _pipe(pfd, size, mode);
2592 }
2593
2594 DllExport PerlIO*
2595 win32_popenlist(const char *mode, IV narg, SV **args)
2596 {
2597  dTHX;
2598  Perl_croak(aTHX_ "List form of pipe open not implemented");
2599  return NULL;
2600 }
2601
2602 /*
2603  * a popen() clone that respects PERL5SHELL
2604  *
2605  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2606  */
2607
2608 DllExport PerlIO*
2609 win32_popen(const char *command, const char *mode)
2610 {
2611 #ifdef USE_RTL_POPEN
2612     return _popen(command, mode);
2613 #else
2614     int p[2];
2615     int parent, child;
2616     int stdfd, oldfd;
2617     int ourmode;
2618     int childpid;
2619
2620     /* establish which ends read and write */
2621     if (strchr(mode,'w')) {
2622         stdfd = 0;              /* stdin */
2623         parent = 1;
2624         child = 0;
2625     }
2626     else if (strchr(mode,'r')) {
2627         stdfd = 1;              /* stdout */
2628         parent = 0;
2629         child = 1;
2630     }
2631     else
2632         return NULL;
2633
2634     /* set the correct mode */
2635     if (strchr(mode,'b'))
2636         ourmode = O_BINARY;
2637     else if (strchr(mode,'t'))
2638         ourmode = O_TEXT;
2639     else
2640         ourmode = _fmode & (O_TEXT | O_BINARY);
2641
2642     /* the child doesn't inherit handles */
2643     ourmode |= O_NOINHERIT;
2644
2645     if (win32_pipe( p, 512, ourmode) == -1)
2646         return NULL;
2647
2648     /* save current stdfd */
2649     if ((oldfd = win32_dup(stdfd)) == -1)
2650         goto cleanup;
2651
2652     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2653     /* stdfd will be inherited by the child */
2654     if (win32_dup2(p[child], stdfd) == -1)
2655         goto cleanup;
2656
2657     /* close the child end in parent */
2658     win32_close(p[child]);
2659
2660     /* start the child */
2661     {
2662         dTHX;
2663         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2664             goto cleanup;
2665
2666         /* revert stdfd to whatever it was before */
2667         if (win32_dup2(oldfd, stdfd) == -1)
2668             goto cleanup;
2669
2670         /* close saved handle */
2671         win32_close(oldfd);
2672
2673         LOCK_FDPID_MUTEX;
2674         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2675         UNLOCK_FDPID_MUTEX;
2676
2677         /* set process id so that it can be returned by perl's open() */
2678         PL_forkprocess = childpid;
2679     }
2680
2681     /* we have an fd, return a file stream */
2682     return (PerlIO_fdopen(p[parent], (char *)mode));
2683
2684 cleanup:
2685     /* we don't need to check for errors here */
2686     win32_close(p[0]);
2687     win32_close(p[1]);
2688     if (oldfd != -1) {
2689         win32_dup2(oldfd, stdfd);
2690         win32_close(oldfd);
2691     }
2692     return (NULL);
2693
2694 #endif /* USE_RTL_POPEN */
2695 }
2696
2697 /*
2698  * pclose() clone
2699  */
2700
2701 DllExport int
2702 win32_pclose(PerlIO *pf)
2703 {
2704 #ifdef USE_RTL_POPEN
2705     return _pclose(pf);
2706 #else
2707     dTHX;
2708     int childpid, status;
2709     SV *sv;
2710
2711     LOCK_FDPID_MUTEX;
2712     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2713
2714     if (SvIOK(sv))
2715         childpid = SvIVX(sv);
2716     else
2717         childpid = 0;
2718
2719     if (!childpid) {
2720         errno = EBADF;
2721         return -1;
2722     }
2723
2724 #ifdef USE_PERLIO
2725     PerlIO_close(pf);
2726 #else
2727     fclose(pf);
2728 #endif
2729     SvIVX(sv) = 0;
2730     UNLOCK_FDPID_MUTEX;
2731
2732     if (win32_waitpid(childpid, &status, 0) == -1)
2733         return -1;
2734
2735     return status;
2736
2737 #endif /* USE_RTL_POPEN */
2738 }
2739
2740 static BOOL WINAPI
2741 Nt4CreateHardLinkW(
2742     LPCWSTR lpFileName,
2743     LPCWSTR lpExistingFileName,
2744     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2745 {
2746     HANDLE handle;
2747     WCHAR wFullName[MAX_PATH+1];
2748     LPVOID lpContext = NULL;
2749     WIN32_STREAM_ID StreamId;
2750     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2751     DWORD dwWritten;
2752     DWORD dwLen;
2753     BOOL bSuccess;
2754
2755     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2756                                      BOOL, BOOL, LPVOID*) =
2757         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2758                             BOOL, BOOL, LPVOID*))
2759         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2760     if (pfnBackupWrite == NULL)
2761         return 0;
2762
2763     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2764     if (dwLen == 0)
2765         return 0;
2766     dwLen = (dwLen+1)*sizeof(WCHAR);
2767
2768     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2769                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2770                          NULL, OPEN_EXISTING, 0, NULL);
2771     if (handle == INVALID_HANDLE_VALUE)
2772         return 0;
2773
2774     StreamId.dwStreamId = BACKUP_LINK;
2775     StreamId.dwStreamAttributes = 0;
2776     StreamId.dwStreamNameSize = 0;
2777 #if defined(__BORLANDC__) \
2778  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2779     StreamId.Size.u.HighPart = 0;
2780     StreamId.Size.u.LowPart = dwLen;
2781 #else
2782     StreamId.Size.HighPart = 0;
2783     StreamId.Size.LowPart = dwLen;
2784 #endif
2785
2786     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2787                               FALSE, FALSE, &lpContext);
2788     if (bSuccess) {
2789         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2790                                   FALSE, FALSE, &lpContext);
2791         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2792     }
2793
2794     CloseHandle(handle);
2795     return bSuccess;
2796 }
2797
2798 DllExport int
2799 win32_link(const char *oldname, const char *newname)
2800 {
2801     dTHX;
2802     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2803     WCHAR wOldName[MAX_PATH+1];
2804     WCHAR wNewName[MAX_PATH+1];
2805
2806     if (IsWin95())
2807         Perl_croak(aTHX_ PL_no_func, "link");
2808
2809     pfnCreateHardLinkW =
2810         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2811         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2812     if (pfnCreateHardLinkW == NULL)
2813         pfnCreateHardLinkW = Nt4CreateHardLinkW;
2814
2815     if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2816         (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2817         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2818         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2819     {
2820         return 0;
2821     }
2822     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2823     return -1;
2824 }
2825
2826 DllExport int
2827 win32_rename(const char *oname, const char *newname)
2828 {
2829     WCHAR wOldName[MAX_PATH+1];
2830     WCHAR wNewName[MAX_PATH+1];
2831     char szOldName[MAX_PATH+1];
2832     char szNewName[MAX_PATH+1];
2833     BOOL bResult;
2834     dTHX;
2835
2836     /* XXX despite what the documentation says about MoveFileEx(),
2837      * it doesn't work under Windows95!
2838      */
2839     if (IsWinNT()) {
2840         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2841         if (USING_WIDE()) {
2842             A2WHELPER(oname, wOldName, sizeof(wOldName));
2843             A2WHELPER(newname, wNewName, sizeof(wNewName));
2844             if (wcsicmp(wNewName, wOldName))
2845                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2846             wcscpy(wOldName, PerlDir_mapW(wOldName));
2847             bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2848         }
2849         else {
2850             if (stricmp(newname, oname))
2851                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2852             strcpy(szOldName, PerlDir_mapA(oname));
2853             bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2854         }
2855         if (!bResult) {
2856             DWORD err = GetLastError();
2857             switch (err) {
2858             case ERROR_BAD_NET_NAME:
2859             case ERROR_BAD_NETPATH:
2860             case ERROR_BAD_PATHNAME:
2861             case ERROR_FILE_NOT_FOUND:
2862             case ERROR_FILENAME_EXCED_RANGE:
2863             case ERROR_INVALID_DRIVE:
2864             case ERROR_NO_MORE_FILES:
2865             case ERROR_PATH_NOT_FOUND:
2866                 errno = ENOENT;
2867                 break;
2868             default:
2869                 errno = EACCES;
2870                 break;
2871             }
2872             return -1;
2873         }
2874         return 0;
2875     }
2876     else {
2877         int retval = 0;
2878         char szTmpName[MAX_PATH+1];
2879         char dname[MAX_PATH+1];
2880         char *endname = Nullch;
2881         STRLEN tmplen = 0;
2882         DWORD from_attr, to_attr;
2883
2884         strcpy(szOldName, PerlDir_mapA(oname));
2885         strcpy(szNewName, PerlDir_mapA(newname));
2886
2887         /* if oname doesn't exist, do nothing */
2888         from_attr = GetFileAttributes(szOldName);
2889         if (from_attr == 0xFFFFFFFF) {
2890             errno = ENOENT;
2891             return -1;
2892         }
2893
2894         /* if newname exists, rename it to a temporary name so that we
2895          * don't delete it in case oname happens to be the same file
2896          * (but perhaps accessed via a different path)
2897          */
2898         to_attr = GetFileAttributes(szNewName);
2899         if (to_attr != 0xFFFFFFFF) {
2900             /* if newname is a directory, we fail
2901              * XXX could overcome this with yet more convoluted logic */
2902             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2903                 errno = EACCES;
2904                 return -1;
2905             }
2906             tmplen = strlen(szNewName);
2907             strcpy(szTmpName,szNewName);
2908             endname = szTmpName+tmplen;
2909             for (; endname > szTmpName ; --endname) {
2910                 if (*endname == '/' || *endname == '\\') {
2911                     *endname = '\0';
2912                     break;
2913                 }
2914             }
2915             if (endname > szTmpName)
2916                 endname = strcpy(dname,szTmpName);
2917             else
2918                 endname = ".";
2919
2920             /* get a temporary filename in same directory
2921              * XXX is this really the best we can do? */
2922             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2923                 errno = ENOENT;
2924                 return -1;
2925             }
2926             DeleteFile(szTmpName);
2927
2928             retval = rename(szNewName, szTmpName);
2929             if (retval != 0) {
2930                 errno = EACCES;
2931                 return retval;
2932             }
2933         }
2934
2935         /* rename oname to newname */
2936         retval = rename(szOldName, szNewName);
2937
2938         /* if we created a temporary file before ... */
2939         if (endname != Nullch) {
2940             /* ...and rename succeeded, delete temporary file/directory */
2941             if (retval == 0)
2942                 DeleteFile(szTmpName);
2943             /* else restore it to what it was */
2944             else
2945                 (void)rename(szTmpName, szNewName);
2946         }
2947         return retval;
2948     }
2949 }
2950
2951 DllExport int
2952 win32_setmode(int fd, int mode)
2953 {
2954     return setmode(fd, mode);
2955 }
2956
2957 DllExport long
2958 win32_lseek(int fd, long offset, int origin)
2959 {
2960     return lseek(fd, offset, origin);
2961 }
2962
2963 DllExport long
2964 win32_tell(int fd)
2965 {
2966     return tell(fd);
2967 }
2968
2969 DllExport int
2970 win32_open(const char *path, int flag, ...)
2971 {
2972     dTHX;
2973     va_list ap;
2974     int pmode;
2975     WCHAR wBuffer[MAX_PATH+1];
2976
2977     va_start(ap, flag);
2978     pmode = va_arg(ap, int);
2979     va_end(ap);
2980
2981     if (stricmp(path, "/dev/null")==0)
2982         path = "NUL";
2983
2984     if (USING_WIDE()) {
2985         A2WHELPER(path, wBuffer, sizeof(wBuffer));
2986         return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
2987     }
2988     return open(PerlDir_mapA(path), flag, pmode);
2989 }
2990
2991 /* close() that understands socket */
2992 extern int my_close(int);       /* in win32sck.c */
2993
2994 DllExport int
2995 win32_close(int fd)
2996 {
2997     return my_close(fd);
2998 }
2999
3000 DllExport int
3001 win32_eof(int fd)
3002 {
3003     return eof(fd);
3004 }
3005
3006 DllExport int
3007 win32_dup(int fd)
3008 {
3009     return dup(fd);
3010 }
3011
3012 DllExport int
3013 win32_dup2(int fd1,int fd2)
3014 {
3015     return dup2(fd1,fd2);
3016 }
3017
3018 #ifdef PERL_MSVCRT_READFIX
3019
3020 #define LF              10      /* line feed */
3021 #define CR              13      /* carriage return */
3022 #define CTRLZ           26      /* ctrl-z means eof for text */
3023 #define FOPEN           0x01    /* file handle open */
3024 #define FEOFLAG         0x02    /* end of file has been encountered */
3025 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3026 #define FPIPE           0x08    /* file handle refers to a pipe */
3027 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3028 #define FDEV            0x40    /* file handle refers to device */
3029 #define FTEXT           0x80    /* file handle is in text mode */
3030 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3031
3032 int __cdecl
3033 _fixed_read(int fh, void *buf, unsigned cnt)
3034 {
3035     int bytes_read;                 /* number of bytes read */
3036     char *buffer;                   /* buffer to read to */
3037     int os_read;                    /* bytes read on OS call */
3038     char *p, *q;                    /* pointers into buffer */
3039     char peekchr;                   /* peek-ahead character */
3040     ULONG filepos;                  /* file position after seek */
3041     ULONG dosretval;                /* o.s. return value */
3042
3043     /* validate handle */
3044     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3045          !(_osfile(fh) & FOPEN))
3046     {
3047         /* out of range -- return error */
3048         errno = EBADF;
3049         _doserrno = 0;  /* not o.s. error */
3050         return -1;
3051     }
3052
3053     /*
3054      * If lockinitflag is FALSE, assume fd is device
3055      * lockinitflag is set to TRUE by open.
3056      */
3057     if (_pioinfo(fh)->lockinitflag)
3058         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3059
3060     bytes_read = 0;                 /* nothing read yet */
3061     buffer = (char*)buf;
3062
3063     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3064         /* nothing to read or at EOF, so return 0 read */
3065         goto functionexit;
3066     }
3067
3068     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3069         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3070          * char */
3071         *buffer++ = _pipech(fh);
3072         ++bytes_read;
3073         --cnt;
3074         _pipech(fh) = LF;           /* mark as empty */
3075     }
3076
3077     /* read the data */
3078
3079     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3080     {
3081         /* ReadFile has reported an error. recognize two special cases.
3082          *
3083          *      1. map ERROR_ACCESS_DENIED to EBADF
3084          *
3085          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3086          *         means the handle is a read-handle on a pipe for which
3087          *         all write-handles have been closed and all data has been
3088          *         read. */
3089
3090         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3091             /* wrong read/write mode should return EBADF, not EACCES */
3092             errno = EBADF;
3093             _doserrno = dosretval;
3094             bytes_read = -1;
3095             goto functionexit;
3096         }
3097         else if (dosretval == ERROR_BROKEN_PIPE) {
3098             bytes_read = 0;
3099             goto functionexit;
3100         }
3101         else {
3102             bytes_read = -1;
3103             goto functionexit;
3104         }
3105     }
3106
3107     bytes_read += os_read;          /* update bytes read */
3108
3109     if (_osfile(fh) & FTEXT) {
3110         /* now must translate CR-LFs to LFs in the buffer */
3111
3112         /* set CRLF flag to indicate LF at beginning of buffer */
3113         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3114         /*    _osfile(fh) |= FCRLF;                      */
3115         /* else                                          */
3116         /*    _osfile(fh) &= ~FCRLF;                     */
3117
3118         _osfile(fh) &= ~FCRLF;
3119
3120         /* convert chars in the buffer: p is src, q is dest */
3121         p = q = (char*)buf;
3122         while (p < (char *)buf + bytes_read) {
3123             if (*p == CTRLZ) {
3124                 /* if fh is not a device, set ctrl-z flag */
3125                 if (!(_osfile(fh) & FDEV))
3126                     _osfile(fh) |= FEOFLAG;
3127                 break;              /* stop translating */
3128             }
3129             else if (*p != CR)
3130                 *q++ = *p++;
3131             else {
3132                 /* *p is CR, so must check next char for LF */
3133                 if (p < (char *)buf + bytes_read - 1) {
3134                     if (*(p+1) == LF) {
3135                         p += 2;
3136                         *q++ = LF;  /* convert CR-LF to LF */
3137                     }
3138                     else
3139                         *q++ = *p++;    /* store char normally */
3140                 }
3141                 else {
3142                     /* This is the hard part.  We found a CR at end of
3143                        buffer.  We must peek ahead to see if next char
3144                        is an LF. */
3145                     ++p;
3146
3147                     dosretval = 0;
3148                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3149                                     (LPDWORD)&os_read, NULL))
3150                         dosretval = GetLastError();
3151
3152                     if (dosretval != 0 || os_read == 0) {
3153                         /* couldn't read ahead, store CR */
3154                         *q++ = CR;
3155                     }
3156                     else {
3157                         /* peekchr now has the extra character -- we now
3158                            have several possibilities:
3159                            1. disk file and char is not LF; just seek back
3160                               and copy CR
3161                            2. disk file and char is LF; store LF, don't seek back
3162                            3. pipe/device and char is LF; store LF.
3163                            4. pipe/device and char isn't LF, store CR and
3164                               put char in pipe lookahead buffer. */
3165                         if (_osfile(fh) & (FDEV|FPIPE)) {
3166                             /* non-seekable device */
3167                             if (peekchr == LF)
3168                                 *q++ = LF;
3169                             else {
3170                                 *q++ = CR;
3171                                 _pipech(fh) = peekchr;
3172                             }
3173                         }
3174                         else {
3175                             /* disk file */
3176                             if (peekchr == LF) {
3177                                 /* nothing read yet; must make some
3178                                    progress */
3179                                 *q++ = LF;
3180                                 /* turn on this flag for tell routine */
3181                                 _osfile(fh) |= FCRLF;
3182                             }
3183                             else {
3184                                 HANDLE osHandle;        /* o.s. handle value */
3185                                 /* seek back */
3186                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3187                                 {
3188                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3189                                         dosretval = GetLastError();
3190                                 }
3191                                 if (peekchr != LF)
3192                                     *q++ = CR;
3193                             }
3194                         }
3195                     }
3196                 }
3197             }
3198         }
3199
3200         /* we now change bytes_read to reflect the true number of chars
3201            in the buffer */
3202         bytes_read = q - (char *)buf;
3203     }
3204
3205 functionexit:
3206     if (_pioinfo(fh)->lockinitflag)
3207         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3208
3209     return bytes_read;
3210 }
3211
3212 #endif  /* PERL_MSVCRT_READFIX */
3213
3214 DllExport int
3215 win32_read(int fd, void *buf, unsigned int cnt)
3216 {
3217 #ifdef PERL_MSVCRT_READFIX
3218     return _fixed_read(fd, buf, cnt);
3219 #else
3220     return read(fd, buf, cnt);
3221 #endif
3222 }
3223
3224 DllExport int
3225 win32_write(int fd, const void *buf, unsigned int cnt)
3226 {
3227     return write(fd, buf, cnt);
3228 }
3229
3230 DllExport int
3231 win32_mkdir(const char *dir, int mode)
3232 {
3233     dTHX;
3234     if (USING_WIDE()) {
3235         WCHAR wBuffer[MAX_PATH+1];
3236         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3237         return _wmkdir(PerlDir_mapW(wBuffer));
3238     }
3239     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3240 }
3241
3242 DllExport int
3243 win32_rmdir(const char *dir)
3244 {
3245     dTHX;
3246     if (USING_WIDE()) {
3247         WCHAR wBuffer[MAX_PATH+1];
3248         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3249         return _wrmdir(PerlDir_mapW(wBuffer));
3250     }
3251     return rmdir(PerlDir_mapA(dir));
3252 }
3253
3254 DllExport int
3255 win32_chdir(const char *dir)
3256 {
3257     dTHX;
3258     if (!dir) {
3259         errno = ENOENT;
3260         return -1;
3261     }
3262     if (USING_WIDE()) {
3263         WCHAR wBuffer[MAX_PATH+1];
3264         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3265         return _wchdir(wBuffer);
3266     }
3267     return chdir(dir);
3268 }
3269
3270 DllExport  int
3271 win32_access(const char *path, int mode)
3272 {
3273     dTHX;
3274     if (USING_WIDE()) {
3275         WCHAR wBuffer[MAX_PATH+1];
3276         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3277         return _waccess(PerlDir_mapW(wBuffer), mode);
3278     }
3279     return access(PerlDir_mapA(path), mode);
3280 }
3281
3282 DllExport  int
3283 win32_chmod(const char *path, int mode)
3284 {
3285     dTHX;
3286     if (USING_WIDE()) {
3287         WCHAR wBuffer[MAX_PATH+1];
3288         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3289         return _wchmod(PerlDir_mapW(wBuffer), mode);
3290     }
3291     return chmod(PerlDir_mapA(path), mode);
3292 }
3293
3294
3295 static char *
3296 create_command_line(char *cname, STRLEN clen, const char * const *args)
3297 {
3298     dTHX;
3299     int index, argc;
3300     char *cmd, *ptr;
3301     const char *arg;
3302     STRLEN len = 0;
3303     bool bat_file = FALSE;
3304     bool cmd_shell = FALSE;
3305     bool dumb_shell = FALSE;
3306     bool extra_quotes = FALSE;
3307     bool quote_next = FALSE;
3308
3309     if (!cname)
3310         cname = (char*)args[0];
3311
3312     /* The NT cmd.exe shell has the following peculiarity that needs to be
3313      * worked around.  It strips a leading and trailing dquote when any
3314      * of the following is true:
3315      *    1. the /S switch was used
3316      *    2. there are more than two dquotes
3317      *    3. there is a special character from this set: &<>()@^|
3318      *    4. no whitespace characters within the two dquotes
3319      *    5. string between two dquotes isn't an executable file
3320      * To work around this, we always add a leading and trailing dquote
3321      * to the string, if the first argument is either "cmd.exe" or "cmd",
3322      * and there were at least two or more arguments passed to cmd.exe
3323      * (not including switches).
3324      * XXX the above rules (from "cmd /?") don't seem to be applied
3325      * always, making for the convolutions below :-(
3326      */
3327     if (cname) {
3328         if (!clen)
3329             clen = strlen(cname);
3330
3331         if (clen > 4
3332             && (stricmp(&cname[clen-4], ".bat") == 0
3333                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3334         {
3335             bat_file = TRUE;
3336             len += 3;
3337         }
3338         else {
3339             char *exe = strrchr(cname, '/');
3340             char *exe2 = strrchr(cname, '\\');
3341             if (exe2 > exe)
3342                 exe = exe2;
3343             if (exe)
3344                 ++exe;
3345             else
3346                 exe = cname;
3347             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3348                 cmd_shell = TRUE;
3349                 len += 3;
3350             }
3351             else if (stricmp(exe, "command.com") == 0
3352                      || stricmp(exe, "command") == 0)
3353             {
3354                 dumb_shell = TRUE;
3355             }
3356         }
3357     }
3358
3359     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3360     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3361         STRLEN curlen = strlen(arg);
3362         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3363             len += 2;   /* assume quoting needed (worst case) */
3364         len += curlen + 1;
3365         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3366     }
3367     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3368
3369     argc = index;
3370     New(1310, cmd, len, char);
3371     ptr = cmd;
3372
3373     if (bat_file) {
3374         *ptr++ = '"';
3375         extra_quotes = TRUE;
3376     }
3377
3378     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3379         bool do_quote = 0;
3380         STRLEN curlen = strlen(arg);
3381
3382         /* we want to protect empty arguments and ones with spaces with
3383          * dquotes, but only if they aren't already there */
3384         if (!dumb_shell) {
3385             if (!curlen) {
3386                 do_quote = 1;
3387             }
3388             else if (quote_next) {
3389                 /* see if it really is multiple arguments pretending to
3390                  * be one and force a set of quotes around it */
3391                 if (*find_next_space(arg))
3392                     do_quote = 1;
3393             }
3394             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3395                 STRLEN i = 0;
3396                 while (i < curlen) {
3397                     if (isSPACE(arg[i])) {
3398                         do_quote = 1;
3399                     }
3400                     else if (arg[i] == '"') {
3401                         do_quote = 0;
3402                         break;
3403                     }
3404                     i++;
3405                 }
3406             }
3407         }
3408
3409         if (do_quote)
3410             *ptr++ = '"';
3411
3412         strcpy(ptr, arg);
3413         ptr += curlen;
3414
3415         if (do_quote)
3416             *ptr++ = '"';
3417
3418         if (args[index+1])
3419             *ptr++ = ' ';
3420
3421         if (!extra_quotes
3422             && cmd_shell
3423             && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3424         {
3425             /* is there a next argument? */
3426             if (args[index+1]) {
3427                 /* are there two or more next arguments? */
3428                 if (args[index+2]) {
3429                     *ptr++ = '"';
3430                     extra_quotes = TRUE;
3431                 }
3432                 else {
3433                     /* single argument, force quoting if it has spaces */
3434                     quote_next = TRUE;
3435                 }
3436             }
3437         }
3438     }
3439
3440     if (extra_quotes)
3441         *ptr++ = '"';
3442
3443     *ptr = '\0';
3444
3445     return cmd;
3446 }
3447
3448 static char *
3449 qualified_path(const char *cmd)
3450 {
3451     dTHX;
3452     char *pathstr;
3453     char *fullcmd, *curfullcmd;
3454     STRLEN cmdlen = 0;
3455     int has_slash = 0;
3456
3457     if (!cmd)
3458         return Nullch;
3459     fullcmd = (char*)cmd;
3460     while (*fullcmd) {
3461         if (*fullcmd == '/' || *fullcmd == '\\')
3462             has_slash++;
3463         fullcmd++;
3464         cmdlen++;
3465     }
3466
3467     /* look in PATH */
3468     pathstr = PerlEnv_getenv("PATH");
3469     New(0, fullcmd, MAX_PATH+1, char);
3470     curfullcmd = fullcmd;
3471
3472     while (1) {
3473         DWORD res;
3474
3475         /* start by appending the name to the current prefix */
3476         strcpy(curfullcmd, cmd);
3477         curfullcmd += cmdlen;
3478
3479         /* if it doesn't end with '.', or has no extension, try adding
3480          * a trailing .exe first */
3481         if (cmd[cmdlen-1] != '.'
3482             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3483         {
3484             strcpy(curfullcmd, ".exe");
3485             res = GetFileAttributes(fullcmd);
3486             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3487                 return fullcmd;
3488             *curfullcmd = '\0';
3489         }
3490
3491         /* that failed, try the bare name */
3492         res = GetFileAttributes(fullcmd);
3493         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3494             return fullcmd;
3495
3496         /* quit if no other path exists, or if cmd already has path */
3497         if (!pathstr || !*pathstr || has_slash)
3498             break;
3499
3500         /* skip leading semis */
3501         while (*pathstr == ';')
3502             pathstr++;
3503
3504         /* build a new prefix from scratch */
3505         curfullcmd = fullcmd;
3506         while (*pathstr && *pathstr != ';') {
3507             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3508                 pathstr++;              /* skip initial '"' */
3509                 while (*pathstr && *pathstr != '"') {
3510                     if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3511                         *curfullcmd++ = *pathstr;
3512                     pathstr++;
3513                 }
3514                 if (*pathstr)
3515                     pathstr++;          /* skip trailing '"' */
3516             }
3517             else {
3518                 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
3519                     *curfullcmd++ = *pathstr;
3520                 pathstr++;
3521             }
3522         }
3523         if (*pathstr)
3524             pathstr++;                  /* skip trailing semi */
3525         if (curfullcmd > fullcmd        /* append a dir separator */
3526             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3527         {
3528             *curfullcmd++ = '\\';
3529         }
3530     }
3531 GIVE_UP:
3532     Safefree(fullcmd);
3533     return Nullch;
3534 }
3535
3536 /* The following are just place holders.
3537  * Some hosts may provide and environment that the OS is
3538  * not tracking, therefore, these host must provide that
3539  * environment and the current directory to CreateProcess
3540  */
3541
3542 DllExport void*
3543 win32_get_childenv(void)
3544 {
3545     return NULL;
3546 }
3547
3548 DllExport void
3549 win32_free_childenv(void* d)
3550 {
3551 }
3552
3553 DllExport void
3554 win32_clearenv(void)
3555 {
3556     char *envv = GetEnvironmentStrings();
3557     char *cur = envv;
3558     STRLEN len;
3559     while (*cur) {
3560         char *end = strchr(cur,'=');
3561         if (end && end != cur) {
3562             *end = '\0';
3563             SetEnvironmentVariable(cur, NULL);
3564             *end = '=';
3565             cur = end + strlen(end+1)+2;
3566         }
3567         else if ((len = strlen(cur)))
3568             cur += len+1;
3569     }
3570     FreeEnvironmentStrings(envv);
3571 }
3572
3573 DllExport char*
3574 win32_get_childdir(void)
3575 {
3576     dTHX;
3577     char* ptr;
3578     char szfilename[(MAX_PATH+1)*2];
3579     if (USING_WIDE()) {
3580         WCHAR wfilename[MAX_PATH+1];
3581         GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3582         W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3583     }
3584     else {
3585         GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3586     }
3587
3588     New(0, ptr, strlen(szfilename)+1, char);
3589     strcpy(ptr, szfilename);
3590     return ptr;
3591 }
3592
3593 DllExport void
3594 win32_free_childdir(char* d)
3595 {
3596     dTHX;
3597     Safefree(d);
3598 }
3599
3600
3601 /* XXX this needs to be made more compatible with the spawnvp()
3602  * provided by the various RTLs.  In particular, searching for
3603  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3604  * This doesn't significantly affect perl itself, because we
3605  * always invoke things using PERL5SHELL if a direct attempt to
3606  * spawn the executable fails.
3607  *
3608  * XXX splitting and rejoining the commandline between do_aspawn()
3609  * and win32_spawnvp() could also be avoided.
3610  */
3611
3612 DllExport int
3613 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3614 {
3615 #ifdef USE_RTL_SPAWNVP
3616     return spawnvp(mode, cmdname, (char * const *)argv);
3617 #else
3618     dTHX;
3619     int ret;
3620     void* env;
3621     char* dir;
3622     child_IO_table tbl;
3623     STARTUPINFO StartupInfo;
3624     PROCESS_INFORMATION ProcessInformation;
3625     DWORD create = 0;
3626     char *cmd;
3627     char *fullcmd = Nullch;
3628     char *cname = (char *)cmdname;
3629     STRLEN clen = 0;
3630
3631     if (cname) {
3632         clen = strlen(cname);
3633         /* if command name contains dquotes, must remove them */
3634         if (strchr(cname, '"')) {
3635             cmd = cname;
3636             New(0,cname,clen+1,char);
3637             clen = 0;
3638             while (*cmd) {
3639                 if (*cmd != '"') {
3640                     cname[clen] = *cmd;
3641                     ++clen;
3642                 }
3643                 ++cmd;
3644             }
3645             cname[clen] = '\0';
3646         }
3647     }
3648
3649     cmd = create_command_line(cname, clen, argv);
3650
3651     env = PerlEnv_get_childenv();
3652     dir = PerlEnv_get_childdir();
3653
3654     switch(mode) {
3655     case P_NOWAIT:      /* asynch + remember result */
3656         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3657             errno = EAGAIN;
3658             ret = -1;
3659             goto RETVAL;
3660         }
3661         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3662          * in win32_kill()
3663          */
3664         create |= CREATE_NEW_PROCESS_GROUP;
3665         /* FALL THROUGH */
3666
3667     case P_WAIT:        /* synchronous execution */
3668         break;
3669     default:            /* invalid mode */
3670         errno = EINVAL;
3671         ret = -1;
3672         goto RETVAL;
3673     }
3674     memset(&StartupInfo,0,sizeof(StartupInfo));
3675     StartupInfo.cb = sizeof(StartupInfo);
3676     memset(&tbl,0,sizeof(tbl));
3677     PerlEnv_get_child_IO(&tbl);
3678     StartupInfo.dwFlags         = tbl.dwFlags;
3679     StartupInfo.dwX             = tbl.dwX;
3680     StartupInfo.dwY             = tbl.dwY;
3681     StartupInfo.dwXSize         = tbl.dwXSize;
3682     StartupInfo.dwYSize         = tbl.dwYSize;
3683     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3684     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3685     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3686     StartupInfo.wShowWindow     = tbl.wShowWindow;
3687     StartupInfo.hStdInput       = tbl.childStdIn;
3688     StartupInfo.hStdOutput      = tbl.childStdOut;
3689     StartupInfo.hStdError       = tbl.childStdErr;
3690     if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3691         StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3692         StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3693     {
3694         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3695     }
3696     else {
3697         create |= CREATE_NEW_CONSOLE;
3698     }
3699     if (w32_use_showwindow) {
3700         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3701         StartupInfo.wShowWindow = w32_showwindow;
3702     }
3703
3704     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3705                           cname,cmd));
3706 RETRY:
3707     if (!CreateProcess(cname,           /* search PATH to find executable */
3708                        cmd,             /* executable, and its arguments */
3709                        NULL,            /* process attributes */
3710                        NULL,            /* thread attributes */
3711                        TRUE,            /* inherit handles */
3712                        create,          /* creation flags */
3713                        (LPVOID)env,     /* inherit environment */
3714                        dir,             /* inherit cwd */
3715                        &StartupInfo,
3716                        &ProcessInformation))
3717     {
3718         /* initial NULL argument to CreateProcess() does a PATH
3719          * search, but it always first looks in the directory
3720          * where the current process was started, which behavior
3721          * is undesirable for backward compatibility.  So we
3722          * jump through our own hoops by picking out the path
3723          * we really want it to use. */
3724         if (!fullcmd) {
3725             fullcmd = qualified_path(cname);
3726             if (fullcmd) {
3727                 if (cname != cmdname)
3728                     Safefree(cname);
3729                 cname = fullcmd;
3730                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3731                                       "Retrying [%s] with same args\n",
3732                                       cname));
3733                 goto RETRY;
3734             }
3735         }
3736         errno = ENOENT;
3737         ret = -1;
3738         goto RETVAL;
3739     }
3740
3741     if (mode == P_NOWAIT) {
3742         /* asynchronous spawn -- store handle, return PID */
3743         ret = (int)ProcessInformation.dwProcessId;
3744         if (IsWin95() && ret < 0)
3745             ret = -ret;
3746
3747         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3748         w32_child_pids[w32_num_children] = (DWORD)ret;
3749         ++w32_num_children;
3750     }
3751     else  {
3752         DWORD status;
3753         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3754         /* FIXME: if msgwait returned due to message perhaps forward the
3755            "signal" to the process
3756          */
3757         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3758         ret = (int)status;
3759         CloseHandle(ProcessInformation.hProcess);
3760     }
3761
3762     CloseHandle(ProcessInformation.hThread);
3763
3764 RETVAL:
3765     PerlEnv_free_childenv(env);
3766     PerlEnv_free_childdir(dir);
3767     Safefree(cmd);
3768     if (cname != cmdname)
3769         Safefree(cname);
3770     return ret;
3771 #endif
3772 }
3773
3774 DllExport int
3775 win32_execv(const char *cmdname, const char *const *argv)
3776 {
3777 #ifdef USE_ITHREADS
3778     dTHX;
3779     /* if this is a pseudo-forked child, we just want to spawn
3780      * the new program, and return */
3781     if (w32_pseudo_id)
3782         return spawnv(P_WAIT, cmdname, (char *const *)argv);
3783 #endif
3784     return execv(cmdname, (char *const *)argv);
3785 }
3786
3787 DllExport int
3788 win32_execvp(const char *cmdname, const char *const *argv)
3789 {
3790 #ifdef USE_ITHREADS
3791     dTHX;
3792     /* if this is a pseudo-forked child, we just want to spawn
3793      * the new program, and return */
3794     if (w32_pseudo_id) {
3795         int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3796         if (status != -1) {
3797             my_exit(status);
3798             return 0;
3799         }
3800         else
3801             return status;
3802     }
3803 #endif
3804     return execvp(cmdname, (char *const *)argv);
3805 }
3806
3807 DllExport void
3808 win32_perror(const char *str)
3809 {
3810     perror(str);
3811 }
3812
3813 DllExport void
3814 win32_setbuf(FILE *pf, char *buf)
3815 {
3816     setbuf(pf, buf);
3817 }
3818
3819 DllExport int
3820 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3821 {
3822     return setvbuf(pf, buf, type, size);
3823 }
3824
3825 DllExport int
3826 win32_flushall(void)
3827 {
3828     return flushall();
3829 }
3830
3831 DllExport int
3832 win32_fcloseall(void)
3833 {
3834     return fcloseall();
3835 }
3836
3837 DllExport char*
3838 win32_fgets(char *s, int n, FILE *pf)
3839 {
3840     return fgets(s, n, pf);
3841 }
3842
3843 DllExport char*
3844 win32_gets(char *s)
3845 {
3846     return gets(s);
3847 }
3848
3849 DllExport int
3850 win32_fgetc(FILE *pf)
3851 {
3852     return fgetc(pf);
3853 }
3854
3855 DllExport int
3856 win32_putc(int c, FILE *pf)
3857 {
3858     return putc(c,pf);
3859 }
3860
3861 DllExport int
3862 win32_puts(const char *s)
3863 {
3864     return puts(s);
3865 }
3866
3867 DllExport int
3868 win32_getchar(void)
3869 {
3870     return getchar();
3871 }
3872
3873 DllExport int
3874 win32_putchar(int c)
3875 {
3876     return putchar(c);
3877 }
3878
3879 #ifdef MYMALLOC
3880
3881 #ifndef USE_PERL_SBRK
3882
3883 static char *committed = NULL;          /* XXX threadead */
3884 static char *base      = NULL;          /* XXX threadead */
3885 static char *reserved  = NULL;          /* XXX threadead */
3886 static char *brk       = NULL;          /* XXX threadead */
3887 static DWORD pagesize  = 0;             /* XXX threadead */
3888 static DWORD allocsize = 0;             /* XXX threadead */
3889
3890 void *
3891 sbrk(int need)
3892 {
3893  void *result;
3894  if (!pagesize)
3895   {SYSTEM_INFO info;
3896    GetSystemInfo(&info);
3897    /* Pretend page size is larger so we don't perpetually
3898     * call the OS to commit just one page ...
3899     */
3900    pagesize = info.dwPageSize << 3;
3901    allocsize = info.dwAllocationGranularity;
3902   }
3903  /* This scheme fails eventually if request for contiguous
3904   * block is denied so reserve big blocks - this is only
3905   * address space not memory ...
3906   */
3907  if (brk+need >= reserved)
3908   {
3909    DWORD size = 64*1024*1024;
3910    char *addr;
3911    if (committed && reserved && committed < reserved)
3912     {
3913      /* Commit last of previous chunk cannot span allocations */
3914      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3915      if (addr)
3916       committed = reserved;
3917     }
3918    /* Reserve some (more) space
3919     * Note this is a little sneaky, 1st call passes NULL as reserved
3920     * so lets system choose where we start, subsequent calls pass
3921     * the old end address so ask for a contiguous block
3922     */
3923    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3924    if (addr)
3925     {
3926      reserved = addr+size;
3927      if (!base)
3928       base = addr;
3929      if (!committed)
3930       committed = base;
3931      if (!brk)
3932       brk = committed;
3933     }
3934    else
3935     {
3936      return (void *) -1;
3937     }
3938   }
3939  result = brk;
3940  brk += need;
3941  if (brk > committed)
3942   {
3943    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3944    char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3945    if (addr)
3946     {
3947      committed += size;
3948     }
3949    else
3950     return (void *) -1;
3951   }
3952  return result;
3953 }
3954
3955 #endif
3956 #endif
3957
3958 DllExport void*
3959 win32_malloc(size_t size)
3960 {
3961     return malloc(size);
3962 }
3963
3964 DllExport void*
3965 win32_calloc(size_t numitems, size_t size)
3966 {
3967     return calloc(numitems,size);
3968 }
3969
3970 DllExport void*
3971 win32_realloc(void *block, size_t size)
3972 {
3973     return realloc(block,size);
3974 }
3975
3976 DllExport void
3977 win32_free(void *block)
3978 {
3979     free(block);
3980 }
3981
3982
3983 int
3984 win32_open_osfhandle(long handle, int flags)
3985 {
3986 #ifdef USE_FIXED_OSFHANDLE
3987     if (IsWin95())
3988         return my_open_osfhandle(handle, flags);
3989 #endif
3990     return _open_osfhandle(handle, flags);
3991 }
3992
3993 long
3994 win32_get_osfhandle(int fd)
3995 {
3996     return _get_osfhandle(fd);
3997 }
3998
3999 DllExport void*
4000 win32_dynaload(const char* filename)
4001 {
4002     dTHX;
4003     HMODULE hModule;
4004     char buf[MAX_PATH+1];
4005     char *first;
4006
4007     /* LoadLibrary() doesn't recognize forward slashes correctly,
4008      * so turn 'em back. */
4009     first = strchr(filename, '/');
4010     if (first) {
4011         STRLEN len = strlen(filename);
4012         if (len <= MAX_PATH) {
4013             strcpy(buf, filename);
4014             filename = &buf[first - filename];
4015             while (*filename) {
4016                 if (*filename == '/')
4017                     *(char*)filename = '\\';
4018                 ++filename;
4019             }
4020             filename = buf;
4021         }
4022     }
4023     if (USING_WIDE()) {
4024         WCHAR wfilename[MAX_PATH+1];
4025         A2WHELPER(filename, wfilename, sizeof(wfilename));
4026         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4027     }
4028     else {
4029         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4030     }
4031     return hModule;
4032 }
4033
4034 /*
4035  * Extras.
4036  */
4037
4038 static
4039 XS(w32_SetChildShowWindow)
4040 {
4041     dXSARGS;
4042     BOOL use_showwindow = w32_use_showwindow;
4043     /* use "unsigned short" because Perl has redefined "WORD" */
4044     unsigned short showwindow = w32_showwindow;
4045
4046     if (items > 1)
4047         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4048
4049     if (items == 0 || !SvOK(ST(0)))
4050         w32_use_showwindow = FALSE;
4051     else {
4052         w32_use_showwindow = TRUE;
4053         w32_showwindow = (unsigned short)SvIV(ST(0));
4054     }
4055
4056     EXTEND(SP, 1);
4057     if (use_showwindow)
4058         ST(0) = sv_2mortal(newSViv(showwindow));
4059     else
4060         ST(0) = &PL_sv_undef;
4061     XSRETURN(1);
4062 }
4063
4064 static
4065 XS(w32_GetCwd)
4066 {
4067     dXSARGS;
4068     /* Make the host for current directory */
4069     char* ptr = PerlEnv_get_childdir();
4070     /*
4071      * If ptr != Nullch
4072      *   then it worked, set PV valid,
4073      *   else return 'undef'
4074      */
4075     if (ptr) {
4076         SV *sv = sv_newmortal();
4077         sv_setpv(sv, ptr);
4078         PerlEnv_free_childdir(ptr);
4079
4080 #ifndef INCOMPLETE_TAINTS
4081         SvTAINTED_on(sv);
4082 #endif
4083
4084         EXTEND(SP,1);
4085         SvPOK_on(sv);
4086         ST(0) = sv;
4087         XSRETURN(1);
4088     }
4089     XSRETURN_UNDEF;
4090 }
4091
4092 static
4093 XS(w32_SetCwd)
4094 {
4095     dXSARGS;
4096     if (items != 1)
4097         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4098     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4099         XSRETURN_YES;
4100
4101     XSRETURN_NO;
4102 }
4103
4104 static
4105 XS(w32_GetNextAvailDrive)
4106 {
4107     dXSARGS;
4108     char ix = 'C';
4109     char root[] = "_:\\";
4110
4111     EXTEND(SP,1);
4112     while (ix <= 'Z') {
4113         root[0] = ix++;
4114         if (GetDriveType(root) == 1) {
4115             root[2] = '\0';
4116             XSRETURN_PV(root);
4117         }
4118     }
4119     XSRETURN_UNDEF;
4120 }
4121
4122 static
4123 XS(w32_GetLastError)
4124 {
4125     dXSARGS;
4126     EXTEND(SP,1);
4127     XSRETURN_IV(GetLastError());
4128 }
4129
4130 static
4131 XS(w32_SetLastError)
4132 {
4133     dXSARGS;
4134     if (items != 1)
4135         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4136     SetLastError(SvIV(ST(0)));
4137     XSRETURN_EMPTY;
4138 }
4139
4140 static
4141 XS(w32_LoginName)
4142 {
4143     dXSARGS;
4144     char *name = w32_getlogin_buffer;
4145     DWORD size = sizeof(w32_getlogin_buffer);
4146     EXTEND(SP,1);
4147     if (GetUserName(name,&size)) {
4148         /* size includes NULL */
4149         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4150         XSRETURN(1);
4151     }
4152     XSRETURN_UNDEF;
4153 }
4154
4155 static
4156 XS(w32_NodeName)
4157 {
4158     dXSARGS;
4159     char name[MAX_COMPUTERNAME_LENGTH+1];
4160     DWORD size = sizeof(name);
4161     EXTEND(SP,1);
4162     if (GetComputerName(name,&size)) {
4163         /* size does NOT include NULL :-( */
4164         ST(0) = sv_2mortal(newSVpvn(name,size));
4165         XSRETURN(1);
4166     }
4167     XSRETURN_UNDEF;
4168 }
4169
4170
4171 static
4172 XS(w32_DomainName)
4173 {
4174     dXSARGS;
4175     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4176     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4177     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4178                                           void *bufptr);
4179
4180     if (hNetApi32) {
4181         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4182             GetProcAddress(hNetApi32, "NetApiBufferFree");
4183         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4184             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4185     }
4186     EXTEND(SP,1);
4187     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4188         /* this way is more reliable, in case user has a local account. */
4189         char dname[256];
4190         DWORD dnamelen = sizeof(dname);
4191         struct {
4192             DWORD   wki100_platform_id;
4193             LPWSTR  wki100_computername;
4194             LPWSTR  wki100_langroup;
4195             DWORD   wki100_ver_major;
4196             DWORD   wki100_ver_minor;
4197         } *pwi;
4198         /* NERR_Success *is* 0*/
4199         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4200             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4201                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4202                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4203             }
4204             else {
4205                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4206                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4207             }
4208             pfnNetApiBufferFree(pwi);
4209             FreeLibrary(hNetApi32);
4210             XSRETURN_PV(dname);
4211         }
4212         FreeLibrary(hNetApi32);
4213     }
4214     else {
4215         /* Win95 doesn't have NetWksta*(), so do it the old way */
4216         char name[256];
4217         DWORD size = sizeof(name);
4218         if (hNetApi32)
4219             FreeLibrary(hNetApi32);
4220         if (GetUserName(name,&size)) {
4221             char sid[ONE_K_BUFSIZE];
4222             DWORD sidlen = sizeof(sid);
4223             char dname[256];
4224             DWORD dnamelen = sizeof(dname);
4225             SID_NAME_USE snu;
4226             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4227                                   dname, &dnamelen, &snu)) {
4228                 XSRETURN_PV(dname);             /* all that for this */
4229             }
4230         }
4231     }
4232     XSRETURN_UNDEF;
4233 }
4234
4235 static
4236 XS(w32_FsType)
4237 {
4238     dXSARGS;
4239     char fsname[256];
4240     DWORD flags, filecomplen;
4241     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4242                          &flags, fsname, sizeof(fsname))) {
4243         if (GIMME_V == G_ARRAY) {
4244             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4245             XPUSHs(sv_2mortal(newSViv(flags)));
4246             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4247             PUTBACK;
4248             return;
4249         }
4250         EXTEND(SP,1);
4251         XSRETURN_PV(fsname);
4252     }
4253     XSRETURN_EMPTY;
4254 }
4255
4256 static
4257 XS(w32_GetOSVersion)
4258 {
4259     dXSARGS;
4260     OSVERSIONINFOA osver;
4261
4262     if (USING_WIDE()) {
4263         OSVERSIONINFOW osverw;
4264         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4265         osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4266         if (!GetVersionExW(&osverw)) {
4267             XSRETURN_EMPTY;
4268         }
4269         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4270         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4271         osver.dwMajorVersion = osverw.dwMajorVersion;
4272         osver.dwMinorVersion = osverw.dwMinorVersion;
4273         osver.dwBuildNumber = osverw.dwBuildNumber;
4274         osver.dwPlatformId = osverw.dwPlatformId;
4275     }
4276     else {
4277         osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4278         if (!GetVersionExA(&osver)) {
4279             XSRETURN_EMPTY;
4280         }
4281         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4282     }
4283     XPUSHs(newSViv(osver.dwMajorVersion));
4284     XPUSHs(newSViv(osver.dwMinorVersion));
4285     XPUSHs(newSViv(osver.dwBuildNumber));
4286     XPUSHs(newSViv(osver.dwPlatformId));
4287     PUTBACK;
4288 }
4289
4290 static
4291 XS(w32_IsWinNT)
4292 {
4293     dXSARGS;
4294     EXTEND(SP,1);
4295     XSRETURN_IV(IsWinNT());
4296 }
4297
4298 static
4299 XS(w32_IsWin95)
4300 {
4301     dXSARGS;
4302     EXTEND(SP,1);
4303     XSRETURN_IV(IsWin95());
4304 }
4305
4306 static
4307 XS(w32_FormatMessage)
4308 {
4309     dXSARGS;
4310     DWORD source = 0;
4311     char msgbuf[ONE_K_BUFSIZE];
4312
4313     if (items != 1)
4314         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4315
4316     if (USING_WIDE()) {
4317         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4318         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4319                           &source, SvIV(ST(0)), 0,
4320                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4321         {
4322             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4323             XSRETURN_PV(msgbuf);
4324         }
4325     }
4326     else {
4327         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4328                           &source, SvIV(ST(0)), 0,
4329                           msgbuf, sizeof(msgbuf)-1, NULL))
4330             XSRETURN_PV(msgbuf);
4331     }
4332
4333     XSRETURN_UNDEF;
4334 }
4335
4336 static
4337 XS(w32_Spawn)
4338 {
4339     dXSARGS;
4340     char *cmd, *args;
4341     void *env;
4342     char *dir;
4343     PROCESS_INFORMATION stProcInfo;
4344     STARTUPINFO stStartInfo;
4345     BOOL bSuccess = FALSE;
4346
4347     if (items != 3)
4348         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4349
4350     cmd = SvPV_nolen(ST(0));
4351     args = SvPV_nolen(ST(1));
4352
4353     env = PerlEnv_get_childenv();
4354     dir = PerlEnv_get_childdir();
4355
4356     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4357     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4358     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4359     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4360
4361     if (CreateProcess(
4362                 cmd,                    /* Image path */
4363                 args,                   /* Arguments for command line */
4364                 NULL,                   /* Default process security */
4365                 NULL,                   /* Default thread security */
4366                 FALSE,                  /* Must be TRUE to use std handles */
4367                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4368                 env,                    /* Inherit our environment block */
4369                 dir,                    /* Inherit our currrent directory */
4370                 &stStartInfo,           /* -> Startup info */
4371                 &stProcInfo))           /* <- Process info (if OK) */
4372     {
4373         int pid = (int)stProcInfo.dwProcessId;
4374         if (IsWin95() && pid < 0)
4375             pid = -pid;
4376         sv_setiv(ST(2), pid);
4377         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4378         bSuccess = TRUE;
4379     }
4380     PerlEnv_free_childenv(env);
4381     PerlEnv_free_childdir(dir);
4382     XSRETURN_IV(bSuccess);
4383 }
4384
4385 static
4386 XS(w32_GetTickCount)
4387 {
4388     dXSARGS;
4389     DWORD msec = GetTickCount();
4390     EXTEND(SP,1);
4391     if ((IV)msec > 0)
4392         XSRETURN_IV(msec);
4393     XSRETURN_NV(msec);
4394 }
4395
4396 static
4397 XS(w32_GetShortPathName)
4398 {
4399     dXSARGS;
4400     SV *shortpath;
4401     DWORD len;
4402
4403     if (items != 1)
4404         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4405
4406     shortpath = sv_mortalcopy(ST(0));
4407     SvUPGRADE(shortpath, SVt_PV);
4408     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4409         XSRETURN_UNDEF;
4410
4411     /* src == target is allowed */
4412     do {
4413         len = GetShortPathName(SvPVX(shortpath),
4414                                SvPVX(shortpath),
4415                                SvLEN(shortpath));
4416     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4417     if (len) {
4418         SvCUR_set(shortpath,len);
4419         ST(0) = shortpath;
4420         XSRETURN(1);
4421     }
4422     XSRETURN_UNDEF;
4423 }
4424
4425 static
4426 XS(w32_GetFullPathName)
4427 {
4428     dXSARGS;
4429     SV *filename;
4430     SV *fullpath;
4431     char *filepart;
4432     DWORD len;
4433
4434     if (items != 1)
4435         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4436
4437     filename = ST(0);
4438     fullpath = sv_mortalcopy(filename);
4439     SvUPGRADE(fullpath, SVt_PV);
4440     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4441         XSRETURN_UNDEF;
4442
4443     do {
4444         len = GetFullPathName(SvPVX(filename),
4445                               SvLEN(fullpath),
4446                               SvPVX(fullpath),
4447                               &filepart);
4448     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4449     if (len) {
4450         if (GIMME_V == G_ARRAY) {
4451             EXTEND(SP,1);
4452             XST_mPV(1,filepart);
4453             len = filepart - SvPVX(fullpath);
4454             items = 2;
4455         }
4456         SvCUR_set(fullpath,len);
4457         ST(0) = fullpath;
4458         XSRETURN(items);
4459     }
4460     XSRETURN_EMPTY;
4461 }
4462
4463 static
4464 XS(w32_GetLongPathName)
4465 {
4466     dXSARGS;
4467     SV *path;
4468     char tmpbuf[MAX_PATH+1];
4469     char *pathstr;
4470     STRLEN len;
4471
4472     if (items != 1)
4473         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4474
4475     path = ST(0);
4476     pathstr = SvPV(path,len);
4477     strcpy(tmpbuf, pathstr);
4478     pathstr = win32_longpath(tmpbuf);
4479     if (pathstr) {
4480         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4481         XSRETURN(1);
4482     }
4483     XSRETURN_EMPTY;
4484 }
4485
4486 static
4487 XS(w32_Sleep)
4488 {
4489     dXSARGS;
4490     if (items != 1)
4491         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4492     Sleep(SvIV(ST(0)));
4493     XSRETURN_YES;
4494 }
4495
4496 static
4497 XS(w32_CopyFile)
4498 {
4499     dXSARGS;
4500     BOOL bResult;
4501     if (items != 3)
4502         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4503     if (USING_WIDE()) {
4504         WCHAR wSourceFile[MAX_PATH+1];
4505         WCHAR wDestFile[MAX_PATH+1];
4506         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4507         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4508         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4509         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4510     }
4511     else {
4512         char szSourceFile[MAX_PATH+1];
4513         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4514         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4515     }
4516
4517     if (bResult)
4518         XSRETURN_YES;
4519     XSRETURN_NO;
4520 }
4521
4522 void
4523 Perl_init_os_extras(void)
4524 {
4525     dTHX;
4526     char *file = __FILE__;
4527     dXSUB_SYS;
4528
4529     /* these names are Activeware compatible */
4530     newXS("Win32::GetCwd", w32_GetCwd, file);
4531     newXS("Win32::SetCwd", w32_SetCwd, file);
4532     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4533     newXS("Win32::GetLastError", w32_GetLastError, file);
4534     newXS("Win32::SetLastError", w32_SetLastError, file);
4535     newXS("Win32::LoginName", w32_LoginName, file);
4536     newXS("Win32::NodeName", w32_NodeName, file);
4537     newXS("Win32::DomainName", w32_DomainName, file);
4538     newXS("Win32::FsType", w32_FsType, file);
4539     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4540     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4541     newXS("Win32::IsWin95", w32_IsWin95, file);
4542     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4543     newXS("Win32::Spawn", w32_Spawn, file);
4544     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4545     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4546     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4547     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4548     newXS("Win32::CopyFile", w32_CopyFile, file);
4549     newXS("Win32::Sleep", w32_Sleep, file);
4550     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4551
4552     /* XXX Bloat Alert! The following Activeware preloads really
4553      * ought to be part of Win32::Sys::*, so they're not included
4554      * here.
4555      */
4556     /* LookupAccountName
4557      * LookupAccountSID
4558      * InitiateSystemShutdown
4559      * AbortSystemShutdown
4560      * ExpandEnvrironmentStrings
4561      */
4562 }
4563
4564 #ifdef MULTIPLICITY
4565
4566 PerlInterpreter *
4567 win32_signal_context(void)
4568 {
4569     dTHX;
4570     if (!my_perl) {
4571         my_perl = PL_curinterp;
4572         PERL_SET_THX(my_perl);
4573     }
4574     return my_perl;
4575 }
4576
4577 #endif
4578
4579 BOOL WINAPI
4580 win32_ctrlhandler(DWORD dwCtrlType)
4581 {
4582 #ifdef MULTIPLICITY
4583     dTHXa(PERL_GET_SIG_CONTEXT);
4584
4585     if (!my_perl)
4586         return FALSE;
4587 #endif
4588
4589     switch(dwCtrlType) {
4590     case CTRL_CLOSE_EVENT:
4591      /*  A signal that the system sends to all processes attached to a console when
4592          the user closes the console (either by choosing the Close command from the
4593          console window's System menu, or by choosing the End Task command from the
4594          Task List
4595       */
4596         if (do_raise(aTHX_ 1))        /* SIGHUP */
4597             sig_terminate(aTHX_ 1);
4598         return TRUE;
4599
4600     case CTRL_C_EVENT:
4601         /*  A CTRL+c signal was received */
4602         if (do_raise(aTHX_ SIGINT))
4603             sig_terminate(aTHX_ SIGINT);
4604         return TRUE;
4605
4606     case CTRL_BREAK_EVENT:
4607         /*  A CTRL+BREAK signal was received */
4608         if (do_raise(aTHX_ SIGBREAK))
4609             sig_terminate(aTHX_ SIGBREAK);
4610         return TRUE;
4611
4612     case CTRL_LOGOFF_EVENT:
4613       /*  A signal that the system sends to all console processes when a user is logging
4614           off. This signal does not indicate which user is logging off, so no
4615           assumptions can be made.
4616        */
4617         break;
4618     case CTRL_SHUTDOWN_EVENT:
4619       /*  A signal that the system sends to all console processes when the system is
4620           shutting down.
4621        */
4622         if (do_raise(aTHX_ SIGTERM))
4623             sig_terminate(aTHX_ SIGTERM);
4624         return TRUE;
4625     default:
4626         break;
4627     }
4628     return FALSE;
4629 }
4630
4631
4632 void
4633 Perl_win32_init(int *argcp, char ***argvp)
4634 {
4635     /* Disable floating point errors, Perl will trap the ones we
4636      * care about.  VC++ RTL defaults to switching these off
4637      * already, but the Borland RTL doesn't.  Since we don't
4638      * want to be at the vendor's whim on the default, we set
4639      * it explicitly here.
4640      */
4641 #if !defined(_ALPHA_) && !defined(__GNUC__)
4642     _control87(MCW_EM, MCW_EM);
4643 #endif
4644     MALLOC_INIT;
4645 }
4646
4647 void
4648 win32_get_child_IO(child_IO_table* ptbl)
4649 {
4650     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4651     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4652     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4653 }
4654
4655 Sighandler_t
4656 win32_signal(int sig, Sighandler_t subcode)
4657 {
4658     dTHX;
4659     if (sig < SIG_SIZE) {
4660         int save_errno = errno;
4661         Sighandler_t result = signal(sig, subcode);
4662         if (result == SIG_ERR) {
4663             result = w32_sighandler[sig];
4664             errno = save_errno;
4665         }
4666         w32_sighandler[sig] = subcode;
4667         return result;
4668     }
4669     else {
4670         errno = EINVAL;
4671         return SIG_ERR;
4672     }
4673 }
4674
4675
4676 #ifdef HAVE_INTERP_INTERN
4677
4678
4679 static void
4680 win32_csighandler(int sig)
4681 {
4682 #if 0
4683     dTHXa(PERL_GET_SIG_CONTEXT);
4684     Perl_warn(aTHX_ "Got signal %d",sig);
4685 #endif
4686     /* Does nothing */
4687 }
4688
4689 void
4690 Perl_sys_intern_init(pTHX)
4691 {
4692     int i;
4693     w32_perlshell_tokens        = Nullch;
4694     w32_perlshell_vec           = (char**)NULL;
4695     w32_perlshell_items         = 0;
4696     w32_fdpid                   = newAV();
4697     New(1313, w32_children, 1, child_tab);
4698     w32_num_children            = 0;
4699 #  ifdef USE_ITHREADS
4700     w32_pseudo_id               = 0;
4701     New(1313, w32_pseudo_children, 1, child_tab);
4702     w32_num_pseudo_children     = 0;
4703 #  endif
4704     w32_init_socktype           = 0;
4705     w32_timerid                 = 0;
4706     w32_poll_count              = 0;
4707     for (i=0; i < SIG_SIZE; i++) {
4708         w32_sighandler[i] = SIG_DFL;
4709     }
4710 #  ifdef MULTIPLICTY
4711     if (my_perl == PL_curinterp) {
4712 #  else
4713     {
4714 #  endif
4715         /* Force C runtime signal stuff to set its console handler */
4716         signal(SIGINT,&win32_csighandler);
4717         signal(SIGBREAK,&win32_csighandler);
4718         /* Push our handler on top */
4719         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4720     }
4721 }
4722
4723 void
4724 Perl_sys_intern_clear(pTHX)
4725 {
4726     Safefree(w32_perlshell_tokens);
4727     Safefree(w32_perlshell_vec);
4728     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4729     Safefree(w32_children);
4730     if (w32_timerid) {
4731         KillTimer(NULL,w32_timerid);
4732         w32_timerid=0;
4733     }
4734 #  ifdef MULTIPLICITY
4735     if (my_perl == PL_curinterp) {
4736 #  else
4737     {
4738 #  endif
4739         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4740     }
4741 #  ifdef USE_ITHREADS
4742     Safefree(w32_pseudo_children);
4743 #  endif
4744 }
4745
4746 #  ifdef USE_ITHREADS
4747
4748 void
4749 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4750 {
4751     dst->perlshell_tokens       = Nullch;
4752     dst->perlshell_vec          = (char**)NULL;
4753     dst->perlshell_items        = 0;
4754     dst->fdpid                  = newAV();
4755     Newz(1313, dst->children, 1, child_tab);
4756     dst->pseudo_id              = 0;
4757     Newz(1313, dst->pseudo_children, 1, child_tab);
4758     dst->thr_intern.Winit_socktype = 0;
4759     dst->timerid                 = 0;
4760     dst->poll_count              = 0;
4761     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4762 }
4763 #  endif /* USE_ITHREADS */
4764 #endif /* HAVE_INTERP_INTERN */
4765
4766 static void
4767 win32_free_argvw(pTHX_ void *ptr)
4768 {
4769     char** argv = (char**)ptr;
4770     while(*argv) {
4771         Safefree(*argv);
4772         *argv++ = Nullch;
4773     }
4774 }
4775
4776 void
4777 win32_argv2utf8(int argc, char** argv)
4778 {
4779     dTHX;
4780     char* psz;
4781     int length, wargc;
4782     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4783     if (lpwStr && argc) {
4784         while (argc--) {
4785             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4786             Newz(0, psz, length, char);
4787             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4788             argv[argc] = psz;
4789         }
4790         call_atexit(win32_free_argvw, argv);
4791     }
4792     GlobalFree((HGLOBAL)lpwStr);
4793 }