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