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