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     New(0, fullcmd, MAX_PATH+1, char);
3740     curfullcmd = fullcmd;
3741
3742     while (1) {
3743         DWORD res;
3744
3745         /* start by appending the name to the current prefix */
3746         strcpy(curfullcmd, cmd);
3747         curfullcmd += cmdlen;
3748
3749         /* if it doesn't end with '.', or has no extension, try adding
3750          * a trailing .exe first */
3751         if (cmd[cmdlen-1] != '.'
3752             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3753         {
3754             strcpy(curfullcmd, ".exe");
3755             res = GetFileAttributes(fullcmd);
3756             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3757                 return fullcmd;
3758             *curfullcmd = '\0';
3759         }
3760
3761         /* that failed, try the bare name */
3762         res = GetFileAttributes(fullcmd);
3763         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3764             return fullcmd;
3765
3766         /* quit if no other path exists, or if cmd already has path */
3767         if (!pathstr || !*pathstr || has_slash)
3768             break;
3769
3770         /* skip leading semis */
3771         while (*pathstr == ';')
3772             pathstr++;
3773
3774         /* build a new prefix from scratch */
3775         curfullcmd = fullcmd;
3776         while (*pathstr && *pathstr != ';') {
3777             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3778                 pathstr++;              /* skip initial '"' */
3779                 while (*pathstr && *pathstr != '"') {
3780                     if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3781                         *curfullcmd++ = *pathstr;
3782                     pathstr++;
3783                 }
3784                 if (*pathstr)
3785                     pathstr++;          /* skip trailing '"' */
3786             }
3787             else {
3788                 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
3789                     *curfullcmd++ = *pathstr;
3790                 pathstr++;
3791             }
3792         }
3793         if (*pathstr)
3794             pathstr++;                  /* skip trailing semi */
3795         if (curfullcmd > fullcmd        /* append a dir separator */
3796             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3797         {
3798             *curfullcmd++ = '\\';
3799         }
3800     }
3801
3802     Safefree(fullcmd);
3803     return Nullch;
3804 }
3805
3806 /* The following are just place holders.
3807  * Some hosts may provide and environment that the OS is
3808  * not tracking, therefore, these host must provide that
3809  * environment and the current directory to CreateProcess
3810  */
3811
3812 DllExport void*
3813 win32_get_childenv(void)
3814 {
3815     return NULL;
3816 }
3817
3818 DllExport void
3819 win32_free_childenv(void* d)
3820 {
3821 }
3822
3823 DllExport void
3824 win32_clearenv(void)
3825 {
3826     char *envv = GetEnvironmentStrings();
3827     char *cur = envv;
3828     STRLEN len;
3829     while (*cur) {
3830         char *end = strchr(cur,'=');
3831         if (end && end != cur) {
3832             *end = '\0';
3833             SetEnvironmentVariable(cur, NULL);
3834             *end = '=';
3835             cur = end + strlen(end+1)+2;
3836         }
3837         else if ((len = strlen(cur)))
3838             cur += len+1;
3839     }
3840     FreeEnvironmentStrings(envv);
3841 }
3842
3843 DllExport char*
3844 win32_get_childdir(void)
3845 {
3846     dTHX;
3847     char* ptr;
3848     char szfilename[(MAX_PATH+1)*2];
3849     if (USING_WIDE()) {
3850         WCHAR wfilename[MAX_PATH+1];
3851         GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3852         W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3853     }
3854     else {
3855         GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3856     }
3857
3858     New(0, ptr, strlen(szfilename)+1, char);
3859     strcpy(ptr, szfilename);
3860     return ptr;
3861 }
3862
3863 DllExport void
3864 win32_free_childdir(char* d)
3865 {
3866     dTHX;
3867     Safefree(d);
3868 }
3869
3870
3871 /* XXX this needs to be made more compatible with the spawnvp()
3872  * provided by the various RTLs.  In particular, searching for
3873  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3874  * This doesn't significantly affect perl itself, because we
3875  * always invoke things using PERL5SHELL if a direct attempt to
3876  * spawn the executable fails.
3877  *
3878  * XXX splitting and rejoining the commandline between do_aspawn()
3879  * and win32_spawnvp() could also be avoided.
3880  */
3881
3882 DllExport int
3883 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3884 {
3885 #ifdef USE_RTL_SPAWNVP
3886     return spawnvp(mode, cmdname, (char * const *)argv);
3887 #else
3888     dTHX;
3889     int ret;
3890     void* env;
3891     char* dir;
3892     child_IO_table tbl;
3893     STARTUPINFO StartupInfo;
3894     PROCESS_INFORMATION ProcessInformation;
3895     DWORD create = 0;
3896     char *cmd;
3897     char *fullcmd = Nullch;
3898     char *cname = (char *)cmdname;
3899     STRLEN clen = 0;
3900
3901     if (cname) {
3902         clen = strlen(cname);
3903         /* if command name contains dquotes, must remove them */
3904         if (strchr(cname, '"')) {
3905             cmd = cname;
3906             New(0,cname,clen+1,char);
3907             clen = 0;
3908             while (*cmd) {
3909                 if (*cmd != '"') {
3910                     cname[clen] = *cmd;
3911                     ++clen;
3912                 }
3913                 ++cmd;
3914             }
3915             cname[clen] = '\0';
3916         }
3917     }
3918
3919     cmd = create_command_line(cname, clen, argv);
3920
3921     env = PerlEnv_get_childenv();
3922     dir = PerlEnv_get_childdir();
3923
3924     switch(mode) {
3925     case P_NOWAIT:      /* asynch + remember result */
3926         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3927             errno = EAGAIN;
3928             ret = -1;
3929             goto RETVAL;
3930         }
3931         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3932          * in win32_kill()
3933          */
3934         create |= CREATE_NEW_PROCESS_GROUP;
3935         /* FALL THROUGH */
3936
3937     case P_WAIT:        /* synchronous execution */
3938         break;
3939     default:            /* invalid mode */
3940         errno = EINVAL;
3941         ret = -1;
3942         goto RETVAL;
3943     }
3944     memset(&StartupInfo,0,sizeof(StartupInfo));
3945     StartupInfo.cb = sizeof(StartupInfo);
3946     memset(&tbl,0,sizeof(tbl));
3947     PerlEnv_get_child_IO(&tbl);
3948     StartupInfo.dwFlags         = tbl.dwFlags;
3949     StartupInfo.dwX             = tbl.dwX;
3950     StartupInfo.dwY             = tbl.dwY;
3951     StartupInfo.dwXSize         = tbl.dwXSize;
3952     StartupInfo.dwYSize         = tbl.dwYSize;
3953     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
3954     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
3955     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3956     StartupInfo.wShowWindow     = tbl.wShowWindow;
3957     StartupInfo.hStdInput       = tbl.childStdIn;
3958     StartupInfo.hStdOutput      = tbl.childStdOut;
3959     StartupInfo.hStdError       = tbl.childStdErr;
3960     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3961         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3962         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3963     {
3964         create |= CREATE_NEW_CONSOLE;
3965     }
3966     else {
3967         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3968     }
3969     if (w32_use_showwindow) {
3970         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3971         StartupInfo.wShowWindow = w32_showwindow;
3972     }
3973
3974     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
3975                           cname,cmd));
3976 RETRY:
3977     if (!CreateProcess(cname,           /* search PATH to find executable */
3978                        cmd,             /* executable, and its arguments */
3979                        NULL,            /* process attributes */
3980                        NULL,            /* thread attributes */
3981                        TRUE,            /* inherit handles */
3982                        create,          /* creation flags */
3983                        (LPVOID)env,     /* inherit environment */
3984                        dir,             /* inherit cwd */
3985                        &StartupInfo,
3986                        &ProcessInformation))
3987     {
3988         /* initial NULL argument to CreateProcess() does a PATH
3989          * search, but it always first looks in the directory
3990          * where the current process was started, which behavior
3991          * is undesirable for backward compatibility.  So we
3992          * jump through our own hoops by picking out the path
3993          * we really want it to use. */
3994         if (!fullcmd) {
3995             fullcmd = qualified_path(cname);
3996             if (fullcmd) {
3997                 if (cname != cmdname)
3998                     Safefree(cname);
3999                 cname = fullcmd;
4000                 DEBUG_p(PerlIO_printf(Perl_debug_log,
4001                                       "Retrying [%s] with same args\n",
4002                                       cname));
4003                 goto RETRY;
4004             }
4005         }
4006         errno = ENOENT;
4007         ret = -1;
4008         goto RETVAL;
4009     }
4010
4011     if (mode == P_NOWAIT) {
4012         /* asynchronous spawn -- store handle, return PID */
4013         ret = (int)ProcessInformation.dwProcessId;
4014         if (IsWin95() && ret < 0)
4015             ret = -ret;
4016
4017         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4018         w32_child_pids[w32_num_children] = (DWORD)ret;
4019         ++w32_num_children;
4020     }
4021     else  {
4022         DWORD status;
4023         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4024         /* FIXME: if msgwait returned due to message perhaps forward the
4025            "signal" to the process
4026          */
4027         GetExitCodeProcess(ProcessInformation.hProcess, &status);
4028         ret = (int)status;
4029         CloseHandle(ProcessInformation.hProcess);
4030     }
4031
4032     CloseHandle(ProcessInformation.hThread);
4033
4034 RETVAL:
4035     PerlEnv_free_childenv(env);
4036     PerlEnv_free_childdir(dir);
4037     Safefree(cmd);
4038     if (cname != cmdname)
4039         Safefree(cname);
4040     return ret;
4041 #endif
4042 }
4043
4044 DllExport int
4045 win32_execv(const char *cmdname, const char *const *argv)
4046 {
4047 #ifdef USE_ITHREADS
4048     dTHX;
4049     /* if this is a pseudo-forked child, we just want to spawn
4050      * the new program, and return */
4051     if (w32_pseudo_id)
4052         return spawnv(P_WAIT, cmdname, (char *const *)argv);
4053 #endif
4054     return execv(cmdname, (char *const *)argv);
4055 }
4056
4057 DllExport int
4058 win32_execvp(const char *cmdname, const char *const *argv)
4059 {
4060 #ifdef USE_ITHREADS
4061     dTHX;
4062     /* if this is a pseudo-forked child, we just want to spawn
4063      * the new program, and return */
4064     if (w32_pseudo_id) {
4065         int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4066         if (status != -1) {
4067             my_exit(status);
4068             return 0;
4069         }
4070         else
4071             return status;
4072     }
4073 #endif
4074     return execvp(cmdname, (char *const *)argv);
4075 }
4076
4077 DllExport void
4078 win32_perror(const char *str)
4079 {
4080     perror(str);
4081 }
4082
4083 DllExport void
4084 win32_setbuf(FILE *pf, char *buf)
4085 {
4086     setbuf(pf, buf);
4087 }
4088
4089 DllExport int
4090 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4091 {
4092     return setvbuf(pf, buf, type, size);
4093 }
4094
4095 DllExport int
4096 win32_flushall(void)
4097 {
4098     return flushall();
4099 }
4100
4101 DllExport int
4102 win32_fcloseall(void)
4103 {
4104     return fcloseall();
4105 }
4106
4107 DllExport char*
4108 win32_fgets(char *s, int n, FILE *pf)
4109 {
4110     return fgets(s, n, pf);
4111 }
4112
4113 DllExport char*
4114 win32_gets(char *s)
4115 {
4116     return gets(s);
4117 }
4118
4119 DllExport int
4120 win32_fgetc(FILE *pf)
4121 {
4122     return fgetc(pf);
4123 }
4124
4125 DllExport int
4126 win32_putc(int c, FILE *pf)
4127 {
4128     return putc(c,pf);
4129 }
4130
4131 DllExport int
4132 win32_puts(const char *s)
4133 {
4134     return puts(s);
4135 }
4136
4137 DllExport int
4138 win32_getchar(void)
4139 {
4140     return getchar();
4141 }
4142
4143 DllExport int
4144 win32_putchar(int c)
4145 {
4146     return putchar(c);
4147 }
4148
4149 #ifdef MYMALLOC
4150
4151 #ifndef USE_PERL_SBRK
4152
4153 static char *committed = NULL;          /* XXX threadead */
4154 static char *base      = NULL;          /* XXX threadead */
4155 static char *reserved  = NULL;          /* XXX threadead */
4156 static char *brk       = NULL;          /* XXX threadead */
4157 static DWORD pagesize  = 0;             /* XXX threadead */
4158 static DWORD allocsize = 0;             /* XXX threadead */
4159
4160 void *
4161 sbrk(ptrdiff_t need)
4162 {
4163  void *result;
4164  if (!pagesize)
4165   {SYSTEM_INFO info;
4166    GetSystemInfo(&info);
4167    /* Pretend page size is larger so we don't perpetually
4168     * call the OS to commit just one page ...
4169     */
4170    pagesize = info.dwPageSize << 3;
4171    allocsize = info.dwAllocationGranularity;
4172   }
4173  /* This scheme fails eventually if request for contiguous
4174   * block is denied so reserve big blocks - this is only
4175   * address space not memory ...
4176   */
4177  if (brk+need >= reserved)
4178   {
4179    DWORD size = 64*1024*1024;
4180    char *addr;
4181    if (committed && reserved && committed < reserved)
4182     {
4183      /* Commit last of previous chunk cannot span allocations */
4184      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4185      if (addr)
4186       committed = reserved;
4187     }
4188    /* Reserve some (more) space
4189     * Note this is a little sneaky, 1st call passes NULL as reserved
4190     * so lets system choose where we start, subsequent calls pass
4191     * the old end address so ask for a contiguous block
4192     */
4193    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4194    if (addr)
4195     {
4196      reserved = addr+size;
4197      if (!base)
4198       base = addr;
4199      if (!committed)
4200       committed = base;
4201      if (!brk)
4202       brk = committed;
4203     }
4204    else
4205     {
4206      return (void *) -1;
4207     }
4208   }
4209  result = brk;
4210  brk += need;
4211  if (brk > committed)
4212   {
4213    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4214    char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4215    if (addr)
4216     {
4217      committed += size;
4218     }
4219    else
4220     return (void *) -1;
4221   }
4222  return result;
4223 }
4224
4225 #endif
4226 #endif
4227
4228 DllExport void*
4229 win32_malloc(size_t size)
4230 {
4231     return malloc(size);
4232 }
4233
4234 DllExport void*
4235 win32_calloc(size_t numitems, size_t size)
4236 {
4237     return calloc(numitems,size);
4238 }
4239
4240 DllExport void*
4241 win32_realloc(void *block, size_t size)
4242 {
4243     return realloc(block,size);
4244 }
4245
4246 DllExport void
4247 win32_free(void *block)
4248 {
4249     free(block);
4250 }
4251
4252
4253 DllExport int
4254 win32_open_osfhandle(intptr_t handle, int flags)
4255 {
4256 #ifdef USE_FIXED_OSFHANDLE
4257     if (IsWin95())
4258         return my_open_osfhandle(handle, flags);
4259 #endif
4260     return _open_osfhandle(handle, flags);
4261 }
4262
4263 DllExport intptr_t
4264 win32_get_osfhandle(int fd)
4265 {
4266     return (intptr_t)_get_osfhandle(fd);
4267 }
4268
4269 DllExport FILE *
4270 win32_fdupopen(FILE *pf)
4271 {
4272     FILE* pfdup;
4273     fpos_t pos;
4274     char mode[3];
4275     int fileno = win32_dup(win32_fileno(pf));
4276
4277     /* open the file in the same mode */
4278 #ifdef __BORLANDC__
4279     if((pf)->flags & _F_READ) {
4280         mode[0] = 'r';
4281         mode[1] = 0;
4282     }
4283     else if((pf)->flags & _F_WRIT) {
4284         mode[0] = 'a';
4285         mode[1] = 0;
4286     }
4287     else if((pf)->flags & _F_RDWR) {
4288         mode[0] = 'r';
4289         mode[1] = '+';
4290         mode[2] = 0;
4291     }
4292 #else
4293     if((pf)->_flag & _IOREAD) {
4294         mode[0] = 'r';
4295         mode[1] = 0;
4296     }
4297     else if((pf)->_flag & _IOWRT) {
4298         mode[0] = 'a';
4299         mode[1] = 0;
4300     }
4301     else if((pf)->_flag & _IORW) {
4302         mode[0] = 'r';
4303         mode[1] = '+';
4304         mode[2] = 0;
4305     }
4306 #endif
4307
4308     /* it appears that the binmode is attached to the
4309      * file descriptor so binmode files will be handled
4310      * correctly
4311      */
4312     pfdup = win32_fdopen(fileno, mode);
4313
4314     /* move the file pointer to the same position */
4315     if (!fgetpos(pf, &pos)) {
4316         fsetpos(pfdup, &pos);
4317     }
4318     return pfdup;
4319 }
4320
4321 DllExport void*
4322 win32_dynaload(const char* filename)
4323 {
4324     dTHX;
4325     HMODULE hModule;
4326     char buf[MAX_PATH+1];
4327     char *first;
4328
4329     /* LoadLibrary() doesn't recognize forward slashes correctly,
4330      * so turn 'em back. */
4331     first = strchr(filename, '/');
4332     if (first) {
4333         STRLEN len = strlen(filename);
4334         if (len <= MAX_PATH) {
4335             strcpy(buf, filename);
4336             filename = &buf[first - filename];
4337             while (*filename) {
4338                 if (*filename == '/')
4339                     *(char*)filename = '\\';
4340                 ++filename;
4341             }
4342             filename = buf;
4343         }
4344     }
4345     if (USING_WIDE()) {
4346         WCHAR wfilename[MAX_PATH+1];
4347         A2WHELPER(filename, wfilename, sizeof(wfilename));
4348         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4349     }
4350     else {
4351         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4352     }
4353     return hModule;
4354 }
4355
4356 /*
4357  * Extras.
4358  */
4359
4360 static
4361 XS(w32_SetChildShowWindow)
4362 {
4363     dXSARGS;
4364     BOOL use_showwindow = w32_use_showwindow;
4365     /* use "unsigned short" because Perl has redefined "WORD" */
4366     unsigned short showwindow = w32_showwindow;
4367
4368     if (items > 1)
4369         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4370
4371     if (items == 0 || !SvOK(ST(0)))
4372         w32_use_showwindow = FALSE;
4373     else {
4374         w32_use_showwindow = TRUE;
4375         w32_showwindow = (unsigned short)SvIV(ST(0));
4376     }
4377
4378     EXTEND(SP, 1);
4379     if (use_showwindow)
4380         ST(0) = sv_2mortal(newSViv(showwindow));
4381     else
4382         ST(0) = &PL_sv_undef;
4383     XSRETURN(1);
4384 }
4385
4386 static
4387 XS(w32_GetCwd)
4388 {
4389     dXSARGS;
4390     /* Make the host for current directory */
4391     char* ptr = PerlEnv_get_childdir();
4392     /*
4393      * If ptr != Nullch
4394      *   then it worked, set PV valid,
4395      *   else return 'undef'
4396      */
4397     if (ptr) {
4398         SV *sv = sv_newmortal();
4399         sv_setpv(sv, ptr);
4400         PerlEnv_free_childdir(ptr);
4401
4402 #ifndef INCOMPLETE_TAINTS
4403         SvTAINTED_on(sv);
4404 #endif
4405
4406         EXTEND(SP,1);
4407         SvPOK_on(sv);
4408         ST(0) = sv;
4409         XSRETURN(1);
4410     }
4411     XSRETURN_UNDEF;
4412 }
4413
4414 static
4415 XS(w32_SetCwd)
4416 {
4417     dXSARGS;
4418     if (items != 1)
4419         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4420     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4421         XSRETURN_YES;
4422
4423     XSRETURN_NO;
4424 }
4425
4426 static
4427 XS(w32_GetNextAvailDrive)
4428 {
4429     dXSARGS;
4430     char ix = 'C';
4431     char root[] = "_:\\";
4432
4433     EXTEND(SP,1);
4434     while (ix <= 'Z') {
4435         root[0] = ix++;
4436         if (GetDriveType(root) == 1) {
4437             root[2] = '\0';
4438             XSRETURN_PV(root);
4439         }
4440     }
4441     XSRETURN_UNDEF;
4442 }
4443
4444 static
4445 XS(w32_GetLastError)
4446 {
4447     dXSARGS;
4448     EXTEND(SP,1);
4449     XSRETURN_IV(GetLastError());
4450 }
4451
4452 static
4453 XS(w32_SetLastError)
4454 {
4455     dXSARGS;
4456     if (items != 1)
4457         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4458     SetLastError(SvIV(ST(0)));
4459     XSRETURN_EMPTY;
4460 }
4461
4462 static
4463 XS(w32_LoginName)
4464 {
4465     dXSARGS;
4466     char *name = w32_getlogin_buffer;
4467     DWORD size = sizeof(w32_getlogin_buffer);
4468     EXTEND(SP,1);
4469     if (GetUserName(name,&size)) {
4470         /* size includes NULL */
4471         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4472         XSRETURN(1);
4473     }
4474     XSRETURN_UNDEF;
4475 }
4476
4477 static
4478 XS(w32_NodeName)
4479 {
4480     dXSARGS;
4481     char name[MAX_COMPUTERNAME_LENGTH+1];
4482     DWORD size = sizeof(name);
4483     EXTEND(SP,1);
4484     if (GetComputerName(name,&size)) {
4485         /* size does NOT include NULL :-( */
4486         ST(0) = sv_2mortal(newSVpvn(name,size));
4487         XSRETURN(1);
4488     }
4489     XSRETURN_UNDEF;
4490 }
4491
4492
4493 static
4494 XS(w32_DomainName)
4495 {
4496     dXSARGS;
4497     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4498     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4499     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4500                                           void *bufptr);
4501
4502     if (hNetApi32) {
4503         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4504             GetProcAddress(hNetApi32, "NetApiBufferFree");
4505         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4506             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4507     }
4508     EXTEND(SP,1);
4509     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4510         /* this way is more reliable, in case user has a local account. */
4511         char dname[256];
4512         DWORD dnamelen = sizeof(dname);
4513         struct {
4514             DWORD   wki100_platform_id;
4515             LPWSTR  wki100_computername;
4516             LPWSTR  wki100_langroup;
4517             DWORD   wki100_ver_major;
4518             DWORD   wki100_ver_minor;
4519         } *pwi;
4520         /* NERR_Success *is* 0*/
4521         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4522             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4523                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4524                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4525             }
4526             else {
4527                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4528                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4529             }
4530             pfnNetApiBufferFree(pwi);
4531             FreeLibrary(hNetApi32);
4532             XSRETURN_PV(dname);
4533         }
4534         FreeLibrary(hNetApi32);
4535     }
4536     else {
4537         /* Win95 doesn't have NetWksta*(), so do it the old way */
4538         char name[256];
4539         DWORD size = sizeof(name);
4540         if (hNetApi32)
4541             FreeLibrary(hNetApi32);
4542         if (GetUserName(name,&size)) {
4543             char sid[ONE_K_BUFSIZE];
4544             DWORD sidlen = sizeof(sid);
4545             char dname[256];
4546             DWORD dnamelen = sizeof(dname);
4547             SID_NAME_USE snu;
4548             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4549                                   dname, &dnamelen, &snu)) {
4550                 XSRETURN_PV(dname);             /* all that for this */
4551             }
4552         }
4553     }
4554     XSRETURN_UNDEF;
4555 }
4556
4557 static
4558 XS(w32_FsType)
4559 {
4560     dXSARGS;
4561     char fsname[256];
4562     DWORD flags, filecomplen;
4563     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4564                          &flags, fsname, sizeof(fsname))) {
4565         if (GIMME_V == G_ARRAY) {
4566             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4567             XPUSHs(sv_2mortal(newSViv(flags)));
4568             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4569             PUTBACK;
4570             return;
4571         }
4572         EXTEND(SP,1);
4573         XSRETURN_PV(fsname);
4574     }
4575     XSRETURN_EMPTY;
4576 }
4577
4578 static
4579 XS(w32_GetOSVersion)
4580 {
4581     dXSARGS;
4582     /* Use explicit struct definition because wSuiteMask and
4583      * wProductType are not defined in the VC++ 6.0 headers.
4584      * WORD type has been replaced by unsigned short because
4585      * WORD is already used by Perl itself.
4586      */
4587     struct {
4588         DWORD dwOSVersionInfoSize;
4589         DWORD dwMajorVersion;
4590         DWORD dwMinorVersion;
4591         DWORD dwBuildNumber;
4592         DWORD dwPlatformId;
4593         CHAR  szCSDVersion[128];
4594         unsigned short wServicePackMajor;
4595         unsigned short wServicePackMinor;
4596         unsigned short wSuiteMask;
4597         BYTE  wProductType;
4598         BYTE  wReserved;
4599     }   osver;
4600     BOOL bEx = TRUE;
4601
4602     if (USING_WIDE()) {
4603         struct {
4604             DWORD dwOSVersionInfoSize;
4605             DWORD dwMajorVersion;
4606             DWORD dwMinorVersion;
4607             DWORD dwBuildNumber;
4608             DWORD dwPlatformId;
4609             WCHAR szCSDVersion[128];
4610             unsigned short wServicePackMajor;
4611             unsigned short wServicePackMinor;
4612             unsigned short wSuiteMask;
4613             BYTE  wProductType;
4614             BYTE  wReserved;
4615         } osverw;
4616         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4617         osverw.dwOSVersionInfoSize = sizeof(osverw);
4618         if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4619             bEx = FALSE;
4620             osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4621             if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4622                 XSRETURN_EMPTY;
4623             }
4624         }
4625         if (GIMME_V == G_SCALAR) {
4626             XSRETURN_IV(osverw.dwPlatformId);
4627         }
4628         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4629         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4630         osver.dwMajorVersion    = osverw.dwMajorVersion;
4631         osver.dwMinorVersion    = osverw.dwMinorVersion;
4632         osver.dwBuildNumber     = osverw.dwBuildNumber;
4633         osver.dwPlatformId      = osverw.dwPlatformId;
4634         osver.wServicePackMajor = osverw.wServicePackMajor;
4635         osver.wServicePackMinor = osverw.wServicePackMinor;
4636         osver.wSuiteMask        = osverw.wSuiteMask;
4637         osver.wProductType      = osverw.wProductType;
4638     }
4639     else {
4640         osver.dwOSVersionInfoSize = sizeof(osver);
4641         if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4642             bEx = FALSE;
4643             osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4644             if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4645                 XSRETURN_EMPTY;
4646             }
4647         }
4648         if (GIMME_V == G_SCALAR) {
4649             XSRETURN_IV(osver.dwPlatformId);
4650         }
4651         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4652     }
4653     XPUSHs(newSViv(osver.dwMajorVersion));
4654     XPUSHs(newSViv(osver.dwMinorVersion));
4655     XPUSHs(newSViv(osver.dwBuildNumber));
4656     XPUSHs(newSViv(osver.dwPlatformId));
4657     if (bEx) {
4658         XPUSHs(newSViv(osver.wServicePackMajor));
4659         XPUSHs(newSViv(osver.wServicePackMinor));
4660         XPUSHs(newSViv(osver.wSuiteMask));
4661         XPUSHs(newSViv(osver.wProductType));
4662     }
4663     PUTBACK;
4664 }
4665
4666 static
4667 XS(w32_IsWinNT)
4668 {
4669     dXSARGS;
4670     EXTEND(SP,1);
4671     XSRETURN_IV(IsWinNT());
4672 }
4673
4674 static
4675 XS(w32_IsWin95)
4676 {
4677     dXSARGS;
4678     EXTEND(SP,1);
4679     XSRETURN_IV(IsWin95());
4680 }
4681
4682 static
4683 XS(w32_FormatMessage)
4684 {
4685     dXSARGS;
4686     DWORD source = 0;
4687     char msgbuf[ONE_K_BUFSIZE];
4688
4689     if (items != 1)
4690         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4691
4692     if (USING_WIDE()) {
4693         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4694         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4695                           &source, SvIV(ST(0)), 0,
4696                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4697         {
4698             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4699             XSRETURN_PV(msgbuf);
4700         }
4701     }
4702     else {
4703         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4704                           &source, SvIV(ST(0)), 0,
4705                           msgbuf, sizeof(msgbuf)-1, NULL))
4706             XSRETURN_PV(msgbuf);
4707     }
4708
4709     XSRETURN_UNDEF;
4710 }
4711
4712 static
4713 XS(w32_Spawn)
4714 {
4715     dXSARGS;
4716     char *cmd, *args;
4717     void *env;
4718     char *dir;
4719     PROCESS_INFORMATION stProcInfo;
4720     STARTUPINFO stStartInfo;
4721     BOOL bSuccess = FALSE;
4722
4723     if (items != 3)
4724         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4725
4726     cmd = SvPV_nolen(ST(0));
4727     args = SvPV_nolen(ST(1));
4728
4729     env = PerlEnv_get_childenv();
4730     dir = PerlEnv_get_childdir();
4731
4732     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4733     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4734     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4735     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4736
4737     if (CreateProcess(
4738                 cmd,                    /* Image path */
4739                 args,                   /* Arguments for command line */
4740                 NULL,                   /* Default process security */
4741                 NULL,                   /* Default thread security */
4742                 FALSE,                  /* Must be TRUE to use std handles */
4743                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4744                 env,                    /* Inherit our environment block */
4745                 dir,                    /* Inherit our currrent directory */
4746                 &stStartInfo,           /* -> Startup info */
4747                 &stProcInfo))           /* <- Process info (if OK) */
4748     {
4749         int pid = (int)stProcInfo.dwProcessId;
4750         if (IsWin95() && pid < 0)
4751             pid = -pid;
4752         sv_setiv(ST(2), pid);
4753         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4754         bSuccess = TRUE;
4755     }
4756     PerlEnv_free_childenv(env);
4757     PerlEnv_free_childdir(dir);
4758     XSRETURN_IV(bSuccess);
4759 }
4760
4761 static
4762 XS(w32_GetTickCount)
4763 {
4764     dXSARGS;
4765     DWORD msec = GetTickCount();
4766     EXTEND(SP,1);
4767     if ((IV)msec > 0)
4768         XSRETURN_IV(msec);
4769     XSRETURN_NV(msec);
4770 }
4771
4772 static
4773 XS(w32_GetShortPathName)
4774 {
4775     dXSARGS;
4776     SV *shortpath;
4777     DWORD len;
4778
4779     if (items != 1)
4780         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4781
4782     shortpath = sv_mortalcopy(ST(0));
4783     SvUPGRADE(shortpath, SVt_PV);
4784     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4785         XSRETURN_UNDEF;
4786
4787     /* src == target is allowed */
4788     do {
4789         len = GetShortPathName(SvPVX(shortpath),
4790                                SvPVX(shortpath),
4791                                SvLEN(shortpath));
4792     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4793     if (len) {
4794         SvCUR_set(shortpath,len);
4795         *SvEND(shortpath) = '\0';
4796         ST(0) = shortpath;
4797         XSRETURN(1);
4798     }
4799     XSRETURN_UNDEF;
4800 }
4801
4802 static
4803 XS(w32_GetFullPathName)
4804 {
4805     dXSARGS;
4806     SV *filename;
4807     SV *fullpath;
4808     char *filepart;
4809     DWORD len;
4810
4811     if (items != 1)
4812         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4813
4814     filename = ST(0);
4815     fullpath = sv_mortalcopy(filename);
4816     SvUPGRADE(fullpath, SVt_PV);
4817     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4818         XSRETURN_UNDEF;
4819
4820     do {
4821         len = GetFullPathName(SvPVX(filename),
4822                               SvLEN(fullpath),
4823                               SvPVX(fullpath),
4824                               &filepart);
4825     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4826     if (len) {
4827         if (GIMME_V == G_ARRAY) {
4828             EXTEND(SP,1);
4829             if (filepart) {
4830                 XST_mPV(1,filepart);
4831                 len = filepart - SvPVX(fullpath);
4832             }
4833             else {
4834                 XST_mPVN(1,"",0);
4835             }
4836             items = 2;
4837         }
4838         SvCUR_set(fullpath,len);
4839         *SvEND(fullpath) = '\0';
4840         ST(0) = fullpath;
4841         XSRETURN(items);
4842     }
4843     XSRETURN_EMPTY;
4844 }
4845
4846 static
4847 XS(w32_GetLongPathName)
4848 {
4849     dXSARGS;
4850     SV *path;
4851     char tmpbuf[MAX_PATH+1];
4852     char *pathstr;
4853     STRLEN len;
4854
4855     if (items != 1)
4856         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4857
4858     path = ST(0);
4859     pathstr = SvPV(path,len);
4860     strcpy(tmpbuf, pathstr);
4861     pathstr = win32_longpath(tmpbuf);
4862     if (pathstr) {
4863         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4864         XSRETURN(1);
4865     }
4866     XSRETURN_EMPTY;
4867 }
4868
4869 static
4870 XS(w32_Sleep)
4871 {
4872     dXSARGS;
4873     if (items != 1)
4874         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4875     Sleep(SvIV(ST(0)));
4876     XSRETURN_YES;
4877 }
4878
4879 static
4880 XS(w32_CopyFile)
4881 {
4882     dXSARGS;
4883     BOOL bResult;
4884     if (items != 3)
4885         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4886     if (USING_WIDE()) {
4887         WCHAR wSourceFile[MAX_PATH+1];
4888         WCHAR wDestFile[MAX_PATH+1];
4889         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4890         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4891         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4892         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4893     }
4894     else {
4895         char szSourceFile[MAX_PATH+1];
4896         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4897         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4898     }
4899
4900     if (bResult)
4901         XSRETURN_YES;
4902     XSRETURN_NO;
4903 }
4904
4905 void
4906 Perl_init_os_extras(void)
4907 {
4908     dTHX;
4909     char *file = __FILE__;
4910     dXSUB_SYS;
4911
4912     /* these names are Activeware compatible */
4913     newXS("Win32::GetCwd", w32_GetCwd, file);
4914     newXS("Win32::SetCwd", w32_SetCwd, file);
4915     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4916     newXS("Win32::GetLastError", w32_GetLastError, file);
4917     newXS("Win32::SetLastError", w32_SetLastError, file);
4918     newXS("Win32::LoginName", w32_LoginName, file);
4919     newXS("Win32::NodeName", w32_NodeName, file);
4920     newXS("Win32::DomainName", w32_DomainName, file);
4921     newXS("Win32::FsType", w32_FsType, file);
4922     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4923     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4924     newXS("Win32::IsWin95", w32_IsWin95, file);
4925     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4926     newXS("Win32::Spawn", w32_Spawn, file);
4927     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4928     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4929     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4930     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4931     newXS("Win32::CopyFile", w32_CopyFile, file);
4932     newXS("Win32::Sleep", w32_Sleep, file);
4933     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4934
4935     /* XXX Bloat Alert! The following Activeware preloads really
4936      * ought to be part of Win32::Sys::*, so they're not included
4937      * here.
4938      */
4939     /* LookupAccountName
4940      * LookupAccountSID
4941      * InitiateSystemShutdown
4942      * AbortSystemShutdown
4943      * ExpandEnvrironmentStrings
4944      */
4945 }
4946
4947 void *
4948 win32_signal_context(void)
4949 {
4950     dTHX;
4951 #ifdef MULTIPLICITY
4952     if (!my_perl) {
4953         my_perl = PL_curinterp;
4954         PERL_SET_THX(my_perl);
4955     }
4956     return my_perl;
4957 #else
4958     return PL_curinterp;
4959 #endif
4960 }
4961
4962
4963 BOOL WINAPI
4964 win32_ctrlhandler(DWORD dwCtrlType)
4965 {
4966 #ifdef MULTIPLICITY
4967     dTHXa(PERL_GET_SIG_CONTEXT);
4968
4969     if (!my_perl)
4970         return FALSE;
4971 #endif
4972
4973     switch(dwCtrlType) {
4974     case CTRL_CLOSE_EVENT:
4975      /*  A signal that the system sends to all processes attached to a console when
4976          the user closes the console (either by choosing the Close command from the
4977          console window's System menu, or by choosing the End Task command from the
4978          Task List
4979       */
4980         if (do_raise(aTHX_ 1))        /* SIGHUP */
4981             sig_terminate(aTHX_ 1);
4982         return TRUE;
4983
4984     case CTRL_C_EVENT:
4985         /*  A CTRL+c signal was received */
4986         if (do_raise(aTHX_ SIGINT))
4987             sig_terminate(aTHX_ SIGINT);
4988         return TRUE;
4989
4990     case CTRL_BREAK_EVENT:
4991         /*  A CTRL+BREAK signal was received */
4992         if (do_raise(aTHX_ SIGBREAK))
4993             sig_terminate(aTHX_ SIGBREAK);
4994         return TRUE;
4995
4996     case CTRL_LOGOFF_EVENT:
4997       /*  A signal that the system sends to all console processes when a user is logging
4998           off. This signal does not indicate which user is logging off, so no
4999           assumptions can be made.
5000        */
5001         break;
5002     case CTRL_SHUTDOWN_EVENT:
5003       /*  A signal that the system sends to all console processes when the system is
5004           shutting down.
5005        */
5006         if (do_raise(aTHX_ SIGTERM))
5007             sig_terminate(aTHX_ SIGTERM);
5008         return TRUE;
5009     default:
5010         break;
5011     }
5012     return FALSE;
5013 }
5014
5015
5016 void
5017 Perl_win32_init(int *argcp, char ***argvp)
5018 {
5019     /* Disable floating point errors, Perl will trap the ones we
5020      * care about.  VC++ RTL defaults to switching these off
5021      * already, but the Borland RTL doesn't.  Since we don't
5022      * want to be at the vendor's whim on the default, we set
5023      * it explicitly here.
5024      */
5025 #if !defined(_ALPHA_) && !defined(__GNUC__)
5026     _control87(MCW_EM, MCW_EM);
5027 #endif
5028     MALLOC_INIT;
5029 }
5030
5031 void
5032 Perl_win32_term(void)
5033 {
5034     OP_REFCNT_TERM;
5035     MALLOC_TERM;
5036 }
5037
5038 void
5039 win32_get_child_IO(child_IO_table* ptbl)
5040 {
5041     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
5042     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
5043     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
5044 }
5045
5046 Sighandler_t
5047 win32_signal(int sig, Sighandler_t subcode)
5048 {
5049     dTHX;
5050     if (sig < SIG_SIZE) {
5051         int save_errno = errno;
5052         Sighandler_t result = signal(sig, subcode);
5053         if (result == SIG_ERR) {
5054             result = w32_sighandler[sig];
5055             errno = save_errno;
5056         }
5057         w32_sighandler[sig] = subcode;
5058         return result;
5059     }
5060     else {
5061         errno = EINVAL;
5062         return SIG_ERR;
5063     }
5064 }
5065
5066
5067 #ifdef HAVE_INTERP_INTERN
5068
5069
5070 static void
5071 win32_csighandler(int sig)
5072 {
5073 #if 0
5074     dTHXa(PERL_GET_SIG_CONTEXT);
5075     Perl_warn(aTHX_ "Got signal %d",sig);
5076 #endif
5077     /* Does nothing */
5078 }
5079
5080 void
5081 Perl_sys_intern_init(pTHX)
5082 {
5083     int i;
5084     w32_perlshell_tokens        = Nullch;
5085     w32_perlshell_vec           = (char**)NULL;
5086     w32_perlshell_items         = 0;
5087     w32_fdpid                   = newAV();
5088     New(1313, w32_children, 1, child_tab);
5089     w32_num_children            = 0;
5090 #  ifdef USE_ITHREADS
5091     w32_pseudo_id               = 0;
5092     New(1313, w32_pseudo_children, 1, child_tab);
5093     w32_num_pseudo_children     = 0;
5094 #  endif
5095     w32_init_socktype           = 0;
5096     w32_timerid                 = 0;
5097     w32_poll_count              = 0;
5098     for (i=0; i < SIG_SIZE; i++) {
5099         w32_sighandler[i] = SIG_DFL;
5100     }
5101 #  ifdef MULTIPLICTY
5102     if (my_perl == PL_curinterp) {
5103 #  else
5104     {
5105 #  endif
5106         /* Force C runtime signal stuff to set its console handler */
5107         signal(SIGINT,&win32_csighandler);
5108         signal(SIGBREAK,&win32_csighandler);
5109         /* Push our handler on top */
5110         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5111     }
5112 }
5113
5114 void
5115 Perl_sys_intern_clear(pTHX)
5116 {
5117     Safefree(w32_perlshell_tokens);
5118     Safefree(w32_perlshell_vec);
5119     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5120     Safefree(w32_children);
5121     if (w32_timerid) {
5122         KillTimer(NULL,w32_timerid);
5123         w32_timerid=0;
5124     }
5125 #  ifdef MULTIPLICITY
5126     if (my_perl == PL_curinterp) {
5127 #  else
5128     {
5129 #  endif
5130         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5131     }
5132 #  ifdef USE_ITHREADS
5133     Safefree(w32_pseudo_children);
5134 #  endif
5135 }
5136
5137 #  ifdef USE_ITHREADS
5138
5139 void
5140 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5141 {
5142     dst->perlshell_tokens       = Nullch;
5143     dst->perlshell_vec          = (char**)NULL;
5144     dst->perlshell_items        = 0;
5145     dst->fdpid                  = newAV();
5146     Newz(1313, dst->children, 1, child_tab);
5147     dst->pseudo_id              = 0;
5148     Newz(1313, dst->pseudo_children, 1, child_tab);
5149     dst->thr_intern.Winit_socktype = 0;
5150     dst->timerid                 = 0;
5151     dst->poll_count              = 0;
5152     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5153 }
5154 #  endif /* USE_ITHREADS */
5155 #endif /* HAVE_INTERP_INTERN */
5156
5157 static void
5158 win32_free_argvw(pTHX_ void *ptr)
5159 {
5160     char** argv = (char**)ptr;
5161     while(*argv) {
5162         Safefree(*argv);
5163         *argv++ = Nullch;
5164     }
5165 }
5166
5167 void
5168 win32_argv2utf8(int argc, char** argv)
5169 {
5170     dTHX;
5171     char* psz;
5172     int length, wargc;
5173     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5174     if (lpwStr && argc) {
5175         while (argc--) {
5176             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5177             Newz(0, psz, length, char);
5178             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5179             argv[argc] = psz;
5180         }
5181         call_atexit(win32_free_argvw, argv);
5182     }
5183     GlobalFree((HGLOBAL)lpwStr);
5184 }