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