win32/win32.c

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