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