win32/win32.c

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