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