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