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