win32/win32.c

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