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