win32/perllib.c

   1 /*
   2  * "The Road goes ever on and on, down from the door where it began."
   3  */
   4
   5
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8
   9 #ifdef PERL_OBJECT
  10 #define NO_XSLOCKS
  11 #endif
  12
  13 #include "XSUB.h"
  14
  15 #ifdef PERL_IMPLICIT_SYS
  16 #include "win32iop.h"
  17 #include <fcntl.h>
  18 #endif
  19
  20
  21 /* Register any extra external extensions */
  22 char *staticlinkmodules[] = {
  23     "DynaLoader",
  24     NULL,
  25 };
  26
  27 EXTERN_C void boot_DynaLoader (pTHXo_ CV* cv);
  28
  29 static void
  30 xs_init(pTHXo)
  31 {
  32     char *file = __FILE__;
  33     dXSUB_SYS;
  34     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
  35 }
  36
  37 #ifdef PERL_IMPLICIT_SYS
  38 /* IPerlMem */
  39 void*
  40 PerlMemMalloc(struct IPerlMem *I, size_t size)
  41 {
  42     return win32_malloc(size);
  43 }
  44 void*
  45 PerlMemRealloc(struct IPerlMem *I, void* ptr, size_t size)
  46 {
  47     return win32_realloc(ptr, size);
  48 }
  49 void
  50 PerlMemFree(struct IPerlMem *I, void* ptr)
  51 {
  52     win32_free(ptr);
  53 }
  54
  55 struct IPerlMem perlMem =
  56 {
  57     PerlMemMalloc,
  58     PerlMemRealloc,
  59     PerlMemFree,
  60 };
  61
  62
  63 /* IPerlEnv */
  64 extern char *           g_win32_get_privlib(char *pl);
  65 extern char *           g_win32_get_sitelib(char *pl);
  66
  67
  68 char*
  69 PerlEnvGetenv(struct IPerlEnv *I, const char *varname)
  70 {
  71     return win32_getenv(varname);
  72 };
  73 int
  74 PerlEnvPutenv(struct IPerlEnv *I, const char *envstring)
  75 {
  76     return win32_putenv(envstring);
  77 };
  78
  79 char*
  80 PerlEnvGetenv_len(struct IPerlEnv *I, const char* varname, unsigned long* len)
  81 {
  82     char *e = win32_getenv(varname);
  83     if (e)
  84         *len = strlen(e);
  85     return e;
  86 }
  87
  88 int
  89 PerlEnvUname(struct IPerlEnv *I, struct utsname *name)
  90 {
  91     return win32_uname(name);
  92 }
  93
  94 void
  95 PerlEnvClearenv(struct IPerlEnv *I)
  96 {
  97     dTHXo;
  98     char *envv = GetEnvironmentStrings();
  99     char *cur = envv;
 100     STRLEN len;
 101     while (*cur) {
 102         char *end = strchr(cur,'=');
 103         if (end && end != cur) {
 104             *end = '\0';
 105             my_setenv(cur,Nullch);
 106             *end = '=';
 107             cur = end + strlen(end+1)+2;
 108         }
 109         else if ((len = strlen(cur)))
 110             cur += len+1;
 111     }
 112     FreeEnvironmentStrings(envv);
 113 }
 114
 115 void*
 116 PerlEnvGetChildEnv(struct IPerlEnv *I)
 117 {
 118     return NULL;
 119 }
 120
 121 void
 122 PerlEnvFreeChildEnv(struct IPerlEnv *I, void* env)
 123 {
 124 }
 125
 126 char*
 127 PerlEnvGetChildDir(struct IPerlEnv *I)
 128 {
 129     return NULL;
 130 }
 131
 132 void
 133 PerlEnvFreeChildDir(struct IPerlEnv *I, char* dir)
 134 {
 135 }
 136
 137 unsigned long
 138 PerlEnvOsId(struct IPerlEnv *I)
 139 {
 140     return win32_os_id();
 141 }
 142
 143 char*
 144 PerlEnvLibPath(struct IPerlEnv *I, char *pl)
 145 {
 146     return g_win32_get_privlib(pl);
 147 }
 148
 149 char*
 150 PerlEnvSiteLibPath(struct IPerlEnv *I, char *pl)
 151 {
 152     return g_win32_get_sitelib(pl);
 153 }
 154
 155 struct IPerlEnv perlEnv =
 156 {
 157     PerlEnvGetenv,
 158     PerlEnvPutenv,
 159     PerlEnvGetenv_len,
 160     PerlEnvUname,
 161     PerlEnvClearenv,
 162     PerlEnvGetChildEnv,
 163     PerlEnvFreeChildEnv,
 164     PerlEnvGetChildDir,
 165     PerlEnvFreeChildDir,
 166     PerlEnvOsId,
 167     PerlEnvLibPath,
 168     PerlEnvSiteLibPath,
 169 };
 170
 171
 172 /* PerlStdIO */
 173 PerlIO*
 174 PerlStdIOStdin(struct IPerlStdIO *I)
 175 {
 176     return (PerlIO*)win32_stdin();
 177 }
 178
 179 PerlIO*
 180 PerlStdIOStdout(struct IPerlStdIO *I)
 181 {
 182     return (PerlIO*)win32_stdout();
 183 }
 184
 185 PerlIO*
 186 PerlStdIOStderr(struct IPerlStdIO *I)
 187 {
 188     return (PerlIO*)win32_stderr();
 189 }
 190
 191 PerlIO*
 192 PerlStdIOOpen(struct IPerlStdIO *I, const char *path, const char *mode)
 193 {
 194     return (PerlIO*)win32_fopen(path, mode);
 195 }
 196
 197 int
 198 PerlStdIOClose(struct IPerlStdIO *I, PerlIO* pf)
 199 {
 200     return win32_fclose(((FILE*)pf));
 201 }
 202
 203 int
 204 PerlStdIOEof(struct IPerlStdIO *I, PerlIO* pf)
 205 {
 206     return win32_feof((FILE*)pf);
 207 }
 208
 209 int
 210 PerlStdIOError(struct IPerlStdIO *I, PerlIO* pf)
 211 {
 212     return win32_ferror((FILE*)pf);
 213 }
 214
 215 void
 216 PerlStdIOClearerr(struct IPerlStdIO *I, PerlIO* pf)
 217 {
 218     win32_clearerr((FILE*)pf);
 219 }
 220
 221 int
 222 PerlStdIOGetc(struct IPerlStdIO *I, PerlIO* pf)
 223 {
 224     return win32_getc((FILE*)pf);
 225 }
 226
 227 char*
 228 PerlStdIOGetBase(struct IPerlStdIO *I, PerlIO* pf)
 229 {
 230 #ifdef FILE_base
 231     FILE *f = (FILE*)pf;
 232     return FILE_base(f);
 233 #else
 234     return Nullch;
 235 #endif
 236 }
 237
 238 int
 239 PerlStdIOGetBufsiz(struct IPerlStdIO *I, PerlIO* pf)
 240 {
 241 #ifdef FILE_bufsiz
 242     FILE *f = (FILE*)pf;
 243     return FILE_bufsiz(f);
 244 #else
 245     return (-1);
 246 #endif
 247 }
 248
 249 int
 250 PerlStdIOGetCnt(struct IPerlStdIO *I, PerlIO* pf)
 251 {
 252 #ifdef USE_STDIO_PTR
 253     FILE *f = (FILE*)pf;
 254     return FILE_cnt(f);
 255 #else
 256     return (-1);
 257 #endif
 258 }
 259
 260 char*
 261 PerlStdIOGetPtr(struct IPerlStdIO *I, PerlIO* pf)
 262 {
 263 #ifdef USE_STDIO_PTR
 264     FILE *f = (FILE*)pf;
 265     return FILE_ptr(f);
 266 #else
 267     return Nullch;
 268 #endif
 269 }
 270
 271 char*
 272 PerlStdIOGets(struct IPerlStdIO *I, PerlIO* pf, char* s, int n)
 273 {
 274     return win32_fgets(s, n, (FILE*)pf);
 275 }
 276
 277 int
 278 PerlStdIOPutc(struct IPerlStdIO *I, PerlIO* pf, int c)
 279 {
 280     return win32_fputc(c, (FILE*)pf);
 281 }
 282
 283 int
 284 PerlStdIOPuts(struct IPerlStdIO *I, PerlIO* pf, const char *s)
 285 {
 286     return win32_fputs(s, (FILE*)pf);
 287 }
 288
 289 int
 290 PerlStdIOFlush(struct IPerlStdIO *I, PerlIO* pf)
 291 {
 292     return win32_fflush((FILE*)pf);
 293 }
 294
 295 int
 296 PerlStdIOUngetc(struct IPerlStdIO *I, PerlIO* pf,int c)
 297 {
 298     return win32_ungetc(c, (FILE*)pf);
 299 }
 300
 301 int
 302 PerlStdIOFileno(struct IPerlStdIO *I, PerlIO* pf)
 303 {
 304     return win32_fileno((FILE*)pf);
 305 }
 306
 307 PerlIO*
 308 PerlStdIOFdopen(struct IPerlStdIO *I, int fd, const char *mode)
 309 {
 310     return (PerlIO*)win32_fdopen(fd, mode);
 311 }
 312
 313 PerlIO*
 314 PerlStdIOReopen(struct IPerlStdIO *I, const char*path, const char*mode, PerlIO* pf)
 315 {
 316     return (PerlIO*)win32_freopen(path, mode, (FILE*)pf);
 317 }
 318
 319 SSize_t
 320 PerlStdIORead(struct IPerlStdIO *I, PerlIO* pf, void *buffer, Size_t size)
 321 {
 322     return win32_fread(buffer, 1, size, (FILE*)pf);
 323 }
 324
 325 SSize_t
 326 PerlStdIOWrite(struct IPerlStdIO *I, PerlIO* pf, const void *buffer, Size_t size)
 327 {
 328     return win32_fwrite(buffer, 1, size, (FILE*)pf);
 329 }
 330
 331 void
 332 PerlStdIOSetBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer)
 333 {
 334     win32_setbuf((FILE*)pf, buffer);
 335 }
 336
 337 int
 338 PerlStdIOSetVBuf(struct IPerlStdIO *I, PerlIO* pf, char* buffer, int type, Size_t size)
 339 {
 340     return win32_setvbuf((FILE*)pf, buffer, type, size);
 341 }
 342
 343 void
 344 PerlStdIOSetCnt(struct IPerlStdIO *I, PerlIO* pf, int n)
 345 {
 346 #ifdef STDIO_CNT_LVALUE
 347     FILE *f = (FILE*)pf;
 348     FILE_cnt(f) = n;
 349 #endif
 350 }
 351
 352 void
 353 PerlStdIOSetPtrCnt(struct IPerlStdIO *I, PerlIO* pf, char * ptr, int n)
 354 {
 355 #ifdef STDIO_PTR_LVALUE
 356     FILE *f = (FILE*)pf;
 357     FILE_ptr(f) = ptr;
 358     FILE_cnt(f) = n;
 359 #endif
 360 }
 361
 362 void
 363 PerlStdIOSetlinebuf(struct IPerlStdIO *I, PerlIO* pf)
 364 {
 365     win32_setvbuf((FILE*)pf, NULL, _IOLBF, 0);
 366 }
 367
 368 int
 369 PerlStdIOPrintf(struct IPerlStdIO *I, PerlIO* pf, const char *format,...)
 370 {
 371     va_list(arglist);
 372     va_start(arglist, format);
 373     return win32_vfprintf((FILE*)pf, format, arglist);
 374 }
 375
 376 int
 377 PerlStdIOVprintf(struct IPerlStdIO *I, PerlIO* pf, const char *format, va_list arglist)
 378 {
 379     return win32_vfprintf((FILE*)pf, format, arglist);
 380 }
 381
 382 long
 383 PerlStdIOTell(struct IPerlStdIO *I, PerlIO* pf)
 384 {
 385     return win32_ftell((FILE*)pf);
 386 }
 387
 388 int
 389 PerlStdIOSeek(struct IPerlStdIO *I, PerlIO* pf, off_t offset, int origin)
 390 {
 391     return win32_fseek((FILE*)pf, offset, origin);
 392 }
 393
 394 void
 395 PerlStdIORewind(struct IPerlStdIO *I, PerlIO* pf)
 396 {
 397     win32_rewind((FILE*)pf);
 398 }
 399
 400 PerlIO*
 401 PerlStdIOTmpfile(struct IPerlStdIO *I)
 402 {
 403     return (PerlIO*)win32_tmpfile();
 404 }
 405
 406 int
 407 PerlStdIOGetpos(struct IPerlStdIO *I, PerlIO* pf, Fpos_t *p)
 408 {
 409     return win32_fgetpos((FILE*)pf, p);
 410 }
 411
 412 int
 413 PerlStdIOSetpos(struct IPerlStdIO *I, PerlIO* pf, const Fpos_t *p)
 414 {
 415     return win32_fsetpos((FILE*)pf, p);
 416 }
 417 void
 418 PerlStdIOInit(struct IPerlStdIO *I)
 419 {
 420 }
 421
 422 void
 423 PerlStdIOInitOSExtras(struct IPerlStdIO *I)
 424 {
 425     Perl_init_os_extras();
 426 }
 427
 428 int
 429 PerlStdIOOpenOSfhandle(struct IPerlStdIO *I, long osfhandle, int flags)
 430 {
 431     return win32_open_osfhandle(osfhandle, flags);
 432 }
 433
 434 int
 435 PerlStdIOGetOSfhandle(struct IPerlStdIO *I, int filenum)
 436 {
 437     return win32_get_osfhandle(filenum);
 438 }
 439
 440
 441 struct IPerlStdIO perlStdIO =
 442 {
 443     PerlStdIOStdin,
 444     PerlStdIOStdout,
 445     PerlStdIOStderr,
 446     PerlStdIOOpen,
 447     PerlStdIOClose,
 448     PerlStdIOEof,
 449     PerlStdIOError,
 450     PerlStdIOClearerr,
 451     PerlStdIOGetc,
 452     PerlStdIOGetBase,
 453     PerlStdIOGetBufsiz,
 454     PerlStdIOGetCnt,
 455     PerlStdIOGetPtr,
 456     PerlStdIOGets,
 457     PerlStdIOPutc,
 458     PerlStdIOPuts,
 459     PerlStdIOFlush,
 460     PerlStdIOUngetc,
 461     PerlStdIOFileno,
 462     PerlStdIOFdopen,
 463     PerlStdIOReopen,
 464     PerlStdIORead,
 465     PerlStdIOWrite,
 466     PerlStdIOSetBuf,
 467     PerlStdIOSetVBuf,
 468     PerlStdIOSetCnt,
 469     PerlStdIOSetPtrCnt,
 470     PerlStdIOSetlinebuf,
 471     PerlStdIOPrintf,
 472     PerlStdIOVprintf,
 473     PerlStdIOTell,
 474     PerlStdIOSeek,
 475     PerlStdIORewind,
 476     PerlStdIOTmpfile,
 477     PerlStdIOGetpos,
 478     PerlStdIOSetpos,
 479     PerlStdIOInit,
 480     PerlStdIOInitOSExtras,
 481 };
 482
 483
 484 /* IPerlLIO */
 485 int
 486 PerlLIOAccess(struct IPerlLIO *I, const char *path, int mode)
 487 {
 488     return access(path, mode);
 489 }
 490
 491 int
 492 PerlLIOChmod(struct IPerlLIO *I, const char *filename, int pmode)
 493 {
 494     return chmod(filename, pmode);
 495 }
 496
 497 int
 498 PerlLIOChown(struct IPerlLIO *I, const char *filename, uid_t owner, gid_t group)
 499 {
 500     return chown(filename, owner, group);
 501 }
 502
 503 int
 504 PerlLIOChsize(struct IPerlLIO *I, int handle, long size)
 505 {
 506     return chsize(handle, size);
 507 }
 508
 509 int
 510 PerlLIOClose(struct IPerlLIO *I, int handle)
 511 {
 512     return win32_close(handle);
 513 }
 514
 515 int
 516 PerlLIODup(struct IPerlLIO *I, int handle)
 517 {
 518     return win32_dup(handle);
 519 }
 520
 521 int
 522 PerlLIODup2(struct IPerlLIO *I, int handle1, int handle2)
 523 {
 524     return win32_dup2(handle1, handle2);
 525 }
 526
 527 int
 528 PerlLIOFlock(struct IPerlLIO *I, int fd, int oper)
 529 {
 530     return win32_flock(fd, oper);
 531 }
 532
 533 int
 534 PerlLIOFileStat(struct IPerlLIO *I, int handle, struct stat *buffer)
 535 {
 536     return fstat(handle, buffer);
 537 }
 538
 539 int
 540 PerlLIOIOCtl(struct IPerlLIO *I, int i, unsigned int u, char *data)
 541 {
 542     return win32_ioctlsocket((SOCKET)i, (long)u, (u_long*)data);
 543 }
 544
 545 int
 546 PerlLIOIsatty(struct IPerlLIO *I, int fd)
 547 {
 548     return isatty(fd);
 549 }
 550
 551 int
 552 PerlLIOLink(struct IPerlLIO *I, const char*oldname, const char *newname)
 553 {
 554     return win32_link(oldname, newname);
 555 }
 556
 557 long
 558 PerlLIOLseek(struct IPerlLIO *I, int handle, long offset, int origin)
 559 {
 560     return win32_lseek(handle, offset, origin);
 561 }
 562
 563 int
 564 PerlLIOLstat(struct IPerlLIO* p, const char *path, struct stat *buffer)
 565 {
 566     return win32_stat(path, buffer);
 567 }
 568
 569 char*
 570 PerlLIOMktemp(struct IPerlLIO *I, char *Template)
 571 {
 572     return mktemp(Template);
 573 }
 574
 575 int
 576 PerlLIOOpen(struct IPerlLIO *I, const char *filename, int oflag)
 577 {
 578     return win32_open(filename, oflag);
 579 }
 580
 581 int
 582 PerlLIOOpen3(struct IPerlLIO *I, const char *filename, int oflag, int pmode)
 583 {
 584     int ret;
 585     if(stricmp(filename, "/dev/null") == 0)
 586         ret = open("NUL", oflag, pmode);
 587     else
 588         ret = open(filename, oflag, pmode);
 589
 590     return ret;
 591 }
 592
 593 int
 594 PerlLIORead(struct IPerlLIO *I, int handle, void *buffer, unsigned int count)
 595 {
 596     return win32_read(handle, buffer, count);
 597 }
 598
 599 int
 600 PerlLIORename(struct IPerlLIO *I, const char *OldFileName, const char *newname)
 601 {
 602     return win32_rename(OldFileName, newname);
 603 }
 604
 605 int
 606 PerlLIOSetmode(struct IPerlLIO *I, int handle, int mode)
 607 {
 608     return win32_setmode(handle, mode);
 609 }
 610
 611 int
 612 PerlLIONameStat(struct IPerlLIO *I, const char *path, struct stat *buffer)
 613 {
 614     return win32_stat(path, buffer);
 615 }
 616
 617 char*
 618 PerlLIOTmpnam(struct IPerlLIO *I, char *string)
 619 {
 620     return tmpnam(string);
 621 }
 622
 623 int
 624 PerlLIOUmask(struct IPerlLIO *I, int pmode)
 625 {
 626     return umask(pmode);
 627 }
 628
 629 int
 630 PerlLIOUnlink(struct IPerlLIO *I, const char *filename)
 631 {
 632     chmod(filename, S_IREAD | S_IWRITE);
 633     return unlink(filename);
 634 }
 635
 636 int
 637 PerlLIOUtime(struct IPerlLIO *I, char *filename, struct utimbuf *times)
 638 {
 639     return win32_utime(filename, times);
 640 }
 641
 642 int
 643 PerlLIOWrite(struct IPerlLIO *I, int handle, const void *buffer, unsigned int count)
 644 {
 645     return win32_write(handle, buffer, count);
 646 }
 647
 648 struct IPerlLIO perlLIO =
 649 {
 650     PerlLIOAccess,
 651     PerlLIOChmod,
 652     PerlLIOChown,
 653     PerlLIOChsize,
 654     PerlLIOClose,
 655     PerlLIODup,
 656     PerlLIODup2,
 657     PerlLIOFlock,
 658     PerlLIOFileStat,
 659     PerlLIOIOCtl,
 660     PerlLIOIsatty,
 661     PerlLIOLink,
 662     PerlLIOLseek,
 663     PerlLIOLstat,
 664     PerlLIOMktemp,
 665     PerlLIOOpen,
 666     PerlLIOOpen3,
 667     PerlLIORead,
 668     PerlLIORename,
 669     PerlLIOSetmode,
 670     PerlLIONameStat,
 671     PerlLIOTmpnam,
 672     PerlLIOUmask,
 673     PerlLIOUnlink,
 674     PerlLIOUtime,
 675     PerlLIOWrite,
 676 };
 677
 678 /* IPerlDIR */
 679 int
 680 PerlDirMakedir(struct IPerlDir *I, const char *dirname, int mode)
 681 {
 682     return win32_mkdir(dirname, mode);
 683 }
 684
 685 int
 686 PerlDirChdir(struct IPerlDir *I, const char *dirname)
 687 {
 688     return win32_chdir(dirname);
 689 }
 690
 691 int
 692 PerlDirRmdir(struct IPerlDir *I, const char *dirname)
 693 {
 694     return win32_rmdir(dirname);
 695 }
 696
 697 int
 698 PerlDirClose(struct IPerlDir *I, DIR *dirp)
 699 {
 700     return win32_closedir(dirp);
 701 }
 702
 703 DIR*
 704 PerlDirOpen(struct IPerlDir *I, char *filename)
 705 {
 706     return win32_opendir(filename);
 707 }
 708
 709 struct direct *
 710 PerlDirRead(struct IPerlDir *I, DIR *dirp)
 711 {
 712     return win32_readdir(dirp);
 713 }
 714
 715 void
 716 PerlDirRewind(struct IPerlDir *I, DIR *dirp)
 717 {
 718     win32_rewinddir(dirp);
 719 }
 720
 721 void
 722 PerlDirSeek(struct IPerlDir *I, DIR *dirp, long loc)
 723 {
 724     win32_seekdir(dirp, loc);
 725 }
 726
 727 long
 728 PerlDirTell(struct IPerlDir *I, DIR *dirp)
 729 {
 730     return win32_telldir(dirp);
 731 }
 732
 733 struct IPerlDir perlDir =
 734 {
 735     PerlDirMakedir,
 736     PerlDirChdir,
 737     PerlDirRmdir,
 738     PerlDirClose,
 739     PerlDirOpen,
 740     PerlDirRead,
 741     PerlDirRewind,
 742     PerlDirSeek,
 743     PerlDirTell,
 744 };
 745
 746
 747 /* IPerlSock */
 748 u_long
 749 PerlSockHtonl(struct IPerlSock *I, u_long hostlong)
 750 {
 751     return win32_htonl(hostlong);
 752 }
 753
 754 u_short
 755 PerlSockHtons(struct IPerlSock *I, u_short hostshort)
 756 {
 757     return win32_htons(hostshort);
 758 }
 759
 760 u_long
 761 PerlSockNtohl(struct IPerlSock *I, u_long netlong)
 762 {
 763     return win32_ntohl(netlong);
 764 }
 765
 766 u_short
 767 PerlSockNtohs(struct IPerlSock *I, u_short netshort)
 768 {
 769     return win32_ntohs(netshort);
 770 }
 771
 772 SOCKET PerlSockAccept(struct IPerlSock *I, SOCKET s, struct sockaddr* addr, int* addrlen)
 773 {
 774     return win32_accept(s, addr, addrlen);
 775 }
 776
 777 int
 778 PerlSockBind(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
 779 {
 780     return win32_bind(s, name, namelen);
 781 }
 782
 783 int
 784 PerlSockConnect(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
 785 {
 786     return win32_connect(s, name, namelen);
 787 }
 788
 789 void
 790 PerlSockEndhostent(struct IPerlSock *I)
 791 {
 792     win32_endhostent();
 793 }
 794
 795 void
 796 PerlSockEndnetent(struct IPerlSock *I)
 797 {
 798     win32_endnetent();
 799 }
 800
 801 void
 802 PerlSockEndprotoent(struct IPerlSock *I)
 803 {
 804     win32_endprotoent();
 805 }
 806
 807 void
 808 PerlSockEndservent(struct IPerlSock *I)
 809 {
 810     win32_endservent();
 811 }
 812
 813 struct hostent*
 814 PerlSockGethostbyaddr(struct IPerlSock *I, const char* addr, int len, int type)
 815 {
 816     return win32_gethostbyaddr(addr, len, type);
 817 }
 818
 819 struct hostent*
 820 PerlSockGethostbyname(struct IPerlSock *I, const char* name)
 821 {
 822     return win32_gethostbyname(name);
 823 }
 824
 825 struct hostent*
 826 PerlSockGethostent(struct IPerlSock *I)
 827 {
 828     dTHXo;
 829     Perl_croak(aTHX_ "gethostent not implemented!\n");
 830     return NULL;
 831 }
 832
 833 int
 834 PerlSockGethostname(struct IPerlSock *I, char* name, int namelen)
 835 {
 836     return win32_gethostname(name, namelen);
 837 }
 838
 839 struct netent *
 840 PerlSockGetnetbyaddr(struct IPerlSock *I, long net, int type)
 841 {
 842     return win32_getnetbyaddr(net, type);
 843 }
 844
 845 struct netent *
 846 PerlSockGetnetbyname(struct IPerlSock *I, const char *name)
 847 {
 848     return win32_getnetbyname((char*)name);
 849 }
 850
 851 struct netent *
 852 PerlSockGetnetent(struct IPerlSock *I)
 853 {
 854     return win32_getnetent();
 855 }
 856
 857 int PerlSockGetpeername(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
 858 {
 859     return win32_getpeername(s, name, namelen);
 860 }
 861
 862 struct protoent*
 863 PerlSockGetprotobyname(struct IPerlSock *I, const char* name)
 864 {
 865     return win32_getprotobyname(name);
 866 }
 867
 868 struct protoent*
 869 PerlSockGetprotobynumber(struct IPerlSock *I, int number)
 870 {
 871     return win32_getprotobynumber(number);
 872 }
 873
 874 struct protoent*
 875 PerlSockGetprotoent(struct IPerlSock *I)
 876 {
 877     return win32_getprotoent();
 878 }
 879
 880 struct servent*
 881 PerlSockGetservbyname(struct IPerlSock *I, const char* name, const char* proto)
 882 {
 883     return win32_getservbyname(name, proto);
 884 }
 885
 886 struct servent*
 887 PerlSockGetservbyport(struct IPerlSock *I, int port, const char* proto)
 888 {
 889     return win32_getservbyport(port, proto);
 890 }
 891
 892 struct servent*
 893 PerlSockGetservent(struct IPerlSock *I)
 894 {
 895     return win32_getservent();
 896 }
 897
 898 int
 899 PerlSockGetsockname(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
 900 {
 901     return win32_getsockname(s, name, namelen);
 902 }
 903
 904 int
 905 PerlSockGetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, char* optval, int* optlen)
 906 {
 907     return win32_getsockopt(s, level, optname, optval, optlen);
 908 }
 909
 910 unsigned long
 911 PerlSockInetAddr(struct IPerlSock *I, const char* cp)
 912 {
 913     return win32_inet_addr(cp);
 914 }
 915
 916 char*
 917 PerlSockInetNtoa(struct IPerlSock *I, struct in_addr in)
 918 {
 919     return win32_inet_ntoa(in);
 920 }
 921
 922 int
 923 PerlSockListen(struct IPerlSock *I, SOCKET s, int backlog)
 924 {
 925     return win32_listen(s, backlog);
 926 }
 927
 928 int
 929 PerlSockRecv(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags)
 930 {
 931     return win32_recv(s, buffer, len, flags);
 932 }
 933
 934 int
 935 PerlSockRecvfrom(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
 936 {
 937     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
 938 }
 939
 940 int
 941 PerlSockSelect(struct IPerlSock *I, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
 942 {
 943     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
 944 }
 945
 946 int
 947 PerlSockSend(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags)
 948 {
 949     return win32_send(s, buffer, len, flags);
 950 }
 951
 952 int
 953 PerlSockSendto(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
 954 {
 955     return win32_sendto(s, buffer, len, flags, to, tolen);
 956 }
 957
 958 void
 959 PerlSockSethostent(struct IPerlSock *I, int stayopen)
 960 {
 961     win32_sethostent(stayopen);
 962 }
 963
 964 void
 965 PerlSockSetnetent(struct IPerlSock *I, int stayopen)
 966 {
 967     win32_setnetent(stayopen);
 968 }
 969
 970 void
 971 PerlSockSetprotoent(struct IPerlSock *I, int stayopen)
 972 {
 973     win32_setprotoent(stayopen);
 974 }
 975
 976 void
 977 PerlSockSetservent(struct IPerlSock *I, int stayopen)
 978 {
 979     win32_setservent(stayopen);
 980 }
 981
 982 int
 983 PerlSockSetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, const char* optval, int optlen)
 984 {
 985     return win32_setsockopt(s, level, optname, optval, optlen);
 986 }
 987
 988 int
 989 PerlSockShutdown(struct IPerlSock *I, SOCKET s, int how)
 990 {
 991     return win32_shutdown(s, how);
 992 }
 993
 994 SOCKET
 995 PerlSockSocket(struct IPerlSock *I, int af, int type, int protocol)
 996 {
 997     return win32_socket(af, type, protocol);
 998 }
 999
1000 int
1001 PerlSockSocketpair(struct IPerlSock *I, int domain, int type, int protocol, int* fds)
1002 {
1003     dTHXo;
1004     Perl_croak(aTHX_ "socketpair not implemented!\n");
1005     return 0;
1006 }
1007
1008 int
1009 PerlSockClosesocket(struct IPerlSock *I, SOCKET s)
1010 {
1011     return win32_closesocket(s);
1012 }
1013
1014 int
1015 PerlSockIoctlsocket(struct IPerlSock *I, SOCKET s, long cmd, u_long *argp)
1016 {
1017     return win32_ioctlsocket(s, cmd, argp);
1018 }
1019
1020 struct IPerlSock perlSock =
1021 {
1022     PerlSockHtonl,
1023     PerlSockHtons,
1024     PerlSockNtohl,
1025     PerlSockNtohs,
1026     PerlSockAccept,
1027     PerlSockBind,
1028     PerlSockConnect,
1029     PerlSockEndhostent,
1030     PerlSockEndnetent,
1031     PerlSockEndprotoent,
1032     PerlSockEndservent,
1033     PerlSockGethostname,
1034     PerlSockGetpeername,
1035     PerlSockGethostbyaddr,
1036     PerlSockGethostbyname,
1037     PerlSockGethostent,
1038     PerlSockGetnetbyaddr,
1039     PerlSockGetnetbyname,
1040     PerlSockGetnetent,
1041     PerlSockGetprotobyname,
1042     PerlSockGetprotobynumber,
1043     PerlSockGetprotoent,
1044     PerlSockGetservbyname,
1045     PerlSockGetservbyport,
1046     PerlSockGetservent,
1047     PerlSockGetsockname,
1048     PerlSockGetsockopt,
1049     PerlSockInetAddr,
1050     PerlSockInetNtoa,
1051     PerlSockListen,
1052     PerlSockRecv,
1053     PerlSockRecvfrom,
1054     PerlSockSelect,
1055     PerlSockSend,
1056     PerlSockSendto,
1057     PerlSockSethostent,
1058     PerlSockSetnetent,
1059     PerlSockSetprotoent,
1060     PerlSockSetservent,
1061     PerlSockSetsockopt,
1062     PerlSockShutdown,
1063     PerlSockSocket,
1064     PerlSockSocketpair,
1065     PerlSockClosesocket,
1066 };
1067
1068
1069 /* IPerlProc */
1070
1071 #define EXECF_EXEC 1
1072 #define EXECF_SPAWN 2
1073
1074 extern char *           g_getlogin(void);
1075 extern int              do_spawn2(char *cmd, int exectype);
1076 #ifdef PERL_OBJECT
1077 extern int              g_do_aspawn(void *vreally, void **vmark, void **vsp);
1078 #define do_aspawn g_do_aspawn
1079 #endif
1080 EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
1081                         struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
1082                         struct IPerlLIO* pLIO, struct IPerlDir* pDir,
1083                         struct IPerlSock* pSock, struct IPerlProc* pProc);
1084
1085 void
1086 PerlProcAbort(struct IPerlProc *I)
1087 {
1088     win32_abort();
1089 }
1090
1091 char *
1092 PerlProcCrypt(struct IPerlProc *I, const char* clear, const char* salt)
1093 {
1094     return win32_crypt(clear, salt);
1095 }
1096
1097 void
1098 PerlProcExit(struct IPerlProc *I, int status)
1099 {
1100     exit(status);
1101 }
1102
1103 void
1104 PerlProc_Exit(struct IPerlProc *I, int status)
1105 {
1106     _exit(status);
1107 }
1108
1109 int
1110 PerlProcExecl(struct IPerlProc *I, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1111 {
1112     return execl(cmdname, arg0, arg1, arg2, arg3);
1113 }
1114
1115 int
1116 PerlProcExecv(struct IPerlProc *I, const char *cmdname, const char *const *argv)
1117 {
1118     return win32_execvp(cmdname, argv);
1119 }
1120
1121 int
1122 PerlProcExecvp(struct IPerlProc *I, const char *cmdname, const char *const *argv)
1123 {
1124     return win32_execvp(cmdname, argv);
1125 }
1126
1127 uid_t
1128 PerlProcGetuid(struct IPerlProc *I)
1129 {
1130     return getuid();
1131 }
1132
1133 uid_t
1134 PerlProcGeteuid(struct IPerlProc *I)
1135 {
1136     return geteuid();
1137 }
1138
1139 gid_t
1140 PerlProcGetgid(struct IPerlProc *I)
1141 {
1142     return getgid();
1143 }
1144
1145 gid_t
1146 PerlProcGetegid(struct IPerlProc *I)
1147 {
1148     return getegid();
1149 }
1150
1151 char *
1152 PerlProcGetlogin(struct IPerlProc *I)
1153 {
1154     return g_getlogin();
1155 }
1156
1157 int
1158 PerlProcKill(struct IPerlProc *I, int pid, int sig)
1159 {
1160     return win32_kill(pid, sig);
1161 }
1162
1163 int
1164 PerlProcKillpg(struct IPerlProc *I, int pid, int sig)
1165 {
1166     dTHXo;
1167     Perl_croak(aTHX_ "killpg not implemented!\n");
1168     return 0;
1169 }
1170
1171 int
1172 PerlProcPauseProc(struct IPerlProc *I)
1173 {
1174     return win32_sleep((32767L << 16) + 32767);
1175 }
1176
1177 PerlIO*
1178 PerlProcPopen(struct IPerlProc *I, const char *command, const char *mode)
1179 {
1180     dTHXo;
1181     PERL_FLUSHALL_FOR_CHILD;
1182     return (PerlIO*)win32_popen(command, mode);
1183 }
1184
1185 int
1186 PerlProcPclose(struct IPerlProc *I, PerlIO *stream)
1187 {
1188     return win32_pclose((FILE*)stream);
1189 }
1190
1191 int
1192 PerlProcPipe(struct IPerlProc *I, int *phandles)
1193 {
1194     return win32_pipe(phandles, 512, O_BINARY);
1195 }
1196
1197 int
1198 PerlProcSetuid(struct IPerlProc *I, uid_t u)
1199 {
1200     return setuid(u);
1201 }
1202
1203 int
1204 PerlProcSetgid(struct IPerlProc *I, gid_t g)
1205 {
1206     return setgid(g);
1207 }
1208
1209 int
1210 PerlProcSleep(struct IPerlProc *I, unsigned int s)
1211 {
1212     return win32_sleep(s);
1213 }
1214
1215 int
1216 PerlProcTimes(struct IPerlProc *I, struct tms *timebuf)
1217 {
1218     return win32_times(timebuf);
1219 }
1220
1221 int
1222 PerlProcWait(struct IPerlProc *I, int *status)
1223 {
1224     return win32_wait(status);
1225 }
1226
1227 int
1228 PerlProcWaitpid(struct IPerlProc *I, int pid, int *status, int flags)
1229 {
1230     return win32_waitpid(pid, status, flags);
1231 }
1232
1233 Sighandler_t
1234 PerlProcSignal(struct IPerlProc *I, int sig, Sighandler_t subcode)
1235 {
1236     return 0;
1237 }
1238
1239 void*
1240 PerlProcDynaLoader(struct IPerlProc *I, const char* filename)
1241 {
1242     return win32_dynaload(filename);
1243 }
1244
1245 void
1246 PerlProcGetOSError(struct IPerlProc *I, SV* sv, DWORD dwErr)
1247 {
1248     win32_str_os_error(sv, dwErr);
1249 }
1250
1251 BOOL
1252 PerlProcDoCmd(struct IPerlProc *I, char *cmd)
1253 {
1254     do_spawn2(cmd, EXECF_EXEC);
1255     return FALSE;
1256 }
1257
1258 int
1259 PerlProcSpawn(struct IPerlProc *I, char* cmds)
1260 {
1261     return do_spawn2(cmds, EXECF_SPAWN);
1262 }
1263
1264 int
1265 PerlProcSpawnvp(struct IPerlProc *I, int mode, const char *cmdname, const char *const *argv)
1266 {
1267     return win32_spawnvp(mode, cmdname, argv);
1268 }
1269
1270 int
1271 PerlProcASpawn(struct IPerlProc *I, void *vreally, void **vmark, void **vsp)
1272 {
1273     return do_aspawn(vreally, vmark, vsp);
1274 }
1275
1276 struct IPerlProc perlProc =
1277 {
1278     PerlProcAbort,
1279     PerlProcCrypt,
1280     PerlProcExit,
1281     PerlProc_Exit,
1282     PerlProcExecl,
1283     PerlProcExecv,
1284     PerlProcExecvp,
1285     PerlProcGetuid,
1286     PerlProcGeteuid,
1287     PerlProcGetgid,
1288     PerlProcGetegid,
1289     PerlProcGetlogin,
1290     PerlProcKill,
1291     PerlProcKillpg,
1292     PerlProcPauseProc,
1293     PerlProcPopen,
1294     PerlProcPclose,
1295     PerlProcPipe,
1296     PerlProcSetuid,
1297     PerlProcSetgid,
1298     PerlProcSleep,
1299     PerlProcTimes,
1300     PerlProcWait,
1301     PerlProcWaitpid,
1302     PerlProcSignal,
1303     PerlProcDynaLoader,
1304     PerlProcGetOSError,
1305     PerlProcDoCmd,
1306     PerlProcSpawn,
1307     PerlProcSpawnvp,
1308     PerlProcASpawn,
1309 };
1310
1311 /*#include "perlhost.h" */
1312
1313
1314 EXTERN_C void
1315 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
1316                    struct IPerlEnvInfo* perlEnvInfo,
1317                    struct IPerlStdIOInfo* perlStdIOInfo,
1318                    struct IPerlLIOInfo* perlLIOInfo,
1319                    struct IPerlDirInfo* perlDirInfo,
1320                    struct IPerlSockInfo* perlSockInfo,
1321                    struct IPerlProcInfo* perlProcInfo)
1322 {
1323     if(perlMemInfo) {
1324         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
1325         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
1326     }
1327     if(perlEnvInfo) {
1328         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
1329         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
1330     }
1331     if(perlStdIOInfo) {
1332         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
1333         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
1334     }
1335     if(perlLIOInfo) {
1336         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
1337         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
1338     }
1339     if(perlDirInfo) {
1340         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
1341         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
1342     }
1343     if(perlSockInfo) {
1344         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
1345         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
1346     }
1347     if(perlProcInfo) {
1348         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
1349         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
1350     }
1351 }
1352
1353 #ifdef PERL_OBJECT
1354
1355 EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
1356                         struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
1357                         struct IPerlLIO* pLIO, struct IPerlDir* pDir,
1358                         struct IPerlSock* pSock, struct IPerlProc* pProc)
1359 {
1360     CPerlObj* pPerl = NULL;
1361     try
1362     {
1363         pPerl = Perl_alloc(pMem, pEnv, pStdIO, pLIO, pDir, pSock, pProc);
1364     }
1365     catch(...)
1366     {
1367         win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
1368         pPerl = NULL;
1369     }
1370     if(pPerl)
1371     {
1372         SetPerlInterpreter(pPerl);
1373         return (PerlInterpreter*)pPerl;
1374     }
1375     SetPerlInterpreter(NULL);
1376     return NULL;
1377 }
1378
1379 #undef perl_alloc
1380 #undef perl_construct
1381 #undef perl_destruct
1382 #undef perl_free
1383 #undef perl_run
1384 #undef perl_parse
1385 EXTERN_C PerlInterpreter* perl_alloc(void)
1386 {
1387     CPerlObj* pPerl = NULL;
1388     try
1389     {
1390         pPerl = Perl_alloc(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
1391                            &perlDir, &perlSock, &perlProc);
1392     }
1393     catch(...)
1394     {
1395         win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
1396         pPerl = NULL;
1397     }
1398     if(pPerl)
1399     {
1400         SetPerlInterpreter(pPerl);
1401         return (PerlInterpreter*)pPerl;
1402     }
1403     SetPerlInterpreter(NULL);
1404     return NULL;
1405 }
1406
1407 EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
1408 {
1409     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1410     try
1411     {
1412         pPerl->perl_construct();
1413     }
1414     catch(...)
1415     {
1416         win32_fprintf(stderr, "%s\n",
1417                       "Error: Unable to construct data structures");
1418         pPerl->perl_free();
1419         SetPerlInterpreter(NULL);
1420     }
1421 }
1422
1423 EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
1424 {
1425     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1426     try
1427     {
1428         pPerl->perl_destruct();
1429     }
1430     catch(...)
1431     {
1432     }
1433 }
1434
1435 EXTERN_C void perl_free(PerlInterpreter* sv_interp)
1436 {
1437     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1438     try
1439     {
1440         pPerl->perl_free();
1441     }
1442     catch(...)
1443     {
1444     }
1445     SetPerlInterpreter(NULL);
1446 }
1447
1448 EXTERN_C int perl_run(PerlInterpreter* sv_interp)
1449 {
1450     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1451     int retVal;
1452     try
1453     {
1454         retVal = pPerl->perl_run();
1455     }
1456 /*
1457     catch(int x)
1458     {
1459         // this is where exit() should arrive
1460         retVal = x;
1461     }
1462 */
1463     catch(...)
1464     {
1465         win32_fprintf(stderr, "Error: Runtime exception\n");
1466         retVal = -1;
1467     }
1468     return retVal;
1469 }
1470
1471 EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
1472 {
1473     int retVal;
1474     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1475     try
1476     {
1477         retVal = pPerl->perl_parse(xsinit, argc, argv, env);
1478     }
1479 /*
1480     catch(int x)
1481     {
1482         // this is where exit() should arrive
1483         retVal = x;
1484     }
1485 */
1486     catch(...)
1487     {
1488         win32_fprintf(stderr, "Error: Parse exception\n");
1489         retVal = -1;
1490     }
1491     *win32_errno() = 0;
1492     return retVal;
1493 }
1494
1495 #undef PL_perl_destruct_level
1496 #define PL_perl_destruct_level int dummy
1497
1498 #else /* !PERL_OBJECT */
1499
1500 EXTERN_C PerlInterpreter*
1501 perl_alloc(void)
1502 {
1503     return perl_alloc_using(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
1504                            &perlDir, &perlSock, &perlProc);
1505 }
1506
1507 #endif /* PERL_OBJECT */
1508
1509 #endif /* PERL_IMPLICIT_SYS */
1510
1511 extern HANDLE w32_perldll_handle;
1512 static DWORD g_TlsAllocIndex;
1513
1514 EXTERN_C DllExport bool
1515 SetPerlInterpreter(void *interp)
1516 {
1517     return TlsSetValue(g_TlsAllocIndex, interp);
1518 }
1519
1520 EXTERN_C DllExport void*
1521 GetPerlInterpreter(void)
1522 {
1523     return TlsGetValue(g_TlsAllocIndex);
1524 }
1525
1526 EXTERN_C DllExport int
1527 RunPerl(int argc, char **argv, char **env)
1528 {
1529     int exitstatus;
1530     PerlInterpreter *my_perl, *new_perl = NULL;
1531     struct perl_thread *thr;
1532
1533 #ifndef __BORLANDC__
1534     /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
1535      * want to free() argv after main() returns.  As luck would have it,
1536      * Borland's CRT does the right thing to argv[0] already. */
1537     char szModuleName[MAX_PATH];
1538     char *ptr;
1539
1540     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
1541     (void)win32_longpath(szModuleName);
1542     argv[0] = szModuleName;
1543 #endif
1544
1545 #ifdef PERL_GLOBAL_STRUCT
1546 #define PERLVAR(var,type) /**/
1547 #define PERLVARA(var,type) /**/
1548 #define PERLVARI(var,type,init) PL_Vars.var = init;
1549 #define PERLVARIC(var,type,init) PL_Vars.var = init;
1550 #include "perlvars.h"
1551 #undef PERLVAR
1552 #undef PERLVARA
1553 #undef PERLVARI
1554 #undef PERLVARIC
1555 #endif
1556
1557     PERL_SYS_INIT(&argc,&argv);
1558
1559     if (!(my_perl = perl_alloc()))
1560         return (1);
1561     perl_construct( my_perl );
1562     PL_perl_destruct_level = 0;
1563
1564     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
1565     if (!exitstatus) {
1566 #ifdef USE_ITHREADS             /* XXXXXX testing */
1567         new_perl = perl_clone(my_perl, 0);
1568         Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */
1569         exitstatus = perl_run( new_perl );
1570         SetPerlInterpreter(my_perl);
1571 #else
1572         exitstatus = perl_run( my_perl );
1573 #endif
1574     }
1575
1576     perl_destruct( my_perl );
1577     perl_free( my_perl );
1578 #ifdef USE_ITHREADS
1579     if (new_perl) {
1580         SetPerlInterpreter(new_perl);
1581         perl_destruct(new_perl);
1582         perl_free(new_perl);
1583     }
1584 #endif
1585
1586     PERL_SYS_TERM();
1587
1588     return (exitstatus);
1589 }
1590
1591 BOOL APIENTRY
1592 DllMain(HANDLE hModule,         /* DLL module handle */
1593         DWORD fdwReason,        /* reason called */
1594         LPVOID lpvReserved)     /* reserved */
1595 {
1596     switch (fdwReason) {
1597         /* The DLL is attaching to a process due to process
1598          * initialization or a call to LoadLibrary.
1599          */
1600     case DLL_PROCESS_ATTACH:
1601 /* #define DEFAULT_BINMODE */
1602 #ifdef DEFAULT_BINMODE
1603         setmode( fileno( stdin  ), O_BINARY );
1604         setmode( fileno( stdout ), O_BINARY );
1605         setmode( fileno( stderr ), O_BINARY );
1606         _fmode = O_BINARY;
1607 #endif
1608         g_TlsAllocIndex = TlsAlloc();
1609         DisableThreadLibraryCalls(hModule);
1610         w32_perldll_handle = hModule;
1611         break;
1612
1613         /* The DLL is detaching from a process due to
1614          * process termination or call to FreeLibrary.
1615          */
1616     case DLL_PROCESS_DETACH:
1617         TlsFree(g_TlsAllocIndex);
1618         break;
1619
1620         /* The attached process creates a new thread. */
1621     case DLL_THREAD_ATTACH:
1622         break;
1623
1624         /* The thread of the attached process terminates. */
1625     case DLL_THREAD_DETACH:
1626         break;
1627
1628     default:
1629         break;
1630     }
1631     return TRUE;
1632 }
1633