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