win32/win32.c

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