win32/perlhost.h

   1 /* perlhost.h
   2  *
   3  * (c) 1999 Microsoft Corporation. All rights reserved.
   4  * Portions (c) 1999 ActiveState Tool Corp, http://www.ActiveState.com/
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  */
   9
  10 #ifndef UNDER_CE
  11 #define CHECK_HOST_INTERP
  12 #endif
  13
  14 #ifndef ___PerlHost_H___
  15 #define ___PerlHost_H___
  16
  17 #ifndef UNDER_CE
  18 #include <signal.h>
  19 #endif
  20 #include "iperlsys.h"
  21 #include "vmem.h"
  22 #include "vdir.h"
  23
  24 #ifndef WC_NO_BEST_FIT_CHARS
  25 #  define WC_NO_BEST_FIT_CHARS 0x00000400
  26 #endif
  27
  28 START_EXTERN_C
  29 extern char *           g_win32_get_privlib(const char *pl, STRLEN *const len);
  30 extern char *           g_win32_get_sitelib(const char *pl, STRLEN *const len);
  31 extern char *           g_win32_get_vendorlib(const char *pl,
  32                                               STRLEN *const len);
  33 extern char *           g_getlogin(void);
  34 END_EXTERN_C
  35
  36 class CPerlHost
  37 {
  38 public:
  39     /* Constructors */
  40     CPerlHost(void);
  41     CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
  42                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
  43                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
  44                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
  45                  struct IPerlProc** ppProc);
  46     CPerlHost(CPerlHost& host);
  47     ~CPerlHost(void);
  48
  49     static CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl);
  50     static CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl);
  51     static CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl);
  52     static CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl);
  53     static CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl);
  54     static CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl);
  55     static CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl);
  56     static CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl);
  57     static CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl);
  58
  59     BOOL PerlCreate(void);
  60     int PerlParse(int argc, char** argv, char** env);
  61     int PerlRun(void);
  62     void PerlDestroy(void);
  63
  64 /* IPerlMem */
  65     /* Locks provided but should be unnecessary as this is private pool */
  66     inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); };
  67     inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); };
  68     inline void Free(void* ptr) { m_pVMem->Free(ptr); };
  69     inline void* Calloc(size_t num, size_t size)
  70     {
  71         size_t count = num*size;
  72         void* lpVoid = Malloc(count);
  73         if (lpVoid)
  74             ZeroMemory(lpVoid, count);
  75         return lpVoid;
  76     };
  77     inline void GetLock(void) { m_pVMem->GetLock(); };
  78     inline void FreeLock(void) { m_pVMem->FreeLock(); };
  79     inline int IsLocked(void) { return m_pVMem->IsLocked(); };
  80
  81 /* IPerlMemShared */
  82     /* Locks used to serialize access to the pool */
  83     inline void GetLockShared(void) { m_pVMemShared->GetLock(); };
  84     inline void FreeLockShared(void) { m_pVMemShared->FreeLock(); };
  85     inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); };
  86     inline void* MallocShared(size_t size)
  87     {
  88         void *result;
  89         GetLockShared();
  90         result = m_pVMemShared->Malloc(size);
  91         FreeLockShared();
  92         return result;
  93     };
  94     inline void* ReallocShared(void* ptr, size_t size)
  95     {
  96         void *result;
  97         GetLockShared();
  98         result = m_pVMemShared->Realloc(ptr, size);
  99         FreeLockShared();
 100         return result;
 101     };
 102     inline void FreeShared(void* ptr)
 103     {
 104         GetLockShared();
 105         m_pVMemShared->Free(ptr);
 106         FreeLockShared();
 107     };
 108     inline void* CallocShared(size_t num, size_t size)
 109     {
 110         size_t count = num*size;
 111         void* lpVoid = MallocShared(count);
 112         if (lpVoid)
 113             ZeroMemory(lpVoid, count);
 114         return lpVoid;
 115     };
 116
 117 /* IPerlMemParse */
 118     /* Assume something else is using locks to mangaging serialize
 119        on a batch basis
 120      */
 121     inline void GetLockParse(void) { m_pVMemParse->GetLock(); };
 122     inline void FreeLockParse(void) { m_pVMemParse->FreeLock(); };
 123     inline int IsLockedParse(void) { return m_pVMemParse->IsLocked(); };
 124     inline void* MallocParse(size_t size) { return m_pVMemParse->Malloc(size); };
 125     inline void* ReallocParse(void* ptr, size_t size) { return m_pVMemParse->Realloc(ptr, size); };
 126     inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); };
 127     inline void* CallocParse(size_t num, size_t size)
 128     {
 129         size_t count = num*size;
 130         void* lpVoid = MallocParse(count);
 131         if (lpVoid)
 132             ZeroMemory(lpVoid, count);
 133         return lpVoid;
 134     };
 135
 136 /* IPerlEnv */
 137     char *Getenv(const char *varname);
 138     int Putenv(const char *envstring);
 139     inline char *Getenv(const char *varname, unsigned long *len)
 140     {
 141         *len = 0;
 142         char *e = Getenv(varname);
 143         if (e)
 144             *len = strlen(e);
 145         return e;
 146     }
 147     void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); };
 148     void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); };
 149     char* GetChildDir(void);
 150     void FreeChildDir(char* pStr);
 151     void Reset(void);
 152     void Clearenv(void);
 153
 154     inline LPSTR GetIndex(DWORD &dwIndex)
 155     {
 156         if(dwIndex < m_dwEnvCount)
 157         {
 158             ++dwIndex;
 159             return m_lppEnvList[dwIndex-1];
 160         }
 161         return NULL;
 162     };
 163
 164 protected:
 165     LPSTR Find(LPCSTR lpStr);
 166     void Add(LPCSTR lpStr);
 167
 168     LPSTR CreateLocalEnvironmentStrings(VDir &vDir);
 169     void FreeLocalEnvironmentStrings(LPSTR lpStr);
 170     LPSTR* Lookup(LPCSTR lpStr);
 171     DWORD CalculateEnvironmentSpace(void);
 172
 173 public:
 174
 175 /* IPerlDIR */
 176     virtual int Chdir(const char *dirname);
 177
 178 /* IPerllProc */
 179     void Abort(void);
 180     void Exit(int status);
 181     void _Exit(int status);
 182     int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3);
 183     int Execv(const char *cmdname, const char *const *argv);
 184     int Execvp(const char *cmdname, const char *const *argv);
 185
 186     inline VMem* GetMemShared(void) { m_pVMemShared->AddRef(); return m_pVMemShared; };
 187     inline VMem* GetMemParse(void) { m_pVMemParse->AddRef(); return m_pVMemParse; };
 188     inline VDir* GetDir(void) { return m_pvDir; };
 189
 190 public:
 191
 192     struct IPerlMem         m_hostperlMem;
 193     struct IPerlMem         m_hostperlMemShared;
 194     struct IPerlMem         m_hostperlMemParse;
 195     struct IPerlEnv         m_hostperlEnv;
 196     struct IPerlStdIO       m_hostperlStdIO;
 197     struct IPerlLIO         m_hostperlLIO;
 198     struct IPerlDir         m_hostperlDir;
 199     struct IPerlSock        m_hostperlSock;
 200     struct IPerlProc        m_hostperlProc;
 201
 202     struct IPerlMem*        m_pHostperlMem;
 203     struct IPerlMem*        m_pHostperlMemShared;
 204     struct IPerlMem*        m_pHostperlMemParse;
 205     struct IPerlEnv*        m_pHostperlEnv;
 206     struct IPerlStdIO*      m_pHostperlStdIO;
 207     struct IPerlLIO*        m_pHostperlLIO;
 208     struct IPerlDir*        m_pHostperlDir;
 209     struct IPerlSock*       m_pHostperlSock;
 210     struct IPerlProc*       m_pHostperlProc;
 211
 212     inline char* MapPathA(const char *pInName) { return m_pvDir->MapPathA(pInName); };
 213     inline WCHAR* MapPathW(const WCHAR *pInName) { return m_pvDir->MapPathW(pInName); };
 214 protected:
 215
 216     VDir*   m_pvDir;
 217     VMem*   m_pVMem;
 218     VMem*   m_pVMemShared;
 219     VMem*   m_pVMemParse;
 220
 221     DWORD   m_dwEnvCount;
 222     LPSTR*  m_lppEnvList;
 223     BOOL    m_bTopLevel;        // is this a toplevel host?
 224     static long num_hosts;
 225 public:
 226     inline  int LastHost(void) { return num_hosts == 1L; };
 227     struct interpreter *host_perl;
 228 };
 229
 230 long CPerlHost::num_hosts = 0L;
 231
 232 extern "C" void win32_checkTLS(struct interpreter *host_perl);
 233
 234 #define STRUCT2RAWPTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
 235 #ifdef CHECK_HOST_INTERP
 236 inline CPerlHost* CheckInterp(CPerlHost *host)
 237 {
 238  win32_checkTLS(host->host_perl);
 239  return host;
 240 }
 241 #define STRUCT2PTR(x, y) CheckInterp(STRUCT2RAWPTR(x, y))
 242 #else
 243 #define STRUCT2PTR(x, y) STRUCT2RAWPTR(x, y)
 244 #endif
 245
 246 inline CPerlHost* IPerlMem2Host(struct IPerlMem* piPerl)
 247 {
 248     return STRUCT2RAWPTR(piPerl, m_hostperlMem);
 249 }
 250
 251 inline CPerlHost* IPerlMemShared2Host(struct IPerlMem* piPerl)
 252 {
 253     return STRUCT2RAWPTR(piPerl, m_hostperlMemShared);
 254 }
 255
 256 inline CPerlHost* IPerlMemParse2Host(struct IPerlMem* piPerl)
 257 {
 258     return STRUCT2RAWPTR(piPerl, m_hostperlMemParse);
 259 }
 260
 261 inline CPerlHost* IPerlEnv2Host(struct IPerlEnv* piPerl)
 262 {
 263     return STRUCT2PTR(piPerl, m_hostperlEnv);
 264 }
 265
 266 inline CPerlHost* IPerlStdIO2Host(struct IPerlStdIO* piPerl)
 267 {
 268     return STRUCT2PTR(piPerl, m_hostperlStdIO);
 269 }
 270
 271 inline CPerlHost* IPerlLIO2Host(struct IPerlLIO* piPerl)
 272 {
 273     return STRUCT2PTR(piPerl, m_hostperlLIO);
 274 }
 275
 276 inline CPerlHost* IPerlDir2Host(struct IPerlDir* piPerl)
 277 {
 278     return STRUCT2PTR(piPerl, m_hostperlDir);
 279 }
 280
 281 inline CPerlHost* IPerlSock2Host(struct IPerlSock* piPerl)
 282 {
 283     return STRUCT2PTR(piPerl, m_hostperlSock);
 284 }
 285
 286 inline CPerlHost* IPerlProc2Host(struct IPerlProc* piPerl)
 287 {
 288     return STRUCT2PTR(piPerl, m_hostperlProc);
 289 }
 290
 291
 292
 293 #undef IPERL2HOST
 294 #define IPERL2HOST(x) IPerlMem2Host(x)
 295
 296 /* IPerlMem */
 297 void*
 298 PerlMemMalloc(struct IPerlMem* piPerl, size_t size)
 299 {
 300     return IPERL2HOST(piPerl)->Malloc(size);
 301 }
 302 void*
 303 PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
 304 {
 305     return IPERL2HOST(piPerl)->Realloc(ptr, size);
 306 }
 307 void
 308 PerlMemFree(struct IPerlMem* piPerl, void* ptr)
 309 {
 310     IPERL2HOST(piPerl)->Free(ptr);
 311 }
 312 void*
 313 PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
 314 {
 315     return IPERL2HOST(piPerl)->Calloc(num, size);
 316 }
 317
 318 void
 319 PerlMemGetLock(struct IPerlMem* piPerl)
 320 {
 321     IPERL2HOST(piPerl)->GetLock();
 322 }
 323
 324 void
 325 PerlMemFreeLock(struct IPerlMem* piPerl)
 326 {
 327     IPERL2HOST(piPerl)->FreeLock();
 328 }
 329
 330 int
 331 PerlMemIsLocked(struct IPerlMem* piPerl)
 332 {
 333     return IPERL2HOST(piPerl)->IsLocked();
 334 }
 335
 336 struct IPerlMem perlMem =
 337 {
 338     PerlMemMalloc,
 339     PerlMemRealloc,
 340     PerlMemFree,
 341     PerlMemCalloc,
 342     PerlMemGetLock,
 343     PerlMemFreeLock,
 344     PerlMemIsLocked,
 345 };
 346
 347 #undef IPERL2HOST
 348 #define IPERL2HOST(x) IPerlMemShared2Host(x)
 349
 350 /* IPerlMemShared */
 351 void*
 352 PerlMemSharedMalloc(struct IPerlMem* piPerl, size_t size)
 353 {
 354     return IPERL2HOST(piPerl)->MallocShared(size);
 355 }
 356 void*
 357 PerlMemSharedRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
 358 {
 359     return IPERL2HOST(piPerl)->ReallocShared(ptr, size);
 360 }
 361 void
 362 PerlMemSharedFree(struct IPerlMem* piPerl, void* ptr)
 363 {
 364     IPERL2HOST(piPerl)->FreeShared(ptr);
 365 }
 366 void*
 367 PerlMemSharedCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
 368 {
 369     return IPERL2HOST(piPerl)->CallocShared(num, size);
 370 }
 371
 372 void
 373 PerlMemSharedGetLock(struct IPerlMem* piPerl)
 374 {
 375     IPERL2HOST(piPerl)->GetLockShared();
 376 }
 377
 378 void
 379 PerlMemSharedFreeLock(struct IPerlMem* piPerl)
 380 {
 381     IPERL2HOST(piPerl)->FreeLockShared();
 382 }
 383
 384 int
 385 PerlMemSharedIsLocked(struct IPerlMem* piPerl)
 386 {
 387     return IPERL2HOST(piPerl)->IsLockedShared();
 388 }
 389
 390 struct IPerlMem perlMemShared =
 391 {
 392     PerlMemSharedMalloc,
 393     PerlMemSharedRealloc,
 394     PerlMemSharedFree,
 395     PerlMemSharedCalloc,
 396     PerlMemSharedGetLock,
 397     PerlMemSharedFreeLock,
 398     PerlMemSharedIsLocked,
 399 };
 400
 401 #undef IPERL2HOST
 402 #define IPERL2HOST(x) IPerlMemParse2Host(x)
 403
 404 /* IPerlMemParse */
 405 void*
 406 PerlMemParseMalloc(struct IPerlMem* piPerl, size_t size)
 407 {
 408     return IPERL2HOST(piPerl)->MallocParse(size);
 409 }
 410 void*
 411 PerlMemParseRealloc(struct IPerlMem* piPerl, void* ptr, size_t size)
 412 {
 413     return IPERL2HOST(piPerl)->ReallocParse(ptr, size);
 414 }
 415 void
 416 PerlMemParseFree(struct IPerlMem* piPerl, void* ptr)
 417 {
 418     IPERL2HOST(piPerl)->FreeParse(ptr);
 419 }
 420 void*
 421 PerlMemParseCalloc(struct IPerlMem* piPerl, size_t num, size_t size)
 422 {
 423     return IPERL2HOST(piPerl)->CallocParse(num, size);
 424 }
 425
 426 void
 427 PerlMemParseGetLock(struct IPerlMem* piPerl)
 428 {
 429     IPERL2HOST(piPerl)->GetLockParse();
 430 }
 431
 432 void
 433 PerlMemParseFreeLock(struct IPerlMem* piPerl)
 434 {
 435     IPERL2HOST(piPerl)->FreeLockParse();
 436 }
 437
 438 int
 439 PerlMemParseIsLocked(struct IPerlMem* piPerl)
 440 {
 441     return IPERL2HOST(piPerl)->IsLockedParse();
 442 }
 443
 444 struct IPerlMem perlMemParse =
 445 {
 446     PerlMemParseMalloc,
 447     PerlMemParseRealloc,
 448     PerlMemParseFree,
 449     PerlMemParseCalloc,
 450     PerlMemParseGetLock,
 451     PerlMemParseFreeLock,
 452     PerlMemParseIsLocked,
 453 };
 454
 455
 456 #undef IPERL2HOST
 457 #define IPERL2HOST(x) IPerlEnv2Host(x)
 458
 459 /* IPerlEnv */
 460 char*
 461 PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname)
 462 {
 463     return IPERL2HOST(piPerl)->Getenv(varname);
 464 };
 465
 466 int
 467 PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring)
 468 {
 469     return IPERL2HOST(piPerl)->Putenv(envstring);
 470 };
 471
 472 char*
 473 PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len)
 474 {
 475     return IPERL2HOST(piPerl)->Getenv(varname, len);
 476 }
 477
 478 int
 479 PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name)
 480 {
 481     return win32_uname(name);
 482 }
 483
 484 void
 485 PerlEnvClearenv(struct IPerlEnv* piPerl)
 486 {
 487     IPERL2HOST(piPerl)->Clearenv();
 488 }
 489
 490 void*
 491 PerlEnvGetChildenv(struct IPerlEnv* piPerl)
 492 {
 493     return IPERL2HOST(piPerl)->CreateChildEnv();
 494 }
 495
 496 void
 497 PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv)
 498 {
 499     IPERL2HOST(piPerl)->FreeChildEnv(childEnv);
 500 }
 501
 502 char*
 503 PerlEnvGetChilddir(struct IPerlEnv* piPerl)
 504 {
 505     return IPERL2HOST(piPerl)->GetChildDir();
 506 }
 507
 508 void
 509 PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir)
 510 {
 511     IPERL2HOST(piPerl)->FreeChildDir(childDir);
 512 }
 513
 514 unsigned long
 515 PerlEnvOsId(struct IPerlEnv* piPerl)
 516 {
 517     return win32_os_id();
 518 }
 519
 520 char*
 521 PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
 522 {
 523     return g_win32_get_privlib(pl, len);
 524 }
 525
 526 char*
 527 PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len)
 528 {
 529     return g_win32_get_sitelib(pl, len);
 530 }
 531
 532 char*
 533 PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl,
 534                      STRLEN *const len)
 535 {
 536     return g_win32_get_vendorlib(pl, len);
 537 }
 538
 539 void
 540 PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr)
 541 {
 542     win32_get_child_IO(ptr);
 543 }
 544
 545 struct IPerlEnv perlEnv =
 546 {
 547     PerlEnvGetenv,
 548     PerlEnvPutenv,
 549     PerlEnvGetenv_len,
 550     PerlEnvUname,
 551     PerlEnvClearenv,
 552     PerlEnvGetChildenv,
 553     PerlEnvFreeChildenv,
 554     PerlEnvGetChilddir,
 555     PerlEnvFreeChilddir,
 556     PerlEnvOsId,
 557     PerlEnvLibPath,
 558     PerlEnvSiteLibPath,
 559     PerlEnvVendorLibPath,
 560     PerlEnvGetChildIO,
 561 };
 562
 563 #undef IPERL2HOST
 564 #define IPERL2HOST(x) IPerlStdIO2Host(x)
 565
 566 /* PerlStdIO */
 567 FILE*
 568 PerlStdIOStdin(struct IPerlStdIO* piPerl)
 569 {
 570     return win32_stdin();
 571 }
 572
 573 FILE*
 574 PerlStdIOStdout(struct IPerlStdIO* piPerl)
 575 {
 576     return win32_stdout();
 577 }
 578
 579 FILE*
 580 PerlStdIOStderr(struct IPerlStdIO* piPerl)
 581 {
 582     return win32_stderr();
 583 }
 584
 585 FILE*
 586 PerlStdIOOpen(struct IPerlStdIO* piPerl, const char *path, const char *mode)
 587 {
 588     return win32_fopen(path, mode);
 589 }
 590
 591 int
 592 PerlStdIOClose(struct IPerlStdIO* piPerl, FILE* pf)
 593 {
 594     return win32_fclose((pf));
 595 }
 596
 597 int
 598 PerlStdIOEof(struct IPerlStdIO* piPerl, FILE* pf)
 599 {
 600     return win32_feof(pf);
 601 }
 602
 603 int
 604 PerlStdIOError(struct IPerlStdIO* piPerl, FILE* pf)
 605 {
 606     return win32_ferror(pf);
 607 }
 608
 609 void
 610 PerlStdIOClearerr(struct IPerlStdIO* piPerl, FILE* pf)
 611 {
 612     win32_clearerr(pf);
 613 }
 614
 615 int
 616 PerlStdIOGetc(struct IPerlStdIO* piPerl, FILE* pf)
 617 {
 618     return win32_getc(pf);
 619 }
 620
 621 STDCHAR*
 622 PerlStdIOGetBase(struct IPerlStdIO* piPerl, FILE* pf)
 623 {
 624 #ifdef FILE_base
 625     FILE *f = pf;
 626     return FILE_base(f);
 627 #else
 628     return NULL;
 629 #endif
 630 }
 631
 632 int
 633 PerlStdIOGetBufsiz(struct IPerlStdIO* piPerl, FILE* pf)
 634 {
 635 #ifdef FILE_bufsiz
 636     FILE *f = pf;
 637     return FILE_bufsiz(f);
 638 #else
 639     return (-1);
 640 #endif
 641 }
 642
 643 int
 644 PerlStdIOGetCnt(struct IPerlStdIO* piPerl, FILE* pf)
 645 {
 646 #ifdef USE_STDIO_PTR
 647     FILE *f = pf;
 648     return FILE_cnt(f);
 649 #else
 650     return (-1);
 651 #endif
 652 }
 653
 654 STDCHAR*
 655 PerlStdIOGetPtr(struct IPerlStdIO* piPerl, FILE* pf)
 656 {
 657 #ifdef USE_STDIO_PTR
 658     FILE *f = pf;
 659     return FILE_ptr(f);
 660 #else
 661     return NULL;
 662 #endif
 663 }
 664
 665 char*
 666 PerlStdIOGets(struct IPerlStdIO* piPerl, FILE* pf, char* s, int n)
 667 {
 668     return win32_fgets(s, n, pf);
 669 }
 670
 671 int
 672 PerlStdIOPutc(struct IPerlStdIO* piPerl, FILE* pf, int c)
 673 {
 674     return win32_fputc(c, pf);
 675 }
 676
 677 int
 678 PerlStdIOPuts(struct IPerlStdIO* piPerl, FILE* pf, const char *s)
 679 {
 680     return win32_fputs(s, pf);
 681 }
 682
 683 int
 684 PerlStdIOFlush(struct IPerlStdIO* piPerl, FILE* pf)
 685 {
 686     return win32_fflush(pf);
 687 }
 688
 689 int
 690 PerlStdIOUngetc(struct IPerlStdIO* piPerl,int c, FILE* pf)
 691 {
 692     return win32_ungetc(c, pf);
 693 }
 694
 695 int
 696 PerlStdIOFileno(struct IPerlStdIO* piPerl, FILE* pf)
 697 {
 698     return win32_fileno(pf);
 699 }
 700
 701 FILE*
 702 PerlStdIOFdopen(struct IPerlStdIO* piPerl, int fd, const char *mode)
 703 {
 704     return win32_fdopen(fd, mode);
 705 }
 706
 707 FILE*
 708 PerlStdIOReopen(struct IPerlStdIO* piPerl, const char*path, const char*mode, FILE* pf)
 709 {
 710     return win32_freopen(path, mode, (FILE*)pf);
 711 }
 712
 713 SSize_t
 714 PerlStdIORead(struct IPerlStdIO* piPerl, void *buffer, Size_t size, Size_t count, FILE* pf)
 715 {
 716     return win32_fread(buffer, size, count, pf);
 717 }
 718
 719 SSize_t
 720 PerlStdIOWrite(struct IPerlStdIO* piPerl, const void *buffer, Size_t size, Size_t count, FILE* pf)
 721 {
 722     return win32_fwrite(buffer, size, count, pf);
 723 }
 724
 725 void
 726 PerlStdIOSetBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer)
 727 {
 728     win32_setbuf(pf, buffer);
 729 }
 730
 731 int
 732 PerlStdIOSetVBuf(struct IPerlStdIO* piPerl, FILE* pf, char* buffer, int type, Size_t size)
 733 {
 734     return win32_setvbuf(pf, buffer, type, size);
 735 }
 736
 737 void
 738 PerlStdIOSetCnt(struct IPerlStdIO* piPerl, FILE* pf, int n)
 739 {
 740 #ifdef STDIO_CNT_LVALUE
 741     FILE *f = pf;
 742     FILE_cnt(f) = n;
 743 #endif
 744 }
 745
 746 void
 747 PerlStdIOSetPtr(struct IPerlStdIO* piPerl, FILE* pf, STDCHAR * ptr)
 748 {
 749 #ifdef STDIO_PTR_LVALUE
 750     FILE *f = pf;
 751     FILE_ptr(f) = ptr;
 752 #endif
 753 }
 754
 755 void
 756 PerlStdIOSetlinebuf(struct IPerlStdIO* piPerl, FILE* pf)
 757 {
 758     win32_setvbuf(pf, NULL, _IOLBF, 0);
 759 }
 760
 761 int
 762 PerlStdIOPrintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format,...)
 763 {
 764     va_list(arglist);
 765     va_start(arglist, format);
 766     return win32_vfprintf(pf, format, arglist);
 767 }
 768
 769 int
 770 PerlStdIOVprintf(struct IPerlStdIO* piPerl, FILE* pf, const char *format, va_list arglist)
 771 {
 772     return win32_vfprintf(pf, format, arglist);
 773 }
 774
 775 Off_t
 776 PerlStdIOTell(struct IPerlStdIO* piPerl, FILE* pf)
 777 {
 778     return win32_ftell(pf);
 779 }
 780
 781 int
 782 PerlStdIOSeek(struct IPerlStdIO* piPerl, FILE* pf, Off_t offset, int origin)
 783 {
 784     return win32_fseek(pf, offset, origin);
 785 }
 786
 787 void
 788 PerlStdIORewind(struct IPerlStdIO* piPerl, FILE* pf)
 789 {
 790     win32_rewind(pf);
 791 }
 792
 793 FILE*
 794 PerlStdIOTmpfile(struct IPerlStdIO* piPerl)
 795 {
 796     return win32_tmpfile();
 797 }
 798
 799 int
 800 PerlStdIOGetpos(struct IPerlStdIO* piPerl, FILE* pf, Fpos_t *p)
 801 {
 802     return win32_fgetpos(pf, p);
 803 }
 804
 805 int
 806 PerlStdIOSetpos(struct IPerlStdIO* piPerl, FILE* pf, const Fpos_t *p)
 807 {
 808     return win32_fsetpos(pf, p);
 809 }
 810 void
 811 PerlStdIOInit(struct IPerlStdIO* piPerl)
 812 {
 813 }
 814
 815 void
 816 PerlStdIOInitOSExtras(struct IPerlStdIO* piPerl)
 817 {
 818     Perl_init_os_extras();
 819 }
 820
 821 int
 822 PerlStdIOOpenOSfhandle(struct IPerlStdIO* piPerl, intptr_t osfhandle, int flags)
 823 {
 824     return win32_open_osfhandle(osfhandle, flags);
 825 }
 826
 827 intptr_t
 828 PerlStdIOGetOSfhandle(struct IPerlStdIO* piPerl, int filenum)
 829 {
 830     return win32_get_osfhandle(filenum);
 831 }
 832
 833 FILE*
 834 PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf)
 835 {
 836 #ifndef UNDER_CE
 837     FILE* pfdup;
 838     fpos_t pos;
 839     char mode[3];
 840     int fileno = win32_dup(win32_fileno(pf));
 841
 842     /* open the file in the same mode */
 843 #ifdef __BORLANDC__
 844     if((pf)->flags & _F_READ) {
 845         mode[0] = 'r';
 846         mode[1] = 0;
 847     }
 848     else if((pf)->flags & _F_WRIT) {
 849         mode[0] = 'a';
 850         mode[1] = 0;
 851     }
 852     else if((pf)->flags & _F_RDWR) {
 853         mode[0] = 'r';
 854         mode[1] = '+';
 855         mode[2] = 0;
 856     }
 857 #else
 858     if((pf)->_flag & _IOREAD) {
 859         mode[0] = 'r';
 860         mode[1] = 0;
 861     }
 862     else if((pf)->_flag & _IOWRT) {
 863         mode[0] = 'a';
 864         mode[1] = 0;
 865     }
 866     else if((pf)->_flag & _IORW) {
 867         mode[0] = 'r';
 868         mode[1] = '+';
 869         mode[2] = 0;
 870     }
 871 #endif
 872
 873     /* it appears that the binmode is attached to the
 874      * file descriptor so binmode files will be handled
 875      * correctly
 876      */
 877     pfdup = win32_fdopen(fileno, mode);
 878
 879     /* move the file pointer to the same position */
 880     if (!fgetpos(pf, &pos)) {
 881         fsetpos(pfdup, &pos);
 882     }
 883     return pfdup;
 884 #else
 885     return 0;
 886 #endif
 887 }
 888
 889 struct IPerlStdIO perlStdIO =
 890 {
 891     PerlStdIOStdin,
 892     PerlStdIOStdout,
 893     PerlStdIOStderr,
 894     PerlStdIOOpen,
 895     PerlStdIOClose,
 896     PerlStdIOEof,
 897     PerlStdIOError,
 898     PerlStdIOClearerr,
 899     PerlStdIOGetc,
 900     PerlStdIOGetBase,
 901     PerlStdIOGetBufsiz,
 902     PerlStdIOGetCnt,
 903     PerlStdIOGetPtr,
 904     PerlStdIOGets,
 905     PerlStdIOPutc,
 906     PerlStdIOPuts,
 907     PerlStdIOFlush,
 908     PerlStdIOUngetc,
 909     PerlStdIOFileno,
 910     PerlStdIOFdopen,
 911     PerlStdIOReopen,
 912     PerlStdIORead,
 913     PerlStdIOWrite,
 914     PerlStdIOSetBuf,
 915     PerlStdIOSetVBuf,
 916     PerlStdIOSetCnt,
 917     PerlStdIOSetPtr,
 918     PerlStdIOSetlinebuf,
 919     PerlStdIOPrintf,
 920     PerlStdIOVprintf,
 921     PerlStdIOTell,
 922     PerlStdIOSeek,
 923     PerlStdIORewind,
 924     PerlStdIOTmpfile,
 925     PerlStdIOGetpos,
 926     PerlStdIOSetpos,
 927     PerlStdIOInit,
 928     PerlStdIOInitOSExtras,
 929     PerlStdIOFdupopen,
 930 };
 931
 932
 933 #undef IPERL2HOST
 934 #define IPERL2HOST(x) IPerlLIO2Host(x)
 935
 936 /* IPerlLIO */
 937 int
 938 PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
 939 {
 940     return win32_access(path, mode);
 941 }
 942
 943 int
 944 PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
 945 {
 946     return win32_chmod(filename, pmode);
 947 }
 948
 949 int
 950 PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
 951 {
 952     return chown(filename, owner, group);
 953 }
 954
 955 int
 956 PerlLIOChsize(struct IPerlLIO* piPerl, int handle, Off_t size)
 957 {
 958     return win32_chsize(handle, size);
 959 }
 960
 961 int
 962 PerlLIOClose(struct IPerlLIO* piPerl, int handle)
 963 {
 964     return win32_close(handle);
 965 }
 966
 967 int
 968 PerlLIODup(struct IPerlLIO* piPerl, int handle)
 969 {
 970     return win32_dup(handle);
 971 }
 972
 973 int
 974 PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
 975 {
 976     return win32_dup2(handle1, handle2);
 977 }
 978
 979 int
 980 PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
 981 {
 982     return win32_flock(fd, oper);
 983 }
 984
 985 int
 986 PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, Stat_t *buffer)
 987 {
 988     return win32_fstat(handle, buffer);
 989 }
 990
 991 int
 992 PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
 993 {
 994     u_long u_long_arg;
 995     int retval;
 996
 997     /* mauke says using memcpy avoids alignment issues */
 998     memcpy(&u_long_arg, data, sizeof u_long_arg);
 999     retval = win32_ioctlsocket((SOCKET)i, (long)u, &u_long_arg);
1000     memcpy(data, &u_long_arg, sizeof u_long_arg);
1001     return retval;
1002 }
1003
1004 int
1005 PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
1006 {
1007     /* The Microsoft isatty() function returns true for *all*
1008      * character mode devices, including "nul".  Our implementation
1009      * should only return true if the handle has a console buffer.
1010      */
1011     DWORD mode;
1012     HANDLE fh = (HANDLE)_get_osfhandle(fd);
1013     if (fh == (HANDLE)-1) {
1014         /* errno is already set to EBADF */
1015         return 0;
1016     }
1017
1018     if (GetConsoleMode(fh, &mode))
1019         return 1;
1020
1021     errno = ENOTTY;
1022     return 0;
1023 }
1024
1025 int
1026 PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
1027 {
1028     return win32_link(oldname, newname);
1029 }
1030
1031 Off_t
1032 PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
1033 {
1034     return win32_lseek(handle, offset, origin);
1035 }
1036
1037 int
1038 PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
1039 {
1040     return win32_stat(path, buffer);
1041 }
1042
1043 char*
1044 PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
1045 {
1046     return mktemp(Template);
1047 }
1048
1049 int
1050 PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
1051 {
1052     return win32_open(filename, oflag);
1053 }
1054
1055 int
1056 PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
1057 {
1058     return win32_open(filename, oflag, pmode);
1059 }
1060
1061 int
1062 PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
1063 {
1064     return win32_read(handle, buffer, count);
1065 }
1066
1067 int
1068 PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
1069 {
1070     return win32_rename(OldFileName, newname);
1071 }
1072
1073 int
1074 PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
1075 {
1076     return win32_setmode(handle, mode);
1077 }
1078
1079 int
1080 PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
1081 {
1082     return win32_stat(path, buffer);
1083 }
1084
1085 char*
1086 PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
1087 {
1088     return tmpnam(string);
1089 }
1090
1091 int
1092 PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
1093 {
1094     return umask(pmode);
1095 }
1096
1097 int
1098 PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
1099 {
1100     return win32_unlink(filename);
1101 }
1102
1103 int
1104 PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
1105 {
1106     return win32_utime(filename, times);
1107 }
1108
1109 int
1110 PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
1111 {
1112     return win32_write(handle, buffer, count);
1113 }
1114
1115 struct IPerlLIO perlLIO =
1116 {
1117     PerlLIOAccess,
1118     PerlLIOChmod,
1119     PerlLIOChown,
1120     PerlLIOChsize,
1121     PerlLIOClose,
1122     PerlLIODup,
1123     PerlLIODup2,
1124     PerlLIOFlock,
1125     PerlLIOFileStat,
1126     PerlLIOIOCtl,
1127     PerlLIOIsatty,
1128     PerlLIOLink,
1129     PerlLIOLseek,
1130     PerlLIOLstat,
1131     PerlLIOMktemp,
1132     PerlLIOOpen,
1133     PerlLIOOpen3,
1134     PerlLIORead,
1135     PerlLIORename,
1136     PerlLIOSetmode,
1137     PerlLIONameStat,
1138     PerlLIOTmpnam,
1139     PerlLIOUmask,
1140     PerlLIOUnlink,
1141     PerlLIOUtime,
1142     PerlLIOWrite,
1143 };
1144
1145
1146 #undef IPERL2HOST
1147 #define IPERL2HOST(x) IPerlDir2Host(x)
1148
1149 /* IPerlDIR */
1150 int
1151 PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
1152 {
1153     return win32_mkdir(dirname, mode);
1154 }
1155
1156 int
1157 PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
1158 {
1159     return IPERL2HOST(piPerl)->Chdir(dirname);
1160 }
1161
1162 int
1163 PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
1164 {
1165     return win32_rmdir(dirname);
1166 }
1167
1168 int
1169 PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
1170 {
1171     return win32_closedir(dirp);
1172 }
1173
1174 DIR*
1175 PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
1176 {
1177     return win32_opendir(filename);
1178 }
1179
1180 struct direct *
1181 PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
1182 {
1183     return win32_readdir(dirp);
1184 }
1185
1186 void
1187 PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
1188 {
1189     win32_rewinddir(dirp);
1190 }
1191
1192 void
1193 PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
1194 {
1195     win32_seekdir(dirp, loc);
1196 }
1197
1198 long
1199 PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
1200 {
1201     return win32_telldir(dirp);
1202 }
1203
1204 char*
1205 PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
1206 {
1207     return IPERL2HOST(piPerl)->MapPathA(path);
1208 }
1209
1210 WCHAR*
1211 PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
1212 {
1213     return IPERL2HOST(piPerl)->MapPathW(path);
1214 }
1215
1216 struct IPerlDir perlDir =
1217 {
1218     PerlDirMakedir,
1219     PerlDirChdir,
1220     PerlDirRmdir,
1221     PerlDirClose,
1222     PerlDirOpen,
1223     PerlDirRead,
1224     PerlDirRewind,
1225     PerlDirSeek,
1226     PerlDirTell,
1227     PerlDirMapPathA,
1228     PerlDirMapPathW,
1229 };
1230
1231
1232 /* IPerlSock */
1233 u_long
1234 PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
1235 {
1236     return win32_htonl(hostlong);
1237 }
1238
1239 u_short
1240 PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
1241 {
1242     return win32_htons(hostshort);
1243 }
1244
1245 u_long
1246 PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
1247 {
1248     return win32_ntohl(netlong);
1249 }
1250
1251 u_short
1252 PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
1253 {
1254     return win32_ntohs(netshort);
1255 }
1256
1257 SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
1258 {
1259     return win32_accept(s, addr, addrlen);
1260 }
1261
1262 int
1263 PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1264 {
1265     return win32_bind(s, name, namelen);
1266 }
1267
1268 int
1269 PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1270 {
1271     return win32_connect(s, name, namelen);
1272 }
1273
1274 void
1275 PerlSockEndhostent(struct IPerlSock* piPerl)
1276 {
1277     win32_endhostent();
1278 }
1279
1280 void
1281 PerlSockEndnetent(struct IPerlSock* piPerl)
1282 {
1283     win32_endnetent();
1284 }
1285
1286 void
1287 PerlSockEndprotoent(struct IPerlSock* piPerl)
1288 {
1289     win32_endprotoent();
1290 }
1291
1292 void
1293 PerlSockEndservent(struct IPerlSock* piPerl)
1294 {
1295     win32_endservent();
1296 }
1297
1298 struct hostent*
1299 PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
1300 {
1301     return win32_gethostbyaddr(addr, len, type);
1302 }
1303
1304 struct hostent*
1305 PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
1306 {
1307     return win32_gethostbyname(name);
1308 }
1309
1310 struct hostent*
1311 PerlSockGethostent(struct IPerlSock* piPerl)
1312 {
1313     dTHX;
1314     Perl_croak(aTHX_ "gethostent not implemented!\n");
1315     return NULL;
1316 }
1317
1318 int
1319 PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
1320 {
1321     return win32_gethostname(name, namelen);
1322 }
1323
1324 struct netent *
1325 PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
1326 {
1327     return win32_getnetbyaddr(net, type);
1328 }
1329
1330 struct netent *
1331 PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
1332 {
1333     return win32_getnetbyname((char*)name);
1334 }
1335
1336 struct netent *
1337 PerlSockGetnetent(struct IPerlSock* piPerl)
1338 {
1339     return win32_getnetent();
1340 }
1341
1342 int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1343 {
1344     return win32_getpeername(s, name, namelen);
1345 }
1346
1347 struct protoent*
1348 PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
1349 {
1350     return win32_getprotobyname(name);
1351 }
1352
1353 struct protoent*
1354 PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
1355 {
1356     return win32_getprotobynumber(number);
1357 }
1358
1359 struct protoent*
1360 PerlSockGetprotoent(struct IPerlSock* piPerl)
1361 {
1362     return win32_getprotoent();
1363 }
1364
1365 struct servent*
1366 PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
1367 {
1368     return win32_getservbyname(name, proto);
1369 }
1370
1371 struct servent*
1372 PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
1373 {
1374     return win32_getservbyport(port, proto);
1375 }
1376
1377 struct servent*
1378 PerlSockGetservent(struct IPerlSock* piPerl)
1379 {
1380     return win32_getservent();
1381 }
1382
1383 int
1384 PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1385 {
1386     return win32_getsockname(s, name, namelen);
1387 }
1388
1389 int
1390 PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
1391 {
1392     return win32_getsockopt(s, level, optname, optval, optlen);
1393 }
1394
1395 unsigned long
1396 PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
1397 {
1398     return win32_inet_addr(cp);
1399 }
1400
1401 char*
1402 PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
1403 {
1404     return win32_inet_ntoa(in);
1405 }
1406
1407 int
1408 PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
1409 {
1410     return win32_listen(s, backlog);
1411 }
1412
1413 int
1414 PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
1415 {
1416     return win32_recv(s, buffer, len, flags);
1417 }
1418
1419 int
1420 PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
1421 {
1422     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
1423 }
1424
1425 int
1426 PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
1427 {
1428     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
1429 }
1430
1431 int
1432 PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
1433 {
1434     return win32_send(s, buffer, len, flags);
1435 }
1436
1437 int
1438 PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
1439 {
1440     return win32_sendto(s, buffer, len, flags, to, tolen);
1441 }
1442
1443 void
1444 PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
1445 {
1446     win32_sethostent(stayopen);
1447 }
1448
1449 void
1450 PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
1451 {
1452     win32_setnetent(stayopen);
1453 }
1454
1455 void
1456 PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
1457 {
1458     win32_setprotoent(stayopen);
1459 }
1460
1461 void
1462 PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
1463 {
1464     win32_setservent(stayopen);
1465 }
1466
1467 int
1468 PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
1469 {
1470     return win32_setsockopt(s, level, optname, optval, optlen);
1471 }
1472
1473 int
1474 PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
1475 {
1476     return win32_shutdown(s, how);
1477 }
1478
1479 SOCKET
1480 PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
1481 {
1482     return win32_socket(af, type, protocol);
1483 }
1484
1485 int
1486 PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
1487 {
1488     return Perl_my_socketpair(domain, type, protocol, fds);
1489 }
1490
1491 int
1492 PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
1493 {
1494     return win32_closesocket(s);
1495 }
1496
1497 int
1498 PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
1499 {
1500     return win32_ioctlsocket(s, cmd, argp);
1501 }
1502
1503 struct IPerlSock perlSock =
1504 {
1505     PerlSockHtonl,
1506     PerlSockHtons,
1507     PerlSockNtohl,
1508     PerlSockNtohs,
1509     PerlSockAccept,
1510     PerlSockBind,
1511     PerlSockConnect,
1512     PerlSockEndhostent,
1513     PerlSockEndnetent,
1514     PerlSockEndprotoent,
1515     PerlSockEndservent,
1516     PerlSockGethostname,
1517     PerlSockGetpeername,
1518     PerlSockGethostbyaddr,
1519     PerlSockGethostbyname,
1520     PerlSockGethostent,
1521     PerlSockGetnetbyaddr,
1522     PerlSockGetnetbyname,
1523     PerlSockGetnetent,
1524     PerlSockGetprotobyname,
1525     PerlSockGetprotobynumber,
1526     PerlSockGetprotoent,
1527     PerlSockGetservbyname,
1528     PerlSockGetservbyport,
1529     PerlSockGetservent,
1530     PerlSockGetsockname,
1531     PerlSockGetsockopt,
1532     PerlSockInetAddr,
1533     PerlSockInetNtoa,
1534     PerlSockListen,
1535     PerlSockRecv,
1536     PerlSockRecvfrom,
1537     PerlSockSelect,
1538     PerlSockSend,
1539     PerlSockSendto,
1540     PerlSockSethostent,
1541     PerlSockSetnetent,
1542     PerlSockSetprotoent,
1543     PerlSockSetservent,
1544     PerlSockSetsockopt,
1545     PerlSockShutdown,
1546     PerlSockSocket,
1547     PerlSockSocketpair,
1548     PerlSockClosesocket,
1549 };
1550
1551
1552 /* IPerlProc */
1553
1554 #define EXECF_EXEC 1
1555 #define EXECF_SPAWN 2
1556
1557 void
1558 PerlProcAbort(struct IPerlProc* piPerl)
1559 {
1560     win32_abort();
1561 }
1562
1563 char *
1564 PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
1565 {
1566     return win32_crypt(clear, salt);
1567 }
1568
1569 void
1570 PerlProcExit(struct IPerlProc* piPerl, int status)
1571 {
1572     exit(status);
1573 }
1574
1575 void
1576 PerlProc_Exit(struct IPerlProc* piPerl, int status)
1577 {
1578     _exit(status);
1579 }
1580
1581 int
1582 PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1583 {
1584     return execl(cmdname, arg0, arg1, arg2, arg3);
1585 }
1586
1587 int
1588 PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1589 {
1590     return win32_execvp(cmdname, argv);
1591 }
1592
1593 int
1594 PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1595 {
1596     return win32_execvp(cmdname, argv);
1597 }
1598
1599 uid_t
1600 PerlProcGetuid(struct IPerlProc* piPerl)
1601 {
1602     return getuid();
1603 }
1604
1605 uid_t
1606 PerlProcGeteuid(struct IPerlProc* piPerl)
1607 {
1608     return geteuid();
1609 }
1610
1611 gid_t
1612 PerlProcGetgid(struct IPerlProc* piPerl)
1613 {
1614     return getgid();
1615 }
1616
1617 gid_t
1618 PerlProcGetegid(struct IPerlProc* piPerl)
1619 {
1620     return getegid();
1621 }
1622
1623 char *
1624 PerlProcGetlogin(struct IPerlProc* piPerl)
1625 {
1626     return g_getlogin();
1627 }
1628
1629 int
1630 PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
1631 {
1632     return win32_kill(pid, sig);
1633 }
1634
1635 int
1636 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
1637 {
1638     return win32_kill(pid, -sig);
1639 }
1640
1641 int
1642 PerlProcPauseProc(struct IPerlProc* piPerl)
1643 {
1644     return win32_sleep((32767L << 16) + 32767);
1645 }
1646
1647 PerlIO*
1648 PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
1649 {
1650     dTHX;
1651     PERL_FLUSHALL_FOR_CHILD;
1652     return win32_popen(command, mode);
1653 }
1654
1655 PerlIO*
1656 PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
1657 {
1658     dTHX;
1659     PERL_FLUSHALL_FOR_CHILD;
1660     return win32_popenlist(mode, narg, args);
1661 }
1662
1663 int
1664 PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
1665 {
1666     return win32_pclose(stream);
1667 }
1668
1669 int
1670 PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
1671 {
1672     return win32_pipe(phandles, 512, O_BINARY);
1673 }
1674
1675 int
1676 PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
1677 {
1678     return setuid(u);
1679 }
1680
1681 int
1682 PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
1683 {
1684     return setgid(g);
1685 }
1686
1687 int
1688 PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
1689 {
1690     return win32_sleep(s);
1691 }
1692
1693 int
1694 PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
1695 {
1696     return win32_times(timebuf);
1697 }
1698
1699 int
1700 PerlProcWait(struct IPerlProc* piPerl, int *status)
1701 {
1702     return win32_wait(status);
1703 }
1704
1705 int
1706 PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
1707 {
1708     return win32_waitpid(pid, status, flags);
1709 }
1710
1711 Sighandler_t
1712 PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
1713 {
1714     return win32_signal(sig, subcode);
1715 }
1716
1717 int
1718 PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
1719 {
1720     return win32_gettimeofday(t, z);
1721 }
1722
1723 #ifdef USE_ITHREADS
1724 static THREAD_RET_TYPE
1725 win32_start_child(LPVOID arg)
1726 {
1727     PerlInterpreter *my_perl = (PerlInterpreter*)arg;
1728     GV *tmpgv;
1729     int status;
1730     HWND parent_message_hwnd;
1731 #ifdef PERL_SYNC_FORK
1732     static long sync_fork_id = 0;
1733     long id = ++sync_fork_id;
1734 #endif
1735
1736
1737     PERL_SET_THX(my_perl);
1738     win32_checkTLS(my_perl);
1739
1740     /* set $$ to pseudo id */
1741 #ifdef PERL_SYNC_FORK
1742     w32_pseudo_id = id;
1743 #else
1744     w32_pseudo_id = GetCurrentThreadId();
1745     if (IsWin95()) {
1746         int pid = (int)w32_pseudo_id;
1747         if (pid < 0)
1748             w32_pseudo_id = -pid;
1749     }
1750 #endif
1751     if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
1752         SV *sv = GvSV(tmpgv);
1753         SvREADONLY_off(sv);
1754         sv_setiv(sv, -(IV)w32_pseudo_id);
1755         SvREADONLY_on(sv);
1756     }
1757 #ifdef PERL_USES_PL_PIDSTATUS
1758     hv_clear(PL_pidstatus);
1759 #endif
1760
1761     /* create message window and tell parent about it */
1762     parent_message_hwnd = w32_message_hwnd;
1763     w32_message_hwnd = win32_create_message_window();
1764     if (parent_message_hwnd != NULL)
1765         PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LPARAM)w32_message_hwnd);
1766
1767     /* push a zero on the stack (we are the child) */
1768     {
1769         dSP;
1770         dTARGET;
1771         PUSHi(0);
1772         PUTBACK;
1773     }
1774
1775     /* continue from next op */
1776     PL_op = PL_op->op_next;
1777
1778     {
1779         dJMPENV;
1780         volatile int oldscope = 1; /* We are responsible for all scopes */
1781
1782 restart:
1783         JMPENV_PUSH(status);
1784         switch (status) {
1785         case 0:
1786             CALLRUNOPS(aTHX);
1787             /* We may have additional unclosed scopes if fork() was called
1788              * from within a BEGIN block.  See perlfork.pod for more details.
1789              * We cannot clean up these other scopes because they belong to a
1790              * different interpreter, but we also cannot leave PL_scopestack_ix
1791              * dangling because that can trigger an assertion in perl_destruct().
1792              */
1793             if (PL_scopestack_ix > oldscope) {
1794                 PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
1795                 PL_scopestack_ix = oldscope;
1796             }
1797             status = 0;
1798             break;
1799         case 2:
1800             while (PL_scopestack_ix > oldscope)
1801                 LEAVE;
1802             FREETMPS;
1803             PL_curstash = PL_defstash;
1804             if (PL_endav && !PL_minus_c)
1805                 call_list(oldscope, PL_endav);
1806             status = STATUS_EXIT;
1807             break;
1808         case 3:
1809             if (PL_restartop) {
1810                 POPSTACK_TO(PL_mainstack);
1811                 PL_op = PL_restartop;
1812                 PL_restartop = (OP*)NULL;
1813                 goto restart;
1814             }
1815             PerlIO_printf(Perl_error_log, "panic: restartop\n");
1816             FREETMPS;
1817             status = 1;
1818             break;
1819         }
1820         JMPENV_POP;
1821
1822         /* XXX hack to avoid perl_destruct() freeing optree */
1823         win32_checkTLS(my_perl);
1824         PL_main_root = (OP*)NULL;
1825     }
1826
1827     win32_checkTLS(my_perl);
1828     /* close the std handles to avoid fd leaks */
1829     {
1830         do_close(PL_stdingv, FALSE);
1831         do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
1832         do_close(PL_stderrgv, FALSE);
1833     }
1834
1835     /* destroy everything (waits for any pseudo-forked children) */
1836     win32_checkTLS(my_perl);
1837     perl_destruct(my_perl);
1838     win32_checkTLS(my_perl);
1839     perl_free(my_perl);
1840
1841 #ifdef PERL_SYNC_FORK
1842     return id;
1843 #else
1844     return (DWORD)status;
1845 #endif
1846 }
1847 #endif /* USE_ITHREADS */
1848
1849 int
1850 PerlProcFork(struct IPerlProc* piPerl)
1851 {
1852     dTHX;
1853 #ifdef USE_ITHREADS
1854     DWORD id;
1855     HANDLE handle;
1856     CPerlHost *h;
1857
1858     if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
1859         errno = EAGAIN;
1860         return -1;
1861     }
1862     h = new CPerlHost(*(CPerlHost*)w32_internal_host);
1863     PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX,
1864                                                  CLONEf_COPY_STACKS,
1865                                                  h->m_pHostperlMem,
1866                                                  h->m_pHostperlMemShared,
1867                                                  h->m_pHostperlMemParse,
1868                                                  h->m_pHostperlEnv,
1869                                                  h->m_pHostperlStdIO,
1870                                                  h->m_pHostperlLIO,
1871                                                  h->m_pHostperlDir,
1872                                                  h->m_pHostperlSock,
1873                                                  h->m_pHostperlProc
1874                                                  );
1875     new_perl->Isys_intern.internal_host = h;
1876     h->host_perl = new_perl;
1877 #  ifdef PERL_SYNC_FORK
1878     id = win32_start_child((LPVOID)new_perl);
1879     PERL_SET_THX(aTHX);
1880 #  else
1881     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
1882         w32_message_hwnd = win32_create_message_window();
1883     new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
1884     w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
1885         (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
1886 #    ifdef USE_RTL_THREAD_API
1887     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
1888                                     (void*)new_perl, 0, (unsigned*)&id);
1889 #    else
1890     handle = CreateThread(NULL, 0, win32_start_child,
1891                           (LPVOID)new_perl, 0, &id);
1892 #    endif
1893     PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
1894     if (!handle) {
1895         errno = EAGAIN;
1896         return -1;
1897     }
1898     if (IsWin95()) {
1899         int pid = (int)id;
1900         if (pid < 0)
1901             id = -pid;
1902     }
1903     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
1904     w32_pseudo_child_pids[w32_num_pseudo_children] = id;
1905     ++w32_num_pseudo_children;
1906 #  endif
1907     return -(int)id;
1908 #else
1909     Perl_croak(aTHX_ "fork() not implemented!\n");
1910     return -1;
1911 #endif /* USE_ITHREADS */
1912 }
1913
1914 int
1915 PerlProcGetpid(struct IPerlProc* piPerl)
1916 {
1917     return win32_getpid();
1918 }
1919
1920 void*
1921 PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
1922 {
1923     return win32_dynaload(filename);
1924 }
1925
1926 void
1927 PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
1928 {
1929     win32_str_os_error(sv, dwErr);
1930 }
1931
1932 int
1933 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
1934 {
1935     return win32_spawnvp(mode, cmdname, argv);
1936 }
1937
1938 int
1939 PerlProcLastHost(struct IPerlProc* piPerl)
1940 {
1941  dTHX;
1942  CPerlHost *h = (CPerlHost*)w32_internal_host;
1943  return h->LastHost();
1944 }
1945
1946 struct IPerlProc perlProc =
1947 {
1948     PerlProcAbort,
1949     PerlProcCrypt,
1950     PerlProcExit,
1951     PerlProc_Exit,
1952     PerlProcExecl,
1953     PerlProcExecv,
1954     PerlProcExecvp,
1955     PerlProcGetuid,
1956     PerlProcGeteuid,
1957     PerlProcGetgid,
1958     PerlProcGetegid,
1959     PerlProcGetlogin,
1960     PerlProcKill,
1961     PerlProcKillpg,
1962     PerlProcPauseProc,
1963     PerlProcPopen,
1964     PerlProcPclose,
1965     PerlProcPipe,
1966     PerlProcSetuid,
1967     PerlProcSetgid,
1968     PerlProcSleep,
1969     PerlProcTimes,
1970     PerlProcWait,
1971     PerlProcWaitpid,
1972     PerlProcSignal,
1973     PerlProcFork,
1974     PerlProcGetpid,
1975     PerlProcDynaLoader,
1976     PerlProcGetOSError,
1977     PerlProcSpawnvp,
1978     PerlProcLastHost,
1979     PerlProcPopenList,
1980     PerlProcGetTimeOfDay
1981 };
1982
1983
1984 /*
1985  * CPerlHost
1986  */
1987
1988 CPerlHost::CPerlHost(void)
1989 {
1990     /* Construct a host from scratch */
1991     InterlockedIncrement(&num_hosts);
1992     m_pvDir = new VDir();
1993     m_pVMem = new VMem();
1994     m_pVMemShared = new VMem();
1995     m_pVMemParse =  new VMem();
1996
1997     m_pvDir->Init(NULL, m_pVMem);
1998
1999     m_dwEnvCount = 0;
2000     m_lppEnvList = NULL;
2001     m_bTopLevel = TRUE;
2002
2003     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2004     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2005     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2006     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2007     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2008     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2009     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2010     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2011     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2012
2013     m_pHostperlMem          = &m_hostperlMem;
2014     m_pHostperlMemShared    = &m_hostperlMemShared;
2015     m_pHostperlMemParse     = &m_hostperlMemParse;
2016     m_pHostperlEnv          = &m_hostperlEnv;
2017     m_pHostperlStdIO        = &m_hostperlStdIO;
2018     m_pHostperlLIO          = &m_hostperlLIO;
2019     m_pHostperlDir          = &m_hostperlDir;
2020     m_pHostperlSock         = &m_hostperlSock;
2021     m_pHostperlProc         = &m_hostperlProc;
2022 }
2023
2024 #define SETUPEXCHANGE(xptr, iptr, table) \
2025     STMT_START {                                \
2026         if (xptr) {                             \
2027             iptr = *xptr;                       \
2028             *xptr = &table;                     \
2029         }                                       \
2030         else {                                  \
2031             iptr = &table;                      \
2032         }                                       \
2033     } STMT_END
2034
2035 CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
2036                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
2037                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
2038                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
2039                  struct IPerlProc** ppProc)
2040 {
2041     InterlockedIncrement(&num_hosts);
2042     m_pvDir = new VDir(0);
2043     m_pVMem = new VMem();
2044     m_pVMemShared = new VMem();
2045     m_pVMemParse =  new VMem();
2046
2047     m_pvDir->Init(NULL, m_pVMem);
2048
2049     m_dwEnvCount = 0;
2050     m_lppEnvList = NULL;
2051     m_bTopLevel = FALSE;
2052
2053     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2054     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2055     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2056     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2057     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2058     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2059     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2060     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2061     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2062
2063     SETUPEXCHANGE(ppMem,        m_pHostperlMem,         m_hostperlMem);
2064     SETUPEXCHANGE(ppMemShared,  m_pHostperlMemShared,   m_hostperlMemShared);
2065     SETUPEXCHANGE(ppMemParse,   m_pHostperlMemParse,    m_hostperlMemParse);
2066     SETUPEXCHANGE(ppEnv,        m_pHostperlEnv,         m_hostperlEnv);
2067     SETUPEXCHANGE(ppStdIO,      m_pHostperlStdIO,       m_hostperlStdIO);
2068     SETUPEXCHANGE(ppLIO,        m_pHostperlLIO,         m_hostperlLIO);
2069     SETUPEXCHANGE(ppDir,        m_pHostperlDir,         m_hostperlDir);
2070     SETUPEXCHANGE(ppSock,       m_pHostperlSock,        m_hostperlSock);
2071     SETUPEXCHANGE(ppProc,       m_pHostperlProc,        m_hostperlProc);
2072 }
2073 #undef SETUPEXCHANGE
2074
2075 CPerlHost::CPerlHost(CPerlHost& host)
2076 {
2077     /* Construct a host from another host */
2078     InterlockedIncrement(&num_hosts);
2079     m_pVMem = new VMem();
2080     m_pVMemShared = host.GetMemShared();
2081     m_pVMemParse =  host.GetMemParse();
2082
2083     /* duplicate directory info */
2084     m_pvDir = new VDir(0);
2085     m_pvDir->Init(host.GetDir(), m_pVMem);
2086
2087     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2088     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2089     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2090     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2091     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2092     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2093     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2094     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2095     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2096     m_pHostperlMem          = &m_hostperlMem;
2097     m_pHostperlMemShared    = &m_hostperlMemShared;
2098     m_pHostperlMemParse     = &m_hostperlMemParse;
2099     m_pHostperlEnv          = &m_hostperlEnv;
2100     m_pHostperlStdIO        = &m_hostperlStdIO;
2101     m_pHostperlLIO          = &m_hostperlLIO;
2102     m_pHostperlDir          = &m_hostperlDir;
2103     m_pHostperlSock         = &m_hostperlSock;
2104     m_pHostperlProc         = &m_hostperlProc;
2105
2106     m_dwEnvCount = 0;
2107     m_lppEnvList = NULL;
2108     m_bTopLevel = FALSE;
2109
2110     /* duplicate environment info */
2111     LPSTR lpPtr;
2112     DWORD dwIndex = 0;
2113     while(lpPtr = host.GetIndex(dwIndex))
2114         Add(lpPtr);
2115 }
2116
2117 CPerlHost::~CPerlHost(void)
2118 {
2119     Reset();
2120     InterlockedDecrement(&num_hosts);
2121     delete m_pvDir;
2122     m_pVMemParse->Release();
2123     m_pVMemShared->Release();
2124     m_pVMem->Release();
2125 }
2126
2127 LPSTR
2128 CPerlHost::Find(LPCSTR lpStr)
2129 {
2130     LPSTR lpPtr;
2131     LPSTR* lppPtr = Lookup(lpStr);
2132     if(lppPtr != NULL) {
2133         for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
2134             ;
2135
2136         if(*lpPtr == '=')
2137             ++lpPtr;
2138
2139         return lpPtr;
2140     }
2141     return NULL;
2142 }
2143
2144 int
2145 lookup(const void *arg1, const void *arg2)
2146 {   // Compare strings
2147     char*ptr1, *ptr2;
2148     char c1,c2;
2149
2150     ptr1 = *(char**)arg1;
2151     ptr2 = *(char**)arg2;
2152     for(;;) {
2153         c1 = *ptr1++;
2154         c2 = *ptr2++;
2155         if(c1 == '\0' || c1 == '=') {
2156             if(c2 == '\0' || c2 == '=')
2157                 break;
2158
2159             return -1; // string 1 < string 2
2160         }
2161         else if(c2 == '\0' || c2 == '=')
2162             return 1; // string 1 > string 2
2163         else if(c1 != c2) {
2164             c1 = toupper(c1);
2165             c2 = toupper(c2);
2166             if(c1 != c2) {
2167                 if(c1 < c2)
2168                     return -1; // string 1 < string 2
2169
2170                 return 1; // string 1 > string 2
2171             }
2172         }
2173     }
2174     return 0;
2175 }
2176
2177 LPSTR*
2178 CPerlHost::Lookup(LPCSTR lpStr)
2179 {
2180 #ifdef UNDER_CE
2181     if (!m_lppEnvList || !m_dwEnvCount)
2182         return NULL;
2183 #endif
2184     if (!lpStr)
2185         return NULL;
2186     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
2187 }
2188
2189 int
2190 compare(const void *arg1, const void *arg2)
2191 {   // Compare strings
2192     char*ptr1, *ptr2;
2193     char c1,c2;
2194
2195     ptr1 = *(char**)arg1;
2196     ptr2 = *(char**)arg2;
2197     for(;;) {
2198         c1 = *ptr1++;
2199         c2 = *ptr2++;
2200         if(c1 == '\0' || c1 == '=') {
2201             if(c1 == c2)
2202                 break;
2203
2204             return -1; // string 1 < string 2
2205         }
2206         else if(c2 == '\0' || c2 == '=')
2207             return 1; // string 1 > string 2
2208         else if(c1 != c2) {
2209             c1 = toupper(c1);
2210             c2 = toupper(c2);
2211             if(c1 != c2) {
2212                 if(c1 < c2)
2213                     return -1; // string 1 < string 2
2214
2215                 return 1; // string 1 > string 2
2216             }
2217         }
2218     }
2219     return 0;
2220 }
2221
2222 void
2223 CPerlHost::Add(LPCSTR lpStr)
2224 {
2225     dTHX;
2226     char szBuffer[1024];
2227     LPSTR *lpPtr;
2228     int index, length = strlen(lpStr)+1;
2229
2230     for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
2231         szBuffer[index] = lpStr[index];
2232
2233     szBuffer[index] = '\0';
2234
2235     // replacing ?
2236     lpPtr = Lookup(szBuffer);
2237     if (lpPtr != NULL) {
2238         // must allocate things via host memory allocation functions
2239         // rather than perl's Renew() et al, as the perl interpreter
2240         // may either not be initialized enough when we allocate these,
2241         // or may already be dead when we go to free these
2242         *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
2243         strcpy(*lpPtr, lpStr);
2244     }
2245     else {
2246         m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
2247         if (m_lppEnvList) {
2248             m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
2249             if (m_lppEnvList[m_dwEnvCount] != NULL) {
2250                 strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
2251                 ++m_dwEnvCount;
2252                 qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
2253             }
2254         }
2255     }
2256 }
2257
2258 DWORD
2259 CPerlHost::CalculateEnvironmentSpace(void)
2260 {
2261     DWORD index;
2262     DWORD dwSize = 0;
2263     for(index = 0; index < m_dwEnvCount; ++index)
2264         dwSize += strlen(m_lppEnvList[index]) + 1;
2265
2266     return dwSize;
2267 }
2268
2269 void
2270 CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
2271 {
2272     dTHX;
2273     Safefree(lpStr);
2274 }
2275
2276 char*
2277 CPerlHost::GetChildDir(void)
2278 {
2279     dTHX;
2280     char* ptr;
2281     size_t length;
2282
2283     Newx(ptr, MAX_PATH+1, char);
2284     m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
2285     length = strlen(ptr);
2286     if (length > 3) {
2287         if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
2288             ptr[length-1] = 0;
2289     }
2290     return ptr;
2291 }
2292
2293 void
2294 CPerlHost::FreeChildDir(char* pStr)
2295 {
2296     dTHX;
2297     Safefree(pStr);
2298 }
2299
2300 LPSTR
2301 CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
2302 {
2303     dTHX;
2304     LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
2305     DWORD dwSize, dwEnvIndex;
2306     int nLength, compVal;
2307
2308     // get the process environment strings
2309     lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
2310
2311     // step over current directory stuff
2312     while(*lpTmp == '=')
2313         lpTmp += strlen(lpTmp) + 1;
2314
2315     // save the start of the environment strings
2316     lpEnvPtr = lpTmp;
2317     for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
2318         // calculate the size of the environment strings
2319         dwSize += strlen(lpTmp) + 1;
2320     }
2321
2322     // add the size of current directories
2323     dwSize += vDir.CalculateEnvironmentSpace();
2324
2325     // add the additional space used by changes made to the environment
2326     dwSize += CalculateEnvironmentSpace();
2327
2328     Newx(lpStr, dwSize, char);
2329     lpPtr = lpStr;
2330     if(lpStr != NULL) {
2331         // build the local environment
2332         lpStr = vDir.BuildEnvironmentSpace(lpStr);
2333
2334         dwEnvIndex = 0;
2335         lpLocalEnv = GetIndex(dwEnvIndex);
2336         while(*lpEnvPtr != '\0') {
2337             if(!lpLocalEnv) {
2338                 // all environment overrides have been added
2339                 // so copy string into place
2340                 strcpy(lpStr, lpEnvPtr);
2341                 nLength = strlen(lpEnvPtr) + 1;
2342                 lpStr += nLength;
2343                 lpEnvPtr += nLength;
2344             }
2345             else {
2346                 // determine which string to copy next
2347                 compVal = compare(&lpEnvPtr, &lpLocalEnv);
2348                 if(compVal < 0) {
2349                     strcpy(lpStr, lpEnvPtr);
2350                     nLength = strlen(lpEnvPtr) + 1;
2351                     lpStr += nLength;
2352                     lpEnvPtr += nLength;
2353                 }
2354                 else {
2355                     char *ptr = strchr(lpLocalEnv, '=');
2356                     if(ptr && ptr[1]) {
2357                         strcpy(lpStr, lpLocalEnv);
2358                         lpStr += strlen(lpLocalEnv) + 1;
2359                     }
2360                     lpLocalEnv = GetIndex(dwEnvIndex);
2361                     if(compVal == 0) {
2362                         // this string was replaced
2363                         lpEnvPtr += strlen(lpEnvPtr) + 1;
2364                     }
2365                 }
2366             }
2367         }
2368
2369         while(lpLocalEnv) {
2370             // still have environment overrides to add
2371             // so copy the strings into place if not an override
2372             char *ptr = strchr(lpLocalEnv, '=');
2373             if(ptr && ptr[1]) {
2374                 strcpy(lpStr, lpLocalEnv);
2375                 lpStr += strlen(lpLocalEnv) + 1;
2376             }
2377             lpLocalEnv = GetIndex(dwEnvIndex);
2378         }
2379
2380         // add final NULL
2381         *lpStr = '\0';
2382     }
2383
2384     // release the process environment strings
2385     FreeEnvironmentStrings(lpAllocPtr);
2386
2387     return lpPtr;
2388 }
2389
2390 void
2391 CPerlHost::Reset(void)
2392 {
2393     dTHX;
2394     if(m_lppEnvList != NULL) {
2395         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2396             Free(m_lppEnvList[index]);
2397             m_lppEnvList[index] = NULL;
2398         }
2399     }
2400     m_dwEnvCount = 0;
2401     Free(m_lppEnvList);
2402     m_lppEnvList = NULL;
2403 }
2404
2405 void
2406 CPerlHost::Clearenv(void)
2407 {
2408     dTHX;
2409     char ch;
2410     LPSTR lpPtr, lpStr, lpEnvPtr;
2411     if (m_lppEnvList != NULL) {
2412         /* set every entry to an empty string */
2413         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2414             char* ptr = strchr(m_lppEnvList[index], '=');
2415             if(ptr) {
2416                 *++ptr = 0;
2417             }
2418         }
2419     }
2420
2421     /* get the process environment strings */
2422     lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
2423
2424     /* step over current directory stuff */
2425     while(*lpStr == '=')
2426         lpStr += strlen(lpStr) + 1;
2427
2428     while(*lpStr) {
2429         lpPtr = strchr(lpStr, '=');
2430         if(lpPtr) {
2431             ch = *++lpPtr;
2432             *lpPtr = 0;
2433             Add(lpStr);
2434             if (m_bTopLevel)
2435                 (void)win32_putenv(lpStr);
2436             *lpPtr = ch;
2437         }
2438         lpStr += strlen(lpStr) + 1;
2439     }
2440
2441     FreeEnvironmentStrings(lpEnvPtr);
2442 }
2443
2444
2445 char*
2446 CPerlHost::Getenv(const char *varname)
2447 {
2448     dTHX;
2449     if (!m_bTopLevel) {
2450         char *pEnv = Find(varname);
2451         if (pEnv && *pEnv)
2452             return pEnv;
2453     }
2454     return win32_getenv(varname);
2455 }
2456
2457 int
2458 CPerlHost::Putenv(const char *envstring)
2459 {
2460     dTHX;
2461     Add(envstring);
2462     if (m_bTopLevel)
2463         return win32_putenv(envstring);
2464
2465     return 0;
2466 }
2467
2468 int
2469 CPerlHost::Chdir(const char *dirname)
2470 {
2471     dTHX;
2472     int ret;
2473     if (!dirname) {
2474         errno = ENOENT;
2475         return -1;
2476     }
2477     ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
2478     if(ret < 0) {
2479         errno = ENOENT;
2480     }
2481     return ret;
2482 }
2483
2484 #endif /* ___PerlHost_H___ */