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 /* NOTE: This does not compute the timezone info (doing so can be expensive,
1655  * and appears to be unsupported even by glibc) */
1656 DllExport int
1657 win32_gettimeofday(struct timeval *tp, void *not_used)
1658 {
1659     return PerlProc_gettimeofday(tp, not_used); // Implemented in Time::HiRes.
1660 }
1661
1662 DllExport int
1663 win32_uname(struct utsname *name)
1664 {
1665     struct hostent *hep;
1666     STRLEN nodemax = sizeof(name->nodename)-1;
1667     OSVERSIONINFO osver;
1668
1669     memset(&osver, 0, sizeof(OSVERSIONINFO));
1670     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1671     if (GetVersionEx(&osver)) {
1672         /* sysname */
1673         switch (osver.dwPlatformId) {
1674         case VER_PLATFORM_WIN32_WINDOWS:
1675             strcpy(name->sysname, "Windows");
1676             break;
1677         case VER_PLATFORM_WIN32_NT:
1678             strcpy(name->sysname, "Windows NT");
1679             break;
1680         case VER_PLATFORM_WIN32s:
1681             strcpy(name->sysname, "Win32s");
1682             break;
1683         default:
1684             strcpy(name->sysname, "Win32 Unknown");
1685             break;
1686         }
1687
1688         /* release */
1689         sprintf(name->release, "%d.%d",
1690                 osver.dwMajorVersion, osver.dwMinorVersion);
1691
1692         /* version */
1693         sprintf(name->version, "Build %d",
1694                 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1695                 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1696         if (osver.szCSDVersion[0]) {
1697             char *buf = name->version + strlen(name->version);
1698             sprintf(buf, " (%s)", osver.szCSDVersion);
1699         }
1700     }
1701     else {
1702         *name->sysname = '\0';
1703         *name->version = '\0';
1704         *name->release = '\0';
1705     }
1706
1707     /* nodename */
1708     hep = win32_gethostbyname("localhost");
1709     if (hep) {
1710         STRLEN len = strlen(hep->h_name);
1711         if (len <= nodemax) {
1712             strcpy(name->nodename, hep->h_name);
1713         }
1714         else {
1715             strncpy(name->nodename, hep->h_name, nodemax);
1716             name->nodename[nodemax] = '\0';
1717         }
1718     }
1719     else {
1720         DWORD sz = nodemax;
1721         if (!GetComputerName(name->nodename, &sz))
1722             *name->nodename = '\0';
1723     }
1724
1725     /* machine (architecture) */
1726     {
1727         SYSTEM_INFO info;
1728         char *arch;
1729         GetSystemInfo(&info);
1730
1731 #if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1732  || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1733         switch (info.u.s.wProcessorArchitecture) {
1734 #else
1735         switch (info.wProcessorArchitecture) {
1736 #endif
1737         case PROCESSOR_ARCHITECTURE_INTEL:
1738             arch = "x86"; break;
1739         case PROCESSOR_ARCHITECTURE_MIPS:
1740             arch = "mips"; break;
1741         case PROCESSOR_ARCHITECTURE_ALPHA:
1742             arch = "alpha"; break;
1743         case PROCESSOR_ARCHITECTURE_PPC:
1744             arch = "ppc"; break;
1745         default:
1746             arch = "unknown"; break;
1747         }
1748         strcpy(name->machine, arch);
1749     }
1750     return 0;
1751 }
1752
1753 /* Timing related stuff */
1754
1755 int
1756 do_raise(pTHX_ int sig)
1757 {
1758     if (sig < SIG_SIZE) {
1759         Sighandler_t handler = w32_sighandler[sig];
1760         if (handler == SIG_IGN) {
1761             return 0;
1762         }
1763         else if (handler != SIG_DFL) {
1764             (*handler)(sig);
1765             return 0;
1766         }
1767         else {
1768             /* Choose correct default behaviour */
1769             switch (sig) {
1770 #ifdef SIGCLD
1771                 case SIGCLD:
1772 #endif
1773 #ifdef SIGCHLD
1774                 case SIGCHLD:
1775 #endif
1776                 case 0:
1777                     return 0;
1778                 case SIGTERM:
1779                 default:
1780                     break;
1781             }
1782         }
1783     }
1784     /* Tell caller to exit thread/process as approriate */
1785     return 1;
1786 }
1787
1788 void
1789 sig_terminate(pTHX_ int sig)
1790 {
1791     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1792     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1793        thread
1794      */
1795     exit(sig);
1796 }
1797
1798 DllExport int
1799 win32_async_check(pTHX)
1800 {
1801     MSG msg;
1802     int ours = 1;
1803     /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1804      * and ignores window messages - should co-exist better with windows apps e.g. Tk
1805      */
1806     while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1807         int sig;
1808         switch(msg.message) {
1809
1810 #if 0
1811     /* Perhaps some other messages could map to signals ? ... */
1812         case WM_CLOSE:
1813         case WM_QUIT:
1814             /* Treat WM_QUIT like SIGHUP?  */
1815             sig = SIGHUP;
1816             goto Raise;
1817             break;
1818 #endif
1819
1820         /* We use WM_USER to fake kill() with other signals */
1821         case WM_USER: {
1822             sig = msg.wParam;
1823         Raise:
1824             if (do_raise(aTHX_ sig)) {
1825                    sig_terminate(aTHX_ sig);
1826             }
1827             break;
1828         }
1829
1830         case WM_TIMER: {
1831             /* alarm() is a one-shot but SetTimer() repeats so kill it */
1832             if (w32_timerid) {
1833                 KillTimer(NULL,w32_timerid);
1834                 w32_timerid=0;
1835             }
1836             /* Now fake a call to signal handler */
1837             if (do_raise(aTHX_ 14)) {
1838                 sig_terminate(aTHX_ 14);
1839             }
1840             break;
1841         }
1842
1843         /* Otherwise do normal Win32 thing - in case it is useful */
1844         default:
1845             TranslateMessage(&msg);
1846             DispatchMessage(&msg);
1847             ours = 0;
1848             break;
1849         }
1850     }
1851     w32_poll_count = 0;
1852
1853     /* Above or other stuff may have set a signal flag */
1854     if (PL_sig_pending) {
1855         despatch_signals();
1856     }
1857     return ours;
1858 }
1859
1860 DllExport DWORD
1861 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1862 {
1863     /* We may need several goes at this - so compute when we stop */
1864     DWORD ticks = 0;
1865     if (timeout != INFINITE) {
1866         ticks = GetTickCount();
1867         timeout += ticks;
1868     }
1869     while (1) {
1870         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1871         if (resultp)
1872            *resultp = result;
1873         if (result == WAIT_TIMEOUT) {
1874             /* Ran out of time - explicit return of zero to avoid -ve if we
1875                have scheduling issues
1876              */
1877             return 0;
1878         }
1879         if (timeout != INFINITE) {
1880             ticks = GetTickCount();
1881         }
1882         if (result == WAIT_OBJECT_0 + count) {
1883             /* Message has arrived - check it */
1884             if (win32_async_check(aTHX)) {
1885                 /* was one of ours */
1886                 break;
1887             }
1888         }
1889         else {
1890            /* Not timeout or message - one of handles is ready */
1891            break;
1892         }
1893     }
1894     /* compute time left to wait */
1895     ticks = timeout - ticks;
1896     /* If we are past the end say zero */
1897     return (ticks > 0) ? ticks : 0;
1898 }
1899
1900 int
1901 win32_internal_wait(int *status, DWORD timeout)
1902 {
1903     /* XXX this wait emulation only knows about processes
1904      * spawned via win32_spawnvp(P_NOWAIT, ...).
1905      */
1906     dTHX;
1907     int i, retval;
1908     DWORD exitcode, waitcode;
1909
1910 #ifdef USE_ITHREADS
1911     if (w32_num_pseudo_children) {
1912         win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1913                       timeout, &waitcode);
1914         /* Time out here if there are no other children to wait for. */
1915         if (waitcode == WAIT_TIMEOUT) {
1916             if (!w32_num_children) {
1917                 return 0;
1918             }
1919         }
1920         else if (waitcode != WAIT_FAILED) {
1921             if (waitcode >= WAIT_ABANDONED_0
1922                 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1923                 i = waitcode - WAIT_ABANDONED_0;
1924             else
1925                 i = waitcode - WAIT_OBJECT_0;
1926             if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1927                 *status = (int)((exitcode & 0xff) << 8);
1928                 retval = (int)w32_pseudo_child_pids[i];
1929                 remove_dead_pseudo_process(i);
1930                 return -retval;
1931             }
1932         }
1933     }
1934 #endif
1935
1936     if (!w32_num_children) {
1937         errno = ECHILD;
1938         return -1;
1939     }
1940
1941     /* if a child exists, wait for it to die */
1942     win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
1943     if (waitcode == WAIT_TIMEOUT) {
1944         return 0;
1945     }
1946     if (waitcode != WAIT_FAILED) {
1947         if (waitcode >= WAIT_ABANDONED_0
1948             && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1949             i = waitcode - WAIT_ABANDONED_0;
1950         else
1951             i = waitcode - WAIT_OBJECT_0;
1952         if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1953             *status = (int)((exitcode & 0xff) << 8);
1954             retval = (int)w32_child_pids[i];
1955             remove_dead_process(i);
1956             return retval;
1957         }
1958     }
1959
1960     errno = GetLastError();
1961     return -1;
1962 }
1963
1964 DllExport int
1965 win32_waitpid(int pid, int *status, int flags)
1966 {
1967     dTHX;
1968     DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
1969     int retval = -1;
1970     long child;
1971     if (pid == -1)                              /* XXX threadid == 1 ? */
1972         return win32_internal_wait(status, timeout);
1973 #ifdef USE_ITHREADS
1974     else if (pid < 0) {
1975         child = find_pseudo_pid(-pid);
1976         if (child >= 0) {
1977             HANDLE hThread = w32_pseudo_child_handles[child];
1978             DWORD waitcode;
1979             win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
1980             if (waitcode == WAIT_TIMEOUT) {
1981                 return 0;
1982             }
1983             else if (waitcode == WAIT_OBJECT_0) {
1984                 if (GetExitCodeThread(hThread, &waitcode)) {
1985                     *status = (int)((waitcode & 0xff) << 8);
1986                     retval = (int)w32_pseudo_child_pids[child];
1987                     remove_dead_pseudo_process(child);
1988                     return -retval;
1989                 }
1990             }
1991             else
1992                 errno = ECHILD;
1993         }
1994         else if (IsWin95()) {
1995             pid = -pid;
1996             goto alien_process;
1997         }
1998     }
1999 #endif
2000     else {
2001         HANDLE hProcess;
2002         DWORD waitcode;
2003         child = find_pid(pid);
2004         if (child >= 0) {
2005             hProcess = w32_child_handles[child];
2006             win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2007             if (waitcode == WAIT_TIMEOUT) {
2008                 return 0;
2009             }
2010             else if (waitcode == WAIT_OBJECT_0) {
2011                 if (GetExitCodeProcess(hProcess, &waitcode)) {
2012                     *status = (int)((waitcode & 0xff) << 8);
2013                     retval = (int)w32_child_pids[child];
2014                     remove_dead_process(child);
2015                     return retval;
2016                 }
2017             }
2018             else
2019                 errno = ECHILD;
2020         }
2021         else {
2022 alien_process:
2023             hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2024                                    (IsWin95() ? -pid : pid));
2025             if (hProcess) {
2026                 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2027                 if (waitcode == WAIT_TIMEOUT) {
2028                     return 0;
2029                 }
2030                 else if (waitcode == WAIT_OBJECT_0) {
2031                     if (GetExitCodeProcess(hProcess, &waitcode)) {
2032                         *status = (int)((waitcode & 0xff) << 8);
2033                         CloseHandle(hProcess);
2034                         return pid;
2035                     }
2036                 }
2037                 CloseHandle(hProcess);
2038             }
2039             else
2040                 errno = ECHILD;
2041         }
2042     }
2043     return retval >= 0 ? pid : retval;
2044 }
2045
2046 DllExport int
2047 win32_wait(int *status)
2048 {
2049     return win32_internal_wait(status, INFINITE);
2050 }
2051
2052 DllExport unsigned int
2053 win32_sleep(unsigned int t)
2054 {
2055     dTHX;
2056     /* Win32 times are in ms so *1000 in and /1000 out */
2057     return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2058 }
2059
2060 DllExport unsigned int
2061 win32_alarm(unsigned int sec)
2062 {
2063     /*
2064      * the 'obvious' implentation is SetTimer() with a callback
2065      * which does whatever receiving SIGALRM would do
2066      * we cannot use SIGALRM even via raise() as it is not
2067      * one of the supported codes in <signal.h>
2068      */
2069     dTHX;
2070     if (sec) {
2071         w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2072     }
2073     else {
2074         if (w32_timerid) {
2075             KillTimer(NULL,w32_timerid);
2076             w32_timerid=0;
2077         }
2078     }
2079     return 0;
2080 }
2081
2082 #ifdef HAVE_DES_FCRYPT
2083 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
2084 #endif
2085
2086 DllExport char *
2087 win32_crypt(const char *txt, const char *salt)
2088 {
2089     dTHX;
2090 #ifdef HAVE_DES_FCRYPT
2091     return des_fcrypt(txt, salt, w32_crypt_buffer);
2092 #else
2093     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2094     return Nullch;
2095 #endif
2096 }
2097
2098 #ifdef USE_FIXED_OSFHANDLE
2099
2100 #define FOPEN                   0x01    /* file handle open */
2101 #define FNOINHERIT              0x10    /* file handle opened O_NOINHERIT */
2102 #define FAPPEND                 0x20    /* file handle opened O_APPEND */
2103 #define FDEV                    0x40    /* file handle refers to device */
2104 #define FTEXT                   0x80    /* file handle is in text mode */
2105
2106 /***
2107 *int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2108 *
2109 *Purpose:
2110 *       This function allocates a free C Runtime file handle and associates
2111 *       it with the Win32 HANDLE specified by the first parameter. This is a
2112 *       temperary fix for WIN95's brain damage GetFileType() error on socket
2113 *       we just bypass that call for socket
2114 *
2115 *       This works with MSVC++ 4.0+ or GCC/Mingw32
2116 *
2117 *Entry:
2118 *       intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2119 *       int flags      - flags to associate with C Runtime file handle.
2120 *
2121 *Exit:
2122 *       returns index of entry in fh, if successful
2123 *       return -1, if no free entry is found
2124 *
2125 *Exceptions:
2126 *
2127 *******************************************************************************/
2128
2129 /*
2130  * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2131  * this lets sockets work on Win9X with GCC and should fix the problems
2132  * with perl95.exe
2133  *      -- BKS, 1-23-2000
2134 */
2135
2136 /* create an ioinfo entry, kill its handle, and steal the entry */
2137
2138 static int
2139 _alloc_osfhnd(void)
2140 {
2141     HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2142     int fh = _open_osfhandle((intptr_t)hF, 0);
2143     CloseHandle(hF);
2144     if (fh == -1)
2145         return fh;
2146     EnterCriticalSection(&(_pioinfo(fh)->lock));
2147     return fh;
2148 }
2149
2150 static int
2151 my_open_osfhandle(intptr_t osfhandle, int flags)
2152 {
2153     int fh;
2154     char fileflags;             /* _osfile flags */
2155
2156     /* copy relevant flags from second parameter */
2157     fileflags = FDEV;
2158
2159     if (flags & O_APPEND)
2160         fileflags |= FAPPEND;
2161
2162     if (flags & O_TEXT)
2163         fileflags |= FTEXT;
2164
2165     if (flags & O_NOINHERIT)
2166         fileflags |= FNOINHERIT;
2167
2168     /* attempt to allocate a C Runtime file handle */
2169     if ((fh = _alloc_osfhnd()) == -1) {
2170         errno = EMFILE;         /* too many open files */
2171         _doserrno = 0L;         /* not an OS error */
2172         return -1;              /* return error to caller */
2173     }
2174
2175     /* the file is open. now, set the info in _osfhnd array */
2176     _set_osfhnd(fh, osfhandle);
2177
2178     fileflags |= FOPEN;         /* mark as open */
2179
2180     _osfile(fh) = fileflags;    /* set osfile entry */
2181     LeaveCriticalSection(&_pioinfo(fh)->lock);
2182
2183     return fh;                  /* return handle */
2184 }
2185
2186 #endif  /* USE_FIXED_OSFHANDLE */
2187
2188 /* simulate flock by locking a range on the file */
2189
2190 #define LK_ERR(f,i)     ((f) ? (i = 0) : (errno = GetLastError()))
2191 #define LK_LEN          0xffff0000
2192
2193 DllExport int
2194 win32_flock(int fd, int oper)
2195 {
2196     OVERLAPPED o;
2197     int i = -1;
2198     HANDLE fh;
2199
2200     if (!IsWinNT()) {
2201         dTHX;
2202         Perl_croak_nocontext("flock() unimplemented on this platform");
2203         return -1;
2204     }
2205     fh = (HANDLE)_get_osfhandle(fd);
2206     memset(&o, 0, sizeof(o));
2207
2208     switch(oper) {
2209     case LOCK_SH:               /* shared lock */
2210         LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2211         break;
2212     case LOCK_EX:               /* exclusive lock */
2213         LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2214         break;
2215     case LOCK_SH|LOCK_NB:       /* non-blocking shared lock */
2216         LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2217         break;
2218     case LOCK_EX|LOCK_NB:       /* non-blocking exclusive lock */
2219         LK_ERR(LockFileEx(fh,
2220                        LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2221                        0, LK_LEN, 0, &o),i);
2222         break;
2223     case LOCK_UN:               /* unlock lock */
2224         LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2225         break;
2226     default:                    /* unknown */
2227         errno = EINVAL;
2228         break;
2229     }
2230     return i;
2231 }
2232
2233 #undef LK_ERR
2234 #undef LK_LEN
2235
2236 /*
2237  *  redirected io subsystem for all XS modules
2238  *
2239  */
2240
2241 DllExport int *
2242 win32_errno(void)
2243 {
2244     return (&errno);
2245 }
2246
2247 DllExport char ***
2248 win32_environ(void)
2249 {
2250     return (&(_environ));
2251 }
2252
2253 /* the rest are the remapped stdio routines */
2254 DllExport FILE *
2255 win32_stderr(void)
2256 {
2257     return (stderr);
2258 }
2259
2260 DllExport FILE *
2261 win32_stdin(void)
2262 {
2263     return (stdin);
2264 }
2265
2266 DllExport FILE *
2267 win32_stdout()
2268 {
2269     return (stdout);
2270 }
2271
2272 DllExport int
2273 win32_ferror(FILE *fp)
2274 {
2275     return (ferror(fp));
2276 }
2277
2278
2279 DllExport int
2280 win32_feof(FILE *fp)
2281 {
2282     return (feof(fp));
2283 }
2284
2285 /*
2286  * Since the errors returned by the socket error function
2287  * WSAGetLastError() are not known by the library routine strerror
2288  * we have to roll our own.
2289  */
2290
2291 DllExport char *
2292 win32_strerror(int e)
2293 {
2294 #if !defined __BORLANDC__ && !defined __MINGW32__      /* compiler intolerance */
2295     extern int sys_nerr;
2296 #endif
2297     DWORD source = 0;
2298
2299     if (e < 0 || e > sys_nerr) {
2300         dTHX;
2301         if (e < 0)
2302             e = GetLastError();
2303
2304         if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2305                           w32_strerror_buffer,
2306                           sizeof(w32_strerror_buffer), NULL) == 0)
2307             strcpy(w32_strerror_buffer, "Unknown Error");
2308
2309         return w32_strerror_buffer;
2310     }
2311     return strerror(e);
2312 }
2313
2314 DllExport void
2315 win32_str_os_error(void *sv, DWORD dwErr)
2316 {
2317     DWORD dwLen;
2318     char *sMsg;
2319     dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2320                           |FORMAT_MESSAGE_IGNORE_INSERTS
2321                           |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2322                            dwErr, 0, (char *)&sMsg, 1, NULL);
2323     /* strip trailing whitespace and period */
2324     if (0 < dwLen) {
2325         do {
2326             --dwLen;    /* dwLen doesn't include trailing null */
2327         } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2328         if ('.' != sMsg[dwLen])
2329             dwLen++;
2330         sMsg[dwLen] = '\0';
2331     }
2332     if (0 == dwLen) {
2333         sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2334         if (sMsg)
2335             dwLen = sprintf(sMsg,
2336                             "Unknown error #0x%lX (lookup 0x%lX)",
2337                             dwErr, GetLastError());
2338     }
2339     if (sMsg) {
2340         dTHX;
2341         sv_setpvn((SV*)sv, sMsg, dwLen);
2342         LocalFree(sMsg);
2343     }
2344 }
2345
2346 DllExport int
2347 win32_fprintf(FILE *fp, const char *format, ...)
2348 {
2349     va_list marker;
2350     va_start(marker, format);     /* Initialize variable arguments. */
2351
2352     return (vfprintf(fp, format, marker));
2353 }
2354
2355 DllExport int
2356 win32_printf(const char *format, ...)
2357 {
2358     va_list marker;
2359     va_start(marker, format);     /* Initialize variable arguments. */
2360
2361     return (vprintf(format, marker));
2362 }
2363
2364 DllExport int
2365 win32_vfprintf(FILE *fp, const char *format, va_list args)
2366 {
2367     return (vfprintf(fp, format, args));
2368 }
2369
2370 DllExport int
2371 win32_vprintf(const char *format, va_list args)
2372 {
2373     return (vprintf(format, args));
2374 }
2375
2376 DllExport size_t
2377 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2378 {
2379     return fread(buf, size, count, fp);
2380 }
2381
2382 DllExport size_t
2383 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2384 {
2385     return fwrite(buf, size, count, fp);
2386 }
2387
2388 #define MODE_SIZE 10
2389
2390 DllExport FILE *
2391 win32_fopen(const char *filename, const char *mode)
2392 {
2393     dTHX;
2394     WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2395     FILE *f;
2396
2397     if (!*filename)
2398         return NULL;
2399
2400     if (stricmp(filename, "/dev/null")==0)
2401         filename = "NUL";
2402
2403     if (USING_WIDE()) {
2404         A2WHELPER(mode, wMode, sizeof(wMode));
2405         A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2406         f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2407     }
2408     else
2409         f = fopen(PerlDir_mapA(filename), mode);
2410     /* avoid buffering headaches for child processes */
2411     if (f && *mode == 'a')
2412         win32_fseek(f, 0, SEEK_END);
2413     return f;
2414 }
2415
2416 #ifndef USE_SOCKETS_AS_HANDLES
2417 #undef fdopen
2418 #define fdopen my_fdopen
2419 #endif
2420
2421 DllExport FILE *
2422 win32_fdopen(int handle, const char *mode)
2423 {
2424     dTHX;
2425     WCHAR wMode[MODE_SIZE];
2426     FILE *f;
2427     if (USING_WIDE()) {
2428         A2WHELPER(mode, wMode, sizeof(wMode));
2429         f = _wfdopen(handle, wMode);
2430     }
2431     else
2432         f = fdopen(handle, (char *) mode);
2433     /* avoid buffering headaches for child processes */
2434     if (f && *mode == 'a')
2435         win32_fseek(f, 0, SEEK_END);
2436     return f;
2437 }
2438
2439 DllExport FILE *
2440 win32_freopen(const char *path, const char *mode, FILE *stream)
2441 {
2442     dTHX;
2443     WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2444     if (stricmp(path, "/dev/null")==0)
2445         path = "NUL";
2446
2447     if (USING_WIDE()) {
2448         A2WHELPER(mode, wMode, sizeof(wMode));
2449         A2WHELPER(path, wBuffer, sizeof(wBuffer));
2450         return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2451     }
2452     return freopen(PerlDir_mapA(path), mode, stream);
2453 }
2454
2455 DllExport int
2456 win32_fclose(FILE *pf)
2457 {
2458     return my_fclose(pf);       /* defined in win32sck.c */
2459 }
2460
2461 DllExport int
2462 win32_fputs(const char *s,FILE *pf)
2463 {
2464     return fputs(s, pf);
2465 }
2466
2467 DllExport int
2468 win32_fputc(int c,FILE *pf)
2469 {
2470     return fputc(c,pf);
2471 }
2472
2473 DllExport int
2474 win32_ungetc(int c,FILE *pf)
2475 {
2476     return ungetc(c,pf);
2477 }
2478
2479 DllExport int
2480 win32_getc(FILE *pf)
2481 {
2482     return getc(pf);
2483 }
2484
2485 DllExport int
2486 win32_fileno(FILE *pf)
2487 {
2488     return fileno(pf);
2489 }
2490
2491 DllExport void
2492 win32_clearerr(FILE *pf)
2493 {
2494     clearerr(pf);
2495     return;
2496 }
2497
2498 DllExport int
2499 win32_fflush(FILE *pf)
2500 {
2501     return fflush(pf);
2502 }
2503
2504 DllExport Off_t
2505 win32_ftell(FILE *pf)
2506 {
2507 #if defined(WIN64) || defined(USE_LARGE_FILES)
2508     fpos_t pos;
2509     if (fgetpos(pf, &pos))
2510         return -1;
2511     return (Off_t)pos;
2512 #else
2513     return ftell(pf);
2514 #endif
2515 }
2516
2517 DllExport int
2518 win32_fseek(FILE *pf, Off_t offset,int origin)
2519 {
2520 #if defined(WIN64) || defined(USE_LARGE_FILES)
2521     fpos_t pos;
2522     switch (origin) {
2523     case SEEK_CUR:
2524         if (fgetpos(pf, &pos))
2525             return -1;
2526         offset += pos;
2527         break;
2528     case SEEK_END:
2529         fseek(pf, 0, SEEK_END);
2530         pos = _telli64(fileno(pf));
2531         offset += pos;
2532         break;
2533     case SEEK_SET:
2534         break;
2535     default:
2536         errno = EINVAL;
2537         return -1;
2538     }
2539     return fsetpos(pf, &offset);
2540 #else
2541     return fseek(pf, offset, origin);
2542 #endif
2543 }
2544
2545 DllExport int
2546 win32_fgetpos(FILE *pf,fpos_t *p)
2547 {
2548     return fgetpos(pf, p);
2549 }
2550
2551 DllExport int
2552 win32_fsetpos(FILE *pf,const fpos_t *p)
2553 {
2554     return fsetpos(pf, p);
2555 }
2556
2557 DllExport void
2558 win32_rewind(FILE *pf)
2559 {
2560     rewind(pf);
2561     return;
2562 }
2563
2564 DllExport FILE*
2565 win32_tmpfile(void)
2566 {
2567     dTHX;
2568     char prefix[MAX_PATH+1];
2569     char filename[MAX_PATH+1];
2570     DWORD len = GetTempPath(MAX_PATH, prefix);
2571     if (len && len < MAX_PATH) {
2572         if (GetTempFileName(prefix, "plx", 0, filename)) {
2573             HANDLE fh = CreateFile(filename,
2574                                    DELETE | GENERIC_READ | GENERIC_WRITE,
2575                                    0,
2576                                    NULL,
2577                                    CREATE_ALWAYS,
2578                                    FILE_ATTRIBUTE_NORMAL
2579                                    | FILE_FLAG_DELETE_ON_CLOSE,
2580                                    NULL);
2581             if (fh != INVALID_HANDLE_VALUE) {
2582                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2583                 if (fd >= 0) {
2584 #if defined(__BORLANDC__)
2585                     setmode(fd,O_BINARY);
2586 #endif
2587                     DEBUG_p(PerlIO_printf(Perl_debug_log,
2588                                           "Created tmpfile=%s\n",filename));
2589                     return fdopen(fd, "w+b");
2590                 }
2591             }
2592         }
2593     }
2594     return NULL;
2595 }
2596
2597 DllExport void
2598 win32_abort(void)
2599 {
2600     abort();
2601     return;
2602 }
2603
2604 DllExport int
2605 win32_fstat(int fd, Stat_t *sbufptr)
2606 {
2607 #ifdef __BORLANDC__
2608     /* A file designated by filehandle is not shown as accessible
2609      * for write operations, probably because it is opened for reading.
2610      * --Vadim Konovalov
2611      */
2612     int rc = fstat(fd,sbufptr);
2613     BY_HANDLE_FILE_INFORMATION bhfi;
2614     if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2615         sbufptr->st_mode &= 0xFE00;
2616         if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2617             sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2618         else
2619             sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2620               + ((S_IREAD|S_IWRITE) >> 6));
2621     }
2622     return rc;
2623 #else
2624     return my_fstat(fd,sbufptr);
2625 #endif
2626 }
2627
2628 DllExport int
2629 win32_pipe(int *pfd, unsigned int size, int mode)
2630 {
2631     return _pipe(pfd, size, mode);
2632 }
2633
2634 DllExport PerlIO*
2635 win32_popenlist(const char *mode, IV narg, SV **args)
2636 {
2637  dTHX;
2638  Perl_croak(aTHX_ "List form of pipe open not implemented");
2639  return NULL;
2640 }
2641
2642 /*
2643  * a popen() clone that respects PERL5SHELL
2644  *
2645  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2646  */
2647
2648 DllExport PerlIO*
2649 win32_popen(const char *command, const char *mode)
2650 {
2651 #ifdef USE_RTL_POPEN
2652     return _popen(command, mode);
2653 #else
2654     dTHX;
2655     int p[2];
2656     int parent, child;
2657     int stdfd, oldfd;
2658     int ourmode;
2659     int childpid;
2660
2661     /* establish which ends read and write */
2662     if (strchr(mode,'w')) {
2663         stdfd = 0;              /* stdin */
2664         parent = 1;
2665         child = 0;
2666     }
2667     else if (strchr(mode,'r')) {
2668         stdfd = 1;              /* stdout */
2669         parent = 0;
2670         child = 1;
2671     }
2672     else
2673         return NULL;
2674
2675     /* set the correct mode */
2676     if (strchr(mode,'b'))
2677         ourmode = O_BINARY;
2678     else if (strchr(mode,'t'))
2679         ourmode = O_TEXT;
2680     else
2681         ourmode = _fmode & (O_TEXT | O_BINARY);
2682
2683     /* the child doesn't inherit handles */
2684     ourmode |= O_NOINHERIT;
2685
2686     if (win32_pipe( p, 512, ourmode) == -1)
2687         return NULL;
2688
2689     /* save current stdfd */
2690     if ((oldfd = win32_dup(stdfd)) == -1)
2691         goto cleanup;
2692
2693     /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2694     /* stdfd will be inherited by the child */
2695     if (win32_dup2(p[child], stdfd) == -1)
2696         goto cleanup;
2697
2698     /* close the child end in parent */
2699     win32_close(p[child]);
2700
2701     /* start the child */
2702     {
2703         dTHX;
2704         if ((childpid = do_spawn_nowait((char*)command)) == -1)
2705             goto cleanup;
2706
2707         /* revert stdfd to whatever it was before */
2708         if (win32_dup2(oldfd, stdfd) == -1)
2709             goto cleanup;
2710
2711         /* close saved handle */
2712         win32_close(oldfd);
2713
2714         LOCK_FDPID_MUTEX;
2715         sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2716         UNLOCK_FDPID_MUTEX;
2717
2718         /* set process id so that it can be returned by perl's open() */
2719         PL_forkprocess = childpid;
2720     }
2721
2722     /* we have an fd, return a file stream */
2723     return (PerlIO_fdopen(p[parent], (char *)mode));
2724
2725 cleanup:
2726     /* we don't need to check for errors here */
2727     win32_close(p[0]);
2728     win32_close(p[1]);
2729     if (oldfd != -1) {
2730         win32_dup2(oldfd, stdfd);
2731         win32_close(oldfd);
2732     }
2733     return (NULL);
2734
2735 #endif /* USE_RTL_POPEN */
2736 }
2737
2738 /*
2739  * pclose() clone
2740  */
2741
2742 DllExport int
2743 win32_pclose(PerlIO *pf)
2744 {
2745 #ifdef USE_RTL_POPEN
2746     return _pclose(pf);
2747 #else
2748     dTHX;
2749     int childpid, status;
2750     SV *sv;
2751
2752     LOCK_FDPID_MUTEX;
2753     sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2754
2755     if (SvIOK(sv))
2756         childpid = SvIVX(sv);
2757     else
2758         childpid = 0;
2759
2760     if (!childpid) {
2761         errno = EBADF;
2762         return -1;
2763     }
2764
2765 #ifdef USE_PERLIO
2766     PerlIO_close(pf);
2767 #else
2768     fclose(pf);
2769 #endif
2770     SvIVX(sv) = 0;
2771     UNLOCK_FDPID_MUTEX;
2772
2773     if (win32_waitpid(childpid, &status, 0) == -1)
2774         return -1;
2775
2776     return status;
2777
2778 #endif /* USE_RTL_POPEN */
2779 }
2780
2781 static BOOL WINAPI
2782 Nt4CreateHardLinkW(
2783     LPCWSTR lpFileName,
2784     LPCWSTR lpExistingFileName,
2785     LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2786 {
2787     HANDLE handle;
2788     WCHAR wFullName[MAX_PATH+1];
2789     LPVOID lpContext = NULL;
2790     WIN32_STREAM_ID StreamId;
2791     DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2792     DWORD dwWritten;
2793     DWORD dwLen;
2794     BOOL bSuccess;
2795
2796     BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2797                                      BOOL, BOOL, LPVOID*) =
2798         (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2799                             BOOL, BOOL, LPVOID*))
2800         GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2801     if (pfnBackupWrite == NULL)
2802         return 0;
2803
2804     dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2805     if (dwLen == 0)
2806         return 0;
2807     dwLen = (dwLen+1)*sizeof(WCHAR);
2808
2809     handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2810                          FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2811                          NULL, OPEN_EXISTING, 0, NULL);
2812     if (handle == INVALID_HANDLE_VALUE)
2813         return 0;
2814
2815     StreamId.dwStreamId = BACKUP_LINK;
2816     StreamId.dwStreamAttributes = 0;
2817     StreamId.dwStreamNameSize = 0;
2818 #if defined(__BORLANDC__) \
2819  ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2820     StreamId.Size.u.HighPart = 0;
2821     StreamId.Size.u.LowPart = dwLen;
2822 #else
2823     StreamId.Size.HighPart = 0;
2824     StreamId.Size.LowPart = dwLen;
2825 #endif
2826
2827     bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2828                               FALSE, FALSE, &lpContext);
2829     if (bSuccess) {
2830         bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2831                                   FALSE, FALSE, &lpContext);
2832         pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2833     }
2834
2835     CloseHandle(handle);
2836     return bSuccess;
2837 }
2838
2839 DllExport int
2840 win32_link(const char *oldname, const char *newname)
2841 {
2842     dTHX;
2843     BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2844     WCHAR wOldName[MAX_PATH+1];
2845     WCHAR wNewName[MAX_PATH+1];
2846
2847     if (IsWin95())
2848         Perl_croak(aTHX_ PL_no_func, "link");
2849
2850     pfnCreateHardLinkW =
2851         (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2852         GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2853     if (pfnCreateHardLinkW == NULL)
2854         pfnCreateHardLinkW = Nt4CreateHardLinkW;
2855
2856     if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2857         (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
2858         (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2859         pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
2860     {
2861         return 0;
2862     }
2863     errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2864     return -1;
2865 }
2866
2867 DllExport int
2868 win32_rename(const char *oname, const char *newname)
2869 {
2870     WCHAR wOldName[MAX_PATH+1];
2871     WCHAR wNewName[MAX_PATH+1];
2872     char szOldName[MAX_PATH+1];
2873     char szNewName[MAX_PATH+1];
2874     BOOL bResult;
2875     dTHX;
2876
2877     /* XXX despite what the documentation says about MoveFileEx(),
2878      * it doesn't work under Windows95!
2879      */
2880     if (IsWinNT()) {
2881         DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
2882         if (USING_WIDE()) {
2883             A2WHELPER(oname, wOldName, sizeof(wOldName));
2884             A2WHELPER(newname, wNewName, sizeof(wNewName));
2885             if (wcsicmp(wNewName, wOldName))
2886                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2887             wcscpy(wOldName, PerlDir_mapW(wOldName));
2888             bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
2889         }
2890         else {
2891             if (stricmp(newname, oname))
2892                 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2893             strcpy(szOldName, PerlDir_mapA(oname));
2894             bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
2895         }
2896         if (!bResult) {
2897             DWORD err = GetLastError();
2898             switch (err) {
2899             case ERROR_BAD_NET_NAME:
2900             case ERROR_BAD_NETPATH:
2901             case ERROR_BAD_PATHNAME:
2902             case ERROR_FILE_NOT_FOUND:
2903             case ERROR_FILENAME_EXCED_RANGE:
2904             case ERROR_INVALID_DRIVE:
2905             case ERROR_NO_MORE_FILES:
2906             case ERROR_PATH_NOT_FOUND:
2907                 errno = ENOENT;
2908                 break;
2909             default:
2910                 errno = EACCES;
2911                 break;
2912             }
2913             return -1;
2914         }
2915         return 0;
2916     }
2917     else {
2918         int retval = 0;
2919         char szTmpName[MAX_PATH+1];
2920         char dname[MAX_PATH+1];
2921         char *endname = Nullch;
2922         STRLEN tmplen = 0;
2923         DWORD from_attr, to_attr;
2924
2925         strcpy(szOldName, PerlDir_mapA(oname));
2926         strcpy(szNewName, PerlDir_mapA(newname));
2927
2928         /* if oname doesn't exist, do nothing */
2929         from_attr = GetFileAttributes(szOldName);
2930         if (from_attr == 0xFFFFFFFF) {
2931             errno = ENOENT;
2932             return -1;
2933         }
2934
2935         /* if newname exists, rename it to a temporary name so that we
2936          * don't delete it in case oname happens to be the same file
2937          * (but perhaps accessed via a different path)
2938          */
2939         to_attr = GetFileAttributes(szNewName);
2940         if (to_attr != 0xFFFFFFFF) {
2941             /* if newname is a directory, we fail
2942              * XXX could overcome this with yet more convoluted logic */
2943             if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2944                 errno = EACCES;
2945                 return -1;
2946             }
2947             tmplen = strlen(szNewName);
2948             strcpy(szTmpName,szNewName);
2949             endname = szTmpName+tmplen;
2950             for (; endname > szTmpName ; --endname) {
2951                 if (*endname == '/' || *endname == '\\') {
2952                     *endname = '\0';
2953                     break;
2954                 }
2955             }
2956             if (endname > szTmpName)
2957                 endname = strcpy(dname,szTmpName);
2958             else
2959                 endname = ".";
2960
2961             /* get a temporary filename in same directory
2962              * XXX is this really the best we can do? */
2963             if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
2964                 errno = ENOENT;
2965                 return -1;
2966             }
2967             DeleteFile(szTmpName);
2968
2969             retval = rename(szNewName, szTmpName);
2970             if (retval != 0) {
2971                 errno = EACCES;
2972                 return retval;
2973             }
2974         }
2975
2976         /* rename oname to newname */
2977         retval = rename(szOldName, szNewName);
2978
2979         /* if we created a temporary file before ... */
2980         if (endname != Nullch) {
2981             /* ...and rename succeeded, delete temporary file/directory */
2982             if (retval == 0)
2983                 DeleteFile(szTmpName);
2984             /* else restore it to what it was */
2985             else
2986                 (void)rename(szTmpName, szNewName);
2987         }
2988         return retval;
2989     }
2990 }
2991
2992 DllExport int
2993 win32_setmode(int fd, int mode)
2994 {
2995     return setmode(fd, mode);
2996 }
2997
2998 DllExport Off_t
2999 win32_lseek(int fd, Off_t offset, int origin)
3000 {
3001 #if defined(WIN64) || defined(USE_LARGE_FILES)
3002     return _lseeki64(fd, offset, origin);
3003 #else
3004     return lseek(fd, offset, origin);
3005 #endif
3006 }
3007
3008 DllExport Off_t
3009 win32_tell(int fd)
3010 {
3011 #if defined(WIN64) || defined(USE_LARGE_FILES)
3012     return _telli64(fd);
3013 #else
3014     return tell(fd);
3015 #endif
3016 }
3017
3018 DllExport int
3019 win32_open(const char *path, int flag, ...)
3020 {
3021     dTHX;
3022     va_list ap;
3023     int pmode;
3024     WCHAR wBuffer[MAX_PATH+1];
3025
3026     va_start(ap, flag);
3027     pmode = va_arg(ap, int);
3028     va_end(ap);
3029
3030     if (stricmp(path, "/dev/null")==0)
3031         path = "NUL";
3032
3033     if (USING_WIDE()) {
3034         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3035         return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3036     }
3037     return open(PerlDir_mapA(path), flag, pmode);
3038 }
3039
3040 /* close() that understands socket */
3041 extern int my_close(int);       /* in win32sck.c */
3042
3043 DllExport int
3044 win32_close(int fd)
3045 {
3046     return my_close(fd);
3047 }
3048
3049 DllExport int
3050 win32_eof(int fd)
3051 {
3052     return eof(fd);
3053 }
3054
3055 DllExport int
3056 win32_dup(int fd)
3057 {
3058     return dup(fd);
3059 }
3060
3061 DllExport int
3062 win32_dup2(int fd1,int fd2)
3063 {
3064     return dup2(fd1,fd2);
3065 }
3066
3067 #ifdef PERL_MSVCRT_READFIX
3068
3069 #define LF              10      /* line feed */
3070 #define CR              13      /* carriage return */
3071 #define CTRLZ           26      /* ctrl-z means eof for text */
3072 #define FOPEN           0x01    /* file handle open */
3073 #define FEOFLAG         0x02    /* end of file has been encountered */
3074 #define FCRLF           0x04    /* CR-LF across read buffer (in text mode) */
3075 #define FPIPE           0x08    /* file handle refers to a pipe */
3076 #define FAPPEND         0x20    /* file handle opened O_APPEND */
3077 #define FDEV            0x40    /* file handle refers to device */
3078 #define FTEXT           0x80    /* file handle is in text mode */
3079 #define MAX_DESCRIPTOR_COUNT    (64*32) /* this is the maximun that MSVCRT can handle */
3080
3081 int __cdecl
3082 _fixed_read(int fh, void *buf, unsigned cnt)
3083 {
3084     int bytes_read;                 /* number of bytes read */
3085     char *buffer;                   /* buffer to read to */
3086     int os_read;                    /* bytes read on OS call */
3087     char *p, *q;                    /* pointers into buffer */
3088     char peekchr;                   /* peek-ahead character */
3089     ULONG filepos;                  /* file position after seek */
3090     ULONG dosretval;                /* o.s. return value */
3091
3092     /* validate handle */
3093     if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3094          !(_osfile(fh) & FOPEN))
3095     {
3096         /* out of range -- return error */
3097         errno = EBADF;
3098         _doserrno = 0;  /* not o.s. error */
3099         return -1;
3100     }
3101
3102     /*
3103      * If lockinitflag is FALSE, assume fd is device
3104      * lockinitflag is set to TRUE by open.
3105      */
3106     if (_pioinfo(fh)->lockinitflag)
3107         EnterCriticalSection(&(_pioinfo(fh)->lock));  /* lock file */
3108
3109     bytes_read = 0;                 /* nothing read yet */
3110     buffer = (char*)buf;
3111
3112     if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3113         /* nothing to read or at EOF, so return 0 read */
3114         goto functionexit;
3115     }
3116
3117     if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3118         /* a pipe/device and pipe lookahead non-empty: read the lookahead
3119          * char */
3120         *buffer++ = _pipech(fh);
3121         ++bytes_read;
3122         --cnt;
3123         _pipech(fh) = LF;           /* mark as empty */
3124     }
3125
3126     /* read the data */
3127
3128     if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3129     {
3130         /* ReadFile has reported an error. recognize two special cases.
3131          *
3132          *      1. map ERROR_ACCESS_DENIED to EBADF
3133          *
3134          *      2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3135          *         means the handle is a read-handle on a pipe for which
3136          *         all write-handles have been closed and all data has been
3137          *         read. */
3138
3139         if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3140             /* wrong read/write mode should return EBADF, not EACCES */
3141             errno = EBADF;
3142             _doserrno = dosretval;
3143             bytes_read = -1;
3144             goto functionexit;
3145         }
3146         else if (dosretval == ERROR_BROKEN_PIPE) {
3147             bytes_read = 0;
3148             goto functionexit;
3149         }
3150         else {
3151             bytes_read = -1;
3152             goto functionexit;
3153         }
3154     }
3155
3156     bytes_read += os_read;          /* update bytes read */
3157
3158     if (_osfile(fh) & FTEXT) {
3159         /* now must translate CR-LFs to LFs in the buffer */
3160
3161         /* set CRLF flag to indicate LF at beginning of buffer */
3162         /* if ((os_read != 0) && (*(char *)buf == LF))   */
3163         /*    _osfile(fh) |= FCRLF;                      */
3164         /* else                                          */
3165         /*    _osfile(fh) &= ~FCRLF;                     */
3166
3167         _osfile(fh) &= ~FCRLF;
3168
3169         /* convert chars in the buffer: p is src, q is dest */
3170         p = q = (char*)buf;
3171         while (p < (char *)buf + bytes_read) {
3172             if (*p == CTRLZ) {
3173                 /* if fh is not a device, set ctrl-z flag */
3174                 if (!(_osfile(fh) & FDEV))
3175                     _osfile(fh) |= FEOFLAG;
3176                 break;              /* stop translating */
3177             }
3178             else if (*p != CR)
3179                 *q++ = *p++;
3180             else {
3181                 /* *p is CR, so must check next char for LF */
3182                 if (p < (char *)buf + bytes_read - 1) {
3183                     if (*(p+1) == LF) {
3184                         p += 2;
3185                         *q++ = LF;  /* convert CR-LF to LF */
3186                     }
3187                     else
3188                         *q++ = *p++;    /* store char normally */
3189                 }
3190                 else {
3191                     /* This is the hard part.  We found a CR at end of
3192                        buffer.  We must peek ahead to see if next char
3193                        is an LF. */
3194                     ++p;
3195
3196                     dosretval = 0;
3197                     if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3198                                     (LPDWORD)&os_read, NULL))
3199                         dosretval = GetLastError();
3200
3201                     if (dosretval != 0 || os_read == 0) {
3202                         /* couldn't read ahead, store CR */
3203                         *q++ = CR;
3204                     }
3205                     else {
3206                         /* peekchr now has the extra character -- we now
3207                            have several possibilities:
3208                            1. disk file and char is not LF; just seek back
3209                               and copy CR
3210                            2. disk file and char is LF; store LF, don't seek back
3211                            3. pipe/device and char is LF; store LF.
3212                            4. pipe/device and char isn't LF, store CR and
3213                               put char in pipe lookahead buffer. */
3214                         if (_osfile(fh) & (FDEV|FPIPE)) {
3215                             /* non-seekable device */
3216                             if (peekchr == LF)
3217                                 *q++ = LF;
3218                             else {
3219                                 *q++ = CR;
3220                                 _pipech(fh) = peekchr;
3221                             }
3222                         }
3223                         else {
3224                             /* disk file */
3225                             if (peekchr == LF) {
3226                                 /* nothing read yet; must make some
3227                                    progress */
3228                                 *q++ = LF;
3229                                 /* turn on this flag for tell routine */
3230                                 _osfile(fh) |= FCRLF;
3231                             }
3232                             else {
3233                                 HANDLE osHandle;        /* o.s. handle value */
3234                                 /* seek back */
3235                                 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3236                                 {
3237                                     if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3238                                         dosretval = GetLastError();
3239                                 }
3240                                 if (peekchr != LF)
3241                                     *q++ = CR;
3242                             }
3243                         }
3244                     }
3245                 }
3246             }
3247         }
3248
3249         /* we now change bytes_read to reflect the true number of chars
3250            in the buffer */
3251         bytes_read = q - (char *)buf;
3252     }
3253
3254 functionexit:
3255     if (_pioinfo(fh)->lockinitflag)
3256         LeaveCriticalSection(&(_pioinfo(fh)->lock));    /* unlock file */
3257
3258     return bytes_read;
3259 }
3260
3261 #endif  /* PERL_MSVCRT_READFIX */
3262
3263 DllExport int
3264 win32_read(int fd, void *buf, unsigned int cnt)
3265 {
3266 #ifdef PERL_MSVCRT_READFIX
3267     return _fixed_read(fd, buf, cnt);
3268 #else
3269     return read(fd, buf, cnt);
3270 #endif
3271 }
3272
3273 DllExport int
3274 win32_write(int fd, const void *buf, unsigned int cnt)
3275 {
3276     return write(fd, buf, cnt);
3277 }
3278
3279 DllExport int
3280 win32_mkdir(const char *dir, int mode)
3281 {
3282     dTHX;
3283     if (USING_WIDE()) {
3284         WCHAR wBuffer[MAX_PATH+1];
3285         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3286         return _wmkdir(PerlDir_mapW(wBuffer));
3287     }
3288     return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3289 }
3290
3291 DllExport int
3292 win32_rmdir(const char *dir)
3293 {
3294     dTHX;
3295     if (USING_WIDE()) {
3296         WCHAR wBuffer[MAX_PATH+1];
3297         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3298         return _wrmdir(PerlDir_mapW(wBuffer));
3299     }
3300     return rmdir(PerlDir_mapA(dir));
3301 }
3302
3303 DllExport int
3304 win32_chdir(const char *dir)
3305 {
3306     dTHX;
3307     if (!dir) {
3308         errno = ENOENT;
3309         return -1;
3310     }
3311     if (USING_WIDE()) {
3312         WCHAR wBuffer[MAX_PATH+1];
3313         A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3314         return _wchdir(wBuffer);
3315     }
3316     return chdir(dir);
3317 }
3318
3319 DllExport  int
3320 win32_access(const char *path, int mode)
3321 {
3322     dTHX;
3323     if (USING_WIDE()) {
3324         WCHAR wBuffer[MAX_PATH+1];
3325         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3326         return _waccess(PerlDir_mapW(wBuffer), mode);
3327     }
3328     return access(PerlDir_mapA(path), mode);
3329 }
3330
3331 DllExport  int
3332 win32_chmod(const char *path, int mode)
3333 {
3334     dTHX;
3335     if (USING_WIDE()) {
3336         WCHAR wBuffer[MAX_PATH+1];
3337         A2WHELPER(path, wBuffer, sizeof(wBuffer));
3338         return _wchmod(PerlDir_mapW(wBuffer), mode);
3339     }
3340     return chmod(PerlDir_mapA(path), mode);
3341 }
3342
3343
3344 static char *
3345 create_command_line(char *cname, STRLEN clen, const char * const *args)
3346 {
3347     dTHX;
3348     int index, argc;
3349     char *cmd, *ptr;
3350     const char *arg;
3351     STRLEN len = 0;
3352     bool bat_file = FALSE;
3353     bool cmd_shell = FALSE;
3354     bool dumb_shell = FALSE;
3355     bool extra_quotes = FALSE;
3356     bool quote_next = FALSE;
3357
3358     if (!cname)
3359         cname = (char*)args[0];
3360
3361     /* The NT cmd.exe shell has the following peculiarity that needs to be
3362      * worked around.  It strips a leading and trailing dquote when any
3363      * of the following is true:
3364      *    1. the /S switch was used
3365      *    2. there are more than two dquotes
3366      *    3. there is a special character from this set: &<>()@^|
3367      *    4. no whitespace characters within the two dquotes
3368      *    5. string between two dquotes isn't an executable file
3369      * To work around this, we always add a leading and trailing dquote
3370      * to the string, if the first argument is either "cmd.exe" or "cmd",
3371      * and there were at least two or more arguments passed to cmd.exe
3372      * (not including switches).
3373      * XXX the above rules (from "cmd /?") don't seem to be applied
3374      * always, making for the convolutions below :-(
3375      */
3376     if (cname) {
3377         if (!clen)
3378             clen = strlen(cname);
3379
3380         if (clen > 4
3381             && (stricmp(&cname[clen-4], ".bat") == 0
3382                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3383         {
3384             bat_file = TRUE;
3385             len += 3;
3386         }
3387         else {
3388             char *exe = strrchr(cname, '/');
3389             char *exe2 = strrchr(cname, '\\');
3390             if (exe2 > exe)
3391                 exe = exe2;
3392             if (exe)
3393                 ++exe;
3394             else
3395                 exe = cname;
3396             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3397                 cmd_shell = TRUE;
3398                 len += 3;
3399             }
3400             else if (stricmp(exe, "command.com") == 0
3401                      || stricmp(exe, "command") == 0)
3402             {
3403                 dumb_shell = TRUE;
3404             }
3405         }
3406     }
3407
3408     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3409     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3410         STRLEN curlen = strlen(arg);
3411         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3412             len += 2;   /* assume quoting needed (worst case) */
3413         len += curlen + 1;
3414         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3415     }
3416     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3417
3418     argc = index;
3419     New(1310, cmd, len, char);
3420     ptr = cmd;
3421
3422     if (bat_file) {
3423         *ptr++ = '"';
3424         extra_quotes = TRUE;
3425     }
3426
3427     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3428         bool do_quote = 0;
3429         STRLEN curlen = strlen(arg);
3430
3431         /* we want to protect empty arguments and ones with spaces with
3432          * dquotes, but only if they aren't already there */
3433         if (!dumb_shell) {
3434             if (!curlen) {
3435                 do_quote = 1;
3436             }
3437             else if (quote_next) {
3438                 /* see if it really is multiple arguments pretending to
3439                  * be one and force a set of quotes around it */
3440                 if (*find_next_space(arg))
3441                     do_quote = 1;
3442             }
3443             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3444                 STRLEN i = 0;
3445                 while (i < curlen) {
3446                     if (isSPACE(arg[i])) {
3447                         do_quote = 1;
3448                     }
3449                     else if (arg[i] == '"') {
3450                         do_quote = 0;
3451                         break;
3452                     }
3453                     i++;
3454                 }
3455             }
3456         }
3457
3458         if (do_quote)
3459             *ptr++ = '"';
3460
3461         strcpy(ptr, arg);
3462         ptr += curlen;
3463
3464         if (do_quote)
3465             *ptr++ = '"';
3466
3467         if (args[index+1])
3468             *ptr++ = ' ';
3469
3470         if (!extra_quotes
3471             && cmd_shell
3472             && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
3473         {
3474             /* is there a next argument? */
3475             if (args[index+1]) {
3476                 /* are there two or more next arguments? */
3477                 if (args[index+2]) {
3478                     *ptr++ = '"';
3479                     extra_quotes = TRUE;
3480                 }
3481                 else {
3482                     /* single argument, force quoting if it has spaces */
3483                     quote_next = TRUE;
3484                 }
3485             }
3486         }
3487     }
3488
3489     if (extra_quotes)
3490         *ptr++ = '"';
3491
3492     *ptr = '\0';
3493
3494     return cmd;
3495 }
3496
3497 static char *
3498 qualified_path(const char *cmd)
3499 {
3500     dTHX;
3501     char *pathstr;
3502     char *fullcmd, *curfullcmd;
3503     STRLEN cmdlen = 0;
3504     int has_slash = 0;
3505
3506     if (!cmd)
3507         return Nullch;
3508     fullcmd = (char*)cmd;
3509     while (*fullcmd) {
3510         if (*fullcmd == '/' || *fullcmd == '\\')
3511             has_slash++;
3512         fullcmd++;
3513         cmdlen++;
3514     }
3515
3516     /* look in PATH */
3517     pathstr = PerlEnv_getenv("PATH");
3518     New(0, fullcmd, MAX_PATH+1, char);
3519     curfullcmd = fullcmd;
3520
3521     while (1) {
3522         DWORD res;
3523
3524         /* start by appending the name to the current prefix */
3525         strcpy(curfullcmd, cmd);
3526         curfullcmd += cmdlen;
3527
3528         /* if it doesn't end with '.', or has no extension, try adding
3529          * a trailing .exe first */
3530         if (cmd[cmdlen-1] != '.'
3531             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3532         {
3533             strcpy(curfullcmd, ".exe");
3534             res = GetFileAttributes(fullcmd);
3535             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3536                 return fullcmd;
3537             *curfullcmd = '\0';
3538         }
3539
3540         /* that failed, try the bare name */
3541         res = GetFileAttributes(fullcmd);
3542         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3543             return fullcmd;
3544
3545         /* quit if no other path exists, or if cmd already has path */
3546         if (!pathstr || !*pathstr || has_slash)
3547             break;
3548
3549         /* skip leading semis */
3550         while (*pathstr == ';')
3551             pathstr++;
3552
3553         /* build a new prefix from scratch */
3554         curfullcmd = fullcmd;
3555         while (*pathstr && *pathstr != ';') {
3556             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3557                 pathstr++;              /* skip initial '"' */
3558                 while (*pathstr && *pathstr != '"') {
3559                     if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3560                         *curfullcmd++ = *pathstr;
3561                     pathstr++;
3562                 }
3563                 if (*pathstr)
3564                     pathstr++;          /* skip trailing '"' */
3565             }
3566             else {
3567                 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3568                     *curfullcmd++ = *pathstr;
3569                 pathstr++;
3570             }
3571         }
3572         if (*pathstr)
3573             pathstr++;                  /* skip trailing semi */
3574         if (curfullcmd > fullcmd        /* append a dir separator */
3575             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3576         {
3577             *curfullcmd++ = '\\';
3578         }
3579     }
3580
3581     Safefree(fullcmd);
3582     return Nullch;
3583 }
3584
3585 /* The following are just place holders.
3586  * Some hosts may provide and environment that the OS is
3587  * not tracking, therefore, these host must provide that
3588  * environment and the current directory to CreateProcess
3589  */
3590
3591 DllExport void*
3592 win32_get_childenv(void)
3593 {
3594     return NULL;
3595 }
3596
3597 DllExport void
3598 win32_free_childenv(void* d)
3599 {
3600 }
3601
3602 DllExport void
3603 win32_clearenv(void)
3604 {
3605     char *envv = GetEnvironmentStrings();
3606     char *cur = envv;
3607     STRLEN len;
3608     while (*cur) {
3609         char *end = strchr(cur,'=');
3610         if (end && end != cur) {
3611             *end = '\0';
3612             SetEnvironmentVariable(cur, NULL);
3613             *end = '=';
3614             cur = end + strlen(end+1)+2;
3615         }
3616         else if ((len = strlen(cur)))
3617             cur += len+1;
3618     }
3619     FreeEnvironmentStrings(envv);
3620 }
3621
3622 DllExport char*
3623 win32_get_childdir(void)
3624 {
3625     dTHX;
3626     char* ptr;
3627     char szfilename[(MAX_PATH+1)*2];
3628     if (USING_WIDE()) {
3629         WCHAR wfilename[MAX_PATH+1];
3630         GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3631         W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3632     }
3633     else {
3634         GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3635     }
3636
3637     New(0, ptr, strlen(szfilename)+1, char);
3638     strcpy(ptr, szfilename);
3639     return ptr;
3640 }
3641
3642 DllExport void
3643 win32_free_childdir(char* d)
3644 {
3645     dTHX;
3646     Safefree(d);
3647 }
3648
3649
3650 /* XXX this needs to be made more compatible with the spawnvp()
3651  * provided by the various RTLs.  In particular, searching for
3652  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3653  * This doesn't significantly affect perl itself, because we
3654  * always invoke things using PERL5SHELL if a direct attempt to
3655  * spawn the executable fails.
3656  *
3657  * XXX splitting and rejoining the commandline between do_aspawn()
3658  * and win32_spawnvp() could also be avoided.
3659  */
3660
3661 DllExport int
3662 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3663 {
3664 #ifdef USE_RTL_SPAWNVP
3665     return spawnvp(mode, cmdname, (char * const *)argv);
3666 #else
3667     dTHX;
3668     int ret;
3669     void* env;
3670     char* dir;
3671     child_IO_table tbl;
3672     STARTUPINFO StartupInfo;
3673     PROCESS_INFORMATION ProcessInformation;
3674     DWORD create = 0;
3675     char *cmd;
3676     char *fullcmd = Nullch;
3677     char *cname = (char *)cmdname;
3678     STRLEN clen = 0;
3679
3680     if (cname) {
3681         clen = strlen(cname);
3682         /* if command name contains dquotes, must remove them */
3683         if (strchr(cname, '"')) {
3684             cmd = cname;
3685             New(0,cname,clen+1,char);
3686             clen = 0;
3687             while (*cmd) {
3688                 if (*cmd != '"') {
3689                     cname[clen] = *cmd;
3690                     ++clen;
3691                 }
3692                 ++cmd;
3693             }
3694             cname[clen] = '\0';
3695         }
3696     }
3697
3698     cmd = create_command_line(cname, clen, argv);
3699
3700     env = PerlEnv_get_childenv();
3701     dir = PerlEnv_get_childdir();
3702
3703     switch(mode) {
3704     case P_NOWAIT:      /* asynch + remember result */
3705         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3706             errno = EAGAIN;
3707             ret = -1;
3708             goto RETVAL;
3709         }
3710         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3711          * in win32_kill()
3712          */
3713         create |= CREATE_NEW_PROCESS_GROUP;
3714         /* FALL THROUGH */
3715
3716     case P_WAIT:        /* synchronous execution */
3717         break;
3718     default:            /* invalid mode */
3719         errno = EINVAL;
3720         ret = -1;
3721         goto RETVAL;
3722     }
3723     memset(&StartupInfo,0,sizeof(StartupInfo));
3724     StartupInfo.cb = sizeof(StartupInfo);
3725     memset(&tbl,0,sizeof(tbl));
3726     PerlEnv_get_child_IO(&tbl);
3727     StartupInfo.dwFlags         = tbl.dwFlags;
3728     StartupInfo.dwX             = tbl.dwX;
3729     StartupInfo.dwY             = tbl.dwY;
3730     StartupInfo.dwXSize         = tbl.dwXSize;
3731     StartupInfo.dwYSize         = tbl.dwYSize;
3732     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3733     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3734     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3735     StartupInfo.wShowWindow     = tbl.wShowWindow;
3736     StartupInfo.hStdInput       = tbl.childStdIn;
3737     StartupInfo.hStdOutput      = tbl.childStdOut;
3738     StartupInfo.hStdError       = tbl.childStdErr;
3739     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3740         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3741         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3742     {
3743         create |= CREATE_NEW_CONSOLE;
3744     }
3745     else {
3746         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3747     }
3748     if (w32_use_showwindow) {
3749         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3750         StartupInfo.wShowWindow = w32_showwindow;
3751     }
3752
3753     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3754                           cname,cmd));
3755 RETRY:
3756     if (!CreateProcess(cname,           /* search PATH to find executable */
3757                        cmd,             /* executable, and its arguments */
3758                        NULL,            /* process attributes */
3759                        NULL,            /* thread attributes */
3760                        TRUE,            /* inherit handles */
3761                        create,          /* creation flags */
3762                        (LPVOID)env,     /* inherit environment */
3763                        dir,             /* inherit cwd */
3764                        &StartupInfo,
3765                        &ProcessInformation))
3766     {
3767         /* initial NULL argument to CreateProcess() does a PATH
3768          * search, but it always first looks in the directory
3769          * where the current process was started, which behavior
3770          * is undesirable for backward compatibility.  So we
3771          * jump through our own hoops by picking out the path
3772          * we really want it to use. */
3773         if (!fullcmd) {
3774             fullcmd = qualified_path(cname);
3775             if (fullcmd) {
3776                 if (cname != cmdname)
3777                     Safefree(cname);
3778                 cname = fullcmd;
3779                 DEBUG_p(PerlIO_printf(Perl_debug_log,
3780                                       "Retrying [%s] with same args\n",
3781                                       cname));
3782                 goto RETRY;
3783             }
3784         }
3785         errno = ENOENT;
3786         ret = -1;
3787         goto RETVAL;
3788     }
3789
3790     if (mode == P_NOWAIT) {
3791         /* asynchronous spawn -- store handle, return PID */
3792         ret = (int)ProcessInformation.dwProcessId;
3793         if (IsWin95() && ret < 0)
3794             ret = -ret;
3795
3796         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3797         w32_child_pids[w32_num_children] = (DWORD)ret;
3798         ++w32_num_children;
3799     }
3800     else  {
3801         DWORD status;
3802         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
3803         /* FIXME: if msgwait returned due to message perhaps forward the
3804            "signal" to the process
3805          */
3806         GetExitCodeProcess(ProcessInformation.hProcess, &status);
3807         ret = (int)status;
3808         CloseHandle(ProcessInformation.hProcess);
3809     }
3810
3811     CloseHandle(ProcessInformation.hThread);
3812
3813 RETVAL:
3814     PerlEnv_free_childenv(env);
3815     PerlEnv_free_childdir(dir);
3816     Safefree(cmd);
3817     if (cname != cmdname)
3818         Safefree(cname);
3819     return ret;
3820 #endif
3821 }
3822
3823 DllExport int
3824 win32_execv(const char *cmdname, const char *const *argv)
3825 {
3826 #ifdef USE_ITHREADS
3827     dTHX;
3828     /* if this is a pseudo-forked child, we just want to spawn
3829      * the new program, and return */
3830     if (w32_pseudo_id)
3831         return spawnv(P_WAIT, cmdname, (char *const *)argv);
3832 #endif
3833     return execv(cmdname, (char *const *)argv);
3834 }
3835
3836 DllExport int
3837 win32_execvp(const char *cmdname, const char *const *argv)
3838 {
3839 #ifdef USE_ITHREADS
3840     dTHX;
3841     /* if this is a pseudo-forked child, we just want to spawn
3842      * the new program, and return */
3843     if (w32_pseudo_id) {
3844         int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3845         if (status != -1) {
3846             my_exit(status);
3847             return 0;
3848         }
3849         else
3850             return status;
3851     }
3852 #endif
3853     return execvp(cmdname, (char *const *)argv);
3854 }
3855
3856 DllExport void
3857 win32_perror(const char *str)
3858 {
3859     perror(str);
3860 }
3861
3862 DllExport void
3863 win32_setbuf(FILE *pf, char *buf)
3864 {
3865     setbuf(pf, buf);
3866 }
3867
3868 DllExport int
3869 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3870 {
3871     return setvbuf(pf, buf, type, size);
3872 }
3873
3874 DllExport int
3875 win32_flushall(void)
3876 {
3877     return flushall();
3878 }
3879
3880 DllExport int
3881 win32_fcloseall(void)
3882 {
3883     return fcloseall();
3884 }
3885
3886 DllExport char*
3887 win32_fgets(char *s, int n, FILE *pf)
3888 {
3889     return fgets(s, n, pf);
3890 }
3891
3892 DllExport char*
3893 win32_gets(char *s)
3894 {
3895     return gets(s);
3896 }
3897
3898 DllExport int
3899 win32_fgetc(FILE *pf)
3900 {
3901     return fgetc(pf);
3902 }
3903
3904 DllExport int
3905 win32_putc(int c, FILE *pf)
3906 {
3907     return putc(c,pf);
3908 }
3909
3910 DllExport int
3911 win32_puts(const char *s)
3912 {
3913     return puts(s);
3914 }
3915
3916 DllExport int
3917 win32_getchar(void)
3918 {
3919     return getchar();
3920 }
3921
3922 DllExport int
3923 win32_putchar(int c)
3924 {
3925     return putchar(c);
3926 }
3927
3928 #ifdef MYMALLOC
3929
3930 #ifndef USE_PERL_SBRK
3931
3932 static char *committed = NULL;          /* XXX threadead */
3933 static char *base      = NULL;          /* XXX threadead */
3934 static char *reserved  = NULL;          /* XXX threadead */
3935 static char *brk       = NULL;          /* XXX threadead */
3936 static DWORD pagesize  = 0;             /* XXX threadead */
3937 static DWORD allocsize = 0;             /* XXX threadead */
3938
3939 void *
3940 sbrk(ptrdiff_t need)
3941 {
3942  void *result;
3943  if (!pagesize)
3944   {SYSTEM_INFO info;
3945    GetSystemInfo(&info);
3946    /* Pretend page size is larger so we don't perpetually
3947     * call the OS to commit just one page ...
3948     */
3949    pagesize = info.dwPageSize << 3;
3950    allocsize = info.dwAllocationGranularity;
3951   }
3952  /* This scheme fails eventually if request for contiguous
3953   * block is denied so reserve big blocks - this is only
3954   * address space not memory ...
3955   */
3956  if (brk+need >= reserved)
3957   {
3958    DWORD size = 64*1024*1024;
3959    char *addr;
3960    if (committed && reserved && committed < reserved)
3961     {
3962      /* Commit last of previous chunk cannot span allocations */
3963      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
3964      if (addr)
3965       committed = reserved;
3966     }
3967    /* Reserve some (more) space
3968     * Note this is a little sneaky, 1st call passes NULL as reserved
3969     * so lets system choose where we start, subsequent calls pass
3970     * the old end address so ask for a contiguous block
3971     */
3972    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
3973    if (addr)
3974     {
3975      reserved = addr+size;
3976      if (!base)
3977       base = addr;
3978      if (!committed)
3979       committed = base;
3980      if (!brk)
3981       brk = committed;
3982     }
3983    else
3984     {
3985      return (void *) -1;
3986     }
3987   }
3988  result = brk;
3989  brk += need;
3990  if (brk > committed)
3991   {
3992    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
3993    char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
3994    if (addr)
3995     {
3996      committed += size;
3997     }
3998    else
3999     return (void *) -1;
4000   }
4001  return result;
4002 }
4003
4004 #endif
4005 #endif
4006
4007 DllExport void*
4008 win32_malloc(size_t size)
4009 {
4010     return malloc(size);
4011 }
4012
4013 DllExport void*
4014 win32_calloc(size_t numitems, size_t size)
4015 {
4016     return calloc(numitems,size);
4017 }
4018
4019 DllExport void*
4020 win32_realloc(void *block, size_t size)
4021 {
4022     return realloc(block,size);
4023 }
4024
4025 DllExport void
4026 win32_free(void *block)
4027 {
4028     free(block);
4029 }
4030
4031
4032 DllExport int
4033 win32_open_osfhandle(intptr_t handle, int flags)
4034 {
4035 #ifdef USE_FIXED_OSFHANDLE
4036     if (IsWin95())
4037         return my_open_osfhandle(handle, flags);
4038 #endif
4039     return _open_osfhandle(handle, flags);
4040 }
4041
4042 DllExport intptr_t
4043 win32_get_osfhandle(int fd)
4044 {
4045     return (intptr_t)_get_osfhandle(fd);
4046 }
4047
4048 DllExport FILE *
4049 win32_fdupopen(FILE *pf)
4050 {
4051     FILE* pfdup;
4052     fpos_t pos;
4053     char mode[3];
4054     int fileno = win32_dup(win32_fileno(pf));
4055
4056     /* open the file in the same mode */
4057 #ifdef __BORLANDC__
4058     if((pf)->flags & _F_READ) {
4059         mode[0] = 'r';
4060         mode[1] = 0;
4061     }
4062     else if((pf)->flags & _F_WRIT) {
4063         mode[0] = 'a';
4064         mode[1] = 0;
4065     }
4066     else if((pf)->flags & _F_RDWR) {
4067         mode[0] = 'r';
4068         mode[1] = '+';
4069         mode[2] = 0;
4070     }
4071 #else
4072     if((pf)->_flag & _IOREAD) {
4073         mode[0] = 'r';
4074         mode[1] = 0;
4075     }
4076     else if((pf)->_flag & _IOWRT) {
4077         mode[0] = 'a';
4078         mode[1] = 0;
4079     }
4080     else if((pf)->_flag & _IORW) {
4081         mode[0] = 'r';
4082         mode[1] = '+';
4083         mode[2] = 0;
4084     }
4085 #endif
4086
4087     /* it appears that the binmode is attached to the
4088      * file descriptor so binmode files will be handled
4089      * correctly
4090      */
4091     pfdup = win32_fdopen(fileno, mode);
4092
4093     /* move the file pointer to the same position */
4094     if (!fgetpos(pf, &pos)) {
4095         fsetpos(pfdup, &pos);
4096     }
4097     return pfdup;
4098 }
4099
4100 DllExport void*
4101 win32_dynaload(const char* filename)
4102 {
4103     dTHX;
4104     HMODULE hModule;
4105     char buf[MAX_PATH+1];
4106     char *first;
4107
4108     /* LoadLibrary() doesn't recognize forward slashes correctly,
4109      * so turn 'em back. */
4110     first = strchr(filename, '/');
4111     if (first) {
4112         STRLEN len = strlen(filename);
4113         if (len <= MAX_PATH) {
4114             strcpy(buf, filename);
4115             filename = &buf[first - filename];
4116             while (*filename) {
4117                 if (*filename == '/')
4118                     *(char*)filename = '\\';
4119                 ++filename;
4120             }
4121             filename = buf;
4122         }
4123     }
4124     if (USING_WIDE()) {
4125         WCHAR wfilename[MAX_PATH+1];
4126         A2WHELPER(filename, wfilename, sizeof(wfilename));
4127         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4128     }
4129     else {
4130         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4131     }
4132     return hModule;
4133 }
4134
4135 /*
4136  * Extras.
4137  */
4138
4139 static
4140 XS(w32_SetChildShowWindow)
4141 {
4142     dXSARGS;
4143     BOOL use_showwindow = w32_use_showwindow;
4144     /* use "unsigned short" because Perl has redefined "WORD" */
4145     unsigned short showwindow = w32_showwindow;
4146
4147     if (items > 1)
4148         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4149
4150     if (items == 0 || !SvOK(ST(0)))
4151         w32_use_showwindow = FALSE;
4152     else {
4153         w32_use_showwindow = TRUE;
4154         w32_showwindow = (unsigned short)SvIV(ST(0));
4155     }
4156
4157     EXTEND(SP, 1);
4158     if (use_showwindow)
4159         ST(0) = sv_2mortal(newSViv(showwindow));
4160     else
4161         ST(0) = &PL_sv_undef;
4162     XSRETURN(1);
4163 }
4164
4165 static
4166 XS(w32_GetCwd)
4167 {
4168     dXSARGS;
4169     /* Make the host for current directory */
4170     char* ptr = PerlEnv_get_childdir();
4171     /*
4172      * If ptr != Nullch
4173      *   then it worked, set PV valid,
4174      *   else return 'undef'
4175      */
4176     if (ptr) {
4177         SV *sv = sv_newmortal();
4178         sv_setpv(sv, ptr);
4179         PerlEnv_free_childdir(ptr);
4180
4181 #ifndef INCOMPLETE_TAINTS
4182         SvTAINTED_on(sv);
4183 #endif
4184
4185         EXTEND(SP,1);
4186         SvPOK_on(sv);
4187         ST(0) = sv;
4188         XSRETURN(1);
4189     }
4190     XSRETURN_UNDEF;
4191 }
4192
4193 static
4194 XS(w32_SetCwd)
4195 {
4196     dXSARGS;
4197     if (items != 1)
4198         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4199     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4200         XSRETURN_YES;
4201
4202     XSRETURN_NO;
4203 }
4204
4205 static
4206 XS(w32_GetNextAvailDrive)
4207 {
4208     dXSARGS;
4209     char ix = 'C';
4210     char root[] = "_:\\";
4211
4212     EXTEND(SP,1);
4213     while (ix <= 'Z') {
4214         root[0] = ix++;
4215         if (GetDriveType(root) == 1) {
4216             root[2] = '\0';
4217             XSRETURN_PV(root);
4218         }
4219     }
4220     XSRETURN_UNDEF;
4221 }
4222
4223 static
4224 XS(w32_GetLastError)
4225 {
4226     dXSARGS;
4227     EXTEND(SP,1);
4228     XSRETURN_IV(GetLastError());
4229 }
4230
4231 static
4232 XS(w32_SetLastError)
4233 {
4234     dXSARGS;
4235     if (items != 1)
4236         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4237     SetLastError(SvIV(ST(0)));
4238     XSRETURN_EMPTY;
4239 }
4240
4241 static
4242 XS(w32_LoginName)
4243 {
4244     dXSARGS;
4245     char *name = w32_getlogin_buffer;
4246     DWORD size = sizeof(w32_getlogin_buffer);
4247     EXTEND(SP,1);
4248     if (GetUserName(name,&size)) {
4249         /* size includes NULL */
4250         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4251         XSRETURN(1);
4252     }
4253     XSRETURN_UNDEF;
4254 }
4255
4256 static
4257 XS(w32_NodeName)
4258 {
4259     dXSARGS;
4260     char name[MAX_COMPUTERNAME_LENGTH+1];
4261     DWORD size = sizeof(name);
4262     EXTEND(SP,1);
4263     if (GetComputerName(name,&size)) {
4264         /* size does NOT include NULL :-( */
4265         ST(0) = sv_2mortal(newSVpvn(name,size));
4266         XSRETURN(1);
4267     }
4268     XSRETURN_UNDEF;
4269 }
4270
4271
4272 static
4273 XS(w32_DomainName)
4274 {
4275     dXSARGS;
4276     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4277     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4278     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4279                                           void *bufptr);
4280
4281     if (hNetApi32) {
4282         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4283             GetProcAddress(hNetApi32, "NetApiBufferFree");
4284         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4285             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4286     }
4287     EXTEND(SP,1);
4288     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4289         /* this way is more reliable, in case user has a local account. */
4290         char dname[256];
4291         DWORD dnamelen = sizeof(dname);
4292         struct {
4293             DWORD   wki100_platform_id;
4294             LPWSTR  wki100_computername;
4295             LPWSTR  wki100_langroup;
4296             DWORD   wki100_ver_major;
4297             DWORD   wki100_ver_minor;
4298         } *pwi;
4299         /* NERR_Success *is* 0*/
4300         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4301             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4302                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4303                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4304             }
4305             else {
4306                 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4307                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4308             }
4309             pfnNetApiBufferFree(pwi);
4310             FreeLibrary(hNetApi32);
4311             XSRETURN_PV(dname);
4312         }
4313         FreeLibrary(hNetApi32);
4314     }
4315     else {
4316         /* Win95 doesn't have NetWksta*(), so do it the old way */
4317         char name[256];
4318         DWORD size = sizeof(name);
4319         if (hNetApi32)
4320             FreeLibrary(hNetApi32);
4321         if (GetUserName(name,&size)) {
4322             char sid[ONE_K_BUFSIZE];
4323             DWORD sidlen = sizeof(sid);
4324             char dname[256];
4325             DWORD dnamelen = sizeof(dname);
4326             SID_NAME_USE snu;
4327             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4328                                   dname, &dnamelen, &snu)) {
4329                 XSRETURN_PV(dname);             /* all that for this */
4330             }
4331         }
4332     }
4333     XSRETURN_UNDEF;
4334 }
4335
4336 static
4337 XS(w32_FsType)
4338 {
4339     dXSARGS;
4340     char fsname[256];
4341     DWORD flags, filecomplen;
4342     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4343                          &flags, fsname, sizeof(fsname))) {
4344         if (GIMME_V == G_ARRAY) {
4345             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4346             XPUSHs(sv_2mortal(newSViv(flags)));
4347             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4348             PUTBACK;
4349             return;
4350         }
4351         EXTEND(SP,1);
4352         XSRETURN_PV(fsname);
4353     }
4354     XSRETURN_EMPTY;
4355 }
4356
4357 static
4358 XS(w32_GetOSVersion)
4359 {
4360     dXSARGS;
4361     OSVERSIONINFOA osver;
4362
4363     if (USING_WIDE()) {
4364         OSVERSIONINFOW osverw;
4365         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4366         osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4367         if (!GetVersionExW(&osverw)) {
4368             XSRETURN_EMPTY;
4369         }
4370         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4371         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4372         osver.dwMajorVersion = osverw.dwMajorVersion;
4373         osver.dwMinorVersion = osverw.dwMinorVersion;
4374         osver.dwBuildNumber = osverw.dwBuildNumber;
4375         osver.dwPlatformId = osverw.dwPlatformId;
4376     }
4377     else {
4378         osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4379         if (!GetVersionExA(&osver)) {
4380             XSRETURN_EMPTY;
4381         }
4382         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4383     }
4384     XPUSHs(newSViv(osver.dwMajorVersion));
4385     XPUSHs(newSViv(osver.dwMinorVersion));
4386     XPUSHs(newSViv(osver.dwBuildNumber));
4387     XPUSHs(newSViv(osver.dwPlatformId));
4388     PUTBACK;
4389 }
4390
4391 static
4392 XS(w32_IsWinNT)
4393 {
4394     dXSARGS;
4395     EXTEND(SP,1);
4396     XSRETURN_IV(IsWinNT());
4397 }
4398
4399 static
4400 XS(w32_IsWin95)
4401 {
4402     dXSARGS;
4403     EXTEND(SP,1);
4404     XSRETURN_IV(IsWin95());
4405 }
4406
4407 static
4408 XS(w32_FormatMessage)
4409 {
4410     dXSARGS;
4411     DWORD source = 0;
4412     char msgbuf[ONE_K_BUFSIZE];
4413
4414     if (items != 1)
4415         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4416
4417     if (USING_WIDE()) {
4418         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4419         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4420                           &source, SvIV(ST(0)), 0,
4421                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4422         {
4423             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4424             XSRETURN_PV(msgbuf);
4425         }
4426     }
4427     else {
4428         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4429                           &source, SvIV(ST(0)), 0,
4430                           msgbuf, sizeof(msgbuf)-1, NULL))
4431             XSRETURN_PV(msgbuf);
4432     }
4433
4434     XSRETURN_UNDEF;
4435 }
4436
4437 static
4438 XS(w32_Spawn)
4439 {
4440     dXSARGS;
4441     char *cmd, *args;
4442     void *env;
4443     char *dir;
4444     PROCESS_INFORMATION stProcInfo;
4445     STARTUPINFO stStartInfo;
4446     BOOL bSuccess = FALSE;
4447
4448     if (items != 3)
4449         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4450
4451     cmd = SvPV_nolen(ST(0));
4452     args = SvPV_nolen(ST(1));
4453
4454     env = PerlEnv_get_childenv();
4455     dir = PerlEnv_get_childdir();
4456
4457     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4458     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4459     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4460     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4461
4462     if (CreateProcess(
4463                 cmd,                    /* Image path */
4464                 args,                   /* Arguments for command line */
4465                 NULL,                   /* Default process security */
4466                 NULL,                   /* Default thread security */
4467                 FALSE,                  /* Must be TRUE to use std handles */
4468                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4469                 env,                    /* Inherit our environment block */
4470                 dir,                    /* Inherit our currrent directory */
4471                 &stStartInfo,           /* -> Startup info */
4472                 &stProcInfo))           /* <- Process info (if OK) */
4473     {
4474         int pid = (int)stProcInfo.dwProcessId;
4475         if (IsWin95() && pid < 0)
4476             pid = -pid;
4477         sv_setiv(ST(2), pid);
4478         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4479         bSuccess = TRUE;
4480     }
4481     PerlEnv_free_childenv(env);
4482     PerlEnv_free_childdir(dir);
4483     XSRETURN_IV(bSuccess);
4484 }
4485
4486 static
4487 XS(w32_GetTickCount)
4488 {
4489     dXSARGS;
4490     DWORD msec = GetTickCount();
4491     EXTEND(SP,1);
4492     if ((IV)msec > 0)
4493         XSRETURN_IV(msec);
4494     XSRETURN_NV(msec);
4495 }
4496
4497 static
4498 XS(w32_GetShortPathName)
4499 {
4500     dXSARGS;
4501     SV *shortpath;
4502     DWORD len;
4503
4504     if (items != 1)
4505         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4506
4507     shortpath = sv_mortalcopy(ST(0));
4508     SvUPGRADE(shortpath, SVt_PV);
4509     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4510         XSRETURN_UNDEF;
4511
4512     /* src == target is allowed */
4513     do {
4514         len = GetShortPathName(SvPVX(shortpath),
4515                                SvPVX(shortpath),
4516                                SvLEN(shortpath));
4517     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4518     if (len) {
4519         SvCUR_set(shortpath,len);
4520         ST(0) = shortpath;
4521         XSRETURN(1);
4522     }
4523     XSRETURN_UNDEF;
4524 }
4525
4526 static
4527 XS(w32_GetFullPathName)
4528 {
4529     dXSARGS;
4530     SV *filename;
4531     SV *fullpath;
4532     char *filepart;
4533     DWORD len;
4534
4535     if (items != 1)
4536         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4537
4538     filename = ST(0);
4539     fullpath = sv_mortalcopy(filename);
4540     SvUPGRADE(fullpath, SVt_PV);
4541     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4542         XSRETURN_UNDEF;
4543
4544     do {
4545         len = GetFullPathName(SvPVX(filename),
4546                               SvLEN(fullpath),
4547                               SvPVX(fullpath),
4548                               &filepart);
4549     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4550     if (len) {
4551         if (GIMME_V == G_ARRAY) {
4552             EXTEND(SP,1);
4553             XST_mPV(1,filepart);
4554             len = filepart - SvPVX(fullpath);
4555             items = 2;
4556         }
4557         SvCUR_set(fullpath,len);
4558         ST(0) = fullpath;
4559         XSRETURN(items);
4560     }
4561     XSRETURN_EMPTY;
4562 }
4563
4564 static
4565 XS(w32_GetLongPathName)
4566 {
4567     dXSARGS;
4568     SV *path;
4569     char tmpbuf[MAX_PATH+1];
4570     char *pathstr;
4571     STRLEN len;
4572
4573     if (items != 1)
4574         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4575
4576     path = ST(0);
4577     pathstr = SvPV(path,len);
4578     strcpy(tmpbuf, pathstr);
4579     pathstr = win32_longpath(tmpbuf);
4580     if (pathstr) {
4581         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4582         XSRETURN(1);
4583     }
4584     XSRETURN_EMPTY;
4585 }
4586
4587 static
4588 XS(w32_Sleep)
4589 {
4590     dXSARGS;
4591     if (items != 1)
4592         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4593     Sleep(SvIV(ST(0)));
4594     XSRETURN_YES;
4595 }
4596
4597 static
4598 XS(w32_CopyFile)
4599 {
4600     dXSARGS;
4601     BOOL bResult;
4602     if (items != 3)
4603         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4604     if (USING_WIDE()) {
4605         WCHAR wSourceFile[MAX_PATH+1];
4606         WCHAR wDestFile[MAX_PATH+1];
4607         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4608         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4609         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4610         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4611     }
4612     else {
4613         char szSourceFile[MAX_PATH+1];
4614         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4615         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4616     }
4617
4618     if (bResult)
4619         XSRETURN_YES;
4620     XSRETURN_NO;
4621 }
4622
4623 void
4624 Perl_init_os_extras(void)
4625 {
4626     dTHX;
4627     char *file = __FILE__;
4628     dXSUB_SYS;
4629
4630     /* these names are Activeware compatible */
4631     newXS("Win32::GetCwd", w32_GetCwd, file);
4632     newXS("Win32::SetCwd", w32_SetCwd, file);
4633     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4634     newXS("Win32::GetLastError", w32_GetLastError, file);
4635     newXS("Win32::SetLastError", w32_SetLastError, file);
4636     newXS("Win32::LoginName", w32_LoginName, file);
4637     newXS("Win32::NodeName", w32_NodeName, file);
4638     newXS("Win32::DomainName", w32_DomainName, file);
4639     newXS("Win32::FsType", w32_FsType, file);
4640     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4641     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4642     newXS("Win32::IsWin95", w32_IsWin95, file);
4643     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4644     newXS("Win32::Spawn", w32_Spawn, file);
4645     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4646     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4647     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4648     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4649     newXS("Win32::CopyFile", w32_CopyFile, file);
4650     newXS("Win32::Sleep", w32_Sleep, file);
4651     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4652
4653     /* XXX Bloat Alert! The following Activeware preloads really
4654      * ought to be part of Win32::Sys::*, so they're not included
4655      * here.
4656      */
4657     /* LookupAccountName
4658      * LookupAccountSID
4659      * InitiateSystemShutdown
4660      * AbortSystemShutdown
4661      * ExpandEnvrironmentStrings
4662      */
4663 }
4664
4665 void *
4666 win32_signal_context(void)
4667 {
4668     dTHX;
4669 #ifdef MULTIPLICITY
4670     if (!my_perl) {
4671         my_perl = PL_curinterp;
4672         PERL_SET_THX(my_perl);
4673     }
4674     return my_perl;
4675 #else
4676 #ifdef USE_5005THREADS
4677     return aTHX;
4678 #else
4679     return PL_curinterp;
4680 #endif
4681 #endif
4682 }
4683
4684
4685 BOOL WINAPI
4686 win32_ctrlhandler(DWORD dwCtrlType)
4687 {
4688 #ifdef MULTIPLICITY
4689     dTHXa(PERL_GET_SIG_CONTEXT);
4690
4691     if (!my_perl)
4692         return FALSE;
4693 #else
4694 #ifdef USE_5005THREADS
4695     dTHX;
4696 #endif
4697 #endif
4698
4699     switch(dwCtrlType) {
4700     case CTRL_CLOSE_EVENT:
4701      /*  A signal that the system sends to all processes attached to a console when
4702          the user closes the console (either by choosing the Close command from the
4703          console window's System menu, or by choosing the End Task command from the
4704          Task List
4705       */
4706         if (do_raise(aTHX_ 1))        /* SIGHUP */
4707             sig_terminate(aTHX_ 1);
4708         return TRUE;
4709
4710     case CTRL_C_EVENT:
4711         /*  A CTRL+c signal was received */
4712         if (do_raise(aTHX_ SIGINT))
4713             sig_terminate(aTHX_ SIGINT);
4714         return TRUE;
4715
4716     case CTRL_BREAK_EVENT:
4717         /*  A CTRL+BREAK signal was received */
4718         if (do_raise(aTHX_ SIGBREAK))
4719             sig_terminate(aTHX_ SIGBREAK);
4720         return TRUE;
4721
4722     case CTRL_LOGOFF_EVENT:
4723       /*  A signal that the system sends to all console processes when a user is logging
4724           off. This signal does not indicate which user is logging off, so no
4725           assumptions can be made.
4726        */
4727         break;
4728     case CTRL_SHUTDOWN_EVENT:
4729       /*  A signal that the system sends to all console processes when the system is
4730           shutting down.
4731        */
4732         if (do_raise(aTHX_ SIGTERM))
4733             sig_terminate(aTHX_ SIGTERM);
4734         return TRUE;
4735     default:
4736         break;
4737     }
4738     return FALSE;
4739 }
4740
4741
4742 void
4743 Perl_win32_init(int *argcp, char ***argvp)
4744 {
4745     /* Disable floating point errors, Perl will trap the ones we
4746      * care about.  VC++ RTL defaults to switching these off
4747      * already, but the Borland RTL doesn't.  Since we don't
4748      * want to be at the vendor's whim on the default, we set
4749      * it explicitly here.
4750      */
4751 #if !defined(_ALPHA_) && !defined(__GNUC__)
4752     _control87(MCW_EM, MCW_EM);
4753 #endif
4754     MALLOC_INIT;
4755 }
4756
4757 void
4758 win32_get_child_IO(child_IO_table* ptbl)
4759 {
4760     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
4761     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
4762     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
4763 }
4764
4765 Sighandler_t
4766 win32_signal(int sig, Sighandler_t subcode)
4767 {
4768     dTHX;
4769     if (sig < SIG_SIZE) {
4770         int save_errno = errno;
4771         Sighandler_t result = signal(sig, subcode);
4772         if (result == SIG_ERR) {
4773             result = w32_sighandler[sig];
4774             errno = save_errno;
4775         }
4776         w32_sighandler[sig] = subcode;
4777         return result;
4778     }
4779     else {
4780         errno = EINVAL;
4781         return SIG_ERR;
4782     }
4783 }
4784
4785
4786 #ifdef HAVE_INTERP_INTERN
4787
4788
4789 static void
4790 win32_csighandler(int sig)
4791 {
4792 #if 0
4793     dTHXa(PERL_GET_SIG_CONTEXT);
4794     Perl_warn(aTHX_ "Got signal %d",sig);
4795 #endif
4796     /* Does nothing */
4797 }
4798
4799 void
4800 Perl_sys_intern_init(pTHX)
4801 {
4802     int i;
4803     w32_perlshell_tokens        = Nullch;
4804     w32_perlshell_vec           = (char**)NULL;
4805     w32_perlshell_items         = 0;
4806     w32_fdpid                   = newAV();
4807     New(1313, w32_children, 1, child_tab);
4808     w32_num_children            = 0;
4809 #  ifdef USE_ITHREADS
4810     w32_pseudo_id               = 0;
4811     New(1313, w32_pseudo_children, 1, child_tab);
4812     w32_num_pseudo_children     = 0;
4813 #  endif
4814     w32_init_socktype           = 0;
4815     w32_timerid                 = 0;
4816     w32_poll_count              = 0;
4817     for (i=0; i < SIG_SIZE; i++) {
4818         w32_sighandler[i] = SIG_DFL;
4819     }
4820 #  ifdef MULTIPLICTY
4821     if (my_perl == PL_curinterp) {
4822 #  else
4823     {
4824 #  endif
4825         /* Force C runtime signal stuff to set its console handler */
4826         signal(SIGINT,&win32_csighandler);
4827         signal(SIGBREAK,&win32_csighandler);
4828         /* Push our handler on top */
4829         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4830     }
4831 }
4832
4833 void
4834 Perl_sys_intern_clear(pTHX)
4835 {
4836     Safefree(w32_perlshell_tokens);
4837     Safefree(w32_perlshell_vec);
4838     /* NOTE: w32_fdpid is freed by sv_clean_all() */
4839     Safefree(w32_children);
4840     if (w32_timerid) {
4841         KillTimer(NULL,w32_timerid);
4842         w32_timerid=0;
4843     }
4844 #  ifdef MULTIPLICITY
4845     if (my_perl == PL_curinterp) {
4846 #  else
4847     {
4848 #  endif
4849         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
4850     }
4851 #  ifdef USE_ITHREADS
4852     Safefree(w32_pseudo_children);
4853 #  endif
4854 }
4855
4856 #  ifdef USE_ITHREADS
4857
4858 void
4859 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4860 {
4861     dst->perlshell_tokens       = Nullch;
4862     dst->perlshell_vec          = (char**)NULL;
4863     dst->perlshell_items        = 0;
4864     dst->fdpid                  = newAV();
4865     Newz(1313, dst->children, 1, child_tab);
4866     dst->pseudo_id              = 0;
4867     Newz(1313, dst->pseudo_children, 1, child_tab);
4868     dst->thr_intern.Winit_socktype = 0;
4869     dst->timerid                 = 0;
4870     dst->poll_count              = 0;
4871     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
4872 }
4873 #  endif /* USE_ITHREADS */
4874 #endif /* HAVE_INTERP_INTERN */
4875
4876 static void
4877 win32_free_argvw(pTHX_ void *ptr)
4878 {
4879     char** argv = (char**)ptr;
4880     while(*argv) {
4881         Safefree(*argv);
4882         *argv++ = Nullch;
4883     }
4884 }
4885
4886 void
4887 win32_argv2utf8(int argc, char** argv)
4888 {
4889     dTHX;
4890     char* psz;
4891     int length, wargc;
4892     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4893     if (lpwStr && argc) {
4894         while (argc--) {
4895             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4896             Newz(0, psz, length, char);
4897             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4898             argv[argc] = psz;
4899         }
4900         call_atexit(win32_free_argvw, argv);
4901     }
4902     GlobalFree((HGLOBAL)lpwStr);
4903 }