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