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