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