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