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