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 #ifdef __BORLANDC__
 786     if(((FILE*)pf)->flags & _F_READ) {
 787         mode[0] = 'r';
 788         mode[1] = 0;
 789     }
 790     else if(((FILE*)pf)->flags & _F_WRIT) {
 791         mode[0] = 'a';
 792         mode[1] = 0;
 793     }
 794     else if(((FILE*)pf)->flags & _F_RDWR) {
 795         mode[0] = 'r';
 796         mode[1] = '+';
 797         mode[2] = 0;
 798     }
 799 #else
 800     if(((FILE*)pf)->_flag & _IOREAD) {
 801         mode[0] = 'r';
 802         mode[1] = 0;
 803     }
 804     else if(((FILE*)pf)->_flag & _IOWRT) {
 805         mode[0] = 'a';
 806         mode[1] = 0;
 807     }
 808     else if(((FILE*)pf)->_flag & _IORW) {
 809         mode[0] = 'r';
 810         mode[1] = '+';
 811         mode[2] = 0;
 812     }
 813 #endif
 814
 815     /* it appears that the binmode is attached to the
 816      * file descriptor so binmode files will be handled
 817      * correctly
 818      */
 819     pfdup = (PerlIO*)win32_fdopen(fileno, mode);
 820
 821     /* move the file pointer to the same position */
 822     if (!fgetpos((FILE*)pf, &pos)) {
 823         fsetpos((FILE*)pfdup, &pos);
 824     }
 825     return pfdup;
 826 }
 827
 828 struct IPerlStdIO perlStdIO =
 829 {
 830     PerlStdIOStdin,
 831     PerlStdIOStdout,
 832     PerlStdIOStderr,
 833     PerlStdIOOpen,
 834     PerlStdIOClose,
 835     PerlStdIOEof,
 836     PerlStdIOError,
 837     PerlStdIOClearerr,
 838     PerlStdIOGetc,
 839     PerlStdIOGetBase,
 840     PerlStdIOGetBufsiz,
 841     PerlStdIOGetCnt,
 842     PerlStdIOGetPtr,
 843     PerlStdIOGets,
 844     PerlStdIOPutc,
 845     PerlStdIOPuts,
 846     PerlStdIOFlush,
 847     PerlStdIOUngetc,
 848     PerlStdIOFileno,
 849     PerlStdIOFdopen,
 850     PerlStdIOReopen,
 851     PerlStdIORead,
 852     PerlStdIOWrite,
 853     PerlStdIOSetBuf,
 854     PerlStdIOSetVBuf,
 855     PerlStdIOSetCnt,
 856     PerlStdIOSetPtrCnt,
 857     PerlStdIOSetlinebuf,
 858     PerlStdIOPrintf,
 859     PerlStdIOVprintf,
 860     PerlStdIOTell,
 861     PerlStdIOSeek,
 862     PerlStdIORewind,
 863     PerlStdIOTmpfile,
 864     PerlStdIOGetpos,
 865     PerlStdIOSetpos,
 866     PerlStdIOInit,
 867     PerlStdIOInitOSExtras,
 868     PerlStdIOFdupopen,
 869 };
 870
 871
 872 #undef IPERL2HOST
 873 #define IPERL2HOST(x) IPerlLIO2Host(x)
 874
 875 /* IPerlLIO */
 876 int
 877 PerlLIOAccess(struct IPerlLIO* piPerl, const char *path, int mode)
 878 {
 879     return win32_access(path, mode);
 880 }
 881
 882 int
 883 PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode)
 884 {
 885     return win32_chmod(filename, pmode);
 886 }
 887
 888 int
 889 PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group)
 890 {
 891     return chown(filename, owner, group);
 892 }
 893
 894 int
 895 PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size)
 896 {
 897     return chsize(handle, size);
 898 }
 899
 900 int
 901 PerlLIOClose(struct IPerlLIO* piPerl, int handle)
 902 {
 903     return win32_close(handle);
 904 }
 905
 906 int
 907 PerlLIODup(struct IPerlLIO* piPerl, int handle)
 908 {
 909     return win32_dup(handle);
 910 }
 911
 912 int
 913 PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2)
 914 {
 915     return win32_dup2(handle1, handle2);
 916 }
 917
 918 int
 919 PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper)
 920 {
 921     return win32_flock(fd, oper);
 922 }
 923
 924 int
 925 PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer)
 926 {
 927     return fstat(handle, buffer);
 928 }
 929
 930 int
 931 PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data)
 932 {
 933     return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
 934 }
 935
 936 int
 937 PerlLIOIsatty(struct IPerlLIO* piPerl, int fd)
 938 {
 939     return isatty(fd);
 940 }
 941
 942 int
 943 PerlLIOLink(struct IPerlLIO* piPerl, const char*oldname, const char *newname)
 944 {
 945     return win32_link(oldname, newname);
 946 }
 947
 948 long
 949 PerlLIOLseek(struct IPerlLIO* piPerl, int handle, long offset, int origin)
 950 {
 951     return win32_lseek(handle, offset, origin);
 952 }
 953
 954 int
 955 PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
 956 {
 957     return win32_stat(path, buffer);
 958 }
 959
 960 char*
 961 PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template)
 962 {
 963     return mktemp(Template);
 964 }
 965
 966 int
 967 PerlLIOOpen(struct IPerlLIO* piPerl, const char *filename, int oflag)
 968 {
 969     return win32_open(filename, oflag);
 970 }
 971
 972 int
 973 PerlLIOOpen3(struct IPerlLIO* piPerl, const char *filename, int oflag, int pmode)
 974 {
 975     return win32_open(filename, oflag, pmode);
 976 }
 977
 978 int
 979 PerlLIORead(struct IPerlLIO* piPerl, int handle, void *buffer, unsigned int count)
 980 {
 981     return win32_read(handle, buffer, count);
 982 }
 983
 984 int
 985 PerlLIORename(struct IPerlLIO* piPerl, const char *OldFileName, const char *newname)
 986 {
 987     return win32_rename(OldFileName, newname);
 988 }
 989
 990 int
 991 PerlLIOSetmode(struct IPerlLIO* piPerl, int handle, int mode)
 992 {
 993     return win32_setmode(handle, mode);
 994 }
 995
 996 int
 997 PerlLIONameStat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer)
 998 {
 999     return win32_stat(path, buffer);
1000 }
1001
1002 char*
1003 PerlLIOTmpnam(struct IPerlLIO* piPerl, char *string)
1004 {
1005     return tmpnam(string);
1006 }
1007
1008 int
1009 PerlLIOUmask(struct IPerlLIO* piPerl, int pmode)
1010 {
1011     return umask(pmode);
1012 }
1013
1014 int
1015 PerlLIOUnlink(struct IPerlLIO* piPerl, const char *filename)
1016 {
1017     return win32_unlink(filename);
1018 }
1019
1020 int
1021 PerlLIOUtime(struct IPerlLIO* piPerl, char *filename, struct utimbuf *times)
1022 {
1023     return win32_utime(filename, times);
1024 }
1025
1026 int
1027 PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned int count)
1028 {
1029     return win32_write(handle, buffer, count);
1030 }
1031
1032 struct IPerlLIO perlLIO =
1033 {
1034     PerlLIOAccess,
1035     PerlLIOChmod,
1036     PerlLIOChown,
1037     PerlLIOChsize,
1038     PerlLIOClose,
1039     PerlLIODup,
1040     PerlLIODup2,
1041     PerlLIOFlock,
1042     PerlLIOFileStat,
1043     PerlLIOIOCtl,
1044     PerlLIOIsatty,
1045     PerlLIOLink,
1046     PerlLIOLseek,
1047     PerlLIOLstat,
1048     PerlLIOMktemp,
1049     PerlLIOOpen,
1050     PerlLIOOpen3,
1051     PerlLIORead,
1052     PerlLIORename,
1053     PerlLIOSetmode,
1054     PerlLIONameStat,
1055     PerlLIOTmpnam,
1056     PerlLIOUmask,
1057     PerlLIOUnlink,
1058     PerlLIOUtime,
1059     PerlLIOWrite,
1060 };
1061
1062
1063 #undef IPERL2HOST
1064 #define IPERL2HOST(x) IPerlDir2Host(x)
1065
1066 /* IPerlDIR */
1067 int
1068 PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode)
1069 {
1070     return win32_mkdir(dirname, mode);
1071 }
1072
1073 int
1074 PerlDirChdir(struct IPerlDir* piPerl, const char *dirname)
1075 {
1076     return IPERL2HOST(piPerl)->Chdir(dirname);
1077 }
1078
1079 int
1080 PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname)
1081 {
1082     return win32_rmdir(dirname);
1083 }
1084
1085 int
1086 PerlDirClose(struct IPerlDir* piPerl, DIR *dirp)
1087 {
1088     return win32_closedir(dirp);
1089 }
1090
1091 DIR*
1092 PerlDirOpen(struct IPerlDir* piPerl, char *filename)
1093 {
1094     return win32_opendir(filename);
1095 }
1096
1097 struct direct *
1098 PerlDirRead(struct IPerlDir* piPerl, DIR *dirp)
1099 {
1100     return win32_readdir(dirp);
1101 }
1102
1103 void
1104 PerlDirRewind(struct IPerlDir* piPerl, DIR *dirp)
1105 {
1106     win32_rewinddir(dirp);
1107 }
1108
1109 void
1110 PerlDirSeek(struct IPerlDir* piPerl, DIR *dirp, long loc)
1111 {
1112     win32_seekdir(dirp, loc);
1113 }
1114
1115 long
1116 PerlDirTell(struct IPerlDir* piPerl, DIR *dirp)
1117 {
1118     return win32_telldir(dirp);
1119 }
1120
1121 char*
1122 PerlDirMapPathA(struct IPerlDir* piPerl, const char* path)
1123 {
1124     return IPERL2HOST(piPerl)->MapPathA(path);
1125 }
1126
1127 WCHAR*
1128 PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path)
1129 {
1130     return IPERL2HOST(piPerl)->MapPathW(path);
1131 }
1132
1133 struct IPerlDir perlDir =
1134 {
1135     PerlDirMakedir,
1136     PerlDirChdir,
1137     PerlDirRmdir,
1138     PerlDirClose,
1139     PerlDirOpen,
1140     PerlDirRead,
1141     PerlDirRewind,
1142     PerlDirSeek,
1143     PerlDirTell,
1144     PerlDirMapPathA,
1145     PerlDirMapPathW,
1146 };
1147
1148
1149 /* IPerlSock */
1150 u_long
1151 PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong)
1152 {
1153     return win32_htonl(hostlong);
1154 }
1155
1156 u_short
1157 PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort)
1158 {
1159     return win32_htons(hostshort);
1160 }
1161
1162 u_long
1163 PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong)
1164 {
1165     return win32_ntohl(netlong);
1166 }
1167
1168 u_short
1169 PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort)
1170 {
1171     return win32_ntohs(netshort);
1172 }
1173
1174 SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen)
1175 {
1176     return win32_accept(s, addr, addrlen);
1177 }
1178
1179 int
1180 PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1181 {
1182     return win32_bind(s, name, namelen);
1183 }
1184
1185 int
1186 PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen)
1187 {
1188     return win32_connect(s, name, namelen);
1189 }
1190
1191 void
1192 PerlSockEndhostent(struct IPerlSock* piPerl)
1193 {
1194     win32_endhostent();
1195 }
1196
1197 void
1198 PerlSockEndnetent(struct IPerlSock* piPerl)
1199 {
1200     win32_endnetent();
1201 }
1202
1203 void
1204 PerlSockEndprotoent(struct IPerlSock* piPerl)
1205 {
1206     win32_endprotoent();
1207 }
1208
1209 void
1210 PerlSockEndservent(struct IPerlSock* piPerl)
1211 {
1212     win32_endservent();
1213 }
1214
1215 struct hostent*
1216 PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type)
1217 {
1218     return win32_gethostbyaddr(addr, len, type);
1219 }
1220
1221 struct hostent*
1222 PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name)
1223 {
1224     return win32_gethostbyname(name);
1225 }
1226
1227 struct hostent*
1228 PerlSockGethostent(struct IPerlSock* piPerl)
1229 {
1230     dTHXo;
1231     Perl_croak(aTHX_ "gethostent not implemented!\n");
1232     return NULL;
1233 }
1234
1235 int
1236 PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen)
1237 {
1238     return win32_gethostname(name, namelen);
1239 }
1240
1241 struct netent *
1242 PerlSockGetnetbyaddr(struct IPerlSock* piPerl, long net, int type)
1243 {
1244     return win32_getnetbyaddr(net, type);
1245 }
1246
1247 struct netent *
1248 PerlSockGetnetbyname(struct IPerlSock* piPerl, const char *name)
1249 {
1250     return win32_getnetbyname((char*)name);
1251 }
1252
1253 struct netent *
1254 PerlSockGetnetent(struct IPerlSock* piPerl)
1255 {
1256     return win32_getnetent();
1257 }
1258
1259 int PerlSockGetpeername(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1260 {
1261     return win32_getpeername(s, name, namelen);
1262 }
1263
1264 struct protoent*
1265 PerlSockGetprotobyname(struct IPerlSock* piPerl, const char* name)
1266 {
1267     return win32_getprotobyname(name);
1268 }
1269
1270 struct protoent*
1271 PerlSockGetprotobynumber(struct IPerlSock* piPerl, int number)
1272 {
1273     return win32_getprotobynumber(number);
1274 }
1275
1276 struct protoent*
1277 PerlSockGetprotoent(struct IPerlSock* piPerl)
1278 {
1279     return win32_getprotoent();
1280 }
1281
1282 struct servent*
1283 PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* proto)
1284 {
1285     return win32_getservbyname(name, proto);
1286 }
1287
1288 struct servent*
1289 PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto)
1290 {
1291     return win32_getservbyport(port, proto);
1292 }
1293
1294 struct servent*
1295 PerlSockGetservent(struct IPerlSock* piPerl)
1296 {
1297     return win32_getservent();
1298 }
1299
1300 int
1301 PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen)
1302 {
1303     return win32_getsockname(s, name, namelen);
1304 }
1305
1306 int
1307 PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen)
1308 {
1309     return win32_getsockopt(s, level, optname, optval, optlen);
1310 }
1311
1312 unsigned long
1313 PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp)
1314 {
1315     return win32_inet_addr(cp);
1316 }
1317
1318 char*
1319 PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in)
1320 {
1321     return win32_inet_ntoa(in);
1322 }
1323
1324 int
1325 PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog)
1326 {
1327     return win32_listen(s, backlog);
1328 }
1329
1330 int
1331 PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags)
1332 {
1333     return win32_recv(s, buffer, len, flags);
1334 }
1335
1336 int
1337 PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
1338 {
1339     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
1340 }
1341
1342 int
1343 PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
1344 {
1345     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
1346 }
1347
1348 int
1349 PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags)
1350 {
1351     return win32_send(s, buffer, len, flags);
1352 }
1353
1354 int
1355 PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
1356 {
1357     return win32_sendto(s, buffer, len, flags, to, tolen);
1358 }
1359
1360 void
1361 PerlSockSethostent(struct IPerlSock* piPerl, int stayopen)
1362 {
1363     win32_sethostent(stayopen);
1364 }
1365
1366 void
1367 PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen)
1368 {
1369     win32_setnetent(stayopen);
1370 }
1371
1372 void
1373 PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen)
1374 {
1375     win32_setprotoent(stayopen);
1376 }
1377
1378 void
1379 PerlSockSetservent(struct IPerlSock* piPerl, int stayopen)
1380 {
1381     win32_setservent(stayopen);
1382 }
1383
1384 int
1385 PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen)
1386 {
1387     return win32_setsockopt(s, level, optname, optval, optlen);
1388 }
1389
1390 int
1391 PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how)
1392 {
1393     return win32_shutdown(s, how);
1394 }
1395
1396 SOCKET
1397 PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol)
1398 {
1399     return win32_socket(af, type, protocol);
1400 }
1401
1402 int
1403 PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int* fds)
1404 {
1405     dTHXo;
1406     Perl_croak(aTHX_ "socketpair not implemented!\n");
1407     return 0;
1408 }
1409
1410 int
1411 PerlSockClosesocket(struct IPerlSock* piPerl, SOCKET s)
1412 {
1413     return win32_closesocket(s);
1414 }
1415
1416 int
1417 PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp)
1418 {
1419     return win32_ioctlsocket(s, cmd, argp);
1420 }
1421
1422 struct IPerlSock perlSock =
1423 {
1424     PerlSockHtonl,
1425     PerlSockHtons,
1426     PerlSockNtohl,
1427     PerlSockNtohs,
1428     PerlSockAccept,
1429     PerlSockBind,
1430     PerlSockConnect,
1431     PerlSockEndhostent,
1432     PerlSockEndnetent,
1433     PerlSockEndprotoent,
1434     PerlSockEndservent,
1435     PerlSockGethostname,
1436     PerlSockGetpeername,
1437     PerlSockGethostbyaddr,
1438     PerlSockGethostbyname,
1439     PerlSockGethostent,
1440     PerlSockGetnetbyaddr,
1441     PerlSockGetnetbyname,
1442     PerlSockGetnetent,
1443     PerlSockGetprotobyname,
1444     PerlSockGetprotobynumber,
1445     PerlSockGetprotoent,
1446     PerlSockGetservbyname,
1447     PerlSockGetservbyport,
1448     PerlSockGetservent,
1449     PerlSockGetsockname,
1450     PerlSockGetsockopt,
1451     PerlSockInetAddr,
1452     PerlSockInetNtoa,
1453     PerlSockListen,
1454     PerlSockRecv,
1455     PerlSockRecvfrom,
1456     PerlSockSelect,
1457     PerlSockSend,
1458     PerlSockSendto,
1459     PerlSockSethostent,
1460     PerlSockSetnetent,
1461     PerlSockSetprotoent,
1462     PerlSockSetservent,
1463     PerlSockSetsockopt,
1464     PerlSockShutdown,
1465     PerlSockSocket,
1466     PerlSockSocketpair,
1467     PerlSockClosesocket,
1468 };
1469
1470
1471 /* IPerlProc */
1472
1473 #define EXECF_EXEC 1
1474 #define EXECF_SPAWN 2
1475
1476 void
1477 PerlProcAbort(struct IPerlProc* piPerl)
1478 {
1479     win32_abort();
1480 }
1481
1482 char *
1483 PerlProcCrypt(struct IPerlProc* piPerl, const char* clear, const char* salt)
1484 {
1485     return win32_crypt(clear, salt);
1486 }
1487
1488 void
1489 PerlProcExit(struct IPerlProc* piPerl, int status)
1490 {
1491     exit(status);
1492 }
1493
1494 void
1495 PerlProc_Exit(struct IPerlProc* piPerl, int status)
1496 {
1497     _exit(status);
1498 }
1499
1500 int
1501 PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1502 {
1503     return execl(cmdname, arg0, arg1, arg2, arg3);
1504 }
1505
1506 int
1507 PerlProcExecv(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1508 {
1509     return win32_execvp(cmdname, argv);
1510 }
1511
1512 int
1513 PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const *argv)
1514 {
1515     return win32_execvp(cmdname, argv);
1516 }
1517
1518 uid_t
1519 PerlProcGetuid(struct IPerlProc* piPerl)
1520 {
1521     return getuid();
1522 }
1523
1524 uid_t
1525 PerlProcGeteuid(struct IPerlProc* piPerl)
1526 {
1527     return geteuid();
1528 }
1529
1530 gid_t
1531 PerlProcGetgid(struct IPerlProc* piPerl)
1532 {
1533     return getgid();
1534 }
1535
1536 gid_t
1537 PerlProcGetegid(struct IPerlProc* piPerl)
1538 {
1539     return getegid();
1540 }
1541
1542 char *
1543 PerlProcGetlogin(struct IPerlProc* piPerl)
1544 {
1545     return g_getlogin();
1546 }
1547
1548 int
1549 PerlProcKill(struct IPerlProc* piPerl, int pid, int sig)
1550 {
1551     return win32_kill(pid, sig);
1552 }
1553
1554 int
1555 PerlProcKillpg(struct IPerlProc* piPerl, int pid, int sig)
1556 {
1557     dTHXo;
1558     Perl_croak(aTHX_ "killpg not implemented!\n");
1559     return 0;
1560 }
1561
1562 int
1563 PerlProcPauseProc(struct IPerlProc* piPerl)
1564 {
1565     return win32_sleep((32767L << 16) + 32767);
1566 }
1567
1568 PerlIO*
1569 PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode)
1570 {
1571     dTHXo;
1572     PERL_FLUSHALL_FOR_CHILD;
1573     return (PerlIO*)win32_popen(command, mode);
1574 }
1575
1576 int
1577 PerlProcPclose(struct IPerlProc* piPerl, PerlIO *stream)
1578 {
1579     return win32_pclose((FILE*)stream);
1580 }
1581
1582 int
1583 PerlProcPipe(struct IPerlProc* piPerl, int *phandles)
1584 {
1585     return win32_pipe(phandles, 512, O_BINARY);
1586 }
1587
1588 int
1589 PerlProcSetuid(struct IPerlProc* piPerl, uid_t u)
1590 {
1591     return setuid(u);
1592 }
1593
1594 int
1595 PerlProcSetgid(struct IPerlProc* piPerl, gid_t g)
1596 {
1597     return setgid(g);
1598 }
1599
1600 int
1601 PerlProcSleep(struct IPerlProc* piPerl, unsigned int s)
1602 {
1603     return win32_sleep(s);
1604 }
1605
1606 int
1607 PerlProcTimes(struct IPerlProc* piPerl, struct tms *timebuf)
1608 {
1609     return win32_times(timebuf);
1610 }
1611
1612 int
1613 PerlProcWait(struct IPerlProc* piPerl, int *status)
1614 {
1615     return win32_wait(status);
1616 }
1617
1618 int
1619 PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags)
1620 {
1621     return win32_waitpid(pid, status, flags);
1622 }
1623
1624 Sighandler_t
1625 PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode)
1626 {
1627     return 0;
1628 }
1629
1630 #ifdef USE_ITHREADS
1631 static DWORD WINAPI
1632 win32_start_child(LPVOID arg)
1633 {
1634     PerlInterpreter *my_perl = (PerlInterpreter*)arg;
1635     GV *tmpgv;
1636     int status;
1637 #ifdef PERL_OBJECT
1638     CPerlObj *pPerl = (CPerlObj*)my_perl;
1639 #endif
1640 #ifdef PERL_SYNC_FORK
1641     static long sync_fork_id = 0;
1642     long id = ++sync_fork_id;
1643 #endif
1644
1645
1646     PERL_SET_INTERP(my_perl);
1647
1648     /* set $$ to pseudo id */
1649 #ifdef PERL_SYNC_FORK
1650     w32_pseudo_id = id;
1651 #else
1652     w32_pseudo_id = GetCurrentThreadId();
1653 #endif
1654     if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1655         sv_setiv(GvSV(tmpgv), -(IV)w32_pseudo_id);
1656     hv_clear(PL_pidstatus);
1657
1658     /* push a zero on the stack (we are the child) */
1659     {
1660         djSP;
1661         dTARGET;
1662         PUSHi(0);
1663         PUTBACK;
1664     }
1665
1666     /* continue from next op */
1667     PL_op = PL_op->op_next;
1668
1669     {
1670         dJMPENV;
1671         volatile int oldscope = PL_scopestack_ix;
1672
1673 restart:
1674         JMPENV_PUSH(status);
1675         switch (status) {
1676         case 0:
1677             CALLRUNOPS(aTHX);
1678             status = 0;
1679             break;
1680         case 2:
1681             while (PL_scopestack_ix > oldscope)
1682                 LEAVE;
1683             FREETMPS;
1684             PL_curstash = PL_defstash;
1685             if (PL_endav && !PL_minus_c)
1686                 call_list(oldscope, PL_endav);
1687             status = STATUS_NATIVE_EXPORT;
1688             break;
1689         case 3:
1690             if (PL_restartop) {
1691                 POPSTACK_TO(PL_mainstack);
1692                 PL_op = PL_restartop;
1693                 PL_restartop = Nullop;
1694                 goto restart;
1695             }
1696             PerlIO_printf(Perl_error_log, "panic: restartop\n");
1697             FREETMPS;
1698             status = 1;
1699             break;
1700         }
1701         JMPENV_POP;
1702
1703         /* XXX hack to avoid perl_destruct() freeing optree */
1704         PL_main_root = Nullop;
1705     }
1706
1707     /* destroy everything (waits for any pseudo-forked children) */
1708     perl_destruct(my_perl);
1709     perl_free(my_perl);
1710
1711 #ifdef PERL_SYNC_FORK
1712     return id;
1713 #else
1714     return (DWORD)status;
1715 #endif
1716 }
1717 #endif /* USE_ITHREADS */
1718
1719 int
1720 PerlProcFork(struct IPerlProc* piPerl)
1721 {
1722     dTHXo;
1723 #ifdef USE_ITHREADS
1724     DWORD id;
1725     HANDLE handle;
1726     CPerlHost *h = new CPerlHost(*(CPerlHost*)w32_internal_host);
1727     PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHXo, 1,
1728                                                  h->m_pHostperlMem,
1729                                                  h->m_pHostperlMemShared,
1730                                                  h->m_pHostperlMemParse,
1731                                                  h->m_pHostperlEnv,
1732                                                  h->m_pHostperlStdIO,
1733                                                  h->m_pHostperlLIO,
1734                                                  h->m_pHostperlDir,
1735                                                  h->m_pHostperlSock,
1736                                                  h->m_pHostperlProc
1737                                                  );
1738     new_perl->Isys_intern.internal_host = h;
1739 #  ifdef PERL_SYNC_FORK
1740     id = win32_start_child((LPVOID)new_perl);
1741     PERL_SET_INTERP(aTHXo);
1742 #  else
1743     handle = CreateThread(NULL, 0, win32_start_child,
1744                           (LPVOID)new_perl, 0, &id);
1745     PERL_SET_INTERP(aTHXo);
1746     if (!handle)
1747         Perl_croak(aTHX_ "panic: pseudo fork() failed");
1748     w32_pseudo_child_handles[w32_num_pseudo_children] = handle;
1749     w32_pseudo_child_pids[w32_num_pseudo_children] = id;
1750     ++w32_num_pseudo_children;
1751 #  endif
1752     return -(int)id;
1753 #else
1754     Perl_croak(aTHX_ "fork() not implemented!\n");
1755     return -1;
1756 #endif /* USE_ITHREADS */
1757 }
1758
1759 int
1760 PerlProcGetpid(struct IPerlProc* piPerl)
1761 {
1762     return win32_getpid();
1763 }
1764
1765 void*
1766 PerlProcDynaLoader(struct IPerlProc* piPerl, const char* filename)
1767 {
1768     return win32_dynaload(filename);
1769 }
1770
1771 void
1772 PerlProcGetOSError(struct IPerlProc* piPerl, SV* sv, DWORD dwErr)
1773 {
1774     win32_str_os_error(sv, dwErr);
1775 }
1776
1777 BOOL
1778 PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
1779 {
1780     do_spawn2(cmd, EXECF_EXEC);
1781     return FALSE;
1782 }
1783
1784 int
1785 PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
1786 {
1787     return do_spawn2(cmds, EXECF_SPAWN);
1788 }
1789
1790 int
1791 PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
1792 {
1793     return win32_spawnvp(mode, cmdname, argv);
1794 }
1795
1796 int
1797 PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp)
1798 {
1799     return do_aspawn(vreally, vmark, vsp);
1800 }
1801
1802 struct IPerlProc perlProc =
1803 {
1804     PerlProcAbort,
1805     PerlProcCrypt,
1806     PerlProcExit,
1807     PerlProc_Exit,
1808     PerlProcExecl,
1809     PerlProcExecv,
1810     PerlProcExecvp,
1811     PerlProcGetuid,
1812     PerlProcGeteuid,
1813     PerlProcGetgid,
1814     PerlProcGetegid,
1815     PerlProcGetlogin,
1816     PerlProcKill,
1817     PerlProcKillpg,
1818     PerlProcPauseProc,
1819     PerlProcPopen,
1820     PerlProcPclose,
1821     PerlProcPipe,
1822     PerlProcSetuid,
1823     PerlProcSetgid,
1824     PerlProcSleep,
1825     PerlProcTimes,
1826     PerlProcWait,
1827     PerlProcWaitpid,
1828     PerlProcSignal,
1829     PerlProcFork,
1830     PerlProcGetpid,
1831     PerlProcDynaLoader,
1832     PerlProcGetOSError,
1833     PerlProcDoCmd,
1834     PerlProcSpawn,
1835     PerlProcSpawnvp,
1836     PerlProcASpawn,
1837 };
1838
1839
1840 /*
1841  * CPerlHost
1842  */
1843
1844 CPerlHost::CPerlHost(void)
1845 {
1846     m_pvDir = new VDir();
1847     m_pVMem = new VMem();
1848     m_pVMemShared = new VMem();
1849     m_pVMemParse =  new VMem();
1850
1851     m_pvDir->Init(NULL, m_pVMem);
1852
1853     m_dwEnvCount = 0;
1854     m_lppEnvList = NULL;
1855
1856     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1857     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1858     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1859     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
1860     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
1861     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
1862     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
1863     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
1864     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
1865
1866     m_pHostperlMem          = &m_hostperlMem;
1867     m_pHostperlMemShared    = &m_hostperlMemShared;
1868     m_pHostperlMemParse     = &m_hostperlMemParse;
1869     m_pHostperlEnv          = &m_hostperlEnv;
1870     m_pHostperlStdIO        = &m_hostperlStdIO;
1871     m_pHostperlLIO          = &m_hostperlLIO;
1872     m_pHostperlDir          = &m_hostperlDir;
1873     m_pHostperlSock         = &m_hostperlSock;
1874     m_pHostperlProc         = &m_hostperlProc;
1875 }
1876
1877 #define SETUPEXCHANGE(xptr, iptr, table) \
1878     STMT_START {                                \
1879         if (xptr) {                             \
1880             iptr = *xptr;                       \
1881             *xptr = &table;                     \
1882         }                                       \
1883         else {                                  \
1884             iptr = &table;                      \
1885         }                                       \
1886     } STMT_END
1887
1888 CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
1889                  struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
1890                  struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO,
1891                  struct IPerlDir** ppDir, struct IPerlSock** ppSock,
1892                  struct IPerlProc** ppProc)
1893 {
1894     m_pvDir = new VDir(0);
1895     m_pVMem = new VMem();
1896     m_pVMemShared = new VMem();
1897     m_pVMemParse =  new VMem();
1898
1899     m_pvDir->Init(NULL, m_pVMem);
1900
1901     m_dwEnvCount = 0;
1902     m_lppEnvList = NULL;
1903
1904     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1905     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1906     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1907     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
1908     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
1909     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
1910     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
1911     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
1912     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
1913
1914     SETUPEXCHANGE(ppMem,        m_pHostperlMem,         m_hostperlMem);
1915     SETUPEXCHANGE(ppMemShared,  m_pHostperlMemShared,   m_hostperlMemShared);
1916     SETUPEXCHANGE(ppMemParse,   m_pHostperlMemParse,    m_hostperlMemParse);
1917     SETUPEXCHANGE(ppEnv,        m_pHostperlEnv,         m_hostperlEnv);
1918     SETUPEXCHANGE(ppStdIO,      m_pHostperlStdIO,       m_hostperlStdIO);
1919     SETUPEXCHANGE(ppLIO,        m_pHostperlLIO,         m_hostperlLIO);
1920     SETUPEXCHANGE(ppDir,        m_pHostperlDir,         m_hostperlDir);
1921     SETUPEXCHANGE(ppSock,       m_pHostperlSock,        m_hostperlSock);
1922     SETUPEXCHANGE(ppProc,       m_pHostperlProc,        m_hostperlProc);
1923 }
1924 #undef SETUPEXCHANGE
1925
1926 CPerlHost::CPerlHost(CPerlHost& host)
1927 {
1928     m_pVMem = new VMem();
1929     m_pVMemShared = host.GetMemShared();
1930     m_pVMemParse =  host.GetMemParse();
1931
1932     /* duplicate directory info */
1933     m_pvDir = new VDir(0);
1934     m_pvDir->Init(host.GetDir(), m_pVMem);
1935
1936     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
1937     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
1938     CopyMemory(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse));
1939     CopyMemory(&m_hostperlEnv, &perlEnv, sizeof(perlEnv));
1940     CopyMemory(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO));
1941     CopyMemory(&m_hostperlLIO, &perlLIO, sizeof(perlLIO));
1942     CopyMemory(&m_hostperlDir, &perlDir, sizeof(perlDir));
1943     CopyMemory(&m_hostperlSock, &perlSock, sizeof(perlSock));
1944     CopyMemory(&m_hostperlProc, &perlProc, sizeof(perlProc));
1945     m_pHostperlMem          = &m_hostperlMem;
1946     m_pHostperlMemShared    = &m_hostperlMemShared;
1947     m_pHostperlMemParse     = &m_hostperlMemParse;
1948     m_pHostperlEnv          = &m_hostperlEnv;
1949     m_pHostperlStdIO        = &m_hostperlStdIO;
1950     m_pHostperlLIO          = &m_hostperlLIO;
1951     m_pHostperlDir          = &m_hostperlDir;
1952     m_pHostperlSock         = &m_hostperlSock;
1953     m_pHostperlProc         = &m_hostperlProc;
1954
1955     m_dwEnvCount = 0;
1956     m_lppEnvList = NULL;
1957
1958     /* duplicate environment info */
1959     LPSTR lpPtr;
1960     DWORD dwIndex = 0;
1961     while(lpPtr = host.GetIndex(dwIndex))
1962         Add(lpPtr);
1963 }
1964
1965 CPerlHost::~CPerlHost(void)
1966 {
1967 //  Reset();
1968     delete m_pvDir;
1969     m_pVMemParse->Release();
1970     m_pVMemShared->Release();
1971     m_pVMem->Release();
1972 }
1973
1974 LPSTR
1975 CPerlHost::Find(LPCSTR lpStr)
1976 {
1977     LPSTR lpPtr;
1978     LPSTR* lppPtr = Lookup(lpStr);
1979     if(lppPtr != NULL) {
1980         for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr)
1981             ;
1982
1983         if(*lpPtr == '=')
1984             ++lpPtr;
1985
1986         return lpPtr;
1987     }
1988     return NULL;
1989 }
1990
1991 int
1992 lookup(const void *arg1, const void *arg2)
1993 {   // Compare strings
1994     char*ptr1, *ptr2;
1995     char c1,c2;
1996
1997     ptr1 = *(char**)arg1;
1998     ptr2 = *(char**)arg2;
1999     for(;;) {
2000         c1 = *ptr1++;
2001         c2 = *ptr2++;
2002         if(c1 == '\0' || c1 == '=') {
2003             if(c2 == '\0' || c2 == '=')
2004                 break;
2005
2006             return -1; // string 1 < string 2
2007         }
2008         else if(c2 == '\0' || c2 == '=')
2009             return 1; // string 1 > string 2
2010         else if(c1 != c2) {
2011             c1 = toupper(c1);
2012             c2 = toupper(c2);
2013             if(c1 != c2) {
2014                 if(c1 < c2)
2015                     return -1; // string 1 < string 2
2016
2017                 return 1; // string 1 > string 2
2018             }
2019         }
2020     }
2021     return 0;
2022 }
2023
2024 LPSTR*
2025 CPerlHost::Lookup(LPCSTR lpStr)
2026 {
2027     return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup);
2028 }
2029
2030 int
2031 compare(const void *arg1, const void *arg2)
2032 {   // Compare strings
2033     char*ptr1, *ptr2;
2034     char c1,c2;
2035
2036     ptr1 = *(char**)arg1;
2037     ptr2 = *(char**)arg2;
2038     for(;;) {
2039         c1 = *ptr1++;
2040         c2 = *ptr2++;
2041         if(c1 == '\0' || c1 == '=') {
2042             if(c1 == c2)
2043                 break;
2044
2045             return -1; // string 1 < string 2
2046         }
2047         else if(c2 == '\0' || c2 == '=')
2048             return 1; // string 1 > string 2
2049         else if(c1 != c2) {
2050             c1 = toupper(c1);
2051             c2 = toupper(c2);
2052             if(c1 != c2) {
2053                 if(c1 < c2)
2054                     return -1; // string 1 < string 2
2055
2056                 return 1; // string 1 > string 2
2057             }
2058         }
2059     }
2060     return 0;
2061 }
2062
2063 void
2064 CPerlHost::Add(LPCSTR lpStr)
2065 {
2066     dTHXo;
2067     char szBuffer[1024];
2068     LPSTR *lpPtr;
2069     int index, length = strlen(lpStr)+1;
2070
2071     for(index = 0; lpStr[index] != '\0' && lpStr[index] != '='; ++index)
2072         szBuffer[index] = lpStr[index];
2073
2074     szBuffer[index] = '\0';
2075
2076     // replacing ?
2077     lpPtr = Lookup(szBuffer);
2078     if(lpPtr != NULL) {
2079         Renew(*lpPtr, length, char);
2080         strcpy(*lpPtr, lpStr);
2081     }
2082     else {
2083         ++m_dwEnvCount;
2084         Renew(m_lppEnvList, m_dwEnvCount, LPSTR);
2085         New(1, m_lppEnvList[m_dwEnvCount-1], length, char);
2086         if(m_lppEnvList[m_dwEnvCount-1] != NULL) {
2087             strcpy(m_lppEnvList[m_dwEnvCount-1], lpStr);
2088             qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare);
2089         }
2090         else
2091             --m_dwEnvCount;
2092     }
2093 }
2094
2095 DWORD
2096 CPerlHost::CalculateEnvironmentSpace(void)
2097 {
2098     DWORD index;
2099     DWORD dwSize = 0;
2100     for(index = 0; index < m_dwEnvCount; ++index)
2101         dwSize += strlen(m_lppEnvList[index]) + 1;
2102
2103     return dwSize;
2104 }
2105
2106 void
2107 CPerlHost::FreeLocalEnvironmentStrings(LPSTR lpStr)
2108 {
2109     dTHXo;
2110     Safefree(lpStr);
2111 }
2112
2113 char*
2114 CPerlHost::GetChildDir(void)
2115 {
2116     dTHXo;
2117     int length;
2118     char* ptr;
2119     New(0, ptr, MAX_PATH+1, char);
2120     if(ptr) {
2121         m_pvDir->GetCurrentDirectoryA(MAX_PATH+1, ptr);
2122         length = strlen(ptr)-1;
2123         if(length > 0) {
2124             if((ptr[length] == '\\') || (ptr[length] == '/'))
2125                 ptr[length] = 0;
2126         }
2127     }
2128     return ptr;
2129 }
2130
2131 void
2132 CPerlHost::FreeChildDir(char* pStr)
2133 {
2134     dTHXo;
2135     Safefree(pStr);
2136 }
2137
2138 LPSTR
2139 CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir)
2140 {
2141     dTHXo;
2142     LPSTR lpStr, lpPtr, lpEnvPtr, lpTmp, lpLocalEnv, lpAllocPtr;
2143     DWORD dwSize, dwEnvIndex;
2144     int nLength, compVal;
2145
2146     // get the process environment strings
2147     lpAllocPtr = lpTmp = (LPSTR)GetEnvironmentStrings();
2148
2149     // step over current directory stuff
2150     while(*lpTmp == '=')
2151         lpTmp += strlen(lpTmp) + 1;
2152
2153     // save the start of the environment strings
2154     lpEnvPtr = lpTmp;
2155     for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) {
2156         // calculate the size of the environment strings
2157         dwSize += strlen(lpTmp) + 1;
2158     }
2159
2160     // add the size of current directories
2161     dwSize += vDir.CalculateEnvironmentSpace();
2162
2163     // add the additional space used by changes made to the environment
2164     dwSize += CalculateEnvironmentSpace();
2165
2166     New(1, lpStr, dwSize, char);
2167     lpPtr = lpStr;
2168     if(lpStr != NULL) {
2169         // build the local environment
2170         lpStr = vDir.BuildEnvironmentSpace(lpStr);
2171
2172         dwEnvIndex = 0;
2173         lpLocalEnv = GetIndex(dwEnvIndex);
2174         while(*lpEnvPtr != '\0') {
2175             if(lpLocalEnv == NULL) {
2176                 // all environment overrides have been added
2177                 // so copy string into place
2178                 strcpy(lpStr, lpEnvPtr);
2179                 nLength = strlen(lpEnvPtr) + 1;
2180                 lpStr += nLength;
2181                 lpEnvPtr += nLength;
2182             }
2183             else {
2184                 // determine which string to copy next
2185                 compVal = compare(&lpEnvPtr, &lpLocalEnv);
2186                 if(compVal < 0) {
2187                     strcpy(lpStr, lpEnvPtr);
2188                     nLength = strlen(lpEnvPtr) + 1;
2189                     lpStr += nLength;
2190                     lpEnvPtr += nLength;
2191                 }
2192                 else {
2193                     char *ptr = strchr(lpLocalEnv, '=');
2194                     if(ptr && ptr[1]) {
2195                         strcpy(lpStr, lpLocalEnv);
2196                         lpStr += strlen(lpLocalEnv) + 1;
2197                     }
2198                     lpLocalEnv = GetIndex(dwEnvIndex);
2199                     if(compVal == 0) {
2200                         // this string was replaced
2201                         lpEnvPtr += strlen(lpEnvPtr) + 1;
2202                     }
2203                 }
2204             }
2205         }
2206
2207         // add final NULL
2208         *lpStr = '\0';
2209     }
2210
2211     // release the process environment strings
2212     FreeEnvironmentStrings(lpAllocPtr);
2213
2214     return lpPtr;
2215 }
2216
2217 void
2218 CPerlHost::Reset(void)
2219 {
2220     dTHXo;
2221     if(m_lppEnvList != NULL) {
2222         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2223             Safefree(m_lppEnvList[index]);
2224             m_lppEnvList[index] = NULL;
2225         }
2226     }
2227     m_dwEnvCount = 0;
2228 }
2229
2230 void
2231 CPerlHost::Clearenv(void)
2232 {
2233     char ch;
2234     LPSTR lpPtr, lpStr, lpEnvPtr;
2235     if(m_lppEnvList != NULL) {
2236         /* set every entry to an empty string */
2237         for(DWORD index = 0; index < m_dwEnvCount; ++index) {
2238             char* ptr = strchr(m_lppEnvList[index], '=');
2239             if(ptr) {
2240                 *++ptr = 0;
2241             }
2242         }
2243     }
2244
2245     /* get the process environment strings */
2246     lpStr = lpEnvPtr = (LPSTR)GetEnvironmentStrings();
2247
2248     /* step over current directory stuff */
2249     while(*lpStr == '=')
2250         lpStr += strlen(lpStr) + 1;
2251
2252     while(*lpStr) {
2253         lpPtr = strchr(lpStr, '=');
2254         if(lpPtr) {
2255             ch = *++lpPtr;
2256             *lpPtr = 0;
2257             Add(lpStr);
2258             *lpPtr = ch;
2259         }
2260         lpStr += strlen(lpStr) + 1;
2261     }
2262
2263     FreeEnvironmentStrings(lpEnvPtr);
2264 }
2265
2266
2267 char*
2268 CPerlHost::Getenv(const char *varname)
2269 {
2270     char* pEnv = Find(varname);
2271     if(pEnv == NULL) {
2272         pEnv = win32_getenv(varname);
2273     }
2274     else {
2275         if(!*pEnv)
2276             pEnv = 0;
2277     }
2278
2279     return pEnv;
2280 }
2281
2282 int
2283 CPerlHost::Putenv(const char *envstring)
2284 {
2285     Add(envstring);
2286     return 0;
2287 }
2288
2289 int
2290 CPerlHost::Chdir(const char *dirname)
2291 {
2292     dTHXo;
2293     int ret;
2294     if (USING_WIDE()) {
2295         WCHAR wBuffer[MAX_PATH];
2296         A2WHELPER(dirname, wBuffer, sizeof(wBuffer));
2297         ret = m_pvDir->SetCurrentDirectoryW(wBuffer);
2298     }
2299     else
2300         ret = m_pvDir->SetCurrentDirectoryA((char*)dirname);
2301     if(ret < 0) {
2302         errno = ENOENT;
2303     }
2304     return ret;
2305 }
2306
2307 #endif /* ___PerlHost_H___ */