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