win32/perlhost.h

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