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