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