win32/win32.c

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