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