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