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 FILE *
4040 win32_fdupopen(FILE *pf)
4041 {
4042     FILE* pfdup;
4043     fpos_t pos;
4044     char mode[3];
4045     int fileno = win32_dup(win32_fileno(pf));
4046
4047     /* open the file in the same mode */
4048 #ifdef __BORLANDC__
4049     if((pf)->flags & _F_READ) {
4050         mode[0] = 'r';
4051         mode[1] = 0;
4052     }
4053     else if((pf)->flags & _F_WRIT) {
4054         mode[0] = 'a';
4055         mode[1] = 0;
4056     }
4057     else if((pf)->flags & _F_RDWR) {
4058         mode[0] = 'r';
4059         mode[1] = '+';
4060         mode[2] = 0;
4061     }
4062 #else
4063     if((pf)->_flag & _IOREAD) {
4064         mode[0] = 'r';
4065         mode[1] = 0;
4066     }
4067     else if((pf)->_flag & _IOWRT) {
4068         mode[0] = 'a';
4069         mode[1] = 0;
4070     }
4071     else if((pf)->_flag & _IORW) {
4072         mode[0] = 'r';
4073         mode[1] = '+';
4074         mode[2] = 0;
4075     }
4076 #endif
4077
4078     /* it appears that the binmode is attached to the
4079      * file descriptor so binmode files will be handled
4080      * correctly
4081      */
4082     pfdup = win32_fdopen(fileno, mode);
4083
4084     /* move the file pointer to the same position */
4085     if (!fgetpos(pf, &pos)) {
4086         fsetpos(pfdup, &pos);
4087     }
4088     return pfdup;
4089 }
4090
4091 DllExport void*
4092 win32_dynaload(const char* filename)
4093 {
4094     dTHX;
4095     HMODULE hModule;
4096     char buf[MAX_PATH+1];
4097     char *first;
4098
4099     /* LoadLibrary() doesn't recognize forward slashes correctly,
4100      * so turn 'em back. */
4101     first = strchr(filename, '/');
4102     if (first) {
4103         STRLEN len = strlen(filename);
4104         if (len <= MAX_PATH) {
4105             strcpy(buf, filename);
4106             filename = &buf[first - filename];
4107             while (*filename) {
4108                 if (*filename == '/')
4109                     *(char*)filename = '\\';
4110                 ++filename;
4111             }
4112             filename = buf;
4113         }
4114     }
4115     if (USING_WIDE()) {
4116         WCHAR wfilename[MAX_PATH+1];
4117         A2WHELPER(filename, wfilename, sizeof(wfilename));
4118         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4119     }
4120     else {
4121         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4122     }
4123     return hModule;
4124 }
4125
4126 /*
4127  * Extras.
4128  */
4129
4130 static
4131 XS(w32_SetChildShowWindow)
4132 {
4133     dXSARGS;
4134     BOOL use_showwindow = w32_use_showwindow;
4135     /* use "unsigned short" because Perl has redefined "WORD" */
4136     unsigned short showwindow = w32_showwindow;
4137
4138     if (items > 1)
4139         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4140
4141     if (items == 0 || !SvOK(ST(0)))
4142         w32_use_showwindow = FALSE;
4143     else {
4144         w32_use_showwindow = TRUE;
4145         w32_showwindow = (unsigned short)SvIV(ST(0));
4146     }
4147
4148     EXTEND(SP, 1);
4149     if (use_showwindow)
4150         ST(0) = sv_2mortal(newSViv(showwindow));
4151     else
4152         ST(0) = &PL_sv_undef;
4153     XSRETURN(1);
4154 }
4155
4156 static
4157 XS(w32_GetCwd)
4158 {
4159     dXSARGS;
4160     /* Make the host for current directory */
4161     char* ptr = PerlEnv_get_childdir();
4162     /*
4163      * If ptr != Nullch
4164      *   then it worked, set PV valid,
4165      *   else return 'undef'
4166      */
4167     if (ptr) {
4168         SV *sv = sv_newmortal();
4169         sv_setpv(sv, ptr);
4170         PerlEnv_free_childdir(ptr);
4171
4172 #ifndef INCOMPLETE_TAINTS
4173         SvTAINTED_on(sv);
4174 #endif
4175
4176         EXTEND(SP,1);
4177         SvPOK_on(sv);
4178         ST(0) = sv;
4179         XSRETURN(1);
4180     }
4181     XSRETURN_UNDEF;
4182 }
4183
4184 static
4185 XS(w32_SetCwd)
4186 {
4187     dXSARGS;
4188     if (items != 1)
4189         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4190     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4191         XSRETURN_YES;
4192
4193     XSRETURN_NO;
4194 }
4195
4196 static
4197 XS(w32_GetNextAvailDrive)
4198 {
4199     dXSARGS;
4200     char ix = 'C';
4201     char root[] = "_:\\";
4202
4203     EXTEND(SP,1);
4204     while (ix <= 'Z') {
4205         root[0] = ix++;
4206         if (GetDriveType(root) == 1) {
4207             root[2] = '\0';
4208             XSRETURN_PV(root);
4209         }
4210     }
4211     XSRETURN_UNDEF;
4212 }
4213
4214 static
4215 XS(w32_GetLastError)
4216 {
4217     dXSARGS;
4218     EXTEND(SP,1);
4219     XSRETURN_IV(GetLastError());
4220 }
4221
4222 static
4223 XS(w32_SetLastError)
4224 {
4225     dXSARGS;
4226     if (items != 1)
4227         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4228     SetLastError(SvIV(ST(0)));
4229     XSRETURN_EMPTY;
4230 }
4231
4232 static
4233 XS(w32_LoginName)
4234 {
4235     dXSARGS;
4236     char *name = w32_getlogin_buffer;
4237     DWORD size = sizeof(w32_getlogin_buffer);
4238     EXTEND(SP,1);
4239     if (GetUserName(name,&size)) {
4240         /* size includes NULL */
4241         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4242         XSRETURN(1);
4243     }
4244     XSRETURN_UNDEF;
4245 }
4246
4247 static
4248 XS(w32_NodeName)
4249 {
4250     dXSARGS;
4251     char name[MAX_COMPUTERNAME_LENGTH+1];
4252     DWORD size = sizeof(name);
4253     EXTEND(SP,1);
4254     if (GetComputerName(name,&size)) {
4255         /* size does NOT include NULL :-( */
4256         ST(0) = sv_2mortal(newSVpvn(name,size));
4257         XSRETURN(1);
4258     }
4259     XSRETURN_UNDEF;
4260 }
4261
4262
4263 static
4264 XS(w32_DomainName)
4265 {
4266     dXSARGS;
4267     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4268     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4269     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4270                                           void *bufptr);
4271
4272     if (hNetApi32) {
4273         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4274             GetProcAddress(hNetApi32, "NetApiBufferFree");
4275         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4276             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4277     }
4278     EXTEND(SP,1);
4279     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4280         /* this way is more reliable, in case user has a local account. */
4281         char dname[256];
4282         DWORD dnamelen = sizeof(dname);
4283         struct {
4284             DWORD   wki100_platform_id;
4285             LPWSTR  wki100_computername;
4286             LPWSTR  wki100_langroup;
4287             DWORD   wki100_ver_major;
4288             DWORD   wki100_ver_minor;
4289         } *pwi;
4290         /* NERR_Success *is* 0*/
4291         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4292             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4293                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4294                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4295             }
4296             else {
4297                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4298                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4299             }
4300             pfnNetApiBufferFree(pwi);
4301             FreeLibrary(hNetApi32);
4302             XSRETURN_PV(dname);
4303         }
4304         FreeLibrary(hNetApi32);
4305     }
4306     else {
4307         /* Win95 doesn't have NetWksta*(), so do it the old way */
4308         char name[256];
4309         DWORD size = sizeof(name);
4310         if (hNetApi32)
4311             FreeLibrary(hNetApi32);
4312         if (GetUserName(name,&size)) {
4313             char sid[ONE_K_BUFSIZE];
4314             DWORD sidlen = sizeof(sid);
4315             char dname[256];
4316             DWORD dnamelen = sizeof(dname);
4317             SID_NAME_USE snu;
4318             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4319                                   dname, &dnamelen, &snu)) {
4320                 XSRETURN_PV(dname);             /* all that for this */
4321             }
4322         }
4323     }
4324     XSRETURN_UNDEF;
4325 }
4326
4327 static
4328 XS(w32_FsType)
4329 {
4330     dXSARGS;
4331     char fsname[256];
4332     DWORD flags, filecomplen;
4333     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4334                          &flags, fsname, sizeof(fsname))) {
4335         if (GIMME_V == G_ARRAY) {
4336             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4337             XPUSHs(sv_2mortal(newSViv(flags)));
4338             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4339             PUTBACK;
4340             return;
4341         }
4342         EXTEND(SP,1);
4343         XSRETURN_PV(fsname);
4344     }
4345     XSRETURN_EMPTY;
4346 }
4347
4348 static
4349 XS(w32_GetOSVersion)
4350 {
4351     dXSARGS;
4352     OSVERSIONINFOA osver;
4353
4354     if (USING_WIDE()) {
4355         OSVERSIONINFOW osverw;
4356         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4357         osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4358         if (!GetVersionExW(&osverw)) {
4359             XSRETURN_EMPTY;
4360         }
4361         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4362         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4363         osver.dwMajorVersion = osverw.dwMajorVersion;
4364         osver.dwMinorVersion = osverw.dwMinorVersion;
4365         osver.dwBuildNumber = osverw.dwBuildNumber;
4366         osver.dwPlatformId = osverw.dwPlatformId;
4367     }
4368     else {
4369         osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4370         if (!GetVersionExA(&osver)) {
4371             XSRETURN_EMPTY;
4372         }
4373         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4374     }
4375     XPUSHs(newSViv(osver.dwMajorVersion));
4376     XPUSHs(newSViv(osver.dwMinorVersion));
4377     XPUSHs(newSViv(osver.dwBuildNumber));
4378     XPUSHs(newSViv(osver.dwPlatformId));
4379     PUTBACK;
4380 }
4381
4382 static
4383 XS(w32_IsWinNT)
4384 {
4385     dXSARGS;
4386     EXTEND(SP,1);
4387     XSRETURN_IV(IsWinNT());
4388 }
4389
4390 static
4391 XS(w32_IsWin95)
4392 {
4393     dXSARGS;
4394     EXTEND(SP,1);
4395     XSRETURN_IV(IsWin95());
4396 }
4397
4398 static
4399 XS(w32_FormatMessage)
4400 {
4401     dXSARGS;
4402     DWORD source = 0;
4403     char msgbuf[ONE_K_BUFSIZE];
4404
4405     if (items != 1)
4406         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4407
4408     if (USING_WIDE()) {
4409         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4410         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4411                           &source, SvIV(ST(0)), 0,
4412                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4413         {
4414             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4415             XSRETURN_PV(msgbuf);
4416         }
4417     }
4418     else {
4419         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4420                           &source, SvIV(ST(0)), 0,
4421                           msgbuf, sizeof(msgbuf)-1, NULL))
4422             XSRETURN_PV(msgbuf);
4423     }
4424
4425     XSRETURN_UNDEF;
4426 }
4427
4428 static
4429 XS(w32_Spawn)
4430 {
4431     dXSARGS;
4432     char *cmd, *args;
4433     void *env;
4434     char *dir;
4435     PROCESS_INFORMATION stProcInfo;
4436     STARTUPINFO stStartInfo;
4437     BOOL bSuccess = FALSE;
4438
4439     if (items != 3)
4440         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4441
4442     cmd = SvPV_nolen(ST(0));
4443     args = SvPV_nolen(ST(1));
4444
4445     env = PerlEnv_get_childenv();
4446     dir = PerlEnv_get_childdir();
4447
4448     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4449     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4450     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4451     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4452
4453     if (CreateProcess(
4454                 cmd,                    /* Image path */
4455                 args,                   /* Arguments for command line */
4456                 NULL,                   /* Default process security */
4457                 NULL,                   /* Default thread security */
4458                 FALSE,                  /* Must be TRUE to use std handles */
4459                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4460                 env,                    /* Inherit our environment block */
4461                 dir,                    /* Inherit our currrent directory */
4462                 &stStartInfo,           /* -> Startup info */
4463                 &stProcInfo))           /* <- Process info (if OK) */
4464     {
4465         int pid = (int)stProcInfo.dwProcessId;
4466         if (IsWin95() && pid < 0)
4467             pid = -pid;
4468         sv_setiv(ST(2), pid);
4469         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4470         bSuccess = TRUE;
4471     }
4472     PerlEnv_free_childenv(env);
4473     PerlEnv_free_childdir(dir);
4474     XSRETURN_IV(bSuccess);
4475 }
4476
4477 static
4478 XS(w32_GetTickCount)
4479 {
4480     dXSARGS;
4481     DWORD msec = GetTickCount();
4482     EXTEND(SP,1);
4483     if ((IV)msec > 0)
4484         XSRETURN_IV(msec);
4485     XSRETURN_NV(msec);
4486 }
4487
4488 static
4489 XS(w32_GetShortPathName)
4490 {
4491     dXSARGS;
4492     SV *shortpath;
4493     DWORD len;
4494
4495     if (items != 1)
4496         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4497
4498     shortpath = sv_mortalcopy(ST(0));
4499     SvUPGRADE(shortpath, SVt_PV);
4500     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4501         XSRETURN_UNDEF;
4502
4503     /* src == target is allowed */
4504     do {
4505         len = GetShortPathName(SvPVX(shortpath),
4506                                SvPVX(shortpath),
4507                                SvLEN(shortpath));
4508     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4509     if (len) {
4510         SvCUR_set(shortpath,len);
4511         ST(0) = shortpath;
4512         XSRETURN(1);
4513     }
4514     XSRETURN_UNDEF;
4515 }
4516
4517 static
4518 XS(w32_GetFullPathName)
4519 {
4520     dXSARGS;
4521     SV *filename;
4522     SV *fullpath;
4523     char *filepart;
4524     DWORD len;
4525
4526     if (items != 1)
4527         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4528
4529     filename = ST(0);
4530     fullpath = sv_mortalcopy(filename);
4531     SvUPGRADE(fullpath, SVt_PV);
4532     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4533         XSRETURN_UNDEF;
4534
4535     do {
4536         len = GetFullPathName(SvPVX(filename),
4537                               SvLEN(fullpath),
4538                               SvPVX(fullpath),
4539                               &filepart);
4540     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4541     if (len) {
4542         if (GIMME_V == G_ARRAY) {
4543             EXTEND(SP,1);
4544             XST_mPV(1,filepart);
4545             len = filepart - SvPVX(fullpath);
4546             items = 2;
4547         }
4548         SvCUR_set(fullpath,len);
4549         ST(0) = fullpath;
4550         XSRETURN(items);
4551     }
4552     XSRETURN_EMPTY;
4553 }
4554
4555 static
4556 XS(w32_GetLongPathName)
4557 {
4558     dXSARGS;
4559     SV *path;
4560     char tmpbuf[MAX_PATH+1];
4561     char *pathstr;
4562     STRLEN len;
4563
4564     if (items != 1)
4565         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4566
4567     path = ST(0);
4568     pathstr = SvPV(path,len);
4569     strcpy(tmpbuf, pathstr);
4570     pathstr = win32_longpath(tmpbuf);
4571     if (pathstr) {
4572         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4573         XSRETURN(1);
4574     }
4575     XSRETURN_EMPTY;
4576 }
4577
4578 static
4579 XS(w32_Sleep)
4580 {
4581     dXSARGS;
4582     if (items != 1)
4583         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4584     Sleep(SvIV(ST(0)));
4585     XSRETURN_YES;
4586 }
4587
4588 static
4589 XS(w32_CopyFile)
4590 {
4591     dXSARGS;
4592     BOOL bResult;
4593     if (items != 3)
4594         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4595     if (USING_WIDE()) {
4596         WCHAR wSourceFile[MAX_PATH+1];
4597         WCHAR wDestFile[MAX_PATH+1];
4598         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4599         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4600         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4601         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4602     }
4603     else {
4604         char szSourceFile[MAX_PATH+1];
4605         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4606         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4607     }
4608
4609     if (bResult)
4610         XSRETURN_YES;
4611     XSRETURN_NO;
4612 }
4613
4614 void
4615 Perl_init_os_extras(void)
4616 {
4617     dTHX;
4618     char *file = __FILE__;
4619     dXSUB_SYS;
4620
4621     /* these names are Activeware compatible */
4622     newXS("Win32::GetCwd", w32_GetCwd, file);
4623     newXS("Win32::SetCwd", w32_SetCwd, file);
4624     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4625     newXS("Win32::GetLastError", w32_GetLastError, file);
4626     newXS("Win32::SetLastError", w32_SetLastError, file);
4627     newXS("Win32::LoginName", w32_LoginName, file);
4628     newXS("Win32::NodeName", w32_NodeName, file);
4629     newXS("Win32::DomainName", w32_DomainName, file);
4630     newXS("Win32::FsType", w32_FsType, file);
4631     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4632     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4633     newXS("Win32::IsWin95", w32_IsWin95, file);
4634     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4635     newXS("Win32::Spawn", w32_Spawn, file);
4636     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4637     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4638     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4639     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4640     newXS("Win32::CopyFile", w32_CopyFile, file);
4641     newXS("Win32::Sleep", w32_Sleep, file);
4642     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4643
4644     /* XXX Bloat Alert! The following Activeware preloads really
4645      * ought to be part of Win32::Sys::*, so they're not included
4646      * here.
4647      */
4648     /* LookupAccountName
4649      * LookupAccountSID
4650      * InitiateSystemShutdown
4651      * AbortSystemShutdown
4652      * ExpandEnvrironmentStrings
4653      */
4654 }
4655
4656 #ifdef MULTIPLICITY
4657
4658 PerlInterpreter *
4659 win32_signal_context(void)
4660 {
4661     dTHX;
4662     if (!my_perl) {
4663         my_perl = PL_curinterp;
4664         PERL_SET_THX(my_perl);
4665     }
4666     return my_perl;
4667 }
4668
4669 #endif
4670
4671 BOOL WINAPI
4672 win32_ctrlhandler(DWORD dwCtrlType)
4673 {
4674 #ifdef MULTIPLICITY
4675     dTHXa(PERL_GET_SIG_CONTEXT);
4676
4677     if (!my_perl)
4678         return FALSE;
4679 #endif
4680
4681     switch(dwCtrlType) {
4682     case CTRL_CLOSE_EVENT:
4683      /*  A signal that the system sends to all processes attached to a console when
4684          the user closes the console (either by choosing the Close command from the
4685          console window's System menu, or by choosing the End Task command from the
4686          Task List
4687       */
4688         if (do_raise(aTHX_ 1))        /* SIGHUP */
4689             sig_terminate(aTHX_ 1);
4690         return TRUE;
4691
4692     case CTRL_C_EVENT:
4693         /*  A CTRL+c signal was received */
4694         if (do_raise(aTHX_ SIGINT))
4695             sig_terminate(aTHX_ SIGINT);
4696         return TRUE;
4697
4698     case CTRL_BREAK_EVENT:
4699         /*  A CTRL+BREAK signal was received */
4700         if (do_raise(aTHX_ SIGBREAK))
4701             sig_terminate(aTHX_ SIGBREAK);
4702         return TRUE;
4703
4704     case CTRL_LOGOFF_EVENT:
4705       /*  A signal that the system sends to all console processes when a user is logging
4706           off. This signal does not indicate which user is logging off, so no
4707           assumptions can be made.
4708        */
4709         break;
4710     case CTRL_SHUTDOWN_EVENT:
4711       /*  A signal that the system sends to all console processes when the system is
4712           shutting down.
4713        */
4714         if (do_raise(aTHX_ SIGTERM))
4715             sig_terminate(aTHX_ SIGTERM);
4716         return TRUE;
4717     default:
4718         break;
4719     }
4720     return FALSE;
4721 }
4722
4723
4724 void
4725 Perl_win32_init(int *argcp, char ***argvp)
4726 {
4727     /* Disable floating point errors, Perl will trap the ones we
4728      * care about.  VC++ RTL defaults to switching these off
4729      * already, but the Borland RTL doesn't.  Since we don't
4730      * want to be at the vendor's whim on the default, we set
4731      * it explicitly here.
4732      */
4733 #if !defined(_ALPHA_) && !defined(__GNUC__)
4734     _control87(MCW_EM, MCW_EM);
4735 #endif
4736     MALLOC_INIT;
4737 }
4738
4739 void
4740 win32_get_child_IO(child_IO_table* ptbl)
4741 {
4742     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4743     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4744     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4745 }
4746
4747 Sighandler_t
4748 win32_signal(int sig, Sighandler_t subcode)
4749 {
4750     dTHX;
4751     if (sig < SIG_SIZE) {
4752         int save_errno = errno;
4753         Sighandler_t result = signal(sig, subcode);
4754         if (result == SIG_ERR) {
4755             result = w32_sighandler[sig];
4756             errno = save_errno;
4757         }
4758         w32_sighandler[sig] = subcode;
4759         return result;
4760     }
4761     else {
4762         errno = EINVAL;
4763         return SIG_ERR;
4764     }
4765 }
4766
4767
4768 #ifdef HAVE_INTERP_INTERN
4769
4770
4771 static void
4772 win32_csighandler(int sig)
4773 {
4774 #if 0
4775     dTHXa(PERL_GET_SIG_CONTEXT);
4776     Perl_warn(aTHX_ "Got signal %d",sig);
4777 #endif
4778     /* Does nothing */
4779 }
4780
4781 void
4782 Perl_sys_intern_init(pTHX)
4783 {
4784     int i;
4785     w32_perlshell_tokens        = Nullch;
4786     w32_perlshell_vec           = (char**)NULL;
4787     w32_perlshell_items         = 0;
4788     w32_fdpid                   = newAV();
4789     New(1313, w32_children, 1, child_tab);
4790     w32_num_children            = 0;
4791 #  ifdef USE_ITHREADS
4792     w32_pseudo_id               = 0;
4793     New(1313, w32_pseudo_children, 1, child_tab);
4794     w32_num_pseudo_children     = 0;
4795 #  endif
4796     w32_init_socktype           = 0;
4797     w32_timerid                 = 0;
4798     w32_poll_count              = 0;
4799     for (i=0; i < SIG_SIZE; i++) {
4800         w32_sighandler[i] = SIG_DFL;
4801     }
4802 #  ifdef MULTIPLICTY
4803     if (my_perl == PL_curinterp) {
4804 #  else
4805     {
4806 #  endif
4807         /* Force C runtime signal stuff to set its console handler */
4808         signal(SIGINT,&win32_csighandler);
4809         signal(SIGBREAK,&win32_csighandler);
4810         /* Push our handler on top */
4811         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4812     }
4813 }
4814
4815 void
4816 Perl_sys_intern_clear(pTHX)
4817 {
4818     Safefree(w32_perlshell_tokens);
4819     Safefree(w32_perlshell_vec);
4820     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4821     Safefree(w32_children);
4822     if (w32_timerid) {
4823         KillTimer(NULL,w32_timerid);
4824         w32_timerid=0;
4825     }
4826 #  ifdef MULTIPLICITY
4827     if (my_perl == PL_curinterp) {
4828 #  else
4829     {
4830 #  endif
4831         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4832     }
4833 #  ifdef USE_ITHREADS
4834     Safefree(w32_pseudo_children);
4835 #  endif
4836 }
4837
4838 #  ifdef USE_ITHREADS
4839
4840 void
4841 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4842 {
4843     dst->perlshell_tokens       = Nullch;
4844     dst->perlshell_vec          = (char**)NULL;
4845     dst->perlshell_items        = 0;
4846     dst->fdpid                  = newAV();
4847     Newz(1313, dst->children, 1, child_tab);
4848     dst->pseudo_id              = 0;
4849     Newz(1313, dst->pseudo_children, 1, child_tab);
4850     dst->thr_intern.Winit_socktype = 0;
4851     dst->timerid                 = 0;
4852     dst->poll_count              = 0;
4853     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4854 }
4855 #  endif /* USE_ITHREADS */
4856 #endif /* HAVE_INTERP_INTERN */
4857
4858 static void
4859 win32_free_argvw(pTHX_ void *ptr)
4860 {
4861     char** argv = (char**)ptr;
4862     while(*argv) {
4863         Safefree(*argv);
4864         *argv++ = Nullch;
4865     }
4866 }
4867
4868 void
4869 win32_argv2utf8(int argc, char** argv)
4870 {
4871     dTHX;
4872     char* psz;
4873     int length, wargc;
4874     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4875     if (lpwStr && argc) {
4876         while (argc--) {
4877             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4878             Newz(0, psz, length, char);
4879             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4880             argv[argc] = psz;
4881         }
4882         call_atexit(win32_free_argvw, argv);
4883     }
4884     GlobalFree((HGLOBAL)lpwStr);
4885 }