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