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