win32/perlhost.h

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