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             if (!IsWin95())
3605                 len += 3;
3606         }
3607         else {
3608             char *exe = strrchr(cname, '/');
3609             char *exe2 = strrchr(cname, '\\');
3610             if (exe2 > exe)
3611                 exe = exe2;
3612             if (exe)
3613                 ++exe;
3614             else
3615                 exe = cname;
3616             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3617                 cmd_shell = TRUE;
3618                 len += 3;
3619             }
3620             else if (stricmp(exe, "command.com") == 0
3621                      || stricmp(exe, "command") == 0)
3622             {
3623                 dumb_shell = TRUE;
3624             }
3625         }
3626     }
3627
3628     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3629     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3630         STRLEN curlen = strlen(arg);
3631         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3632             len += 2;   /* assume quoting needed (worst case) */
3633         len += curlen + 1;
3634         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3635     }
3636     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3637
3638     argc = index;
3639     New(1310, cmd, len, char);
3640     ptr = cmd;
3641
3642     if (bat_file && !IsWin95()) {
3643         *ptr++ = '"';
3644         extra_quotes = TRUE;
3645     }
3646
3647     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3648         bool do_quote = 0;
3649         STRLEN curlen = strlen(arg);
3650
3651         /* we want to protect empty arguments and ones with spaces with
3652          * dquotes, but only if they aren't already there */
3653         if (!dumb_shell) {
3654             if (!curlen) {
3655                 do_quote = 1;
3656             }
3657             else if (quote_next) {
3658                 /* see if it really is multiple arguments pretending to
3659                  * be one and force a set of quotes around it */
3660                 if (*find_next_space(arg))
3661                     do_quote = 1;
3662             }
3663             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3664                 STRLEN i = 0;
3665                 while (i < curlen) {
3666                     if (isSPACE(arg[i])) {
3667                         do_quote = 1;
3668                     }
3669                     else if (arg[i] == '"') {
3670                         do_quote = 0;
3671                         break;
3672                     }
3673                     i++;
3674                 }
3675             }
3676         }
3677
3678         if (do_quote)
3679             *ptr++ = '"';
3680
3681         strcpy(ptr, arg);
3682         ptr += curlen;
3683
3684         if (do_quote)
3685             *ptr++ = '"';
3686
3687         if (args[index+1])
3688             *ptr++ = ' ';
3689
3690         if (!extra_quotes
3691             && cmd_shell
3692             && curlen >= 2
3693             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3694             && stricmp(arg+curlen-2, "/c") == 0)
3695         {
3696             /* is there a next argument? */
3697             if (args[index+1]) {
3698                 /* are there two or more next arguments? */
3699                 if (args[index+2]) {
3700                     *ptr++ = '"';
3701                     extra_quotes = TRUE;
3702                 }
3703                 else {
3704                     /* single argument, force quoting if it has spaces */
3705                     quote_next = TRUE;
3706                 }
3707             }
3708         }
3709     }
3710
3711     if (extra_quotes)
3712         *ptr++ = '"';
3713
3714     *ptr = '\0';
3715
3716     return cmd;
3717 }
3718
3719 static char *
3720 qualified_path(const char *cmd)
3721 {
3722     dTHX;
3723     char *pathstr;
3724     char *fullcmd, *curfullcmd;
3725     STRLEN cmdlen = 0;
3726     int has_slash = 0;
3727
3728     if (!cmd)
3729         return Nullch;
3730     fullcmd = (char*)cmd;
3731     while (*fullcmd) {
3732         if (*fullcmd == '/' || *fullcmd == '\\')
3733             has_slash++;
3734         fullcmd++;
3735         cmdlen++;
3736     }
3737
3738     /* look in PATH */
3739     pathstr = PerlEnv_getenv("PATH");
3740
3741     /* worst case: PATH is a single directory; we need additional space
3742      * to append "/", ".exe" and trailing "\0" */
3743     New(0, fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3744     curfullcmd = fullcmd;
3745
3746     while (1) {
3747         DWORD res;
3748
3749         /* start by appending the name to the current prefix */
3750         strcpy(curfullcmd, cmd);
3751         curfullcmd += cmdlen;
3752
3753         /* if it doesn't end with '.', or has no extension, try adding
3754          * a trailing .exe first */
3755         if (cmd[cmdlen-1] != '.'
3756             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3757         {
3758             strcpy(curfullcmd, ".exe");
3759             res = GetFileAttributes(fullcmd);
3760             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3761                 return fullcmd;
3762             *curfullcmd = '\0';
3763         }
3764
3765         /* that failed, try the bare name */
3766         res = GetFileAttributes(fullcmd);
3767         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3768             return fullcmd;
3769
3770         /* quit if no other path exists, or if cmd already has path */
3771         if (!pathstr || !*pathstr || has_slash)
3772             break;
3773
3774         /* skip leading semis */
3775         while (*pathstr == ';')
3776             pathstr++;
3777
3778         /* build a new prefix from scratch */
3779         curfullcmd = fullcmd;
3780         while (*pathstr && *pathstr != ';') {
3781             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
3782                 pathstr++;              /* skip initial '"' */
3783                 while (*pathstr && *pathstr != '"') {
3784                     *curfullcmd++ = *pathstr++;
3785                 }
3786                 if (*pathstr)
3787                     pathstr++;          /* skip trailing '"' */
3788             }
3789             else {
3790                 *curfullcmd++ = *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
4159 void *
4160 sbrk(ptrdiff_t need)
4161 {
4162  void *result;
4163  if (!pagesize)
4164   {SYSTEM_INFO info;
4165    GetSystemInfo(&info);
4166    /* Pretend page size is larger so we don't perpetually
4167     * call the OS to commit just one page ...
4168     */
4169    pagesize = info.dwPageSize << 3;
4170   }
4171  if (brk+need >= reserved)
4172   {
4173    DWORD size = brk+need-reserved;
4174    char *addr;
4175    char *prev_committed = NULL;
4176    if (committed && reserved && committed < reserved)
4177     {
4178      /* Commit last of previous chunk cannot span allocations */
4179      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4180      if (addr)
4181       {
4182       /* Remember where we committed from in case we want to decommit later */
4183       prev_committed = committed;
4184       committed = reserved;
4185       }
4186     }
4187    /* Reserve some (more) space
4188     * Contiguous blocks give us greater efficiency, so reserve big blocks -
4189     * this is only address space not memory...
4190     * Note this is a little sneaky, 1st call passes NULL as reserved
4191     * so lets system choose where we start, subsequent calls pass
4192     * the old end address so ask for a contiguous block
4193     */
4194 sbrk_reserve:
4195    if (size < 64*1024*1024)
4196     size = 64*1024*1024;
4197    size = ((size + pagesize - 1) / pagesize) * pagesize;
4198    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4199    if (addr)
4200     {
4201      reserved = addr+size;
4202      if (!base)
4203       base = addr;
4204      if (!committed)
4205       committed = base;
4206      if (!brk)
4207       brk = committed;
4208     }
4209    else if (reserved)
4210     {
4211       /* The existing block could not be extended far enough, so decommit
4212        * anything that was just committed above and start anew */
4213       if (prev_committed)
4214        {
4215        if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4216         return (void *) -1;
4217        }
4218       reserved = base = committed = brk = NULL;
4219       size = need;
4220       goto sbrk_reserve;
4221     }
4222    else
4223     {
4224      return (void *) -1;
4225     }
4226   }
4227  result = brk;
4228  brk += need;
4229  if (brk > committed)
4230   {
4231    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4232    char *addr;
4233    if (committed+size > reserved)
4234     size = reserved-committed;
4235    addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4236    if (addr)
4237     committed += size;
4238    else
4239     return (void *) -1;
4240   }
4241  return result;
4242 }
4243
4244 #endif
4245 #endif
4246
4247 DllExport void*
4248 win32_malloc(size_t size)
4249 {
4250     return malloc(size);
4251 }
4252
4253 DllExport void*
4254 win32_calloc(size_t numitems, size_t size)
4255 {
4256     return calloc(numitems,size);
4257 }
4258
4259 DllExport void*
4260 win32_realloc(void *block, size_t size)
4261 {
4262     return realloc(block,size);
4263 }
4264
4265 DllExport void
4266 win32_free(void *block)
4267 {
4268     free(block);
4269 }
4270
4271
4272 DllExport int
4273 win32_open_osfhandle(intptr_t handle, int flags)
4274 {
4275 #ifdef USE_FIXED_OSFHANDLE
4276     if (IsWin95())
4277         return my_open_osfhandle(handle, flags);
4278 #endif
4279     return _open_osfhandle(handle, flags);
4280 }
4281
4282 DllExport intptr_t
4283 win32_get_osfhandle(int fd)
4284 {
4285     return (intptr_t)_get_osfhandle(fd);
4286 }
4287
4288 DllExport FILE *
4289 win32_fdupopen(FILE *pf)
4290 {
4291     FILE* pfdup;
4292     fpos_t pos;
4293     char mode[3];
4294     int fileno = win32_dup(win32_fileno(pf));
4295
4296     /* open the file in the same mode */
4297 #ifdef __BORLANDC__
4298     if((pf)->flags & _F_READ) {
4299         mode[0] = 'r';
4300         mode[1] = 0;
4301     }
4302     else if((pf)->flags & _F_WRIT) {
4303         mode[0] = 'a';
4304         mode[1] = 0;
4305     }
4306     else if((pf)->flags & _F_RDWR) {
4307         mode[0] = 'r';
4308         mode[1] = '+';
4309         mode[2] = 0;
4310     }
4311 #else
4312     if((pf)->_flag & _IOREAD) {
4313         mode[0] = 'r';
4314         mode[1] = 0;
4315     }
4316     else if((pf)->_flag & _IOWRT) {
4317         mode[0] = 'a';
4318         mode[1] = 0;
4319     }
4320     else if((pf)->_flag & _IORW) {
4321         mode[0] = 'r';
4322         mode[1] = '+';
4323         mode[2] = 0;
4324     }
4325 #endif
4326
4327     /* it appears that the binmode is attached to the
4328      * file descriptor so binmode files will be handled
4329      * correctly
4330      */
4331     pfdup = win32_fdopen(fileno, mode);
4332
4333     /* move the file pointer to the same position */
4334     if (!fgetpos(pf, &pos)) {
4335         fsetpos(pfdup, &pos);
4336     }
4337     return pfdup;
4338 }
4339
4340 DllExport void*
4341 win32_dynaload(const char* filename)
4342 {
4343     dTHX;
4344     HMODULE hModule;
4345     char buf[MAX_PATH+1];
4346     char *first;
4347
4348     /* LoadLibrary() doesn't recognize forward slashes correctly,
4349      * so turn 'em back. */
4350     first = strchr(filename, '/');
4351     if (first) {
4352         STRLEN len = strlen(filename);
4353         if (len <= MAX_PATH) {
4354             strcpy(buf, filename);
4355             filename = &buf[first - filename];
4356             while (*filename) {
4357                 if (*filename == '/')
4358                     *(char*)filename = '\\';
4359                 ++filename;
4360             }
4361             filename = buf;
4362         }
4363     }
4364     if (USING_WIDE()) {
4365         WCHAR wfilename[MAX_PATH+1];
4366         A2WHELPER(filename, wfilename, sizeof(wfilename));
4367         hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4368     }
4369     else {
4370         hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4371     }
4372     return hModule;
4373 }
4374
4375 /*
4376  * Extras.
4377  */
4378
4379 static
4380 XS(w32_SetChildShowWindow)
4381 {
4382     dXSARGS;
4383     BOOL use_showwindow = w32_use_showwindow;
4384     /* use "unsigned short" because Perl has redefined "WORD" */
4385     unsigned short showwindow = w32_showwindow;
4386
4387     if (items > 1)
4388         Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4389
4390     if (items == 0 || !SvOK(ST(0)))
4391         w32_use_showwindow = FALSE;
4392     else {
4393         w32_use_showwindow = TRUE;
4394         w32_showwindow = (unsigned short)SvIV(ST(0));
4395     }
4396
4397     EXTEND(SP, 1);
4398     if (use_showwindow)
4399         ST(0) = sv_2mortal(newSViv(showwindow));
4400     else
4401         ST(0) = &PL_sv_undef;
4402     XSRETURN(1);
4403 }
4404
4405 static
4406 XS(w32_GetCwd)
4407 {
4408     dXSARGS;
4409     /* Make the host for current directory */
4410     char* ptr = PerlEnv_get_childdir();
4411     /*
4412      * If ptr != Nullch
4413      *   then it worked, set PV valid,
4414      *   else return 'undef'
4415      */
4416     if (ptr) {
4417         SV *sv = sv_newmortal();
4418         sv_setpv(sv, ptr);
4419         PerlEnv_free_childdir(ptr);
4420
4421 #ifndef INCOMPLETE_TAINTS
4422         SvTAINTED_on(sv);
4423 #endif
4424
4425         EXTEND(SP,1);
4426         SvPOK_on(sv);
4427         ST(0) = sv;
4428         XSRETURN(1);
4429     }
4430     XSRETURN_UNDEF;
4431 }
4432
4433 static
4434 XS(w32_SetCwd)
4435 {
4436     dXSARGS;
4437     if (items != 1)
4438         Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4439     if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4440         XSRETURN_YES;
4441
4442     XSRETURN_NO;
4443 }
4444
4445 static
4446 XS(w32_GetNextAvailDrive)
4447 {
4448     dXSARGS;
4449     char ix = 'C';
4450     char root[] = "_:\\";
4451
4452     EXTEND(SP,1);
4453     while (ix <= 'Z') {
4454         root[0] = ix++;
4455         if (GetDriveType(root) == 1) {
4456             root[2] = '\0';
4457             XSRETURN_PV(root);
4458         }
4459     }
4460     XSRETURN_UNDEF;
4461 }
4462
4463 static
4464 XS(w32_GetLastError)
4465 {
4466     dXSARGS;
4467     EXTEND(SP,1);
4468     XSRETURN_IV(GetLastError());
4469 }
4470
4471 static
4472 XS(w32_SetLastError)
4473 {
4474     dXSARGS;
4475     if (items != 1)
4476         Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4477     SetLastError(SvIV(ST(0)));
4478     XSRETURN_EMPTY;
4479 }
4480
4481 static
4482 XS(w32_LoginName)
4483 {
4484     dXSARGS;
4485     char *name = w32_getlogin_buffer;
4486     DWORD size = sizeof(w32_getlogin_buffer);
4487     EXTEND(SP,1);
4488     if (GetUserName(name,&size)) {
4489         /* size includes NULL */
4490         ST(0) = sv_2mortal(newSVpvn(name,size-1));
4491         XSRETURN(1);
4492     }
4493     XSRETURN_UNDEF;
4494 }
4495
4496 static
4497 XS(w32_NodeName)
4498 {
4499     dXSARGS;
4500     char name[MAX_COMPUTERNAME_LENGTH+1];
4501     DWORD size = sizeof(name);
4502     EXTEND(SP,1);
4503     if (GetComputerName(name,&size)) {
4504         /* size does NOT include NULL :-( */
4505         ST(0) = sv_2mortal(newSVpvn(name,size));
4506         XSRETURN(1);
4507     }
4508     XSRETURN_UNDEF;
4509 }
4510
4511
4512 static
4513 XS(w32_DomainName)
4514 {
4515     dXSARGS;
4516     HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4517     DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4518     DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4519                                           void *bufptr);
4520
4521     if (hNetApi32) {
4522         pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4523             GetProcAddress(hNetApi32, "NetApiBufferFree");
4524         pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4525             GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4526     }
4527     EXTEND(SP,1);
4528     if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4529         /* this way is more reliable, in case user has a local account. */
4530         char dname[256];
4531         DWORD dnamelen = sizeof(dname);
4532         struct {
4533             DWORD   wki100_platform_id;
4534             LPWSTR  wki100_computername;
4535             LPWSTR  wki100_langroup;
4536             DWORD   wki100_ver_major;
4537             DWORD   wki100_ver_minor;
4538         } *pwi;
4539         /* NERR_Success *is* 0*/
4540         if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4541             if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4542                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4543                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4544             }
4545             else {
4546                 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4547                                     -1, (LPSTR)dname, dnamelen, NULL, NULL);
4548             }
4549             pfnNetApiBufferFree(pwi);
4550             FreeLibrary(hNetApi32);
4551             XSRETURN_PV(dname);
4552         }
4553         FreeLibrary(hNetApi32);
4554     }
4555     else {
4556         /* Win95 doesn't have NetWksta*(), so do it the old way */
4557         char name[256];
4558         DWORD size = sizeof(name);
4559         if (hNetApi32)
4560             FreeLibrary(hNetApi32);
4561         if (GetUserName(name,&size)) {
4562             char sid[ONE_K_BUFSIZE];
4563             DWORD sidlen = sizeof(sid);
4564             char dname[256];
4565             DWORD dnamelen = sizeof(dname);
4566             SID_NAME_USE snu;
4567             if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4568                                   dname, &dnamelen, &snu)) {
4569                 XSRETURN_PV(dname);             /* all that for this */
4570             }
4571         }
4572     }
4573     XSRETURN_UNDEF;
4574 }
4575
4576 static
4577 XS(w32_FsType)
4578 {
4579     dXSARGS;
4580     char fsname[256];
4581     DWORD flags, filecomplen;
4582     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4583                          &flags, fsname, sizeof(fsname))) {
4584         if (GIMME_V == G_ARRAY) {
4585             XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4586             XPUSHs(sv_2mortal(newSViv(flags)));
4587             XPUSHs(sv_2mortal(newSViv(filecomplen)));
4588             PUTBACK;
4589             return;
4590         }
4591         EXTEND(SP,1);
4592         XSRETURN_PV(fsname);
4593     }
4594     XSRETURN_EMPTY;
4595 }
4596
4597 static
4598 XS(w32_GetOSVersion)
4599 {
4600     dXSARGS;
4601     /* Use explicit struct definition because wSuiteMask and
4602      * wProductType are not defined in the VC++ 6.0 headers.
4603      * WORD type has been replaced by unsigned short because
4604      * WORD is already used by Perl itself.
4605      */
4606     struct {
4607         DWORD dwOSVersionInfoSize;
4608         DWORD dwMajorVersion;
4609         DWORD dwMinorVersion;
4610         DWORD dwBuildNumber;
4611         DWORD dwPlatformId;
4612         CHAR  szCSDVersion[128];
4613         unsigned short wServicePackMajor;
4614         unsigned short wServicePackMinor;
4615         unsigned short wSuiteMask;
4616         BYTE  wProductType;
4617         BYTE  wReserved;
4618     }   osver;
4619     BOOL bEx = TRUE;
4620
4621     if (USING_WIDE()) {
4622         struct {
4623             DWORD dwOSVersionInfoSize;
4624             DWORD dwMajorVersion;
4625             DWORD dwMinorVersion;
4626             DWORD dwBuildNumber;
4627             DWORD dwPlatformId;
4628             WCHAR szCSDVersion[128];
4629             unsigned short wServicePackMajor;
4630             unsigned short wServicePackMinor;
4631             unsigned short wSuiteMask;
4632             BYTE  wProductType;
4633             BYTE  wReserved;
4634         } osverw;
4635         char szCSDVersion[sizeof(osverw.szCSDVersion)];
4636         osverw.dwOSVersionInfoSize = sizeof(osverw);
4637         if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4638             bEx = FALSE;
4639             osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4640             if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4641                 XSRETURN_EMPTY;
4642             }
4643         }
4644         if (GIMME_V == G_SCALAR) {
4645             XSRETURN_IV(osverw.dwPlatformId);
4646         }
4647         W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4648         XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4649         osver.dwMajorVersion    = osverw.dwMajorVersion;
4650         osver.dwMinorVersion    = osverw.dwMinorVersion;
4651         osver.dwBuildNumber     = osverw.dwBuildNumber;
4652         osver.dwPlatformId      = osverw.dwPlatformId;
4653         osver.wServicePackMajor = osverw.wServicePackMajor;
4654         osver.wServicePackMinor = osverw.wServicePackMinor;
4655         osver.wSuiteMask        = osverw.wSuiteMask;
4656         osver.wProductType      = osverw.wProductType;
4657     }
4658     else {
4659         osver.dwOSVersionInfoSize = sizeof(osver);
4660         if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4661             bEx = FALSE;
4662             osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4663             if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4664                 XSRETURN_EMPTY;
4665             }
4666         }
4667         if (GIMME_V == G_SCALAR) {
4668             XSRETURN_IV(osver.dwPlatformId);
4669         }
4670         XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4671     }
4672     XPUSHs(newSViv(osver.dwMajorVersion));
4673     XPUSHs(newSViv(osver.dwMinorVersion));
4674     XPUSHs(newSViv(osver.dwBuildNumber));
4675     XPUSHs(newSViv(osver.dwPlatformId));
4676     if (bEx) {
4677         XPUSHs(newSViv(osver.wServicePackMajor));
4678         XPUSHs(newSViv(osver.wServicePackMinor));
4679         XPUSHs(newSViv(osver.wSuiteMask));
4680         XPUSHs(newSViv(osver.wProductType));
4681     }
4682     PUTBACK;
4683 }
4684
4685 static
4686 XS(w32_IsWinNT)
4687 {
4688     dXSARGS;
4689     EXTEND(SP,1);
4690     XSRETURN_IV(IsWinNT());
4691 }
4692
4693 static
4694 XS(w32_IsWin95)
4695 {
4696     dXSARGS;
4697     EXTEND(SP,1);
4698     XSRETURN_IV(IsWin95());
4699 }
4700
4701 static
4702 XS(w32_FormatMessage)
4703 {
4704     dXSARGS;
4705     DWORD source = 0;
4706     char msgbuf[ONE_K_BUFSIZE];
4707
4708     if (items != 1)
4709         Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4710
4711     if (USING_WIDE()) {
4712         WCHAR wmsgbuf[ONE_K_BUFSIZE];
4713         if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4714                           &source, SvIV(ST(0)), 0,
4715                           wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4716         {
4717             W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4718             XSRETURN_PV(msgbuf);
4719         }
4720     }
4721     else {
4722         if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4723                           &source, SvIV(ST(0)), 0,
4724                           msgbuf, sizeof(msgbuf)-1, NULL))
4725             XSRETURN_PV(msgbuf);
4726     }
4727
4728     XSRETURN_UNDEF;
4729 }
4730
4731 static
4732 XS(w32_Spawn)
4733 {
4734     dXSARGS;
4735     char *cmd, *args;
4736     void *env;
4737     char *dir;
4738     PROCESS_INFORMATION stProcInfo;
4739     STARTUPINFO stStartInfo;
4740     BOOL bSuccess = FALSE;
4741
4742     if (items != 3)
4743         Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4744
4745     cmd = SvPV_nolen(ST(0));
4746     args = SvPV_nolen(ST(1));
4747
4748     env = PerlEnv_get_childenv();
4749     dir = PerlEnv_get_childdir();
4750
4751     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
4752     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
4753     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
4754     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
4755
4756     if (CreateProcess(
4757                 cmd,                    /* Image path */
4758                 args,                   /* Arguments for command line */
4759                 NULL,                   /* Default process security */
4760                 NULL,                   /* Default thread security */
4761                 FALSE,                  /* Must be TRUE to use std handles */
4762                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
4763                 env,                    /* Inherit our environment block */
4764                 dir,                    /* Inherit our currrent directory */
4765                 &stStartInfo,           /* -> Startup info */
4766                 &stProcInfo))           /* <- Process info (if OK) */
4767     {
4768         int pid = (int)stProcInfo.dwProcessId;
4769         if (IsWin95() && pid < 0)
4770             pid = -pid;
4771         sv_setiv(ST(2), pid);
4772         CloseHandle(stProcInfo.hThread);/* library source code does this. */
4773         bSuccess = TRUE;
4774     }
4775     PerlEnv_free_childenv(env);
4776     PerlEnv_free_childdir(dir);
4777     XSRETURN_IV(bSuccess);
4778 }
4779
4780 static
4781 XS(w32_GetTickCount)
4782 {
4783     dXSARGS;
4784     DWORD msec = GetTickCount();
4785     EXTEND(SP,1);
4786     if ((IV)msec > 0)
4787         XSRETURN_IV(msec);
4788     XSRETURN_NV(msec);
4789 }
4790
4791 static
4792 XS(w32_GetShortPathName)
4793 {
4794     dXSARGS;
4795     SV *shortpath;
4796     DWORD len;
4797
4798     if (items != 1)
4799         Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4800
4801     shortpath = sv_mortalcopy(ST(0));
4802     SvUPGRADE(shortpath, SVt_PV);
4803     if (!SvPVX(shortpath) || !SvLEN(shortpath))
4804         XSRETURN_UNDEF;
4805
4806     /* src == target is allowed */
4807     do {
4808         len = GetShortPathName(SvPVX(shortpath),
4809                                SvPVX(shortpath),
4810                                SvLEN(shortpath));
4811     } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4812     if (len) {
4813         SvCUR_set(shortpath,len);
4814         *SvEND(shortpath) = '\0';
4815         ST(0) = shortpath;
4816         XSRETURN(1);
4817     }
4818     XSRETURN_UNDEF;
4819 }
4820
4821 static
4822 XS(w32_GetFullPathName)
4823 {
4824     dXSARGS;
4825     SV *filename;
4826     SV *fullpath;
4827     char *filepart;
4828     DWORD len;
4829     STRLEN filename_len;
4830     char *filename_p;
4831
4832     if (items != 1)
4833         Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4834
4835     filename = ST(0);
4836     filename_p = SvPV(filename, filename_len);
4837     fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4838     if (!SvPVX(fullpath) || !SvLEN(fullpath))
4839         XSRETURN_UNDEF;
4840
4841     do {
4842         len = GetFullPathName(SvPVX(filename),
4843                               SvLEN(fullpath),
4844                               SvPVX(fullpath),
4845                               &filepart);
4846     } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4847     if (len) {
4848         if (GIMME_V == G_ARRAY) {
4849             EXTEND(SP,1);
4850             if (filepart) {
4851                 XST_mPV(1,filepart);
4852                 len = filepart - SvPVX(fullpath);
4853             }
4854             else {
4855                 XST_mPVN(1,"",0);
4856             }
4857             items = 2;
4858         }
4859         SvCUR_set(fullpath,len);
4860         *SvEND(fullpath) = '\0';
4861         ST(0) = fullpath;
4862         XSRETURN(items);
4863     }
4864     XSRETURN_EMPTY;
4865 }
4866
4867 static
4868 XS(w32_GetLongPathName)
4869 {
4870     dXSARGS;
4871     SV *path;
4872     char tmpbuf[MAX_PATH+1];
4873     char *pathstr;
4874     STRLEN len;
4875
4876     if (items != 1)
4877         Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4878
4879     path = ST(0);
4880     pathstr = SvPV(path,len);
4881     strcpy(tmpbuf, pathstr);
4882     pathstr = win32_longpath(tmpbuf);
4883     if (pathstr) {
4884         ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4885         XSRETURN(1);
4886     }
4887     XSRETURN_EMPTY;
4888 }
4889
4890 static
4891 XS(w32_Sleep)
4892 {
4893     dXSARGS;
4894     if (items != 1)
4895         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4896     Sleep(SvIV(ST(0)));
4897     XSRETURN_YES;
4898 }
4899
4900 static
4901 XS(w32_CopyFile)
4902 {
4903     dXSARGS;
4904     BOOL bResult;
4905     if (items != 3)
4906         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4907     if (USING_WIDE()) {
4908         WCHAR wSourceFile[MAX_PATH+1];
4909         WCHAR wDestFile[MAX_PATH+1];
4910         A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4911         wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4912         A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4913         bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4914     }
4915     else {
4916         char szSourceFile[MAX_PATH+1];
4917         strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4918         bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4919     }
4920
4921     if (bResult)
4922         XSRETURN_YES;
4923     XSRETURN_NO;
4924 }
4925
4926 void
4927 Perl_init_os_extras(void)
4928 {
4929     dTHX;
4930     char *file = __FILE__;
4931     dXSUB_SYS;
4932
4933     /* these names are Activeware compatible */
4934     newXS("Win32::GetCwd", w32_GetCwd, file);
4935     newXS("Win32::SetCwd", w32_SetCwd, file);
4936     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4937     newXS("Win32::GetLastError", w32_GetLastError, file);
4938     newXS("Win32::SetLastError", w32_SetLastError, file);
4939     newXS("Win32::LoginName", w32_LoginName, file);
4940     newXS("Win32::NodeName", w32_NodeName, file);
4941     newXS("Win32::DomainName", w32_DomainName, file);
4942     newXS("Win32::FsType", w32_FsType, file);
4943     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4944     newXS("Win32::IsWinNT", w32_IsWinNT, file);
4945     newXS("Win32::IsWin95", w32_IsWin95, file);
4946     newXS("Win32::FormatMessage", w32_FormatMessage, file);
4947     newXS("Win32::Spawn", w32_Spawn, file);
4948     newXS("Win32::GetTickCount", w32_GetTickCount, file);
4949     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4950     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
4951     newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
4952     newXS("Win32::CopyFile", w32_CopyFile, file);
4953     newXS("Win32::Sleep", w32_Sleep, file);
4954     newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
4955
4956     /* XXX Bloat Alert! The following Activeware preloads really
4957      * ought to be part of Win32::Sys::*, so they're not included
4958      * here.
4959      */
4960     /* LookupAccountName
4961      * LookupAccountSID
4962      * InitiateSystemShutdown
4963      * AbortSystemShutdown
4964      * ExpandEnvrironmentStrings
4965      */
4966 }
4967
4968 void *
4969 win32_signal_context(void)
4970 {
4971     dTHX;
4972 #ifdef MULTIPLICITY
4973     if (!my_perl) {
4974         my_perl = PL_curinterp;
4975         PERL_SET_THX(my_perl);
4976     }
4977     return my_perl;
4978 #else
4979     return PL_curinterp;
4980 #endif
4981 }
4982
4983
4984 BOOL WINAPI
4985 win32_ctrlhandler(DWORD dwCtrlType)
4986 {
4987 #ifdef MULTIPLICITY
4988     dTHXa(PERL_GET_SIG_CONTEXT);
4989
4990     if (!my_perl)
4991         return FALSE;
4992 #endif
4993
4994     switch(dwCtrlType) {
4995     case CTRL_CLOSE_EVENT:
4996      /*  A signal that the system sends to all processes attached to a console when
4997          the user closes the console (either by choosing the Close command from the
4998          console window's System menu, or by choosing the End Task command from the
4999          Task List
5000       */
5001         if (do_raise(aTHX_ 1))        /* SIGHUP */
5002             sig_terminate(aTHX_ 1);
5003         return TRUE;
5004
5005     case CTRL_C_EVENT:
5006         /*  A CTRL+c signal was received */
5007         if (do_raise(aTHX_ SIGINT))
5008             sig_terminate(aTHX_ SIGINT);
5009         return TRUE;
5010
5011     case CTRL_BREAK_EVENT:
5012         /*  A CTRL+BREAK signal was received */
5013         if (do_raise(aTHX_ SIGBREAK))
5014             sig_terminate(aTHX_ SIGBREAK);
5015         return TRUE;
5016
5017     case CTRL_LOGOFF_EVENT:
5018       /*  A signal that the system sends to all console processes when a user is logging
5019           off. This signal does not indicate which user is logging off, so no
5020           assumptions can be made.
5021        */
5022         break;
5023     case CTRL_SHUTDOWN_EVENT:
5024       /*  A signal that the system sends to all console processes when the system is
5025           shutting down.
5026        */
5027         if (do_raise(aTHX_ SIGTERM))
5028             sig_terminate(aTHX_ SIGTERM);
5029         return TRUE;
5030     default:
5031         break;
5032     }
5033     return FALSE;
5034 }
5035
5036
5037 void
5038 Perl_win32_init(int *argcp, char ***argvp)
5039 {
5040     /* Disable floating point errors, Perl will trap the ones we
5041      * care about.  VC++ RTL defaults to switching these off
5042      * already, but the Borland RTL doesn't.  Since we don't
5043      * want to be at the vendor's whim on the default, we set
5044      * it explicitly here.
5045      */
5046 #if !defined(_ALPHA_) && !defined(__GNUC__)
5047     _control87(MCW_EM, MCW_EM);
5048 #endif
5049     MALLOC_INIT;
5050 }
5051
5052 void
5053 Perl_win32_term(void)
5054 {
5055     OP_REFCNT_TERM;
5056     MALLOC_TERM;
5057 }
5058
5059 void
5060 win32_get_child_IO(child_IO_table* ptbl)
5061 {
5062     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
5063     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
5064     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
5065 }
5066
5067 Sighandler_t
5068 win32_signal(int sig, Sighandler_t subcode)
5069 {
5070     dTHX;
5071     if (sig < SIG_SIZE) {
5072         int save_errno = errno;
5073         Sighandler_t result = signal(sig, subcode);
5074         if (result == SIG_ERR) {
5075             result = w32_sighandler[sig];
5076             errno = save_errno;
5077         }
5078         w32_sighandler[sig] = subcode;
5079         return result;
5080     }
5081     else {
5082         errno = EINVAL;
5083         return SIG_ERR;
5084     }
5085 }
5086
5087
5088 #ifdef HAVE_INTERP_INTERN
5089
5090
5091 static void
5092 win32_csighandler(int sig)
5093 {
5094 #if 0
5095     dTHXa(PERL_GET_SIG_CONTEXT);
5096     Perl_warn(aTHX_ "Got signal %d",sig);
5097 #endif
5098     /* Does nothing */
5099 }
5100
5101 void
5102 Perl_sys_intern_init(pTHX)
5103 {
5104     int i;
5105     w32_perlshell_tokens        = Nullch;
5106     w32_perlshell_vec           = (char**)NULL;
5107     w32_perlshell_items         = 0;
5108     w32_fdpid                   = newAV();
5109     New(1313, w32_children, 1, child_tab);
5110     w32_num_children            = 0;
5111 #  ifdef USE_ITHREADS
5112     w32_pseudo_id               = 0;
5113     New(1313, w32_pseudo_children, 1, child_tab);
5114     w32_num_pseudo_children     = 0;
5115 #  endif
5116     w32_timerid                 = 0;
5117     w32_poll_count              = 0;
5118     for (i=0; i < SIG_SIZE; i++) {
5119         w32_sighandler[i] = SIG_DFL;
5120     }
5121 #  ifdef MULTIPLICTY
5122     if (my_perl == PL_curinterp) {
5123 #  else
5124     {
5125 #  endif
5126         /* Force C runtime signal stuff to set its console handler */
5127         signal(SIGINT,&win32_csighandler);
5128         signal(SIGBREAK,&win32_csighandler);
5129         /* Push our handler on top */
5130         SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5131     }
5132 }
5133
5134 void
5135 Perl_sys_intern_clear(pTHX)
5136 {
5137     Safefree(w32_perlshell_tokens);
5138     Safefree(w32_perlshell_vec);
5139     /* NOTE: w32_fdpid is freed by sv_clean_all() */
5140     Safefree(w32_children);
5141     if (w32_timerid) {
5142         KillTimer(NULL,w32_timerid);
5143         w32_timerid=0;
5144     }
5145 #  ifdef MULTIPLICITY
5146     if (my_perl == PL_curinterp) {
5147 #  else
5148     {
5149 #  endif
5150         SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5151     }
5152 #  ifdef USE_ITHREADS
5153     Safefree(w32_pseudo_children);
5154 #  endif
5155 }
5156
5157 #  ifdef USE_ITHREADS
5158
5159 void
5160 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5161 {
5162     dst->perlshell_tokens       = Nullch;
5163     dst->perlshell_vec          = (char**)NULL;
5164     dst->perlshell_items        = 0;
5165     dst->fdpid                  = newAV();
5166     Newz(1313, dst->children, 1, child_tab);
5167     dst->pseudo_id              = 0;
5168     Newz(1313, dst->pseudo_children, 1, child_tab);
5169     dst->timerid                 = 0;
5170     dst->poll_count              = 0;
5171     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5172 }
5173 #  endif /* USE_ITHREADS */
5174 #endif /* HAVE_INTERP_INTERN */
5175
5176 static void
5177 win32_free_argvw(pTHX_ void *ptr)
5178 {
5179     char** argv = (char**)ptr;
5180     while(*argv) {
5181         Safefree(*argv);
5182         *argv++ = Nullch;
5183     }
5184 }
5185
5186 void
5187 win32_argv2utf8(int argc, char** argv)
5188 {
5189     dTHX;
5190     char* psz;
5191     int length, wargc;
5192     LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5193     if (lpwStr && argc) {
5194         while (argc--) {
5195             length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5196             Newz(0, psz, length, char);
5197             WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5198             argv[argc] = psz;
5199         }
5200         call_atexit(win32_free_argvw, argv);
5201     }
5202     GlobalFree((HGLOBAL)lpwStr);
5203 }