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, const 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, const 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 #ifdef PERL_USES_PL_PIDSTATUS
1723     hv_clear(PL_pidstatus);
1724 #endif
1725
1726     /* push a zero on the stack (we are the child) */
1727     {
1728         dSP;
1729         dTARGET;
1730         PUSHi(0);
1731         PUTBACK;
1732     }
1733
1734     /* continue from next op */
1735     PL_op = PL_op->op_next;
1736
1737     {
1738         dJMPENV;
1739         volatile int oldscope = PL_scopestack_ix;
1740
1741 restart:
1742         JMPENV_PUSH(status);
1743         switch (status) {
1744         case 0:
1745             CALLRUNOPS(aTHX);
1746             status = 0;
1747             break;
1748         case 2:
1749             while (PL_scopestack_ix > oldscope)
1750                 LEAVE;
1751             FREETMPS;
1752             PL_curstash = PL_defstash;
1753             if (PL_endav && !PL_minus_c)
1754                 call_list(oldscope, PL_endav);
1755             status = STATUS_EXIT;
1756             break;
1757         case 3:
1758             if (PL_restartop) {
1759                 POPSTACK_TO(PL_mainstack);
1760                 PL_op = PL_restartop;
1761                 PL_restartop = Nullop;
1762                 goto restart;
1763             }
1764             PerlIO_printf(Perl_error_log, "panic: restartop\n");
1765             FREETMPS;
1766             status = 1;
1767             break;
1768         }
1769         JMPENV_POP;
1770
1771         /* XXX hack to avoid perl_destruct() freeing optree */
1772         win32_checkTLS(my_perl);
1773         PL_main_root = Nullop;
1774     }
1775
1776     win32_checkTLS(my_perl);
1777     /* close the std handles to avoid fd leaks */
1778     {
1779         do_close(PL_stdingv, FALSE);
1780         do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
1781         do_close(PL_stderrgv, FALSE);
1782     }
1783
1784     /* destroy everything (waits for any pseudo-forked children) */
1785     win32_checkTLS(my_perl);
1786     perl_destruct(my_perl);
1787     win32_checkTLS(my_perl);
1788     perl_free(my_perl);
1789
1790 #ifdef PERL_SYNC_FORK
1791     return id;
1792 #else
1793     return (DWORD)status;
1794 #endif
1795 }
1796 #endif /* USE_ITHREADS */
1797
1798 int
1799 PerlProcFork(struct IPerlProc* piPerl)
1800 {
1801     dTHX;
1802 #ifdef USE_ITHREADS
1803     DWORD id;
1804     HANDLE handle;
1805     CPerlHost *h;
1806
1807     if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
1808         errno = EAGAIN;
1809         return -1;
1810     }
1811     h = new CPerlHost(*(CPerlHost*)w32_internal_host);
1812     PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
1813                                                  h->m_pHostperlMem,
1814                                                  h->m_pHostperlMemShared,
1815                                                  h->m_pHostperlMemParse,
1816                                                  h->m_pHostperlEnv,
1817                                                  h->m_pHostperlStdIO,
1818                                                  h->m_pHostperlLIO,
1819                                                  h->m_pHostperlDir,
1820                                                  h->m_pHostperlSock,
1821                                                  h->m_pHostperlProc
1822                                                  );
1823     new_perl->Isys_intern.internal_host = h;
1824     h->host_perl = new_perl;
1825 #  ifdef PERL_SYNC_FORK
1826     id = win32_start_child((LPVOID)new_perl);
1827     PERL_SET_THX(aTHX);
1828 #  else
1829 #    ifdef USE_RTL_THREAD_API
1830     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
1831                                     (void*)new_perl, 0, (unsigned*)&id);
1832 #    else
1833     handle = CreateThread(NULL, 0, win32_start_child,
1834                           (LPVOID)new_perl, 0, &id);
1835 #    endif
1836     PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
1837     if (!handle) {
1838         errno = EAGAIN;
1839         return -1;
1840     }
1841     if (IsWin95()) {
1842         int pid = (int)id;
1843         if (pid < 0)
1844             id = -pid;
1845     }
1846     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
1847     w32_pseudo_child_pids[w32_num_pseudo_children] = id;
1848     ++w32_num_pseudo_children;
1849 #  endif
1850     return -(int)id;
1851 #else
1852     Perl_croak(aTHX_ "fork() not implemented!\n");
1853     return -1;
1854 #endif /* USE_ITHREADS */
1855 }
1856
1857 int
1858 PerlProcGetpid(struct IPerlProc* piPerl)
1859 {
1860     return win32_getpid();
1861 }
1862
1863 void*
1864 PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
1865 {
1866     return win32_dynaload(filename);
1867 }
1868
1869 void
1870 PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
1871 {
1872     win32_str_os_error(sv, dwErr);
1873 }
1874
1875 int
1876 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
1877 {
1878     return win32_spawnvp(mode, cmdname, argv);
1879 }
1880
1881 int
1882 PerlProcLastHost(struct IPerlProc* piPerl)
1883 {
1884  dTHX;
1885  CPerlHost *h = (CPerlHost*)w32_internal_host;
1886  return h->LastHost();
1887 }
1888
1889 struct IPerlProc perlProc =
1890 {
1891     PerlProcAbort,
1892     PerlProcCrypt,
1893     PerlProcExit,
1894     PerlProc_Exit,
1895     PerlProcExecl,
1896     PerlProcExecv,
1897     PerlProcExecvp,
1898     PerlProcGetuid,
1899     PerlProcGeteuid,
1900     PerlProcGetgid,
1901     PerlProcGetegid,
1902     PerlProcGetlogin,
1903     PerlProcKill,
1904     PerlProcKillpg,
1905     PerlProcPauseProc,
1906     PerlProcPopen,
1907     PerlProcPclose,
1908     PerlProcPipe,
1909     PerlProcSetuid,
1910     PerlProcSetgid,
1911     PerlProcSleep,
1912     PerlProcTimes,
1913     PerlProcWait,
1914     PerlProcWaitpid,
1915     PerlProcSignal,
1916     PerlProcFork,
1917     PerlProcGetpid,
1918     PerlProcDynaLoader,
1919     PerlProcGetOSError,
1920     PerlProcSpawnvp,
1921     PerlProcLastHost,
1922     PerlProcPopenList,
1923     PerlProcGetTimeOfDay
1924 };
1925
1926
1927 /*
1928  * CPerlHost
1929  */
1930
1931 CPerlHost::CPerlHost(void)
1932 {
1933     /* Construct a host from scratch */
1934     InterlockedIncrement(&num_hosts);
1935     m_pvDir = new VDir();
1936     m_pVMem = new VMem();
1937     m_pVMemShared = new VMem();
1938     m_pVMemParse =  new VMem();
1939
1940     m_pvDir->Init(NULL, m_pVMem);
1941
1942     m_dwEnvCount = 0;
1943     m_lppEnvList = NULL;
1944     m_bTopLevel = TRUE;
1945
1946     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1947     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1948     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1949     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
1950     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
1951     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
1952     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
1953     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
1954     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
1955
1956     m_pHostperlMem          = &m_hostperlMem;
1957     m_pHostperlMemShared    = &m_hostperlMemShared;
1958     m_pHostperlMemParse     = &m_hostperlMemParse;
1959     m_pHostperlEnv          = &m_hostperlEnv;
1960     m_pHostperlStdIO        = &m_hostperlStdIO;
1961     m_pHostperlLIO          = &m_hostperlLIO;
1962     m_pHostperlDir          = &m_hostperlDir;
1963     m_pHostperlSock         = &m_hostperlSock;
1964     m_pHostperlProc         = &m_hostperlProc;
1965 }
1966
1967 #define SETUPEXCHANGE(xptr, iptr, table) \
1968     STMT_START {                                \
1969         if (xptr) {                             \
1970             iptr = *xptr;                       \
1971             *xptr = &table;                     \
1972         }                                       \
1973         else {                                  \
1974             iptr = &table;                      \
1975         }                                       \
1976     } STMT_END
1977
1978 CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
1979                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
1980                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
1981                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
1982                  struct IPerlProc** ppProc)
1983 {
1984     InterlockedIncrement(&num_hosts);
1985     m_pvDir = new VDir(0);
1986     m_pVMem = new VMem();
1987     m_pVMemShared = new VMem();
1988     m_pVMemParse =  new VMem();
1989
1990     m_pvDir->Init(NULL, m_pVMem);
1991
1992     m_dwEnvCount = 0;
1993     m_lppEnvList = NULL;
1994     m_bTopLevel = FALSE;
1995
1996     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1997     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1998     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1999     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2000     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2001     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2002     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2003     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2004     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2005
2006     SETUPEXCHANGE(ppMem,        m_pHostperlMem,         m_hostperlMem);
2007     SETUPEXCHANGE(ppMemShared,  m_pHostperlMemShared,   m_hostperlMemShared);
2008     SETUPEXCHANGE(ppMemParse,   m_pHostperlMemParse,    m_hostperlMemParse);
2009     SETUPEXCHANGE(ppEnv,        m_pHostperlEnv,         m_hostperlEnv);
2010     SETUPEXCHANGE(ppStdIO,      m_pHostperlStdIO,       m_hostperlStdIO);
2011     SETUPEXCHANGE(ppLIO,        m_pHostperlLIO,         m_hostperlLIO);
2012     SETUPEXCHANGE(ppDir,        m_pHostperlDir,         m_hostperlDir);
2013     SETUPEXCHANGE(ppSock,       m_pHostperlSock,        m_hostperlSock);
2014     SETUPEXCHANGE(ppProc,       m_pHostperlProc,        m_hostperlProc);
2015 }
2016 #undef SETUPEXCHANGE
2017
2018 CPerlHost::CPerlHost(CPerlHost& host)
2019 {
2020     /* Construct a host from another host */
2021     InterlockedIncrement(&num_hosts);
2022     m_pVMem = new VMem();
2023     m_pVMemShared = host.GetMemShared();
2024     m_pVMemParse =  host.GetMemParse();
2025
2026     /* duplicate directory info */
2027     m_pvDir = new VDir(0);
2028     m_pvDir->Init(host.GetDir(), m_pVMem);
2029
2030     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2031     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2032     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2033     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2034     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2035     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2036     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2037     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2038     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2039     m_pHostperlMem          = &m_hostperlMem;
2040     m_pHostperlMemShared    = &m_hostperlMemShared;
2041     m_pHostperlMemParse     = &m_hostperlMemParse;
2042     m_pHostperlEnv          = &m_hostperlEnv;
2043     m_pHostperlStdIO        = &m_hostperlStdIO;
2044     m_pHostperlLIO          = &m_hostperlLIO;
2045     m_pHostperlDir          = &m_hostperlDir;
2046     m_pHostperlSock         = &m_hostperlSock;
2047     m_pHostperlProc         = &m_hostperlProc;
2048
2049     m_dwEnvCount = 0;
2050     m_lppEnvList = NULL;
2051     m_bTopLevel = FALSE;
2052
2053     /* duplicate environment info */
2054     LPSTR lpPtr;
2055     DWORD dwIndex = 0;
2056     while(lpPtr = host.GetIndex(dwIndex))
2057         Add(lpPtr);
2058 }
2059
2060 CPerlHost::~CPerlHost(void)
2061 {
2062     Reset();
2063     InterlockedDecrement(&num_hosts);
2064     delete m_pvDir;
2065     m_pVMemParse->Release();
2066     m_pVMemShared->Release();
2067     m_pVMem->Release();
2068 }
2069
2070 LPSTR
2071 CPerlHost::Find(LPCSTR lpStr)
2072 {
2073     LPSTR lpPtr;
2074     LPSTR* lppPtr = Lookup(lpStr);
2075     if(lppPtr != NULL) {
2076         for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
2077             ;
2078
2079         if(*lpPtr == '=')
2080             ++lpPtr;
2081
2082         return lpPtr;
2083     }
2084     return NULL;
2085 }
2086
2087 int
2088 lookup(const void *arg1, const void *arg2)
2089 {   // Compare strings
2090     char*ptr1, *ptr2;
2091     char c1,c2;
2092
2093     ptr1 = *(char**)arg1;
2094     ptr2 = *(char**)arg2;
2095     for(;;) {
2096         c1 = *ptr1++;
2097         c2 = *ptr2++;
2098         if(c1 == '\0' || c1 == '=') {
2099             if(c2 == '\0' || c2 == '=')
2100                 break;
2101
2102             return -1; // string 1 < string 2
2103         }
2104         else if(c2 == '\0' || c2 == '=')
2105             return 1; // string 1 > string 2
2106         else if(c1 != c2) {
2107             c1 = toupper(c1);
2108             c2 = toupper(c2);
2109             if(c1 != c2) {
2110                 if(c1 < c2)
2111                     return -1; // string 1 < string 2
2112
2113                 return 1; // string 1 > string 2
2114             }
2115         }
2116     }
2117     return 0;
2118 }
2119
2120 LPSTR*
2121 CPerlHost::Lookup(LPCSTR lpStr)
2122 {
2123     if (!lpStr)
2124         return NULL;
2125     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
2126 }
2127
2128 int
2129 compare(const void *arg1, const void *arg2)
2130 {   // Compare strings
2131     char*ptr1, *ptr2;
2132     char c1,c2;
2133
2134     ptr1 = *(char**)arg1;
2135     ptr2 = *(char**)arg2;
2136     for(;;) {
2137         c1 = *ptr1++;
2138         c2 = *ptr2++;
2139         if(c1 == '\0' || c1 == '=') {
2140             if(c1 == c2)
2141                 break;
2142
2143             return -1; // string 1 < string 2
2144         }
2145         else if(c2 == '\0' || c2 == '=')
2146             return 1; // string 1 > string 2
2147         else if(c1 != c2) {
2148             c1 = toupper(c1);
2149             c2 = toupper(c2);
2150             if(c1 != c2) {
2151                 if(c1 < c2)
2152                     return -1; // string 1 < string 2
2153
2154                 return 1; // string 1 > string 2
2155             }
2156         }
2157     }
2158     return 0;
2159 }
2160
2161 void
2162 CPerlHost::Add(LPCSTR lpStr)
2163 {
2164     dTHX;
2165     char szBuffer[1024];
2166     LPSTR *lpPtr;
2167     int index, length = strlen(lpStr)+1;
2168
2169     for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
2170         szBuffer[index] = lpStr[index];
2171
2172     szBuffer[index] = '\0';
2173
2174     // replacing ?
2175     lpPtr = Lookup(szBuffer);
2176     if (lpPtr != NULL) {
2177         // must allocate things via host memory allocation functions
2178         // rather than perl's Renew() et al, as the perl interpreter
2179         // may either not be initialized enough when we allocate these,
2180         // or may already be dead when we go to free these
2181         *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
2182         strcpy(*lpPtr, lpStr);
2183     }
2184     else {
2185         m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
2186         if (m_lppEnvList) {
2187             m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
2188             if (m_lppEnvList[m_dwEnvCount] != NULL) {
2189                 strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
2190                 ++m_dwEnvCount;
2191                 qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
2192             }
2193         }
2194     }
2195 }
2196
2197 DWORD
2198 CPerlHost::CalculateEnvironmentSpace(void)
2199 {
2200     DWORD index;
2201     DWORD dwSize = 0;
2202     for(index = 0; index < m_dwEnvCount; ++index)
2203         dwSize += strlen(m_lppEnvList[index]) + 1;
2204
2205     return dwSize;
2206 }
2207
2208 void
2209 CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
2210 {
2211     dTHX;
2212     Safefree(lpStr);
2213 }
2214
2215 char*
2216 CPerlHost::GetChildDir(void)
2217 {
2218     dTHX;
2219     int length;
2220     char* ptr;
2221     Newx(ptr, MAX_PATH+1, char);
2222     if(ptr) {
2223         m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
2224         length = strlen(ptr);
2225         if (length > 3) {
2226             if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
2227                 ptr[length-1] = 0;
2228         }
2229     }
2230     return ptr;
2231 }
2232
2233 void
2234 CPerlHost::FreeChildDir(char* pStr)
2235 {
2236     dTHX;
2237     Safefree(pStr);
2238 }
2239
2240 LPSTR
2241 CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
2242 {
2243     dTHX;
2244     LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
2245     DWORD dwSize, dwEnvIndex;
2246     int nLength, compVal;
2247
2248     // get the process environment strings
2249     lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
2250
2251     // step over current directory stuff
2252     while(*lpTmp == '=')
2253         lpTmp += strlen(lpTmp) + 1;
2254
2255     // save the start of the environment strings
2256     lpEnvPtr = lpTmp;
2257     for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
2258         // calculate the size of the environment strings
2259         dwSize += strlen(lpTmp) + 1;
2260     }
2261
2262     // add the size of current directories
2263     dwSize += vDir.CalculateEnvironmentSpace();
2264
2265     // add the additional space used by changes made to the environment
2266     dwSize += CalculateEnvironmentSpace();
2267
2268     Newx(lpStr, dwSize, char);
2269     lpPtr = lpStr;
2270     if(lpStr != NULL) {
2271         // build the local environment
2272         lpStr = vDir.BuildEnvironmentSpace(lpStr);
2273
2274         dwEnvIndex = 0;
2275         lpLocalEnv = GetIndex(dwEnvIndex);
2276         while(*lpEnvPtr != '\0') {
2277             if(!lpLocalEnv) {
2278                 // all environment overrides have been added
2279                 // so copy string into place
2280                 strcpy(lpStr, lpEnvPtr);
2281                 nLength = strlen(lpEnvPtr) + 1;
2282                 lpStr += nLength;
2283                 lpEnvPtr += nLength;
2284             }
2285             else {
2286                 // determine which string to copy next
2287                 compVal = compare(&lpEnvPtr, &lpLocalEnv);
2288                 if(compVal < 0) {
2289                     strcpy(lpStr, lpEnvPtr);
2290                     nLength = strlen(lpEnvPtr) + 1;
2291                     lpStr += nLength;
2292                     lpEnvPtr += nLength;
2293                 }
2294                 else {
2295                     char *ptr = strchr(lpLocalEnv, '=');
2296                     if(ptr && ptr[1]) {
2297                         strcpy(lpStr, lpLocalEnv);
2298                         lpStr += strlen(lpLocalEnv) + 1;
2299                     }
2300                     lpLocalEnv = GetIndex(dwEnvIndex);
2301                     if(compVal == 0) {
2302                         // this string was replaced
2303                         lpEnvPtr += strlen(lpEnvPtr) + 1;
2304                     }
2305                 }
2306             }
2307         }
2308
2309         while(lpLocalEnv) {
2310             // still have environment overrides to add
2311             // so copy the strings into place if not an override
2312             char *ptr = strchr(lpLocalEnv, '=');
2313             if(ptr && ptr[1]) {
2314                 strcpy(lpStr, lpLocalEnv);
2315                 lpStr += strlen(lpLocalEnv) + 1;
2316             }
2317             lpLocalEnv = GetIndex(dwEnvIndex);
2318         }
2319
2320         // add final NULL
2321         *lpStr = '\0';
2322     }
2323
2324     // release the process environment strings
2325     FreeEnvironmentStrings(lpAllocPtr);
2326
2327     return lpPtr;
2328 }
2329
2330 void
2331 CPerlHost::Reset(void)
2332 {
2333     dTHX;
2334     if(m_lppEnvList != NULL) {
2335         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2336             Free(m_lppEnvList[index]);
2337             m_lppEnvList[index] = NULL;
2338         }
2339     }
2340     m_dwEnvCount = 0;
2341     Free(m_lppEnvList);
2342     m_lppEnvList = NULL;
2343 }
2344
2345 void
2346 CPerlHost::Clearenv(void)
2347 {
2348     dTHX;
2349     char ch;
2350     LPSTR lpPtr, lpStr, lpEnvPtr;
2351     if (m_lppEnvList != NULL) {
2352         /* set every entry to an empty string */
2353         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2354             char* ptr = strchr(m_lppEnvList[index], '=');
2355             if(ptr) {
2356                 *++ptr = 0;
2357             }
2358         }
2359     }
2360
2361     /* get the process environment strings */
2362     lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
2363
2364     /* step over current directory stuff */
2365     while(*lpStr == '=')
2366         lpStr += strlen(lpStr) + 1;
2367
2368     while(*lpStr) {
2369         lpPtr = strchr(lpStr, '=');
2370         if(lpPtr) {
2371             ch = *++lpPtr;
2372             *lpPtr = 0;
2373             Add(lpStr);
2374             if (m_bTopLevel)
2375                 (void)win32_putenv(lpStr);
2376             *lpPtr = ch;
2377         }
2378         lpStr += strlen(lpStr) + 1;
2379     }
2380
2381     FreeEnvironmentStrings(lpEnvPtr);
2382 }
2383
2384
2385 char*
2386 CPerlHost::Getenv(const char *varname)
2387 {
2388     dTHX;
2389     if (!m_bTopLevel) {
2390         char *pEnv = Find(varname);
2391         if (pEnv && *pEnv)
2392             return pEnv;
2393     }
2394     return win32_getenv(varname);
2395 }
2396
2397 int
2398 CPerlHost::Putenv(const char *envstring)
2399 {
2400     dTHX;
2401     Add(envstring);
2402     if (m_bTopLevel)
2403         return win32_putenv(envstring);
2404
2405     return 0;
2406 }
2407
2408 int
2409 CPerlHost::Chdir(const char *dirname)
2410 {
2411     dTHX;
2412     int ret;
2413     if (!dirname) {
2414         errno = ENOENT;
2415         return -1;
2416     }
2417     ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
2418     if(ret < 0) {
2419         errno = ENOENT;
2420     }
2421     return ret;
2422 }
2423
2424 #endif /* ___PerlHost_H___ */