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