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