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