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