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