win32/perlhost.h

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