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