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