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     return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
 993 }
 994
 995 int
 996 PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
 997 {
 998     return isatty(fd);
 999 }
1000
1001 int
1002 PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
1003 {
1004     return win32_link(oldname, newname);
1005 }
1006
1007 Off_t
1008 PerlLIOLseek(struct IPerlLIO* piPerl, int handle, Off_t offset, int origin)
1009 {
1010     return win32_lseek(handle, offset, origin);
1011 }
1012
1013 int
1014 PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
1015 {
1016     return win32_stat(path, buffer);
1017 }
1018
1019 char*
1020 PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
1021 {
1022     return mktemp(Template);
1023 }
1024
1025 int
1026 PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
1027 {
1028     return win32_open(filename, oflag);
1029 }
1030
1031 int
1032 PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
1033 {
1034     return win32_open(filename, oflag, pmode);
1035 }
1036
1037 int
1038 PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
1039 {
1040     return win32_read(handle, buffer, count);
1041 }
1042
1043 int
1044 PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
1045 {
1046     return win32_rename(OldFileName, newname);
1047 }
1048
1049 int
1050 PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
1051 {
1052     return win32_setmode(handle, mode);
1053 }
1054
1055 int
1056 PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, Stat_t *buffer)
1057 {
1058     return win32_stat(path, buffer);
1059 }
1060
1061 char*
1062 PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
1063 {
1064     return tmpnam(string);
1065 }
1066
1067 int
1068 PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
1069 {
1070     return umask(pmode);
1071 }
1072
1073 int
1074 PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
1075 {
1076     return win32_unlink(filename);
1077 }
1078
1079 int
1080 PerlLIOUtime(struct IPerlLIO* piPerl, const char *filename, struct utimbuf *times)
1081 {
1082     return win32_utime(filename, times);
1083 }
1084
1085 int
1086 PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
1087 {
1088     return win32_write(handle, buffer, count);
1089 }
1090
1091 struct IPerlLIO perlLIO =
1092 {
1093     PerlLIOAccess,
1094     PerlLIOChmod,
1095     PerlLIOChown,
1096     PerlLIOChsize,
1097     PerlLIOClose,
1098     PerlLIODup,
1099     PerlLIODup2,
1100     PerlLIOFlock,
1101     PerlLIOFileStat,
1102     PerlLIOIOCtl,
1103     PerlLIOIsatty,
1104     PerlLIOLink,
1105     PerlLIOLseek,
1106     PerlLIOLstat,
1107     PerlLIOMktemp,
1108     PerlLIOOpen,
1109     PerlLIOOpen3,
1110     PerlLIORead,
1111     PerlLIORename,
1112     PerlLIOSetmode,
1113     PerlLIONameStat,
1114     PerlLIOTmpnam,
1115     PerlLIOUmask,
1116     PerlLIOUnlink,
1117     PerlLIOUtime,
1118     PerlLIOWrite,
1119 };
1120
1121
1122 #undef IPERL2HOST
1123 #define IPERL2HOST(x) IPerlDir2Host(x)
1124
1125 /* IPerlDIR */
1126 int
1127 PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
1128 {
1129     return win32_mkdir(dirname, mode);
1130 }
1131
1132 int
1133 PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
1134 {
1135     return IPERL2HOST(piPerl)->Chdir(dirname);
1136 }
1137
1138 int
1139 PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
1140 {
1141     return win32_rmdir(dirname);
1142 }
1143
1144 int
1145 PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
1146 {
1147     return win32_closedir(dirp);
1148 }
1149
1150 DIR*
1151 PerlDirOpen(struct IPerlDir* piPerl, const char *filename)
1152 {
1153     return win32_opendir(filename);
1154 }
1155
1156 struct direct *
1157 PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
1158 {
1159     return win32_readdir(dirp);
1160 }
1161
1162 void
1163 PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
1164 {
1165     win32_rewinddir(dirp);
1166 }
1167
1168 void
1169 PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
1170 {
1171     win32_seekdir(dirp, loc);
1172 }
1173
1174 long
1175 PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
1176 {
1177     return win32_telldir(dirp);
1178 }
1179
1180 char*
1181 PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
1182 {
1183     return IPERL2HOST(piPerl)->MapPathA(path);
1184 }
1185
1186 WCHAR*
1187 PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
1188 {
1189     return IPERL2HOST(piPerl)->MapPathW(path);
1190 }
1191
1192 struct IPerlDir perlDir =
1193 {
1194     PerlDirMakedir,
1195     PerlDirChdir,
1196     PerlDirRmdir,
1197     PerlDirClose,
1198     PerlDirOpen,
1199     PerlDirRead,
1200     PerlDirRewind,
1201     PerlDirSeek,
1202     PerlDirTell,
1203     PerlDirMapPathA,
1204     PerlDirMapPathW,
1205 };
1206
1207
1208 /* IPerlSock */
1209 u_long
1210 PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
1211 {
1212     return win32_htonl(hostlong);
1213 }
1214
1215 u_short
1216 PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
1217 {
1218     return win32_htons(hostshort);
1219 }
1220
1221 u_long
1222 PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
1223 {
1224     return win32_ntohl(netlong);
1225 }
1226
1227 u_short
1228 PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
1229 {
1230     return win32_ntohs(netshort);
1231 }
1232
1233 SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
1234 {
1235     return win32_accept(s, addr, addrlen);
1236 }
1237
1238 int
1239 PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1240 {
1241     return win32_bind(s, name, namelen);
1242 }
1243
1244 int
1245 PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1246 {
1247     return win32_connect(s, name, namelen);
1248 }
1249
1250 void
1251 PerlSockEndhostent(struct IPerlSock* piPerl)
1252 {
1253     win32_endhostent();
1254 }
1255
1256 void
1257 PerlSockEndnetent(struct IPerlSock* piPerl)
1258 {
1259     win32_endnetent();
1260 }
1261
1262 void
1263 PerlSockEndprotoent(struct IPerlSock* piPerl)
1264 {
1265     win32_endprotoent();
1266 }
1267
1268 void
1269 PerlSockEndservent(struct IPerlSock* piPerl)
1270 {
1271     win32_endservent();
1272 }
1273
1274 struct hostent*
1275 PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
1276 {
1277     return win32_gethostbyaddr(addr, len, type);
1278 }
1279
1280 struct hostent*
1281 PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
1282 {
1283     return win32_gethostbyname(name);
1284 }
1285
1286 struct hostent*
1287 PerlSockGethostent(struct IPerlSock* piPerl)
1288 {
1289     dTHX;
1290     Perl_croak(aTHX_ "gethostent not implemented!\n");
1291     return NULL;
1292 }
1293
1294 int
1295 PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
1296 {
1297     return win32_gethostname(name, namelen);
1298 }
1299
1300 struct netent *
1301 PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
1302 {
1303     return win32_getnetbyaddr(net, type);
1304 }
1305
1306 struct netent *
1307 PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
1308 {
1309     return win32_getnetbyname((char*)name);
1310 }
1311
1312 struct netent *
1313 PerlSockGetnetent(struct IPerlSock* piPerl)
1314 {
1315     return win32_getnetent();
1316 }
1317
1318 int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1319 {
1320     return win32_getpeername(s, name, namelen);
1321 }
1322
1323 struct protoent*
1324 PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
1325 {
1326     return win32_getprotobyname(name);
1327 }
1328
1329 struct protoent*
1330 PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
1331 {
1332     return win32_getprotobynumber(number);
1333 }
1334
1335 struct protoent*
1336 PerlSockGetprotoent(struct IPerlSock* piPerl)
1337 {
1338     return win32_getprotoent();
1339 }
1340
1341 struct servent*
1342 PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
1343 {
1344     return win32_getservbyname(name, proto);
1345 }
1346
1347 struct servent*
1348 PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
1349 {
1350     return win32_getservbyport(port, proto);
1351 }
1352
1353 struct servent*
1354 PerlSockGetservent(struct IPerlSock* piPerl)
1355 {
1356     return win32_getservent();
1357 }
1358
1359 int
1360 PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1361 {
1362     return win32_getsockname(s, name, namelen);
1363 }
1364
1365 int
1366 PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
1367 {
1368     return win32_getsockopt(s, level, optname, optval, optlen);
1369 }
1370
1371 unsigned long
1372 PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
1373 {
1374     return win32_inet_addr(cp);
1375 }
1376
1377 char*
1378 PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
1379 {
1380     return win32_inet_ntoa(in);
1381 }
1382
1383 int
1384 PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
1385 {
1386     return win32_listen(s, backlog);
1387 }
1388
1389 int
1390 PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
1391 {
1392     return win32_recv(s, buffer, len, flags);
1393 }
1394
1395 int
1396 PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
1397 {
1398     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
1399 }
1400
1401 int
1402 PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
1403 {
1404     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
1405 }
1406
1407 int
1408 PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
1409 {
1410     return win32_send(s, buffer, len, flags);
1411 }
1412
1413 int
1414 PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
1415 {
1416     return win32_sendto(s, buffer, len, flags, to, tolen);
1417 }
1418
1419 void
1420 PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
1421 {
1422     win32_sethostent(stayopen);
1423 }
1424
1425 void
1426 PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
1427 {
1428     win32_setnetent(stayopen);
1429 }
1430
1431 void
1432 PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
1433 {
1434     win32_setprotoent(stayopen);
1435 }
1436
1437 void
1438 PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
1439 {
1440     win32_setservent(stayopen);
1441 }
1442
1443 int
1444 PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
1445 {
1446     return win32_setsockopt(s, level, optname, optval, optlen);
1447 }
1448
1449 int
1450 PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
1451 {
1452     return win32_shutdown(s, how);
1453 }
1454
1455 SOCKET
1456 PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
1457 {
1458     return win32_socket(af, type, protocol);
1459 }
1460
1461 int
1462 PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
1463 {
1464     return Perl_my_socketpair(domain, type, protocol, fds);
1465 }
1466
1467 int
1468 PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
1469 {
1470     return win32_closesocket(s);
1471 }
1472
1473 int
1474 PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
1475 {
1476     return win32_ioctlsocket(s, cmd, argp);
1477 }
1478
1479 struct IPerlSock perlSock =
1480 {
1481     PerlSockHtonl,
1482     PerlSockHtons,
1483     PerlSockNtohl,
1484     PerlSockNtohs,
1485     PerlSockAccept,
1486     PerlSockBind,
1487     PerlSockConnect,
1488     PerlSockEndhostent,
1489     PerlSockEndnetent,
1490     PerlSockEndprotoent,
1491     PerlSockEndservent,
1492     PerlSockGethostname,
1493     PerlSockGetpeername,
1494     PerlSockGethostbyaddr,
1495     PerlSockGethostbyname,
1496     PerlSockGethostent,
1497     PerlSockGetnetbyaddr,
1498     PerlSockGetnetbyname,
1499     PerlSockGetnetent,
1500     PerlSockGetprotobyname,
1501     PerlSockGetprotobynumber,
1502     PerlSockGetprotoent,
1503     PerlSockGetservbyname,
1504     PerlSockGetservbyport,
1505     PerlSockGetservent,
1506     PerlSockGetsockname,
1507     PerlSockGetsockopt,
1508     PerlSockInetAddr,
1509     PerlSockInetNtoa,
1510     PerlSockListen,
1511     PerlSockRecv,
1512     PerlSockRecvfrom,
1513     PerlSockSelect,
1514     PerlSockSend,
1515     PerlSockSendto,
1516     PerlSockSethostent,
1517     PerlSockSetnetent,
1518     PerlSockSetprotoent,
1519     PerlSockSetservent,
1520     PerlSockSetsockopt,
1521     PerlSockShutdown,
1522     PerlSockSocket,
1523     PerlSockSocketpair,
1524     PerlSockClosesocket,
1525 };
1526
1527
1528 /* IPerlProc */
1529
1530 #define EXECF_EXEC 1
1531 #define EXECF_SPAWN 2
1532
1533 void
1534 PerlProcAbort(struct IPerlProc* piPerl)
1535 {
1536     win32_abort();
1537 }
1538
1539 char *
1540 PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
1541 {
1542     return win32_crypt(clear, salt);
1543 }
1544
1545 void
1546 PerlProcExit(struct IPerlProc* piPerl, int status)
1547 {
1548     exit(status);
1549 }
1550
1551 void
1552 PerlProc_Exit(struct IPerlProc* piPerl, int status)
1553 {
1554     _exit(status);
1555 }
1556
1557 int
1558 PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1559 {
1560     return execl(cmdname, arg0, arg1, arg2, arg3);
1561 }
1562
1563 int
1564 PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1565 {
1566     return win32_execvp(cmdname, argv);
1567 }
1568
1569 int
1570 PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1571 {
1572     return win32_execvp(cmdname, argv);
1573 }
1574
1575 uid_t
1576 PerlProcGetuid(struct IPerlProc* piPerl)
1577 {
1578     return getuid();
1579 }
1580
1581 uid_t
1582 PerlProcGeteuid(struct IPerlProc* piPerl)
1583 {
1584     return geteuid();
1585 }
1586
1587 gid_t
1588 PerlProcGetgid(struct IPerlProc* piPerl)
1589 {
1590     return getgid();
1591 }
1592
1593 gid_t
1594 PerlProcGetegid(struct IPerlProc* piPerl)
1595 {
1596     return getegid();
1597 }
1598
1599 char *
1600 PerlProcGetlogin(struct IPerlProc* piPerl)
1601 {
1602     return g_getlogin();
1603 }
1604
1605 int
1606 PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
1607 {
1608     return win32_kill(pid, sig);
1609 }
1610
1611 int
1612 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
1613 {
1614     return win32_kill(pid, -sig);
1615 }
1616
1617 int
1618 PerlProcPauseProc(struct IPerlProc* piPerl)
1619 {
1620     return win32_sleep((32767L << 16) + 32767);
1621 }
1622
1623 PerlIO*
1624 PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
1625 {
1626     dTHX;
1627     PERL_FLUSHALL_FOR_CHILD;
1628     return win32_popen(command, mode);
1629 }
1630
1631 PerlIO*
1632 PerlProcPopenList(struct IPerlProc* piPerl, const char *mode, IV narg, SV **args)
1633 {
1634     dTHX;
1635     PERL_FLUSHALL_FOR_CHILD;
1636     return win32_popenlist(mode, narg, args);
1637 }
1638
1639 int
1640 PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
1641 {
1642     return win32_pclose(stream);
1643 }
1644
1645 int
1646 PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
1647 {
1648     return win32_pipe(phandles, 512, O_BINARY);
1649 }
1650
1651 int
1652 PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
1653 {
1654     return setuid(u);
1655 }
1656
1657 int
1658 PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
1659 {
1660     return setgid(g);
1661 }
1662
1663 int
1664 PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
1665 {
1666     return win32_sleep(s);
1667 }
1668
1669 int
1670 PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
1671 {
1672     return win32_times(timebuf);
1673 }
1674
1675 int
1676 PerlProcWait(struct IPerlProc* piPerl, int *status)
1677 {
1678     return win32_wait(status);
1679 }
1680
1681 int
1682 PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
1683 {
1684     return win32_waitpid(pid, status, flags);
1685 }
1686
1687 Sighandler_t
1688 PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
1689 {
1690     return win32_signal(sig, subcode);
1691 }
1692
1693 int
1694 PerlProcGetTimeOfDay(struct IPerlProc* piPerl, struct timeval *t, void *z)
1695 {
1696     return win32_gettimeofday(t, z);
1697 }
1698
1699 #ifdef USE_ITHREADS
1700 static THREAD_RET_TYPE
1701 win32_start_child(LPVOID arg)
1702 {
1703     PerlInterpreter *my_perl = (PerlInterpreter*)arg;
1704     GV *tmpgv;
1705     int status;
1706     HWND parent_message_hwnd;
1707 #ifdef PERL_SYNC_FORK
1708     static long sync_fork_id = 0;
1709     long id = ++sync_fork_id;
1710 #endif
1711
1712
1713     PERL_SET_THX(my_perl);
1714     win32_checkTLS(my_perl);
1715
1716     /* set $$ to pseudo id */
1717 #ifdef PERL_SYNC_FORK
1718     w32_pseudo_id = id;
1719 #else
1720     w32_pseudo_id = GetCurrentThreadId();
1721     if (IsWin95()) {
1722         int pid = (int)w32_pseudo_id;
1723         if (pid < 0)
1724             w32_pseudo_id = -pid;
1725     }
1726 #endif
1727     if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV)) {
1728         SV *sv = GvSV(tmpgv);
1729         SvREADONLY_off(sv);
1730         sv_setiv(sv, -(IV)w32_pseudo_id);
1731         SvREADONLY_on(sv);
1732     }
1733 #ifdef PERL_USES_PL_PIDSTATUS
1734     hv_clear(PL_pidstatus);
1735 #endif
1736
1737     /* create message window and tell parent about it */
1738     parent_message_hwnd = w32_message_hwnd;
1739     w32_message_hwnd = win32_create_message_window();
1740     if (parent_message_hwnd != NULL)
1741         PostMessage(parent_message_hwnd, WM_USER_MESSAGE, w32_pseudo_id, (LONG)w32_message_hwnd);
1742
1743     /* push a zero on the stack (we are the child) */
1744     {
1745         dSP;
1746         dTARGET;
1747         PUSHi(0);
1748         PUTBACK;
1749     }
1750
1751     /* continue from next op */
1752     PL_op = PL_op->op_next;
1753
1754     {
1755         dJMPENV;
1756         volatile int oldscope = PL_scopestack_ix;
1757
1758 restart:
1759         JMPENV_PUSH(status);
1760         switch (status) {
1761         case 0:
1762             CALLRUNOPS(aTHX);
1763             status = 0;
1764             break;
1765         case 2:
1766             while (PL_scopestack_ix > oldscope)
1767                 LEAVE;
1768             FREETMPS;
1769             PL_curstash = PL_defstash;
1770             if (PL_endav && !PL_minus_c)
1771                 call_list(oldscope, PL_endav);
1772             status = STATUS_EXIT;
1773             break;
1774         case 3:
1775             if (PL_restartop) {
1776                 POPSTACK_TO(PL_mainstack);
1777                 PL_op = PL_restartop;
1778                 PL_restartop = Nullop;
1779                 goto restart;
1780             }
1781             PerlIO_printf(Perl_error_log, "panic: restartop\n");
1782             FREETMPS;
1783             status = 1;
1784             break;
1785         }
1786         JMPENV_POP;
1787
1788         /* XXX hack to avoid perl_destruct() freeing optree */
1789         win32_checkTLS(my_perl);
1790         PL_main_root = Nullop;
1791     }
1792
1793     win32_checkTLS(my_perl);
1794     /* close the std handles to avoid fd leaks */
1795     {
1796         do_close(PL_stdingv, FALSE);
1797         do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */
1798         do_close(PL_stderrgv, FALSE);
1799     }
1800
1801     /* destroy everything (waits for any pseudo-forked children) */
1802     win32_checkTLS(my_perl);
1803     perl_destruct(my_perl);
1804     win32_checkTLS(my_perl);
1805     perl_free(my_perl);
1806
1807 #ifdef PERL_SYNC_FORK
1808     return id;
1809 #else
1810     return (DWORD)status;
1811 #endif
1812 }
1813 #endif /* USE_ITHREADS */
1814
1815 int
1816 PerlProcFork(struct IPerlProc* piPerl)
1817 {
1818     dTHX;
1819 #ifdef USE_ITHREADS
1820     DWORD id;
1821     HANDLE handle;
1822     CPerlHost *h;
1823
1824     if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) {
1825         errno = EAGAIN;
1826         return -1;
1827     }
1828     h = new CPerlHost(*(CPerlHost*)w32_internal_host);
1829     PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, 1,
1830                                                  h->m_pHostperlMem,
1831                                                  h->m_pHostperlMemShared,
1832                                                  h->m_pHostperlMemParse,
1833                                                  h->m_pHostperlEnv,
1834                                                  h->m_pHostperlStdIO,
1835                                                  h->m_pHostperlLIO,
1836                                                  h->m_pHostperlDir,
1837                                                  h->m_pHostperlSock,
1838                                                  h->m_pHostperlProc
1839                                                  );
1840     new_perl->Isys_intern.internal_host = h;
1841     h->host_perl = new_perl;
1842 #  ifdef PERL_SYNC_FORK
1843     id = win32_start_child((LPVOID)new_perl);
1844     PERL_SET_THX(aTHX);
1845 #  else
1846     if (w32_message_hwnd == INVALID_HANDLE_VALUE)
1847         w32_message_hwnd = win32_create_message_window();
1848     new_perl->Isys_intern.message_hwnd = w32_message_hwnd;
1849     w32_pseudo_child_message_hwnds[w32_num_pseudo_children] =
1850         (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE;
1851 #    ifdef USE_RTL_THREAD_API
1852     handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child,
1853                                     (void*)new_perl, 0, (unsigned*)&id);
1854 #    else
1855     handle = CreateThread(NULL, 0, win32_start_child,
1856                           (LPVOID)new_perl, 0, &id);
1857 #    endif
1858     PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */
1859     if (!handle) {
1860         errno = EAGAIN;
1861         return -1;
1862     }
1863     if (IsWin95()) {
1864         int pid = (int)id;
1865         if (pid < 0)
1866             id = -pid;
1867     }
1868     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
1869     w32_pseudo_child_pids[w32_num_pseudo_children] = id;
1870     ++w32_num_pseudo_children;
1871 #  endif
1872     return -(int)id;
1873 #else
1874     Perl_croak(aTHX_ "fork() not implemented!\n");
1875     return -1;
1876 #endif /* USE_ITHREADS */
1877 }
1878
1879 int
1880 PerlProcGetpid(struct IPerlProc* piPerl)
1881 {
1882     return win32_getpid();
1883 }
1884
1885 void*
1886 PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
1887 {
1888     return win32_dynaload(filename);
1889 }
1890
1891 void
1892 PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
1893 {
1894     win32_str_os_error(sv, dwErr);
1895 }
1896
1897 int
1898 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
1899 {
1900     return win32_spawnvp(mode, cmdname, argv);
1901 }
1902
1903 int
1904 PerlProcLastHost(struct IPerlProc* piPerl)
1905 {
1906  dTHX;
1907  CPerlHost *h = (CPerlHost*)w32_internal_host;
1908  return h->LastHost();
1909 }
1910
1911 struct IPerlProc perlProc =
1912 {
1913     PerlProcAbort,
1914     PerlProcCrypt,
1915     PerlProcExit,
1916     PerlProc_Exit,
1917     PerlProcExecl,
1918     PerlProcExecv,
1919     PerlProcExecvp,
1920     PerlProcGetuid,
1921     PerlProcGeteuid,
1922     PerlProcGetgid,
1923     PerlProcGetegid,
1924     PerlProcGetlogin,
1925     PerlProcKill,
1926     PerlProcKillpg,
1927     PerlProcPauseProc,
1928     PerlProcPopen,
1929     PerlProcPclose,
1930     PerlProcPipe,
1931     PerlProcSetuid,
1932     PerlProcSetgid,
1933     PerlProcSleep,
1934     PerlProcTimes,
1935     PerlProcWait,
1936     PerlProcWaitpid,
1937     PerlProcSignal,
1938     PerlProcFork,
1939     PerlProcGetpid,
1940     PerlProcDynaLoader,
1941     PerlProcGetOSError,
1942     PerlProcSpawnvp,
1943     PerlProcLastHost,
1944     PerlProcPopenList,
1945     PerlProcGetTimeOfDay
1946 };
1947
1948
1949 /*
1950  * CPerlHost
1951  */
1952
1953 CPerlHost::CPerlHost(void)
1954 {
1955     /* Construct a host from scratch */
1956     InterlockedIncrement(&num_hosts);
1957     m_pvDir = new VDir();
1958     m_pVMem = new VMem();
1959     m_pVMemShared = new VMem();
1960     m_pVMemParse =  new VMem();
1961
1962     m_pvDir->Init(NULL, m_pVMem);
1963
1964     m_dwEnvCount = 0;
1965     m_lppEnvList = NULL;
1966     m_bTopLevel = TRUE;
1967
1968     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1969     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1970     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1971     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
1972     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
1973     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
1974     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
1975     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
1976     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
1977
1978     m_pHostperlMem          = &m_hostperlMem;
1979     m_pHostperlMemShared    = &m_hostperlMemShared;
1980     m_pHostperlMemParse     = &m_hostperlMemParse;
1981     m_pHostperlEnv          = &m_hostperlEnv;
1982     m_pHostperlStdIO        = &m_hostperlStdIO;
1983     m_pHostperlLIO          = &m_hostperlLIO;
1984     m_pHostperlDir          = &m_hostperlDir;
1985     m_pHostperlSock         = &m_hostperlSock;
1986     m_pHostperlProc         = &m_hostperlProc;
1987 }
1988
1989 #define SETUPEXCHANGE(xptr, iptr, table) \
1990     STMT_START {                                \
1991         if (xptr) {                             \
1992             iptr = *xptr;                       \
1993             *xptr = &table;                     \
1994         }                                       \
1995         else {                                  \
1996             iptr = &table;                      \
1997         }                                       \
1998     } STMT_END
1999
2000 CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
2001                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
2002                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
2003                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
2004                  struct IPerlProc** ppProc)
2005 {
2006     InterlockedIncrement(&num_hosts);
2007     m_pvDir = new VDir(0);
2008     m_pVMem = new VMem();
2009     m_pVMemShared = new VMem();
2010     m_pVMemParse =  new VMem();
2011
2012     m_pvDir->Init(NULL, m_pVMem);
2013
2014     m_dwEnvCount = 0;
2015     m_lppEnvList = NULL;
2016     m_bTopLevel = FALSE;
2017
2018     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2019     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2020     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2021     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2022     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2023     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2024     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2025     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2026     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2027
2028     SETUPEXCHANGE(ppMem,        m_pHostperlMem,         m_hostperlMem);
2029     SETUPEXCHANGE(ppMemShared,  m_pHostperlMemShared,   m_hostperlMemShared);
2030     SETUPEXCHANGE(ppMemParse,   m_pHostperlMemParse,    m_hostperlMemParse);
2031     SETUPEXCHANGE(ppEnv,        m_pHostperlEnv,         m_hostperlEnv);
2032     SETUPEXCHANGE(ppStdIO,      m_pHostperlStdIO,       m_hostperlStdIO);
2033     SETUPEXCHANGE(ppLIO,        m_pHostperlLIO,         m_hostperlLIO);
2034     SETUPEXCHANGE(ppDir,        m_pHostperlDir,         m_hostperlDir);
2035     SETUPEXCHANGE(ppSock,       m_pHostperlSock,        m_hostperlSock);
2036     SETUPEXCHANGE(ppProc,       m_pHostperlProc,        m_hostperlProc);
2037 }
2038 #undef SETUPEXCHANGE
2039
2040 CPerlHost::CPerlHost(CPerlHost& host)
2041 {
2042     /* Construct a host from another host */
2043     InterlockedIncrement(&num_hosts);
2044     m_pVMem = new VMem();
2045     m_pVMemShared = host.GetMemShared();
2046     m_pVMemParse =  host.GetMemParse();
2047
2048     /* duplicate directory info */
2049     m_pvDir = new VDir(0);
2050     m_pvDir->Init(host.GetDir(), m_pVMem);
2051
2052     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
2053     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
2054     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
2055     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
2056     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
2057     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
2058     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
2059     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
2060     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
2061     m_pHostperlMem          = &m_hostperlMem;
2062     m_pHostperlMemShared    = &m_hostperlMemShared;
2063     m_pHostperlMemParse     = &m_hostperlMemParse;
2064     m_pHostperlEnv          = &m_hostperlEnv;
2065     m_pHostperlStdIO        = &m_hostperlStdIO;
2066     m_pHostperlLIO          = &m_hostperlLIO;
2067     m_pHostperlDir          = &m_hostperlDir;
2068     m_pHostperlSock         = &m_hostperlSock;
2069     m_pHostperlProc         = &m_hostperlProc;
2070
2071     m_dwEnvCount = 0;
2072     m_lppEnvList = NULL;
2073     m_bTopLevel = FALSE;
2074
2075     /* duplicate environment info */
2076     LPSTR lpPtr;
2077     DWORD dwIndex = 0;
2078     while(lpPtr = host.GetIndex(dwIndex))
2079         Add(lpPtr);
2080 }
2081
2082 CPerlHost::~CPerlHost(void)
2083 {
2084     Reset();
2085     InterlockedDecrement(&num_hosts);
2086     delete m_pvDir;
2087     m_pVMemParse->Release();
2088     m_pVMemShared->Release();
2089     m_pVMem->Release();
2090 }
2091
2092 LPSTR
2093 CPerlHost::Find(LPCSTR lpStr)
2094 {
2095     LPSTR lpPtr;
2096     LPSTR* lppPtr = Lookup(lpStr);
2097     if(lppPtr != NULL) {
2098         for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
2099             ;
2100
2101         if(*lpPtr == '=')
2102             ++lpPtr;
2103
2104         return lpPtr;
2105     }
2106     return NULL;
2107 }
2108
2109 int
2110 lookup(const void *arg1, const void *arg2)
2111 {   // Compare strings
2112     char*ptr1, *ptr2;
2113     char c1,c2;
2114
2115     ptr1 = *(char**)arg1;
2116     ptr2 = *(char**)arg2;
2117     for(;;) {
2118         c1 = *ptr1++;
2119         c2 = *ptr2++;
2120         if(c1 == '\0' || c1 == '=') {
2121             if(c2 == '\0' || c2 == '=')
2122                 break;
2123
2124             return -1; // string 1 < string 2
2125         }
2126         else if(c2 == '\0' || c2 == '=')
2127             return 1; // string 1 > string 2
2128         else if(c1 != c2) {
2129             c1 = toupper(c1);
2130             c2 = toupper(c2);
2131             if(c1 != c2) {
2132                 if(c1 < c2)
2133                     return -1; // string 1 < string 2
2134
2135                 return 1; // string 1 > string 2
2136             }
2137         }
2138     }
2139     return 0;
2140 }
2141
2142 LPSTR*
2143 CPerlHost::Lookup(LPCSTR lpStr)
2144 {
2145 #ifdef UNDER_CE
2146     if (!m_lppEnvList || !m_dwEnvCount)
2147         return NULL;
2148 #endif
2149     if (!lpStr)
2150         return NULL;
2151     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
2152 }
2153
2154 int
2155 compare(const void *arg1, const void *arg2)
2156 {   // Compare strings
2157     char*ptr1, *ptr2;
2158     char c1,c2;
2159
2160     ptr1 = *(char**)arg1;
2161     ptr2 = *(char**)arg2;
2162     for(;;) {
2163         c1 = *ptr1++;
2164         c2 = *ptr2++;
2165         if(c1 == '\0' || c1 == '=') {
2166             if(c1 == c2)
2167                 break;
2168
2169             return -1; // string 1 < string 2
2170         }
2171         else if(c2 == '\0' || c2 == '=')
2172             return 1; // string 1 > string 2
2173         else if(c1 != c2) {
2174             c1 = toupper(c1);
2175             c2 = toupper(c2);
2176             if(c1 != c2) {
2177                 if(c1 < c2)
2178                     return -1; // string 1 < string 2
2179
2180                 return 1; // string 1 > string 2
2181             }
2182         }
2183     }
2184     return 0;
2185 }
2186
2187 void
2188 CPerlHost::Add(LPCSTR lpStr)
2189 {
2190     dTHX;
2191     char szBuffer[1024];
2192     LPSTR *lpPtr;
2193     int index, length = strlen(lpStr)+1;
2194
2195     for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
2196         szBuffer[index] = lpStr[index];
2197
2198     szBuffer[index] = '\0';
2199
2200     // replacing ?
2201     lpPtr = Lookup(szBuffer);
2202     if (lpPtr != NULL) {
2203         // must allocate things via host memory allocation functions
2204         // rather than perl's Renew() et al, as the perl interpreter
2205         // may either not be initialized enough when we allocate these,
2206         // or may already be dead when we go to free these
2207         *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char));
2208         strcpy(*lpPtr, lpStr);
2209     }
2210     else {
2211         m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR));
2212         if (m_lppEnvList) {
2213             m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char));
2214             if (m_lppEnvList[m_dwEnvCount] != NULL) {
2215                 strcpy(m_lppEnvList[m_dwEnvCount], lpStr);
2216                 ++m_dwEnvCount;
2217                 qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
2218             }
2219         }
2220     }
2221 }
2222
2223 DWORD
2224 CPerlHost::CalculateEnvironmentSpace(void)
2225 {
2226     DWORD index;
2227     DWORD dwSize = 0;
2228     for(index = 0; index < m_dwEnvCount; ++index)
2229         dwSize += strlen(m_lppEnvList[index]) + 1;
2230
2231     return dwSize;
2232 }
2233
2234 void
2235 CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
2236 {
2237     dTHX;
2238     Safefree(lpStr);
2239 }
2240
2241 char*
2242 CPerlHost::GetChildDir(void)
2243 {
2244     dTHX;
2245     char* ptr;
2246     size_t length;
2247
2248     Newx(ptr, MAX_PATH+1, char);
2249     m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
2250     length = strlen(ptr);
2251     if (length > 3) {
2252         if ((ptr[length-1] == '\\') || (ptr[length-1] == '/'))
2253             ptr[length-1] = 0;
2254     }
2255     return ptr;
2256 }
2257
2258 void
2259 CPerlHost::FreeChildDir(char* pStr)
2260 {
2261     dTHX;
2262     Safefree(pStr);
2263 }
2264
2265 LPSTR
2266 CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
2267 {
2268     dTHX;
2269     LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
2270     DWORD dwSize, dwEnvIndex;
2271     int nLength, compVal;
2272
2273     // get the process environment strings
2274     lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
2275
2276     // step over current directory stuff
2277     while(*lpTmp == '=')
2278         lpTmp += strlen(lpTmp) + 1;
2279
2280     // save the start of the environment strings
2281     lpEnvPtr = lpTmp;
2282     for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
2283         // calculate the size of the environment strings
2284         dwSize += strlen(lpTmp) + 1;
2285     }
2286
2287     // add the size of current directories
2288     dwSize += vDir.CalculateEnvironmentSpace();
2289
2290     // add the additional space used by changes made to the environment
2291     dwSize += CalculateEnvironmentSpace();
2292
2293     Newx(lpStr, dwSize, char);
2294     lpPtr = lpStr;
2295     if(lpStr != NULL) {
2296         // build the local environment
2297         lpStr = vDir.BuildEnvironmentSpace(lpStr);
2298
2299         dwEnvIndex = 0;
2300         lpLocalEnv = GetIndex(dwEnvIndex);
2301         while(*lpEnvPtr != '\0') {
2302             if(!lpLocalEnv) {
2303                 // all environment overrides have been added
2304                 // so copy string into place
2305                 strcpy(lpStr, lpEnvPtr);
2306                 nLength = strlen(lpEnvPtr) + 1;
2307                 lpStr += nLength;
2308                 lpEnvPtr += nLength;
2309             }
2310             else {
2311                 // determine which string to copy next
2312                 compVal = compare(&lpEnvPtr, &lpLocalEnv);
2313                 if(compVal < 0) {
2314                     strcpy(lpStr, lpEnvPtr);
2315                     nLength = strlen(lpEnvPtr) + 1;
2316                     lpStr += nLength;
2317                     lpEnvPtr += nLength;
2318                 }
2319                 else {
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                     if(compVal == 0) {
2327                         // this string was replaced
2328                         lpEnvPtr += strlen(lpEnvPtr) + 1;
2329                     }
2330                 }
2331             }
2332         }
2333
2334         while(lpLocalEnv) {
2335             // still have environment overrides to add
2336             // so copy the strings into place if not an override
2337             char *ptr = strchr(lpLocalEnv, '=');
2338             if(ptr && ptr[1]) {
2339                 strcpy(lpStr, lpLocalEnv);
2340                 lpStr += strlen(lpLocalEnv) + 1;
2341             }
2342             lpLocalEnv = GetIndex(dwEnvIndex);
2343         }
2344
2345         // add final NULL
2346         *lpStr = '\0';
2347     }
2348
2349     // release the process environment strings
2350     FreeEnvironmentStrings(lpAllocPtr);
2351
2352     return lpPtr;
2353 }
2354
2355 void
2356 CPerlHost::Reset(void)
2357 {
2358     dTHX;
2359     if(m_lppEnvList != NULL) {
2360         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2361             Free(m_lppEnvList[index]);
2362             m_lppEnvList[index] = NULL;
2363         }
2364     }
2365     m_dwEnvCount = 0;
2366     Free(m_lppEnvList);
2367     m_lppEnvList = NULL;
2368 }
2369
2370 void
2371 CPerlHost::Clearenv(void)
2372 {
2373     dTHX;
2374     char ch;
2375     LPSTR lpPtr, lpStr, lpEnvPtr;
2376     if (m_lppEnvList != NULL) {
2377         /* set every entry to an empty string */
2378         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2379             char* ptr = strchr(m_lppEnvList[index], '=');
2380             if(ptr) {
2381                 *++ptr = 0;
2382             }
2383         }
2384     }
2385
2386     /* get the process environment strings */
2387     lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
2388
2389     /* step over current directory stuff */
2390     while(*lpStr == '=')
2391         lpStr += strlen(lpStr) + 1;
2392
2393     while(*lpStr) {
2394         lpPtr = strchr(lpStr, '=');
2395         if(lpPtr) {
2396             ch = *++lpPtr;
2397             *lpPtr = 0;
2398             Add(lpStr);
2399             if (m_bTopLevel)
2400                 (void)win32_putenv(lpStr);
2401             *lpPtr = ch;
2402         }
2403         lpStr += strlen(lpStr) + 1;
2404     }
2405
2406     FreeEnvironmentStrings(lpEnvPtr);
2407 }
2408
2409
2410 char*
2411 CPerlHost::Getenv(const char *varname)
2412 {
2413     dTHX;
2414     if (!m_bTopLevel) {
2415         char *pEnv = Find(varname);
2416         if (pEnv && *pEnv)
2417             return pEnv;
2418     }
2419     return win32_getenv(varname);
2420 }
2421
2422 int
2423 CPerlHost::Putenv(const char *envstring)
2424 {
2425     dTHX;
2426     Add(envstring);
2427     if (m_bTopLevel)
2428         return win32_putenv(envstring);
2429
2430     return 0;
2431 }
2432
2433 int
2434 CPerlHost::Chdir(const char *dirname)
2435 {
2436     dTHX;
2437     int ret;
2438     if (!dirname) {
2439         errno = ENOENT;
2440         return -1;
2441     }
2442     ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
2443     if(ret < 0) {
2444         errno = ENOENT;
2445     }
2446     return ret;
2447 }
2448
2449 #endif /* ___PerlHost_H___ */