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