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