win32/win32.c

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