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