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