win32/wince.c

   1 /*  WINCE.C - stuff for Windows CE
   2  *
   3  *  Time-stamp: <26/10/01 15:25:20 keuchel@keuchelnt>
   4  *
   5  *  You may distribute under the terms of either the GNU General Public
   6  *  License or the Artistic License, as specified in the README file.
   7  */
   8
   9 #define WIN32_LEAN_AND_MEAN
  10 #define WIN32IO_IS_STDIO
  11 #include <windows.h>
  12 #include <signal.h>
  13
  14 #define PERLIO_NOT_STDIO 0
  15
  16 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
  17 #define PerlIO FILE
  18 #endif
  19
  20 #define wince_private
  21 #include "errno.h"
  22
  23 #include "EXTERN.h"
  24 #include "perl.h"
  25
  26 #define NO_XSLOCKS
  27 #define PERL_NO_GET_CONTEXT
  28 #include "XSUB.h"
  29
  30 #include "win32iop.h"
  31 #include <string.h>
  32 #include <stdarg.h>
  33 #include <float.h>
  34 #include <shellapi.h>
  35 #include <process.h>
  36
  37 #define perl
  38 #include "celib_defs.h"
  39 #include "cewin32.h"
  40 #include "cecrt.h"
  41 #include "cewin32_defs.h"
  42 #include "cecrt_defs.h"
  43
  44 #define GetCurrentDirectoryW XCEGetCurrentDirectoryW
  45
  46 #ifdef PALM_SIZE
  47 #include "stdio-palmsize.h"
  48 #endif
  49
  50 #define EXECF_EXEC 1
  51 #define EXECF_SPAWN 2
  52 #define EXECF_SPAWN_NOWAIT 3
  53
  54 #if defined(PERL_IMPLICIT_SYS)
  55 #  undef win32_get_privlib
  56 #  define win32_get_privlib g_win32_get_privlib
  57 #  undef win32_get_sitelib
  58 #  define win32_get_sitelib g_win32_get_sitelib
  59 #  undef win32_get_vendorlib
  60 #  define win32_get_vendorlib g_win32_get_vendorlib
  61 #  undef do_spawn
  62 #  define do_spawn g_do_spawn
  63 #  undef getlogin
  64 #  define getlogin g_getlogin
  65 #endif
  66
  67 static void             get_shell(void);
  68 static long             tokenize(const char *str, char **dest, char ***destv);
  69 static int              do_spawn2(pTHX_ char *cmd, int exectype);
  70 static BOOL             has_shell_metachars(char *ptr);
  71 static long             filetime_to_clock(PFILETIME ft);
  72 static BOOL             filetime_from_time(PFILETIME ft, time_t t);
  73 static char *           get_emd_part(SV **leading, char *trailing, ...);
  74 static void             remove_dead_process(long deceased);
  75 static long             find_pid(int pid);
  76 static char *           qualified_path(const char *cmd);
  77 static char *           win32_get_xlib(const char *pl, const char *xlib,
  78                                        const char *libname);
  79
  80 #ifdef USE_ITHREADS
  81 static void             remove_dead_pseudo_process(long child);
  82 static long             find_pseudo_pid(int pid);
  83 #endif
  84
  85 int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */
  86
  87 START_EXTERN_C
  88 HANDLE  w32_perldll_handle = INVALID_HANDLE_VALUE;
  89 char    w32_module_name[MAX_PATH+1];
  90 END_EXTERN_C
  91
  92 static DWORD    w32_platform = (DWORD)-1;
  93
  94 int
  95 IsWin95(void)
  96 {
  97   return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
  98 }
  99
 100 int
 101 IsWinNT(void)
 102 {
 103   return (win32_os_id() == VER_PLATFORM_WIN32_NT);
 104 }
 105
 106 int
 107 IsWinCE(void)
 108 {
 109   return (win32_os_id() == VER_PLATFORM_WIN32_CE);
 110 }
 111
 112 EXTERN_C void
 113 set_w32_module_name(void)
 114 {
 115   char* ptr;
 116   XCEGetModuleFileNameA((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
 117                                   ? XCEGetModuleHandleA(NULL)
 118                                   : w32_perldll_handle),
 119                         w32_module_name, sizeof(w32_module_name));
 120
 121   /* normalize to forward slashes */
 122   ptr = w32_module_name;
 123   while (*ptr) {
 124     if (*ptr == '\\')
 125       *ptr = '/';
 126     ++ptr;
 127   }
 128 }
 129
 130 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
 131 static char*
 132 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
 133 {
 134     /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
 135     HKEY handle;
 136     DWORD type;
 137     const char *subkey = "Software\\Perl";
 138     char *str = NULL;
 139     long retval;
 140
 141     retval = XCERegOpenKeyExA(hkey, subkey, 0, KEY_READ, &handle);
 142     if (retval == ERROR_SUCCESS) {
 143         DWORD datalen;
 144         retval = XCERegQueryValueExA(handle, valuename, 0, &type, NULL, &datalen);
 145         if (retval == ERROR_SUCCESS && type == REG_SZ) {
 146             dTHX;
 147             if (!*svp)
 148                 *svp = sv_2mortal(newSVpvn("",0));
 149             SvGROW(*svp, datalen);
 150             retval = XCERegQueryValueExA(handle, valuename, 0, NULL,
 151                                      (PBYTE)SvPVX(*svp), &datalen);
 152             if (retval == ERROR_SUCCESS) {
 153                 str = SvPVX(*svp);
 154                 SvCUR_set(*svp,datalen-1);
 155             }
 156         }
 157         RegCloseKey(handle);
 158     }
 159     return str;
 160 }
 161
 162 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
 163 static char*
 164 get_regstr(const char *valuename, SV **svp)
 165 {
 166     char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
 167     if (!str)
 168         str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
 169     return str;
 170 }
 171
 172 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
 173 static char *
 174 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
 175 {
 176     char base[10];
 177     va_list ap;
 178     char mod_name[MAX_PATH+1];
 179     char *ptr;
 180     char *optr;
 181     char *strip;
 182     int oldsize, newsize;
 183     STRLEN baselen;
 184
 185     va_start(ap, trailing_path);
 186     strip = va_arg(ap, char *);
 187
 188     sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
 189     baselen = strlen(base);
 190
 191     if (!*w32_module_name) {
 192         set_w32_module_name();
 193     }
 194     strcpy(mod_name, w32_module_name);
 195     ptr = strrchr(mod_name, '/');
 196     while (ptr && strip) {
 197         /* look for directories to skip back */
 198         optr = ptr;
 199         *ptr = '\0';
 200         ptr = strrchr(mod_name, '/');
 201         /* avoid stripping component if there is no slash,
 202          * or it doesn't match ... */
 203         if (!ptr || stricmp(ptr+1, strip) != 0) {
 204             /* ... but not if component matches m|5\.$patchlevel.*| */
 205             if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
 206                           && strncmp(strip, base, baselen) == 0
 207                           && strncmp(ptr+1, base, baselen) == 0))
 208             {
 209                 *optr = '/';
 210                 ptr = optr;
 211             }
 212         }
 213         strip = va_arg(ap, char *);
 214     }
 215     if (!ptr) {
 216         ptr = mod_name;
 217         *ptr++ = '.';
 218         *ptr = '/';
 219     }
 220     va_end(ap);
 221     strcpy(++ptr, trailing_path);
 222
 223     /* only add directory if it exists */
 224     if (XCEGetFileAttributesA(mod_name) != (DWORD) -1) {
 225         /* directory exists */
 226         dTHX;
 227         if (!*prev_pathp)
 228             *prev_pathp = sv_2mortal(newSVpvn("",0));
 229         sv_catpvn(*prev_pathp, ";", 1);
 230         sv_catpv(*prev_pathp, mod_name);
 231         return SvPVX(*prev_pathp);
 232     }
 233
 234     return NULL;
 235 }
 236
 237 char *
 238 win32_get_privlib(const char *pl)
 239 {
 240     dTHX;
 241     char *stdlib = "lib";
 242     char buffer[MAX_PATH+1];
 243     SV *sv = NULL;
 244
 245     /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || "";  */
 246     sprintf(buffer, "%s-%s", stdlib, pl);
 247     if (!get_regstr(buffer, &sv))
 248         (void)get_regstr(stdlib, &sv);
 249
 250     /* $stdlib .= ";$EMD/../../lib" */
 251     return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
 252 }
 253
 254 static char *
 255 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
 256 {
 257     dTHX;
 258     char regstr[40];
 259     char pathstr[MAX_PATH+1];
 260     DWORD datalen;
 261     int len, newsize;
 262     SV *sv1 = NULL;
 263     SV *sv2 = NULL;
 264
 265     /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
 266     sprintf(regstr, "%s-%s", xlib, pl);
 267     (void)get_regstr(regstr, &sv1);
 268
 269     /* $xlib .=
 270      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib";  */
 271     sprintf(pathstr, "%s/%s/lib", libname, pl);
 272     (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
 273
 274     /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
 275     (void)get_regstr(xlib, &sv2);
 276
 277     /* $xlib .=
 278      * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib";  */
 279     sprintf(pathstr, "%s/lib", libname);
 280     (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
 281
 282     if (!sv1 && !sv2)
 283         return NULL;
 284     if (!sv1)
 285         return SvPVX(sv2);
 286     if (!sv2)
 287         return SvPVX(sv1);
 288
 289     sv_catpvn(sv1, ";", 1);
 290     sv_catsv(sv1, sv2);
 291
 292     return SvPVX(sv1);
 293 }
 294
 295 char *
 296 win32_get_sitelib(const char *pl)
 297 {
 298     return win32_get_xlib(pl, "sitelib", "site");
 299 }
 300
 301 #ifndef PERL_VENDORLIB_NAME
 302 #  define PERL_VENDORLIB_NAME   "vendor"
 303 #endif
 304
 305 char *
 306 win32_get_vendorlib(const char *pl)
 307 {
 308     return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
 309 }
 310
 311 static BOOL
 312 has_shell_metachars(char *ptr)
 313 {
 314     int inquote = 0;
 315     char quote = '\0';
 316
 317     /*
 318      * Scan string looking for redirection (< or >) or pipe
 319      * characters (|) that are not in a quoted string.
 320      * Shell variable interpolation (%VAR%) can also happen inside strings.
 321      */
 322     while (*ptr) {
 323         switch(*ptr) {
 324         case '%':
 325             return TRUE;
 326         case '\'':
 327         case '\"':
 328             if (inquote) {
 329                 if (quote == *ptr) {
 330                     inquote = 0;
 331                     quote = '\0';
 332                 }
 333             }
 334             else {
 335                 quote = *ptr;
 336                 inquote++;
 337             }
 338             break;
 339         case '>':
 340         case '<':
 341         case '|':
 342             if (!inquote)
 343                 return TRUE;
 344         default:
 345             break;
 346         }
 347         ++ptr;
 348     }
 349     return FALSE;
 350 }
 351
 352 #if !defined(PERL_IMPLICIT_SYS)
 353 /* since the current process environment is being updated in util.c
 354  * the library functions will get the correct environment
 355  */
 356 PerlIO *
 357 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 358 {
 359   printf("popen(%s)\n", cmd);
 360
 361   Perl_croak(aTHX_ PL_no_func, "popen");
 362   return NULL;
 363 }
 364
 365 long
 366 Perl_my_pclose(pTHX_ PerlIO *fp)
 367 {
 368   Perl_croak(aTHX_ PL_no_func, "pclose");
 369   return -1;
 370 }
 371 #endif
 372
 373 DllExport unsigned long
 374 win32_os_id(void)
 375 {
 376     static OSVERSIONINFOA osver;
 377
 378     if (osver.dwPlatformId != w32_platform) {
 379         memset(&osver, 0, sizeof(OSVERSIONINFOA));
 380         osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
 381         XCEGetVersionExA(&osver);
 382         w32_platform = osver.dwPlatformId;
 383     }
 384     return (unsigned long)w32_platform;
 385 }
 386
 387 DllExport int
 388 win32_getpid(void)
 389 {
 390     int pid;
 391 #ifdef USE_ITHREADS
 392     dTHX;
 393     if (w32_pseudo_id)
 394         return -((int)w32_pseudo_id);
 395 #endif
 396     pid = xcegetpid();
 397     return pid;
 398 }
 399
 400 /* Tokenize a string.  Words are null-separated, and the list
 401  * ends with a doubled null.  Any character (except null and
 402  * including backslash) may be escaped by preceding it with a
 403  * backslash (the backslash will be stripped).
 404  * Returns number of words in result buffer.
 405  */
 406 static long
 407 tokenize(const char *str, char **dest, char ***destv)
 408 {
 409     char *retstart = NULL;
 410     char **retvstart = 0;
 411     int items = -1;
 412     if (str) {
 413         dTHX;
 414         int slen = strlen(str);
 415         register char *ret;
 416         register char **retv;
 417         Newx(ret, slen+2, char);
 418         Newx(retv, (slen+3)/2, char*);
 419
 420         retstart = ret;
 421         retvstart = retv;
 422         *retv = ret;
 423         items = 0;
 424         while (*str) {
 425             *ret = *str++;
 426             if (*ret == '\\' && *str)
 427                 *ret = *str++;
 428             else if (*ret == ' ') {
 429                 while (*str == ' ')
 430                     str++;
 431                 if (ret == retstart)
 432                     ret--;
 433                 else {
 434                     *ret = '\0';
 435                     ++items;
 436                     if (*str)
 437                         *++retv = ret+1;
 438                 }
 439             }
 440             else if (!*str)
 441                 ++items;
 442             ret++;
 443         }
 444         retvstart[items] = NULL;
 445         *ret++ = '\0';
 446         *ret = '\0';
 447     }
 448     *dest = retstart;
 449     *destv = retvstart;
 450     return items;
 451 }
 452
 453 DllExport int
 454 win32_pipe(int *pfd, unsigned int size, int mode)
 455 {
 456   dTHX;
 457   Perl_croak(aTHX_ PL_no_func, "pipe");
 458   return -1;
 459 }
 460
 461 DllExport int
 462 win32_times(struct tms *timebuf)
 463 {
 464   dTHX;
 465   Perl_croak(aTHX_ PL_no_func, "times");
 466   return -1;
 467 }
 468
 469 Sighandler_t
 470 win32_signal(int sig, Sighandler_t subcode)
 471 {
 472   return xcesignal(sig, subcode);
 473 }
 474
 475 static void
 476 get_shell(void)
 477 {
 478     dTHX;
 479     if (!w32_perlshell_tokens) {
 480         /* we don't use COMSPEC here for two reasons:
 481          *  1. the same reason perl on UNIX doesn't use SHELL--rampant and
 482          *     uncontrolled unportability of the ensuing scripts.
 483          *  2. PERL5SHELL could be set to a shell that may not be fit for
 484          *     interactive use (which is what most programs look in COMSPEC
 485          *     for).
 486          */
 487         const char* defaultshell = (IsWinNT()
 488                                     ? "cmd.exe /x/d/c" : "command.com /c");
 489         const char *usershell = PerlEnv_getenv("PERL5SHELL");
 490         w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
 491                                        &w32_perlshell_tokens,
 492                                        &w32_perlshell_vec);
 493     }
 494 }
 495
 496 int
 497 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
 498 {
 499   PERL_ARGS_ASSERT_DO_ASPAWN;
 500
 501   Perl_croak(aTHX_ PL_no_func, "aspawn");
 502   return -1;
 503 }
 504
 505 /* returns pointer to the next unquoted space or the end of the string */
 506 static char*
 507 find_next_space(const char *s)
 508 {
 509     bool in_quotes = FALSE;
 510     while (*s) {
 511         /* ignore doubled backslashes, or backslash+quote */
 512         if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
 513             s += 2;
 514         }
 515         /* keep track of when we're within quotes */
 516         else if (*s == '"') {
 517             s++;
 518             in_quotes = !in_quotes;
 519         }
 520         /* break it up only at spaces that aren't in quotes */
 521         else if (!in_quotes && isSPACE(*s))
 522             return (char*)s;
 523         else
 524             s++;
 525     }
 526     return (char*)s;
 527 }
 528
 529 #if 1
 530 static int
 531 do_spawn2(pTHX_ char *cmd, int exectype)
 532 {
 533     char **a;
 534     char *s;
 535     char **argv;
 536     int status = -1;
 537     BOOL needToTry = TRUE;
 538     char *cmd2;
 539
 540     /* Save an extra exec if possible. See if there are shell
 541      * metacharacters in it */
 542     if (!has_shell_metachars(cmd)) {
 543         Newx(argv, strlen(cmd) / 2 + 2, char*);
 544         Newx(cmd2, strlen(cmd) + 1, char);
 545         strcpy(cmd2, cmd);
 546         a = argv;
 547         for (s = cmd2; *s;) {
 548             while (*s && isSPACE(*s))
 549                 s++;
 550             if (*s)
 551                 *(a++) = s;
 552             s = find_next_space(s);
 553             if (*s)
 554                 *s++ = '\0';
 555         }
 556         *a = NULL;
 557         if (argv[0]) {
 558             switch (exectype) {
 559             case EXECF_SPAWN:
 560                 status = win32_spawnvp(P_WAIT, argv[0],
 561                                        (const char* const*)argv);
 562                 break;
 563             case EXECF_SPAWN_NOWAIT:
 564                 status = win32_spawnvp(P_NOWAIT, argv[0],
 565                                        (const char* const*)argv);
 566                 break;
 567             case EXECF_EXEC:
 568                 status = win32_execvp(argv[0], (const char* const*)argv);
 569                 break;
 570             }
 571             if (status != -1 || errno == 0)
 572                 needToTry = FALSE;
 573         }
 574         Safefree(argv);
 575         Safefree(cmd2);
 576     }
 577     if (needToTry) {
 578         char **argv;
 579         int i = -1;
 580         get_shell();
 581         Newx(argv, w32_perlshell_items + 2, char*);
 582         while (++i < w32_perlshell_items)
 583             argv[i] = w32_perlshell_vec[i];
 584         argv[i++] = cmd;
 585         argv[i] = NULL;
 586         switch (exectype) {
 587         case EXECF_SPAWN:
 588             status = win32_spawnvp(P_WAIT, argv[0],
 589                                    (const char* const*)argv);
 590             break;
 591         case EXECF_SPAWN_NOWAIT:
 592             status = win32_spawnvp(P_NOWAIT, argv[0],
 593                                    (const char* const*)argv);
 594             break;
 595         case EXECF_EXEC:
 596             status = win32_execvp(argv[0], (const char* const*)argv);
 597             break;
 598         }
 599         cmd = argv[0];
 600         Safefree(argv);
 601     }
 602     if (exectype == EXECF_SPAWN_NOWAIT) {
 603         if (IsWin95())
 604             PL_statusvalue = -1;        /* >16bits hint for pp_system() */
 605     }
 606     else {
 607         if (status < 0) {
 608             if (ckWARN(WARN_EXEC))
 609                 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
 610                      (exectype == EXECF_EXEC ? "exec" : "spawn"),
 611                      cmd, strerror(errno));
 612             status = 255 * 256;
 613         }
 614         else
 615             status *= 256;
 616         PL_statusvalue = status;
 617     }
 618     return (status);
 619 }
 620
 621 int
 622 Perl_do_spawn(pTHX_ char *cmd)
 623 {
 624     PERL_ARGS_ASSERT_DO_SPAWN;
 625
 626     return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
 627 }
 628
 629 int
 630 Perl_do_spawn_nowait(pTHX_ char *cmd)
 631 {
 632     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
 633
 634     return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
 635 }
 636
 637 bool
 638 Perl_do_exec(pTHX_ const char *cmd)
 639 {
 640     PERL_ARGS_ASSERT_DO_EXEC;
 641
 642     do_spawn2(aTHX_ cmd, EXECF_EXEC);
 643     return FALSE;
 644 }
 645
 646 /* The idea here is to read all the directory names into a string table
 647  * (separated by nulls) and when one of the other dir functions is called
 648  * return the pointer to the current file name.
 649  */
 650 DllExport DIR *
 651 win32_opendir(const char *filename)
 652 {
 653     dTHX;
 654     DIR                 *dirp;
 655     long                len;
 656     long                idx;
 657     char                scanname[MAX_PATH+3];
 658     Stat_t              sbuf;
 659     WIN32_FIND_DATAA    aFindData;
 660     WIN32_FIND_DATAW    wFindData;
 661     HANDLE              fh;
 662     char                buffer[MAX_PATH*2];
 663     WCHAR               wbuffer[MAX_PATH+1];
 664     char*               ptr;
 665
 666     len = strlen(filename);
 667     if (len > MAX_PATH)
 668         return NULL;
 669
 670     /* check to see if filename is a directory */
 671     if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
 672         return NULL;
 673
 674     /* Get us a DIR structure */
 675     Newxz(dirp, 1, DIR);
 676
 677     /* Create the search pattern */
 678     strcpy(scanname, filename);
 679
 680     /* bare drive name means look in cwd for drive */
 681     if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
 682         scanname[len++] = '.';
 683         scanname[len++] = '/';
 684     }
 685     else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
 686         scanname[len++] = '/';
 687     }
 688     scanname[len++] = '*';
 689     scanname[len] = '\0';
 690
 691     /* do the FindFirstFile call */
 692     fh = FindFirstFile(PerlDir_mapA(scanname), &aFindData);
 693     dirp->handle = fh;
 694     if (fh == INVALID_HANDLE_VALUE) {
 695         DWORD err = GetLastError();
 696         /* FindFirstFile() fails on empty drives! */
 697         switch (err) {
 698         case ERROR_FILE_NOT_FOUND:
 699             return dirp;
 700         case ERROR_NO_MORE_FILES:
 701         case ERROR_PATH_NOT_FOUND:
 702             errno = ENOENT;
 703             break;
 704         case ERROR_NOT_ENOUGH_MEMORY:
 705             errno = ENOMEM;
 706             break;
 707         default:
 708             errno = EINVAL;
 709             break;
 710         }
 711         Safefree(dirp);
 712         return NULL;
 713     }
 714
 715     /* now allocate the first part of the string table for
 716      * the filenames that we find.
 717      */
 718     ptr = aFindData.cFileName;
 719     idx = strlen(ptr)+1;
 720     if (idx < 256)
 721         dirp->size = 128;
 722     else
 723         dirp->size = idx;
 724     Newx(dirp->start, dirp->size, char);
 725     strcpy(dirp->start, ptr);
 726     dirp->nfiles++;
 727     dirp->end = dirp->curr = dirp->start;
 728     dirp->end += idx;
 729     return dirp;
 730 }
 731
 732
 733 /* Readdir just returns the current string pointer and bumps the
 734  * string pointer to the nDllExport entry.
 735  */
 736 DllExport struct direct *
 737 win32_readdir(DIR *dirp)
 738 {
 739     long         len;
 740
 741     if (dirp->curr) {
 742         /* first set up the structure to return */
 743         len = strlen(dirp->curr);
 744         strcpy(dirp->dirstr.d_name, dirp->curr);
 745         dirp->dirstr.d_namlen = len;
 746
 747         /* Fake an inode */
 748         dirp->dirstr.d_ino = dirp->curr - dirp->start;
 749
 750         /* Now set up for the next call to readdir */
 751         dirp->curr += len + 1;
 752         if (dirp->curr >= dirp->end) {
 753             dTHX;
 754             char*               ptr;
 755             BOOL                res;
 756             WIN32_FIND_DATAW    wFindData;
 757             WIN32_FIND_DATAA    aFindData;
 758             char                buffer[MAX_PATH*2];
 759
 760             /* finding the next file that matches the wildcard
 761              * (which should be all of them in this directory!).
 762              */
 763             res = FindNextFile(dirp->handle, &aFindData);
 764             if (res)
 765                 ptr = aFindData.cFileName;
 766             if (res) {
 767                 long endpos = dirp->end - dirp->start;
 768                 long newsize = endpos + strlen(ptr) + 1;
 769                 /* bump the string table size by enough for the
 770                  * new name and its null terminator */
 771                 while (newsize > dirp->size) {
 772                     long curpos = dirp->curr - dirp->start;
 773                     dirp->size *= 2;
 774                     Renew(dirp->start, dirp->size, char);
 775                     dirp->curr = dirp->start + curpos;
 776                 }
 777                 strcpy(dirp->start + endpos, ptr);
 778                 dirp->end = dirp->start + newsize;
 779                 dirp->nfiles++;
 780             }
 781             else
 782                 dirp->curr = NULL;
 783         }
 784         return &(dirp->dirstr);
 785     }
 786     else
 787         return NULL;
 788 }
 789
 790 /* Telldir returns the current string pointer position */
 791 DllExport long
 792 win32_telldir(DIR *dirp)
 793 {
 794     return (dirp->curr - dirp->start);
 795 }
 796
 797
 798 /* Seekdir moves the string pointer to a previously saved position
 799  * (returned by telldir).
 800  */
 801 DllExport void
 802 win32_seekdir(DIR *dirp, long loc)
 803 {
 804     dirp->curr = dirp->start + loc;
 805 }
 806
 807 /* Rewinddir resets the string pointer to the start */
 808 DllExport void
 809 win32_rewinddir(DIR *dirp)
 810 {
 811     dirp->curr = dirp->start;
 812 }
 813
 814 /* free the memory allocated by opendir */
 815 DllExport int
 816 win32_closedir(DIR *dirp)
 817 {
 818     dTHX;
 819     if (dirp->handle != INVALID_HANDLE_VALUE)
 820         FindClose(dirp->handle);
 821     Safefree(dirp->start);
 822     Safefree(dirp);
 823     return 1;
 824 }
 825
 826 #else
 827 /////!!!!!!!!!!! return here and do right stuff!!!!
 828
 829 DllExport DIR *
 830 win32_opendir(const char *filename)
 831 {
 832   return opendir(filename);
 833 }
 834
 835 DllExport struct direct *
 836 win32_readdir(DIR *dirp)
 837 {
 838   return readdir(dirp);
 839 }
 840
 841 DllExport long
 842 win32_telldir(DIR *dirp)
 843 {
 844   dTHX;
 845   Perl_croak(aTHX_ PL_no_func, "telldir");
 846   return -1;
 847 }
 848
 849 DllExport void
 850 win32_seekdir(DIR *dirp, long loc)
 851 {
 852   dTHX;
 853   Perl_croak(aTHX_ PL_no_func, "seekdir");
 854 }
 855
 856 DllExport void
 857 win32_rewinddir(DIR *dirp)
 858 {
 859   dTHX;
 860   Perl_croak(aTHX_ PL_no_func, "rewinddir");
 861 }
 862
 863 DllExport int
 864 win32_closedir(DIR *dirp)
 865 {
 866   closedir(dirp);
 867   return 0;
 868 }
 869 #endif   // 1
 870
 871 DllExport int
 872 win32_kill(int pid, int sig)
 873 {
 874   dTHX;
 875   Perl_croak(aTHX_ PL_no_func, "kill");
 876   return -1;
 877 }
 878
 879 DllExport int
 880 win32_stat(const char *path, struct stat *sbuf)
 881 {
 882   return xcestat(path, sbuf);
 883 }
 884
 885 DllExport char *
 886 win32_longpath(char *path)
 887 {
 888   return path;
 889 }
 890
 891 #ifndef USE_WIN32_RTL_ENV
 892
 893 DllExport char *
 894 win32_getenv(const char *name)
 895 {
 896   return xcegetenv(name);
 897 }
 898
 899 DllExport int
 900 win32_putenv(const char *name)
 901 {
 902   return xceputenv(name);
 903 }
 904
 905 #endif
 906
 907 static long
 908 filetime_to_clock(PFILETIME ft)
 909 {
 910     __int64 qw = ft->dwHighDateTime;
 911     qw <<= 32;
 912     qw |= ft->dwLowDateTime;
 913     qw /= 10000;  /* File time ticks at 0.1uS, clock at 1mS */
 914     return (long) qw;
 915 }
 916
 917 /* fix utime() so it works on directories in NT */
 918 static BOOL
 919 filetime_from_time(PFILETIME pFileTime, time_t Time)
 920 {
 921     struct tm *pTM = localtime(&Time);
 922     SYSTEMTIME SystemTime;
 923     FILETIME LocalTime;
 924
 925     if (pTM == NULL)
 926         return FALSE;
 927
 928     SystemTime.wYear   = pTM->tm_year + 1900;
 929     SystemTime.wMonth  = pTM->tm_mon + 1;
 930     SystemTime.wDay    = pTM->tm_mday;
 931     SystemTime.wHour   = pTM->tm_hour;
 932     SystemTime.wMinute = pTM->tm_min;
 933     SystemTime.wSecond = pTM->tm_sec;
 934     SystemTime.wMilliseconds = 0;
 935
 936     return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
 937            LocalFileTimeToFileTime(&LocalTime, pFileTime);
 938 }
 939
 940 DllExport int
 941 win32_unlink(const char *filename)
 942 {
 943   return xceunlink(filename);
 944 }
 945
 946 DllExport int
 947 win32_utime(const char *filename, struct utimbuf *times)
 948 {
 949   return xceutime(filename, (struct _utimbuf *) times);
 950 }
 951
 952 DllExport int
 953 win32_gettimeofday(struct timeval *tp, void *not_used)
 954 {
 955     return xcegettimeofday(tp,not_used);
 956 }
 957
 958 DllExport int
 959 win32_uname(struct utsname *name)
 960 {
 961     struct hostent *hep;
 962     STRLEN nodemax = sizeof(name->nodename)-1;
 963     OSVERSIONINFOA osver;
 964
 965     memset(&osver, 0, sizeof(OSVERSIONINFOA));
 966     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
 967     if (XCEGetVersionExA(&osver)) {
 968         /* sysname */
 969         switch (osver.dwPlatformId) {
 970         case VER_PLATFORM_WIN32_CE:
 971             strcpy(name->sysname, "Windows CE");
 972             break;
 973         case VER_PLATFORM_WIN32_WINDOWS:
 974             strcpy(name->sysname, "Windows");
 975             break;
 976         case VER_PLATFORM_WIN32_NT:
 977             strcpy(name->sysname, "Windows NT");
 978             break;
 979         case VER_PLATFORM_WIN32s:
 980             strcpy(name->sysname, "Win32s");
 981             break;
 982         default:
 983             strcpy(name->sysname, "Win32 Unknown");
 984             break;
 985         }
 986
 987         /* release */
 988         sprintf(name->release, "%d.%d",
 989                 osver.dwMajorVersion, osver.dwMinorVersion);
 990
 991         /* version */
 992         sprintf(name->version, "Build %d",
 993                 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
 994                 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
 995         if (osver.szCSDVersion[0]) {
 996             char *buf = name->version + strlen(name->version);
 997             sprintf(buf, " (%s)", osver.szCSDVersion);
 998         }
 999     }
1000     else {
1001         *name->sysname = '\0';
1002         *name->version = '\0';
1003         *name->release = '\0';
1004     }
1005
1006     /* nodename */
1007     hep = win32_gethostbyname("localhost");
1008     if (hep) {
1009         STRLEN len = strlen(hep->h_name);
1010         if (len <= nodemax) {
1011             strcpy(name->nodename, hep->h_name);
1012         }
1013         else {
1014             strncpy(name->nodename, hep->h_name, nodemax);
1015             name->nodename[nodemax] = '\0';
1016         }
1017     }
1018     else {
1019         DWORD sz = nodemax;
1020         if (!XCEGetComputerNameA(name->nodename, &sz))
1021             *name->nodename = '\0';
1022     }
1023
1024     /* machine (architecture) */
1025     {
1026         SYSTEM_INFO info;
1027         char *arch;
1028         GetSystemInfo(&info);
1029
1030         switch (info.wProcessorArchitecture) {
1031         case PROCESSOR_ARCHITECTURE_INTEL:
1032             arch = "x86"; break;
1033         case PROCESSOR_ARCHITECTURE_MIPS:
1034             arch = "mips"; break;
1035         case PROCESSOR_ARCHITECTURE_ALPHA:
1036             arch = "alpha"; break;
1037         case PROCESSOR_ARCHITECTURE_PPC:
1038             arch = "ppc"; break;
1039         case PROCESSOR_ARCHITECTURE_ARM:
1040             arch = "arm"; break;
1041         case PROCESSOR_HITACHI_SH3:
1042             arch = "sh3"; break;
1043         case PROCESSOR_SHx_SH3:
1044             arch = "sh3"; break;
1045
1046         default:
1047             arch = "unknown"; break;
1048         }
1049         strcpy(name->machine, arch);
1050     }
1051     return 0;
1052 }
1053
1054 /* Timing related stuff */
1055
1056 int
1057 do_raise(pTHX_ int sig)
1058 {
1059     if (sig < SIG_SIZE) {
1060         Sighandler_t handler = w32_sighandler[sig];
1061         if (handler == SIG_IGN) {
1062             return 0;
1063         }
1064         else if (handler != SIG_DFL) {
1065             (*handler)(sig);
1066             return 0;
1067         }
1068         else {
1069             /* Choose correct default behaviour */
1070             switch (sig) {
1071 #ifdef SIGCLD
1072                 case SIGCLD:
1073 #endif
1074 #ifdef SIGCHLD
1075                 case SIGCHLD:
1076 #endif
1077                 case 0:
1078                     return 0;
1079                 case SIGTERM:
1080                 default:
1081                     break;
1082             }
1083         }
1084     }
1085     /* Tell caller to exit thread/process as approriate */
1086     return 1;
1087 }
1088
1089 void
1090 sig_terminate(pTHX_ int sig)
1091 {
1092     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1093     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1094        thread
1095      */
1096     exit(sig);
1097 }
1098
1099 DllExport int
1100 win32_async_check(pTHX)
1101 {
1102     MSG msg;
1103     int ours = 1;
1104     /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1105      * and ignores window messages - should co-exist better with windows apps e.g. Tk
1106      */
1107     while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1108         int sig;
1109         switch(msg.message) {
1110
1111 #if 0
1112     /* Perhaps some other messages could map to signals ? ... */
1113         case WM_CLOSE:
1114         case WM_QUIT:
1115             /* Treat WM_QUIT like SIGHUP?  */
1116             sig = SIGHUP;
1117             goto Raise;
1118             break;
1119 #endif
1120
1121         /* We use WM_USER to fake kill() with other signals */
1122         case WM_USER: {
1123             sig = msg.wParam;
1124         Raise:
1125             if (do_raise(aTHX_ sig)) {
1126                    sig_terminate(aTHX_ sig);
1127             }
1128             break;
1129         }
1130
1131         case WM_TIMER: {
1132             /* alarm() is a one-shot but SetTimer() repeats so kill it */
1133             if (w32_timerid) {
1134                 KillTimer(NULL,w32_timerid);
1135                 w32_timerid=0;
1136             }
1137             /* Now fake a call to signal handler */
1138             if (do_raise(aTHX_ 14)) {
1139                 sig_terminate(aTHX_ 14);
1140             }
1141             break;
1142         }
1143
1144         /* Otherwise do normal Win32 thing - in case it is useful */
1145         default:
1146             TranslateMessage(&msg);
1147             DispatchMessage(&msg);
1148             ours = 0;
1149             break;
1150         }
1151     }
1152     w32_poll_count = 0;
1153
1154     /* Above or other stuff may have set a signal flag */
1155     if (PL_sig_pending) {
1156         despatch_signals();
1157     }
1158     return ours;
1159 }
1160
1161 /* This function will not return until the timeout has elapsed, or until
1162  * one of the handles is ready. */
1163 DllExport DWORD
1164 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1165 {
1166     /* We may need several goes at this - so compute when we stop */
1167     DWORD ticks = 0;
1168     if (timeout != INFINITE) {
1169         ticks = GetTickCount();
1170         timeout += ticks;
1171     }
1172     while (1) {
1173         DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1174         if (resultp)
1175            *resultp = result;
1176         if (result == WAIT_TIMEOUT) {
1177             /* Ran out of time - explicit return of zero to avoid -ve if we
1178                have scheduling issues
1179              */
1180             return 0;
1181         }
1182         if (timeout != INFINITE) {
1183             ticks = GetTickCount();
1184         }
1185         if (result == WAIT_OBJECT_0 + count) {
1186             /* Message has arrived - check it */
1187             (void)win32_async_check(aTHX);
1188         }
1189         else {
1190            /* Not timeout or message - one of handles is ready */
1191            break;
1192         }
1193     }
1194     /* compute time left to wait */
1195     ticks = timeout - ticks;
1196     /* If we are past the end say zero */
1197     return (ticks > 0) ? ticks : 0;
1198 }
1199
1200 static UINT timerid = 0;
1201
1202 static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
1203 {
1204     dTHX;
1205     KillTimer(NULL,timerid);
1206     timerid=0;
1207     sighandler(14);
1208 }
1209
1210 DllExport unsigned int
1211 win32_sleep(unsigned int t)
1212 {
1213   return xcesleep(t);
1214 }
1215
1216 DllExport unsigned int
1217 win32_alarm(unsigned int sec)
1218 {
1219     /*
1220      * the 'obvious' implentation is SetTimer() with a callback
1221      * which does whatever receiving SIGALRM would do
1222      * we cannot use SIGALRM even via raise() as it is not
1223      * one of the supported codes in <signal.h>
1224      *
1225      * Snag is unless something is looking at the message queue
1226      * nothing happens :-(
1227      */
1228     dTHX;
1229     if (sec)
1230      {
1231       timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
1232       if (!timerid)
1233        Perl_croak_nocontext("Cannot set timer");
1234      }
1235     else
1236      {
1237       if (timerid)
1238        {
1239         KillTimer(NULL,timerid);
1240         timerid=0;
1241        }
1242      }
1243     return 0;
1244 }
1245
1246 #ifdef HAVE_DES_FCRYPT
1247 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
1248 #endif
1249
1250 DllExport char *
1251 win32_crypt(const char *txt, const char *salt)
1252 {
1253     dTHX;
1254 #ifdef HAVE_DES_FCRYPT
1255     dTHR;
1256     return des_fcrypt(txt, salt, w32_crypt_buffer);
1257 #else
1258     Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
1259     return NULL;
1260 #endif
1261 }
1262
1263
1264 /*
1265  *  redirected io subsystem for all XS modules
1266  *
1267  */
1268
1269 DllExport int *
1270 win32_errno(void)
1271 {
1272     return (&errno);
1273 }
1274
1275 DllExport char ***
1276 win32_environ(void)
1277 {
1278   return (&(environ));
1279 }
1280
1281 /* the rest are the remapped stdio routines */
1282 DllExport FILE *
1283 win32_stderr(void)
1284 {
1285     return (stderr);
1286 }
1287
1288 char *g_getlogin() {
1289     return "no-getlogin";
1290 }
1291
1292 DllExport FILE *
1293 win32_stdin(void)
1294 {
1295     return (stdin);
1296 }
1297
1298 DllExport FILE *
1299 win32_stdout()
1300 {
1301     return (stdout);
1302 }
1303
1304 DllExport int
1305 win32_ferror(FILE *fp)
1306 {
1307     return (ferror(fp));
1308 }
1309
1310
1311 DllExport int
1312 win32_feof(FILE *fp)
1313 {
1314     return (feof(fp));
1315 }
1316
1317 /*
1318  * Since the errors returned by the socket error function
1319  * WSAGetLastError() are not known by the library routine strerror
1320  * we have to roll our own.
1321  */
1322
1323 DllExport char *
1324 win32_strerror(int e)
1325 {
1326   return xcestrerror(e);
1327 }
1328
1329 DllExport void
1330 win32_str_os_error(void *sv, DWORD dwErr)
1331 {
1332   dTHX;
1333
1334   sv_setpvn((SV*)sv, "Error", 5);
1335 }
1336
1337
1338 DllExport int
1339 win32_fprintf(FILE *fp, const char *format, ...)
1340 {
1341     va_list marker;
1342     va_start(marker, format);     /* Initialize variable arguments. */
1343
1344     return (vfprintf(fp, format, marker));
1345 }
1346
1347 DllExport int
1348 win32_printf(const char *format, ...)
1349 {
1350     va_list marker;
1351     va_start(marker, format);     /* Initialize variable arguments. */
1352
1353     return (vprintf(format, marker));
1354 }
1355
1356 DllExport int
1357 win32_vfprintf(FILE *fp, const char *format, va_list args)
1358 {
1359     return (vfprintf(fp, format, args));
1360 }
1361
1362 DllExport int
1363 win32_vprintf(const char *format, va_list args)
1364 {
1365     return (vprintf(format, args));
1366 }
1367
1368 DllExport size_t
1369 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
1370 {
1371   return fread(buf, size, count, fp);
1372 }
1373
1374 DllExport size_t
1375 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
1376 {
1377   return fwrite(buf, size, count, fp);
1378 }
1379
1380 DllExport FILE *
1381 win32_fopen(const char *filename, const char *mode)
1382 {
1383   return xcefopen(filename, mode);
1384 }
1385
1386 DllExport FILE *
1387 win32_fdopen(int handle, const char *mode)
1388 {
1389   return palm_fdopen(handle, mode);
1390 }
1391
1392 DllExport FILE *
1393 win32_freopen(const char *path, const char *mode, FILE *stream)
1394 {
1395   return xcefreopen(path, mode, stream);
1396 }
1397
1398 DllExport int
1399 win32_fclose(FILE *pf)
1400 {
1401   return xcefclose(pf);
1402 }
1403
1404 DllExport int
1405 win32_fputs(const char *s,FILE *pf)
1406 {
1407   return fputs(s, pf);
1408 }
1409
1410 DllExport int
1411 win32_fputc(int c,FILE *pf)
1412 {
1413   return fputc(c,pf);
1414 }
1415
1416 DllExport int
1417 win32_ungetc(int c,FILE *pf)
1418 {
1419   return ungetc(c,pf);
1420 }
1421
1422 DllExport int
1423 win32_getc(FILE *pf)
1424 {
1425   return getc(pf);
1426 }
1427
1428 DllExport int
1429 win32_fileno(FILE *pf)
1430 {
1431   return palm_fileno(pf);
1432 }
1433
1434 DllExport void
1435 win32_clearerr(FILE *pf)
1436 {
1437   clearerr(pf);
1438   return;
1439 }
1440
1441 DllExport int
1442 win32_fflush(FILE *pf)
1443 {
1444   return fflush(pf);
1445 }
1446
1447 DllExport long
1448 win32_ftell(FILE *pf)
1449 {
1450   return ftell(pf);
1451 }
1452
1453 DllExport int
1454 win32_fseek(FILE *pf, Off_t offset,int origin)
1455 {
1456   return fseek(pf, offset, origin);
1457 }
1458
1459 /* fpos_t seems to be int64 on hpc pro! Really stupid. */
1460 /* But maybe someday there will be such large disks in a hpc... */
1461 DllExport int
1462 win32_fgetpos(FILE *pf, fpos_t *p)
1463 {
1464   return fgetpos(pf, p);
1465 }
1466
1467 DllExport int
1468 win32_fsetpos(FILE *pf, const fpos_t *p)
1469 {
1470   return fsetpos(pf, p);
1471 }
1472
1473 DllExport void
1474 win32_rewind(FILE *pf)
1475 {
1476   fseek(pf, 0, SEEK_SET);
1477   return;
1478 }
1479
1480 DllExport int
1481 win32_tmpfd(void)
1482 {
1483     dTHX;
1484     char prefix[MAX_PATH+1];
1485     char filename[MAX_PATH+1];
1486     DWORD len = GetTempPath(MAX_PATH, prefix);
1487     if (len && len < MAX_PATH) {
1488         if (GetTempFileName(prefix, "plx", 0, filename)) {
1489             HANDLE fh = CreateFile(filename,
1490                                    DELETE | GENERIC_READ | GENERIC_WRITE,
1491                                    0,
1492                                    NULL,
1493                                    CREATE_ALWAYS,
1494                                    FILE_ATTRIBUTE_NORMAL
1495                                    | FILE_FLAG_DELETE_ON_CLOSE,
1496                                    NULL);
1497             if (fh != INVALID_HANDLE_VALUE) {
1498                 int fd = win32_open_osfhandle((intptr_t)fh, 0);
1499                 if (fd >= 0) {
1500 #if defined(__BORLANDC__)
1501                     setmode(fd,O_BINARY);
1502 #endif
1503                     DEBUG_p(PerlIO_printf(Perl_debug_log,
1504                                           "Created tmpfile=%s\n",filename));
1505                     return fd;
1506                 }
1507             }
1508         }
1509     }
1510     return -1;
1511 }
1512
1513 DllExport FILE*
1514 win32_tmpfile(void)
1515 {
1516     int fd = win32_tmpfd();
1517     if (fd >= 0)
1518         return win32_fdopen(fd, "w+b");
1519     return NULL;
1520 }
1521
1522 DllExport void
1523 win32_abort(void)
1524 {
1525   xceabort();
1526
1527   return;
1528 }
1529
1530 DllExport int
1531 win32_fstat(int fd, struct stat *sbufptr)
1532 {
1533   return xcefstat(fd, sbufptr);
1534 }
1535
1536 DllExport int
1537 win32_link(const char *oldname, const char *newname)
1538 {
1539   dTHX;
1540   Perl_croak(aTHX_ PL_no_func, "link");
1541
1542   return -1;
1543 }
1544
1545 DllExport int
1546 win32_rename(const char *oname, const char *newname)
1547 {
1548   return xcerename(oname, newname);
1549 }
1550
1551 DllExport int
1552 win32_setmode(int fd, int mode)
1553 {
1554     /* currently 'celib' seem to have this function in src, but not
1555      * exported. When it will be, we'll uncomment following line.
1556      */
1557     /* return xcesetmode(fd, mode); */
1558     return 0;
1559 }
1560
1561 DllExport int
1562 win32_chsize(int fd, Off_t size)
1563 {
1564     return chsize(fd, size);
1565 }
1566
1567 DllExport long
1568 win32_lseek(int fd, Off_t offset, int origin)
1569 {
1570   return xcelseek(fd, offset, origin);
1571 }
1572
1573 DllExport long
1574 win32_tell(int fd)
1575 {
1576   return xcelseek(fd, 0, SEEK_CUR);
1577 }
1578
1579 DllExport int
1580 win32_open(const char *path, int flag, ...)
1581 {
1582   int pmode;
1583   va_list ap;
1584
1585   va_start(ap, flag);
1586   pmode = va_arg(ap, int);
1587   va_end(ap);
1588
1589   return xceopen(path, flag, pmode);
1590 }
1591
1592 DllExport int
1593 win32_close(int fd)
1594 {
1595   return xceclose(fd);
1596 }
1597
1598 DllExport int
1599 win32_eof(int fd)
1600 {
1601   dTHX;
1602   Perl_croak(aTHX_ PL_no_func, "eof");
1603   return -1;
1604 }
1605
1606 DllExport int
1607 win32_dup(int fd)
1608 {
1609   return xcedup(fd); /* from celib/ceio.c; requires some more work on it */
1610 }
1611
1612 DllExport int
1613 win32_dup2(int fd1,int fd2)
1614 {
1615   return xcedup2(fd1,fd2);
1616 }
1617
1618 DllExport int
1619 win32_read(int fd, void *buf, unsigned int cnt)
1620 {
1621   return xceread(fd, buf, cnt);
1622 }
1623
1624 DllExport int
1625 win32_write(int fd, const void *buf, unsigned int cnt)
1626 {
1627   return xcewrite(fd, (void *) buf, cnt);
1628 }
1629
1630 DllExport int
1631 win32_mkdir(const char *dir, int mode)
1632 {
1633   return xcemkdir(dir);
1634 }
1635
1636 DllExport int
1637 win32_rmdir(const char *dir)
1638 {
1639   return xcermdir(dir);
1640 }
1641
1642 DllExport int
1643 win32_chdir(const char *dir)
1644 {
1645   return xcechdir(dir);
1646 }
1647
1648 DllExport  int
1649 win32_access(const char *path, int mode)
1650 {
1651   return xceaccess(path, mode);
1652 }
1653
1654 DllExport  int
1655 win32_chmod(const char *path, int mode)
1656 {
1657   return xcechmod(path, mode);
1658 }
1659
1660 static char *
1661 create_command_line(char *cname, STRLEN clen, const char * const *args)
1662 {
1663     dTHX;
1664     int index, argc;
1665     char *cmd, *ptr;
1666     const char *arg;
1667     STRLEN len = 0;
1668     bool bat_file = FALSE;
1669     bool cmd_shell = FALSE;
1670     bool dumb_shell = FALSE;
1671     bool extra_quotes = FALSE;
1672     bool quote_next = FALSE;
1673
1674     if (!cname)
1675         cname = (char*)args[0];
1676
1677     /* The NT cmd.exe shell has the following peculiarity that needs to be
1678      * worked around.  It strips a leading and trailing dquote when any
1679      * of the following is true:
1680      *    1. the /S switch was used
1681      *    2. there are more than two dquotes
1682      *    3. there is a special character from this set: &<>()@^|
1683      *    4. no whitespace characters within the two dquotes
1684      *    5. string between two dquotes isn't an executable file
1685      * To work around this, we always add a leading and trailing dquote
1686      * to the string, if the first argument is either "cmd.exe" or "cmd",
1687      * and there were at least two or more arguments passed to cmd.exe
1688      * (not including switches).
1689      * XXX the above rules (from "cmd /?") don't seem to be applied
1690      * always, making for the convolutions below :-(
1691      */
1692     if (cname) {
1693         if (!clen)
1694             clen = strlen(cname);
1695
1696         if (clen > 4
1697             && (stricmp(&cname[clen-4], ".bat") == 0
1698                 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
1699         {
1700             bat_file = TRUE;
1701             len += 3;
1702         }
1703         else {
1704             char *exe = strrchr(cname, '/');
1705             char *exe2 = strrchr(cname, '\\');
1706             if (exe2 > exe)
1707                 exe = exe2;
1708             if (exe)
1709                 ++exe;
1710             else
1711                 exe = cname;
1712             if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
1713                 cmd_shell = TRUE;
1714                 len += 3;
1715             }
1716             else if (stricmp(exe, "command.com") == 0
1717                      || stricmp(exe, "command") == 0)
1718             {
1719                 dumb_shell = TRUE;
1720             }
1721         }
1722     }
1723
1724     DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
1725     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
1726         STRLEN curlen = strlen(arg);
1727         if (!(arg[0] == '"' && arg[curlen-1] == '"'))
1728             len += 2;   /* assume quoting needed (worst case) */
1729         len += curlen + 1;
1730         DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
1731     }
1732     DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
1733
1734     argc = index;
1735     Newx(cmd, len, char);
1736     ptr = cmd;
1737
1738     if (bat_file) {
1739         *ptr++ = '"';
1740         extra_quotes = TRUE;
1741     }
1742
1743     for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
1744         bool do_quote = 0;
1745         STRLEN curlen = strlen(arg);
1746
1747         /* we want to protect empty arguments and ones with spaces with
1748          * dquotes, but only if they aren't already there */
1749         if (!dumb_shell) {
1750             if (!curlen) {
1751                 do_quote = 1;
1752             }
1753             else if (quote_next) {
1754                 /* see if it really is multiple arguments pretending to
1755                  * be one and force a set of quotes around it */
1756                 if (*find_next_space(arg))
1757                     do_quote = 1;
1758             }
1759             else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
1760                 STRLEN i = 0;
1761                 while (i < curlen) {
1762                     if (isSPACE(arg[i])) {
1763                         do_quote = 1;
1764                     }
1765                     else if (arg[i] == '"') {
1766                         do_quote = 0;
1767                         break;
1768                     }
1769                     i++;
1770                 }
1771             }
1772         }
1773
1774         if (do_quote)
1775             *ptr++ = '"';
1776
1777         strcpy(ptr, arg);
1778         ptr += curlen;
1779
1780         if (do_quote)
1781             *ptr++ = '"';
1782
1783         if (args[index+1])
1784             *ptr++ = ' ';
1785
1786         if (!extra_quotes
1787             && cmd_shell
1788             && curlen >= 2
1789             && *arg  == '/'     /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
1790             && stricmp(arg+curlen-2, "/c") == 0)
1791         {
1792             /* is there a next argument? */
1793             if (args[index+1]) {
1794                 /* are there two or more next arguments? */
1795                 if (args[index+2]) {
1796                     *ptr++ = '"';
1797                     extra_quotes = TRUE;
1798                 }
1799                 else {
1800                     /* single argument, force quoting if it has spaces */
1801                     quote_next = TRUE;
1802                 }
1803             }
1804         }
1805     }
1806
1807     if (extra_quotes)
1808         *ptr++ = '"';
1809
1810     *ptr = '\0';
1811
1812     return cmd;
1813 }
1814
1815 static char *
1816 qualified_path(const char *cmd)
1817 {
1818     dTHX;
1819     char *pathstr;
1820     char *fullcmd, *curfullcmd;
1821     STRLEN cmdlen = 0;
1822     int has_slash = 0;
1823
1824     if (!cmd)
1825         return NULL;
1826     fullcmd = (char*)cmd;
1827     while (*fullcmd) {
1828         if (*fullcmd == '/' || *fullcmd == '\\')
1829             has_slash++;
1830         fullcmd++;
1831         cmdlen++;
1832     }
1833
1834     /* look in PATH */
1835     pathstr = PerlEnv_getenv("PATH");
1836     Newx(fullcmd, MAX_PATH+1, char);
1837     curfullcmd = fullcmd;
1838
1839     while (1) {
1840         DWORD res;
1841
1842         /* start by appending the name to the current prefix */
1843         strcpy(curfullcmd, cmd);
1844         curfullcmd += cmdlen;
1845
1846         /* if it doesn't end with '.', or has no extension, try adding
1847          * a trailing .exe first */
1848         if (cmd[cmdlen-1] != '.'
1849             && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
1850         {
1851             strcpy(curfullcmd, ".exe");
1852             res = GetFileAttributes(fullcmd);
1853             if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
1854                 return fullcmd;
1855             *curfullcmd = '\0';
1856         }
1857
1858         /* that failed, try the bare name */
1859         res = GetFileAttributes(fullcmd);
1860         if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
1861             return fullcmd;
1862
1863         /* quit if no other path exists, or if cmd already has path */
1864         if (!pathstr || !*pathstr || has_slash)
1865             break;
1866
1867         /* skip leading semis */
1868         while (*pathstr == ';')
1869             pathstr++;
1870
1871         /* build a new prefix from scratch */
1872         curfullcmd = fullcmd;
1873         while (*pathstr && *pathstr != ';') {
1874             if (*pathstr == '"') {      /* foo;"baz;etc";bar */
1875                 pathstr++;              /* skip initial '"' */
1876                 while (*pathstr && *pathstr != '"') {
1877                     if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
1878                         *curfullcmd++ = *pathstr;
1879                     pathstr++;
1880                 }
1881                 if (*pathstr)
1882                     pathstr++;          /* skip trailing '"' */
1883             }
1884             else {
1885                 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
1886                     *curfullcmd++ = *pathstr;
1887                 pathstr++;
1888             }
1889         }
1890         if (*pathstr)
1891             pathstr++;                  /* skip trailing semi */
1892         if (curfullcmd > fullcmd        /* append a dir separator */
1893             && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
1894         {
1895             *curfullcmd++ = '\\';
1896         }
1897     }
1898
1899     Safefree(fullcmd);
1900     return NULL;
1901 }
1902
1903 /* The following are just place holders.
1904  * Some hosts may provide and environment that the OS is
1905  * not tracking, therefore, these host must provide that
1906  * environment and the current directory to CreateProcess
1907  */
1908
1909 DllExport void*
1910 win32_get_childenv(void)
1911 {
1912     return NULL;
1913 }
1914
1915 DllExport void
1916 win32_free_childenv(void* d)
1917 {
1918 }
1919
1920 DllExport void
1921 win32_clearenv(void)
1922 {
1923     char *envv = GetEnvironmentStrings();
1924     char *cur = envv;
1925     STRLEN len;
1926     while (*cur) {
1927         char *end = strchr(cur,'=');
1928         if (end && end != cur) {
1929             *end = '\0';
1930             xcesetenv(cur, "", 0);
1931             *end = '=';
1932             cur = end + strlen(end+1)+2;
1933         }
1934         else if ((len = strlen(cur)))
1935             cur += len+1;
1936     }
1937     FreeEnvironmentStrings(envv);
1938 }
1939
1940 DllExport char*
1941 win32_get_childdir(void)
1942 {
1943     dTHX;
1944     char* ptr;
1945     char szfilename[MAX_PATH+1];
1946     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
1947
1948     Newx(ptr, strlen(szfilename)+1, char);
1949     strcpy(ptr, szfilename);
1950     return ptr;
1951 }
1952
1953 DllExport void
1954 win32_free_childdir(char* d)
1955 {
1956     dTHX;
1957     Safefree(d);
1958 }
1959
1960 /* XXX this needs to be made more compatible with the spawnvp()
1961  * provided by the various RTLs.  In particular, searching for
1962  * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
1963  * This doesn't significantly affect perl itself, because we
1964  * always invoke things using PERL5SHELL if a direct attempt to
1965  * spawn the executable fails.
1966  *
1967  * XXX splitting and rejoining the commandline between do_aspawn()
1968  * and win32_spawnvp() could also be avoided.
1969  */
1970
1971 DllExport int
1972 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
1973 {
1974 #ifdef USE_RTL_SPAWNVP
1975     return spawnvp(mode, cmdname, (char * const *)argv);
1976 #else
1977     dTHX;
1978     int ret;
1979     void* env;
1980     char* dir;
1981     child_IO_table tbl;
1982     STARTUPINFO StartupInfo;
1983     PROCESS_INFORMATION ProcessInformation;
1984     DWORD create = 0;
1985     char *cmd;
1986     char *fullcmd = NULL;
1987     char *cname = (char *)cmdname;
1988     STRLEN clen = 0;
1989
1990     if (cname) {
1991         clen = strlen(cname);
1992         /* if command name contains dquotes, must remove them */
1993         if (strchr(cname, '"')) {
1994             cmd = cname;
1995             Newx(cname,clen+1,char);
1996             clen = 0;
1997             while (*cmd) {
1998                 if (*cmd != '"') {
1999                     cname[clen] = *cmd;
2000                     ++clen;
2001                 }
2002                 ++cmd;
2003             }
2004             cname[clen] = '\0';
2005         }
2006     }
2007
2008     cmd = create_command_line(cname, clen, argv);
2009
2010     env = PerlEnv_get_childenv();
2011     dir = PerlEnv_get_childdir();
2012
2013     switch(mode) {
2014     case P_NOWAIT:      /* asynch + remember result */
2015         if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
2016             errno = EAGAIN;
2017             ret = -1;
2018             goto RETVAL;
2019         }
2020         /* Create a new process group so we can use GenerateConsoleCtrlEvent()
2021          * in win32_kill()
2022          */
2023         /* not supported on CE create |= CREATE_NEW_PROCESS_GROUP; */
2024         /* FALL THROUGH */
2025
2026     case P_WAIT:        /* synchronous execution */
2027         break;
2028     default:            /* invalid mode */
2029         errno = EINVAL;
2030         ret = -1;
2031         goto RETVAL;
2032     }
2033     memset(&StartupInfo,0,sizeof(StartupInfo));
2034     StartupInfo.cb = sizeof(StartupInfo);
2035     memset(&tbl,0,sizeof(tbl));
2036     PerlEnv_get_child_IO(&tbl);
2037     StartupInfo.dwFlags         = tbl.dwFlags;
2038     StartupInfo.dwX             = tbl.dwX;
2039     StartupInfo.dwY             = tbl.dwY;
2040     StartupInfo.dwXSize         = tbl.dwXSize;
2041     StartupInfo.dwYSize         = tbl.dwYSize;
2042     StartupInfo.dwXCountChars   = tbl.dwXCountChars;
2043     StartupInfo.dwYCountChars   = tbl.dwYCountChars;
2044     StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
2045     StartupInfo.wShowWindow     = tbl.wShowWindow;
2046     StartupInfo.hStdInput       = tbl.childStdIn;
2047     StartupInfo.hStdOutput      = tbl.childStdOut;
2048     StartupInfo.hStdError       = tbl.childStdErr;
2049     if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
2050         StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
2051         StartupInfo.hStdError == INVALID_HANDLE_VALUE)
2052     {
2053         create |= CREATE_NEW_CONSOLE;
2054     }
2055     else {
2056         StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
2057     }
2058     if (w32_use_showwindow) {
2059         StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
2060         StartupInfo.wShowWindow = w32_showwindow;
2061     }
2062
2063     DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
2064                           cname,cmd));
2065 RETRY:
2066     if (!CreateProcess(cname,           /* search PATH to find executable */
2067                        cmd,             /* executable, and its arguments */
2068                        NULL,            /* process attributes */
2069                        NULL,            /* thread attributes */
2070                        TRUE,            /* inherit handles */
2071                        create,          /* creation flags */
2072                        (LPVOID)env,     /* inherit environment */
2073                        dir,             /* inherit cwd */
2074                        &StartupInfo,
2075                        &ProcessInformation))
2076     {
2077         /* initial NULL argument to CreateProcess() does a PATH
2078          * search, but it always first looks in the directory
2079          * where the current process was started, which behavior
2080          * is undesirable for backward compatibility.  So we
2081          * jump through our own hoops by picking out the path
2082          * we really want it to use. */
2083         if (!fullcmd) {
2084             fullcmd = qualified_path(cname);
2085             if (fullcmd) {
2086                 if (cname != cmdname)
2087                     Safefree(cname);
2088                 cname = fullcmd;
2089                 DEBUG_p(PerlIO_printf(Perl_debug_log,
2090                                       "Retrying [%s] with same args\n",
2091                                       cname));
2092                 goto RETRY;
2093             }
2094         }
2095         errno = ENOENT;
2096         ret = -1;
2097         goto RETVAL;
2098     }
2099
2100     if (mode == P_NOWAIT) {
2101         /* asynchronous spawn -- store handle, return PID */
2102         ret = (int)ProcessInformation.dwProcessId;
2103         if (IsWin95() && ret < 0)
2104             ret = -ret;
2105
2106         w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
2107         w32_child_pids[w32_num_children] = (DWORD)ret;
2108         ++w32_num_children;
2109     }
2110     else  {
2111         DWORD status;
2112         win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
2113         /* FIXME: if msgwait returned due to message perhaps forward the
2114            "signal" to the process
2115          */
2116         GetExitCodeProcess(ProcessInformation.hProcess, &status);
2117         ret = (int)status;
2118         CloseHandle(ProcessInformation.hProcess);
2119     }
2120
2121     CloseHandle(ProcessInformation.hThread);
2122
2123 RETVAL:
2124     PerlEnv_free_childenv(env);
2125     PerlEnv_free_childdir(dir);
2126     Safefree(cmd);
2127     if (cname != cmdname)
2128         Safefree(cname);
2129     return ret;
2130 #endif
2131 }
2132
2133 DllExport int
2134 win32_execv(const char *cmdname, const char *const *argv)
2135 {
2136   dTHX;
2137   Perl_croak(aTHX_ PL_no_func, "execv");
2138   return -1;
2139 }
2140
2141 DllExport int
2142 win32_execvp(const char *cmdname, const char *const *argv)
2143 {
2144   dTHX;
2145   Perl_croak(aTHX_ PL_no_func, "execvp");
2146   return -1;
2147 }
2148
2149 DllExport void
2150 win32_perror(const char *str)
2151 {
2152   xceperror(str);
2153 }
2154
2155 DllExport void
2156 win32_setbuf(FILE *pf, char *buf)
2157 {
2158   dTHX;
2159   Perl_croak(aTHX_ PL_no_func, "setbuf");
2160 }
2161
2162 DllExport int
2163 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
2164 {
2165   return setvbuf(pf, buf, type, size);
2166 }
2167
2168 DllExport int
2169 win32_flushall(void)
2170 {
2171   return flushall();
2172 }
2173
2174 DllExport int
2175 win32_fcloseall(void)
2176 {
2177   return fcloseall();
2178 }
2179
2180 DllExport char*
2181 win32_fgets(char *s, int n, FILE *pf)
2182 {
2183   return fgets(s, n, pf);
2184 }
2185
2186 DllExport char*
2187 win32_gets(char *s)
2188 {
2189   return gets(s);
2190 }
2191
2192 DllExport int
2193 win32_fgetc(FILE *pf)
2194 {
2195   return fgetc(pf);
2196 }
2197
2198 DllExport int
2199 win32_putc(int c, FILE *pf)
2200 {
2201   return putc(c,pf);
2202 }
2203
2204 DllExport int
2205 win32_puts(const char *s)
2206 {
2207   return puts(s);
2208 }
2209
2210 DllExport int
2211 win32_getchar(void)
2212 {
2213   return getchar();
2214 }
2215
2216 DllExport int
2217 win32_putchar(int c)
2218 {
2219   return putchar(c);
2220 }
2221
2222 #ifdef MYMALLOC
2223
2224 #ifndef USE_PERL_SBRK
2225
2226 static char *committed = NULL;
2227 static char *base      = NULL;
2228 static char *reserved  = NULL;
2229 static char *brk       = NULL;
2230 static DWORD pagesize  = 0;
2231 static DWORD allocsize = 0;
2232
2233 void *
2234 sbrk(int need)
2235 {
2236  void *result;
2237  if (!pagesize)
2238   {SYSTEM_INFO info;
2239    GetSystemInfo(&info);
2240    /* Pretend page size is larger so we don't perpetually
2241     * call the OS to commit just one page ...
2242     */
2243    pagesize = info.dwPageSize << 3;
2244    allocsize = info.dwAllocationGranularity;
2245   }
2246  /* This scheme fails eventually if request for contiguous
2247   * block is denied so reserve big blocks - this is only
2248   * address space not memory ...
2249   */
2250  if (brk+need >= reserved)
2251   {
2252    DWORD size = 64*1024*1024;
2253    char *addr;
2254    if (committed && reserved && committed < reserved)
2255     {
2256      /* Commit last of previous chunk cannot span allocations */
2257      addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
2258      if (addr)
2259       committed = reserved;
2260     }
2261    /* Reserve some (more) space
2262     * Note this is a little sneaky, 1st call passes NULL as reserved
2263     * so lets system choose where we start, subsequent calls pass
2264     * the old end address so ask for a contiguous block
2265     */
2266    addr  = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
2267    if (addr)
2268     {
2269      reserved = addr+size;
2270      if (!base)
2271       base = addr;
2272      if (!committed)
2273       committed = base;
2274      if (!brk)
2275       brk = committed;
2276     }
2277    else
2278     {
2279      return (void *) -1;
2280     }
2281   }
2282  result = brk;
2283  brk += need;
2284  if (brk > committed)
2285   {
2286    DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
2287    char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
2288    if (addr)
2289     {
2290      committed += size;
2291     }
2292    else
2293     return (void *) -1;
2294   }
2295  return result;
2296 }
2297
2298 #endif
2299 #endif
2300
2301 DllExport void*
2302 win32_malloc(size_t size)
2303 {
2304     return malloc(size);
2305 }
2306
2307 DllExport void*
2308 win32_calloc(size_t numitems, size_t size)
2309 {
2310     return calloc(numitems,size);
2311 }
2312
2313 DllExport void*
2314 win32_realloc(void *block, size_t size)
2315 {
2316     return realloc(block,size);
2317 }
2318
2319 DllExport void
2320 win32_free(void *block)
2321 {
2322     free(block);
2323 }
2324
2325 int
2326 win32_open_osfhandle(intptr_t osfhandle, int flags)
2327 {
2328     int fh;
2329     char fileflags=0;           /* _osfile flags */
2330
2331     Perl_croak_nocontext("win32_open_osfhandle() TBD on this platform");
2332     return 0;
2333 }
2334
2335 int
2336 win32_get_osfhandle(int fd)
2337 {
2338     int fh;
2339     char fileflags=0;           /* _osfile flags */
2340
2341     Perl_croak_nocontext("win32_get_osfhandle() TBD on this platform");
2342     return 0;
2343 }
2344
2345 FILE *
2346 win32_fdupopen(FILE *pf)
2347 {
2348     FILE* pfdup;
2349     fpos_t pos;
2350     char mode[3];
2351     int fileno = win32_dup(win32_fileno(pf));
2352     int fmode = palm_fgetmode(pfdup);
2353
2354     fprintf(stderr,"DEBUG for win32_fdupopen()\n");
2355
2356     /* open the file in the same mode */
2357     if(fmode & O_RDONLY) {
2358         mode[0] = 'r';
2359         mode[1] = 0;
2360     }
2361     else if(fmode & O_APPEND) {
2362         mode[0] = 'a';
2363         mode[1] = 0;
2364     }
2365     else if(fmode & O_RDWR) {
2366         mode[0] = 'r';
2367         mode[1] = '+';
2368         mode[2] = 0;
2369     }
2370
2371     /* it appears that the binmode is attached to the
2372      * file descriptor so binmode files will be handled
2373      * correctly
2374      */
2375     pfdup = win32_fdopen(fileno, mode);
2376
2377     /* move the file pointer to the same position */
2378     if (!fgetpos(pf, &pos)) {
2379         fsetpos(pfdup, &pos);
2380     }
2381     return pfdup;
2382 }
2383
2384 DllExport void*
2385 win32_dynaload(const char* filename)
2386 {
2387     dTHX;
2388     HMODULE hModule;
2389
2390     hModule = XCELoadLibraryA(filename);
2391
2392     return hModule;
2393 }
2394
2395 /* this is needed by Cwd.pm... */
2396
2397 static
2398 XS(w32_GetCwd)
2399 {
2400   dXSARGS;
2401   char buf[MAX_PATH];
2402   SV *sv = sv_newmortal();
2403
2404   xcegetcwd(buf, sizeof(buf));
2405
2406   sv_setpv(sv, xcestrdup(buf));
2407   EXTEND(SP,1);
2408   SvPOK_on(sv);
2409   ST(0) = sv;
2410 #ifndef INCOMPLETE_TAINTS
2411   SvTAINTED_on(ST(0));
2412 #endif
2413   XSRETURN(1);
2414 }
2415
2416 static
2417 XS(w32_SetCwd)
2418 {
2419   dXSARGS;
2420
2421   if (items != 1)
2422     Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
2423
2424   if (!xcechdir(SvPV_nolen(ST(0))))
2425     XSRETURN_YES;
2426
2427   XSRETURN_NO;
2428 }
2429
2430 static
2431 XS(w32_GetTickCount)
2432 {
2433     dXSARGS;
2434     DWORD msec = GetTickCount();
2435     EXTEND(SP,1);
2436     if ((IV)msec > 0)
2437         XSRETURN_IV(msec);
2438     XSRETURN_NV(msec);
2439 }
2440
2441 static
2442 XS(w32_GetOSVersion)
2443 {
2444     dXSARGS;
2445     OSVERSIONINFOA osver;
2446
2447     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
2448     if (!XCEGetVersionExA(&osver)) {
2449       XSRETURN_EMPTY;
2450     }
2451     mXPUSHp(osver.szCSDVersion, strlen(osver.szCSDVersion));
2452     mXPUSHi(osver.dwMajorVersion);
2453     mXPUSHi(osver.dwMinorVersion);
2454     mXPUSHi(osver.dwBuildNumber);
2455     /* WINCE = 3 */
2456     mXPUSHi(osver.dwPlatformId);
2457     PUTBACK;
2458 }
2459
2460 static
2461 XS(w32_IsWinNT)
2462 {
2463     dXSARGS;
2464     EXTEND(SP,1);
2465     XSRETURN_IV(IsWinNT());
2466 }
2467
2468 static
2469 XS(w32_IsWin95)
2470 {
2471     dXSARGS;
2472     EXTEND(SP,1);
2473     XSRETURN_IV(IsWin95());
2474 }
2475
2476 static
2477 XS(w32_IsWinCE)
2478 {
2479     dXSARGS;
2480     EXTEND(SP,1);
2481     XSRETURN_IV(IsWinCE());
2482 }
2483
2484 static
2485 XS(w32_GetOemInfo)
2486 {
2487   dXSARGS;
2488   wchar_t wbuf[126];
2489   char buf[126];
2490
2491   if(SystemParametersInfoW(SPI_GETOEMINFO, sizeof(wbuf), wbuf, FALSE))
2492     WideCharToMultiByte(CP_ACP, 0, wbuf, -1, buf, sizeof(buf), 0, 0);
2493   else
2494     sprintf(buf, "SystemParametersInfo failed: %d", GetLastError());
2495
2496   EXTEND(SP,1);
2497   XSRETURN_PV(buf);
2498 }
2499
2500 static
2501 XS(w32_Sleep)
2502 {
2503     dXSARGS;
2504     if (items != 1)
2505         Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
2506     Sleep(SvIV(ST(0)));
2507     XSRETURN_YES;
2508 }
2509
2510 static
2511 XS(w32_CopyFile)
2512 {
2513     dXSARGS;
2514     BOOL bResult;
2515     if (items != 3)
2516         Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
2517
2518     {
2519       char szSourceFile[MAX_PATH+1];
2520       strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
2521       bResult = XCECopyFileA(szSourceFile, SvPV_nolen(ST(1)),
2522                              !SvTRUE(ST(2)));
2523     }
2524
2525     if (bResult)
2526         XSRETURN_YES;
2527
2528     XSRETURN_NO;
2529 }
2530
2531 static
2532 XS(w32_MessageBox)
2533 {
2534     dXSARGS;
2535
2536     char *txt;
2537     unsigned int res;
2538     unsigned int flags = MB_OK;
2539
2540     txt = SvPV_nolen(ST(0));
2541
2542     if (items < 1 || items > 2)
2543         Perl_croak(aTHX_ "usage: Win32::MessageBox($txt, [$flags])");
2544
2545     if(items == 2)
2546       flags = SvIV(ST(1));
2547
2548     res = XCEMessageBoxA(NULL, txt, "Perl", flags);
2549
2550     XSRETURN_IV(res);
2551 }
2552
2553 static
2554 XS(w32_GetPowerStatus)
2555 {
2556   dXSARGS;
2557
2558   SYSTEM_POWER_STATUS_EX sps;
2559
2560   if(GetSystemPowerStatusEx(&sps, TRUE) == FALSE)
2561     {
2562       XSRETURN_EMPTY;
2563     }
2564
2565   mXPUSHi(sps.ACLineStatus);
2566   mXPUSHi(sps.BatteryFlag);
2567   mXPUSHi(sps.BatteryLifePercent);
2568   mXPUSHi(sps.BatteryLifeTime);
2569   mXPUSHi(sps.BatteryFullLifeTime);
2570   mXPUSHi(sps.BackupBatteryFlag);
2571   mXPUSHi(sps.BackupBatteryLifePercent);
2572   mXPUSHi(sps.BackupBatteryLifeTime);
2573   mXPUSHi(sps.BackupBatteryFullLifeTime);
2574
2575   PUTBACK;
2576 }
2577
2578 #if UNDER_CE > 200
2579 static
2580 XS(w32_ShellEx)
2581 {
2582   dXSARGS;
2583
2584   char buf[126];
2585   SHELLEXECUTEINFO si;
2586   char *file, *verb;
2587   wchar_t wfile[MAX_PATH];
2588   wchar_t wverb[20];
2589
2590   if (items != 2)
2591     Perl_croak(aTHX_ "usage: Win32::ShellEx($file, $verb)");
2592
2593   file = SvPV_nolen(ST(0));
2594   verb = SvPV_nolen(ST(1));
2595
2596   memset(&si, 0, sizeof(si));
2597   si.cbSize = sizeof(si);
2598   si.fMask = SEE_MASK_FLAG_NO_UI;
2599
2600   MultiByteToWideChar(CP_ACP, 0, verb, -1,
2601                       wverb, sizeof(wverb)/2);
2602   si.lpVerb = (TCHAR *)wverb;
2603
2604   MultiByteToWideChar(CP_ACP, 0, file, -1,
2605                       wfile, sizeof(wfile)/2);
2606   si.lpFile = (TCHAR *)wfile;
2607
2608   if(ShellExecuteEx(&si) == FALSE)
2609     {
2610       XSRETURN_NO;
2611     }
2612   XSRETURN_YES;
2613 }
2614 #endif
2615
2616 void
2617 Perl_init_os_extras(void)
2618 {
2619     dTHX;
2620     char *file = __FILE__;
2621     dXSUB_SYS;
2622
2623     w32_perlshell_tokens = NULL;
2624     w32_perlshell_items = -1;
2625     w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */
2626     Newx(w32_children, 1, child_tab);
2627     w32_num_children = 0;
2628
2629     newXS("Win32::GetCwd", w32_GetCwd, file);
2630     newXS("Win32::SetCwd", w32_SetCwd, file);
2631     newXS("Win32::GetTickCount", w32_GetTickCount, file);
2632     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
2633 #if UNDER_CE > 200
2634     newXS("Win32::ShellEx", w32_ShellEx, file);
2635 #endif
2636     newXS("Win32::IsWinNT", w32_IsWinNT, file);
2637     newXS("Win32::IsWin95", w32_IsWin95, file);
2638     newXS("Win32::IsWinCE", w32_IsWinCE, file);
2639     newXS("Win32::CopyFile", w32_CopyFile, file);
2640     newXS("Win32::Sleep", w32_Sleep, file);
2641     newXS("Win32::MessageBox", w32_MessageBox, file);
2642     newXS("Win32::GetPowerStatus", w32_GetPowerStatus, file);
2643     newXS("Win32::GetOemInfo", w32_GetOemInfo, file);
2644 }
2645
2646 void
2647 myexit(void)
2648 {
2649   char buf[126];
2650
2651   puts("Hit return");
2652   fgets(buf, sizeof(buf), stdin);
2653 }
2654
2655 void
2656 Perl_win32_init(int *argcp, char ***argvp)
2657 {
2658 #ifdef UNDER_CE
2659   char *p;
2660
2661   if((p = xcegetenv("PERLDEBUG")) && (p[0] == 'y' || p[0] == 'Y'))
2662     atexit(myexit);
2663 #endif
2664
2665   MALLOC_INIT;
2666 }
2667
2668 DllExport void
2669 Perl_win32_term(void)
2670 {
2671     dTHX;
2672     HINTS_REFCNT_TERM;
2673     OP_REFCNT_TERM;
2674     PERLIO_TERM;
2675     MALLOC_TERM;
2676 }
2677
2678 void
2679 win32_get_child_IO(child_IO_table* ptbl)
2680 {
2681     ptbl->childStdIn    = GetStdHandle(STD_INPUT_HANDLE);
2682     ptbl->childStdOut   = GetStdHandle(STD_OUTPUT_HANDLE);
2683     ptbl->childStdErr   = GetStdHandle(STD_ERROR_HANDLE);
2684 }
2685
2686 win32_flock(int fd, int oper)
2687 {
2688   dTHX;
2689   Perl_croak(aTHX_ PL_no_func, "flock");
2690   return -1;
2691 }
2692
2693 DllExport int
2694 win32_waitpid(int pid, int *status, int flags)
2695 {
2696   dTHX;
2697   Perl_croak(aTHX_ PL_no_func, "waitpid");
2698   return -1;
2699 }
2700
2701 DllExport int
2702 win32_wait(int *status)
2703 {
2704   dTHX;
2705   Perl_croak(aTHX_ PL_no_func, "wait");
2706   return -1;
2707 }
2708
2709 int
2710 wce_reopen_stdout(char *fname)
2711 {
2712   if(xcefreopen(fname, "w", stdout) == NULL)
2713     return -1;
2714
2715   return 0;
2716 }
2717
2718 void
2719 wce_hitreturn()
2720 {
2721   char buf[126];
2722
2723   printf("Hit RETURN");
2724   fflush(stdout);
2725   fgets(buf, sizeof(buf), stdin);
2726   return;
2727 }
2728
2729 /* //////////////////////////////////////////////////////////////////// */
2730
2731 #undef getcwd
2732
2733 char *
2734 getcwd(char *buf, size_t size)
2735 {
2736   return xcegetcwd(buf, size);
2737 }
2738
2739 int
2740 isnan(double d)
2741 {
2742   return _isnan(d);
2743 }
2744
2745
2746 DllExport PerlIO*
2747 win32_popenlist(const char *mode, IV narg, SV **args)
2748 {
2749  dTHX;
2750  Perl_croak(aTHX_ "List form of pipe open not implemented");
2751  return NULL;
2752 }
2753
2754 /*
2755  * a popen() clone that respects PERL5SHELL
2756  *
2757  * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2758  */
2759
2760 DllExport PerlIO*
2761 win32_popen(const char *command, const char *mode)
2762 {
2763     return _popen(command, mode);
2764 }
2765
2766 /*
2767  * pclose() clone
2768  */
2769
2770 DllExport int
2771 win32_pclose(PerlIO *pf)
2772 {
2773     return _pclose(pf);
2774 }
2775
2776 #ifdef HAVE_INTERP_INTERN
2777
2778
2779 static void
2780 win32_csighandler(int sig)
2781 {
2782 #if 0
2783     dTHXa(PERL_GET_SIG_CONTEXT);
2784     Perl_warn(aTHX_ "Got signal %d",sig);
2785 #endif
2786     /* Does nothing */
2787 }
2788
2789 void
2790 Perl_sys_intern_init(pTHX)
2791 {
2792     int i;
2793     w32_perlshell_tokens        = NULL;
2794     w32_perlshell_vec           = (char**)NULL;
2795     w32_perlshell_items         = 0;
2796     w32_fdpid                   = newAV();
2797     Newx(w32_children, 1, child_tab);
2798     w32_num_children            = 0;
2799 #  ifdef USE_ITHREADS
2800     w32_pseudo_id               = 0;
2801     Newx(w32_pseudo_children, 1, child_tab);
2802     w32_num_pseudo_children     = 0;
2803 #  endif
2804     w32_init_socktype           = 0;
2805     w32_timerid                 = 0;
2806     w32_poll_count              = 0;
2807 }
2808
2809 void
2810 Perl_sys_intern_clear(pTHX)
2811 {
2812     Safefree(w32_perlshell_tokens);
2813     Safefree(w32_perlshell_vec);
2814     /* NOTE: w32_fdpid is freed by sv_clean_all() */
2815     Safefree(w32_children);
2816     if (w32_timerid) {
2817         KillTimer(NULL,w32_timerid);
2818         w32_timerid=0;
2819     }
2820 #  ifdef USE_ITHREADS
2821     Safefree(w32_pseudo_children);
2822 #  endif
2823 }
2824
2825 #  ifdef USE_ITHREADS
2826
2827 void
2828 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
2829 {
2830     dst->perlshell_tokens       = NULL;
2831     dst->perlshell_vec          = (char**)NULL;
2832     dst->perlshell_items        = 0;
2833     dst->fdpid                  = newAV();
2834     Newxz(dst->children, 1, child_tab);
2835     dst->pseudo_id              = 0;
2836     Newxz(dst->pseudo_children, 1, child_tab);
2837     dst->thr_intern.Winit_socktype = 0;
2838     dst->timerid                 = 0;
2839     dst->poll_count              = 0;
2840     Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
2841 }
2842 #  endif /* USE_ITHREADS */
2843 #endif /* HAVE_INTERP_INTERN */
2844
2845 // added to remove undefied symbol error in CodeWarrior compilation
2846 int
2847 Perl_Ireentrant_buffer_ptr(aTHX)
2848 {
2849         return 0;
2850 }