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 long
 552 PerlLIOLseek(struct IPerlLIO *I, int handle, long offset, int origin)
 553 {
 554     return win32_lseek(handle, offset, origin);
 555 }
 556
 557 int
 558 PerlLIOLstat(struct IPerlLIO* p, const char *path, struct stat *buffer)
 559 {
 560     return win32_stat(path, buffer);
 561 }
 562
 563 char*
 564 PerlLIOMktemp(struct IPerlLIO *I, char *Template)
 565 {
 566     return mktemp(Template);
 567 }
 568
 569 int
 570 PerlLIOOpen(struct IPerlLIO *I, const char *filename, int oflag)
 571 {
 572     return win32_open(filename, oflag);
 573 }
 574
 575 int
 576 PerlLIOOpen3(struct IPerlLIO *I, const char *filename, int oflag, int pmode)
 577 {
 578     int ret;
 579     if(stricmp(filename, "/dev/null") == 0)
 580         ret = open("NUL", oflag, pmode);
 581     else
 582         ret = open(filename, oflag, pmode);
 583
 584     return ret;
 585 }
 586
 587 int
 588 PerlLIORead(struct IPerlLIO *I, int handle, void *buffer, unsigned int count)
 589 {
 590     return win32_read(handle, buffer, count);
 591 }
 592
 593 int
 594 PerlLIORename(struct IPerlLIO *I, const char *OldFileName, const char *newname)
 595 {
 596     return win32_rename(OldFileName, newname);
 597 }
 598
 599 int
 600 PerlLIOSetmode(struct IPerlLIO *I, int handle, int mode)
 601 {
 602     return win32_setmode(handle, mode);
 603 }
 604
 605 int
 606 PerlLIONameStat(struct IPerlLIO *I, const char *path, struct stat *buffer)
 607 {
 608     return win32_stat(path, buffer);
 609 }
 610
 611 char*
 612 PerlLIOTmpnam(struct IPerlLIO *I, char *string)
 613 {
 614     return tmpnam(string);
 615 }
 616
 617 int
 618 PerlLIOUmask(struct IPerlLIO *I, int pmode)
 619 {
 620     return umask(pmode);
 621 }
 622
 623 int
 624 PerlLIOUnlink(struct IPerlLIO *I, const char *filename)
 625 {
 626     chmod(filename, S_IREAD | S_IWRITE);
 627     return unlink(filename);
 628 }
 629
 630 int
 631 PerlLIOUtime(struct IPerlLIO *I, char *filename, struct utimbuf *times)
 632 {
 633     return win32_utime(filename, times);
 634 }
 635
 636 int
 637 PerlLIOWrite(struct IPerlLIO *I, int handle, const void *buffer, unsigned int count)
 638 {
 639     return win32_write(handle, buffer, count);
 640 }
 641
 642 struct IPerlLIO perlLIO =
 643 {
 644     PerlLIOAccess,
 645     PerlLIOChmod,
 646     PerlLIOChown,
 647     PerlLIOChsize,
 648     PerlLIOClose,
 649     PerlLIODup,
 650     PerlLIODup2,
 651     PerlLIOFlock,
 652     PerlLIOFileStat,
 653     PerlLIOIOCtl,
 654     PerlLIOIsatty,
 655     PerlLIOLseek,
 656     PerlLIOLstat,
 657     PerlLIOMktemp,
 658     PerlLIOOpen,
 659     PerlLIOOpen3,
 660     PerlLIORead,
 661     PerlLIORename,
 662     PerlLIOSetmode,
 663     PerlLIONameStat,
 664     PerlLIOTmpnam,
 665     PerlLIOUmask,
 666     PerlLIOUnlink,
 667     PerlLIOUtime,
 668     PerlLIOWrite,
 669 };
 670
 671 /* IPerlDIR */
 672 int
 673 PerlDirMakedir(struct IPerlDir *I, const char *dirname, int mode)
 674 {
 675     return win32_mkdir(dirname, mode);
 676 }
 677
 678 int
 679 PerlDirChdir(struct IPerlDir *I, const char *dirname)
 680 {
 681     return win32_chdir(dirname);
 682 }
 683
 684 int
 685 PerlDirRmdir(struct IPerlDir *I, const char *dirname)
 686 {
 687     return win32_rmdir(dirname);
 688 }
 689
 690 int
 691 PerlDirClose(struct IPerlDir *I, DIR *dirp)
 692 {
 693     return win32_closedir(dirp);
 694 }
 695
 696 DIR*
 697 PerlDirOpen(struct IPerlDir *I, char *filename)
 698 {
 699     return win32_opendir(filename);
 700 }
 701
 702 struct direct *
 703 PerlDirRead(struct IPerlDir *I, DIR *dirp)
 704 {
 705     return win32_readdir(dirp);
 706 }
 707
 708 void
 709 PerlDirRewind(struct IPerlDir *I, DIR *dirp)
 710 {
 711     win32_rewinddir(dirp);
 712 }
 713
 714 void
 715 PerlDirSeek(struct IPerlDir *I, DIR *dirp, long loc)
 716 {
 717     win32_seekdir(dirp, loc);
 718 }
 719
 720 long
 721 PerlDirTell(struct IPerlDir *I, DIR *dirp)
 722 {
 723     return win32_telldir(dirp);
 724 }
 725
 726 struct IPerlDir perlDir =
 727 {
 728     PerlDirMakedir,
 729     PerlDirChdir,
 730     PerlDirRmdir,
 731     PerlDirClose,
 732     PerlDirOpen,
 733     PerlDirRead,
 734     PerlDirRewind,
 735     PerlDirSeek,
 736     PerlDirTell,
 737 };
 738
 739
 740 /* IPerlSock */
 741 u_long
 742 PerlSockHtonl(struct IPerlSock *I, u_long hostlong)
 743 {
 744     return win32_htonl(hostlong);
 745 }
 746
 747 u_short
 748 PerlSockHtons(struct IPerlSock *I, u_short hostshort)
 749 {
 750     return win32_htons(hostshort);
 751 }
 752
 753 u_long
 754 PerlSockNtohl(struct IPerlSock *I, u_long netlong)
 755 {
 756     return win32_ntohl(netlong);
 757 }
 758
 759 u_short
 760 PerlSockNtohs(struct IPerlSock *I, u_short netshort)
 761 {
 762     return win32_ntohs(netshort);
 763 }
 764
 765 SOCKET PerlSockAccept(struct IPerlSock *I, SOCKET s, struct sockaddr* addr, int* addrlen)
 766 {
 767     return win32_accept(s, addr, addrlen);
 768 }
 769
 770 int
 771 PerlSockBind(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
 772 {
 773     return win32_bind(s, name, namelen);
 774 }
 775
 776 int
 777 PerlSockConnect(struct IPerlSock *I, SOCKET s, const struct sockaddr* name, int namelen)
 778 {
 779     return win32_connect(s, name, namelen);
 780 }
 781
 782 void
 783 PerlSockEndhostent(struct IPerlSock *I)
 784 {
 785     win32_endhostent();
 786 }
 787
 788 void
 789 PerlSockEndnetent(struct IPerlSock *I)
 790 {
 791     win32_endnetent();
 792 }
 793
 794 void
 795 PerlSockEndprotoent(struct IPerlSock *I)
 796 {
 797     win32_endprotoent();
 798 }
 799
 800 void
 801 PerlSockEndservent(struct IPerlSock *I)
 802 {
 803     win32_endservent();
 804 }
 805
 806 struct hostent*
 807 PerlSockGethostbyaddr(struct IPerlSock *I, const char* addr, int len, int type)
 808 {
 809     return win32_gethostbyaddr(addr, len, type);
 810 }
 811
 812 struct hostent*
 813 PerlSockGethostbyname(struct IPerlSock *I, const char* name)
 814 {
 815     return win32_gethostbyname(name);
 816 }
 817
 818 struct hostent*
 819 PerlSockGethostent(struct IPerlSock *I)
 820 {
 821     dTHXo;
 822     Perl_croak(aTHX_ "gethostent not implemented!\n");
 823     return NULL;
 824 }
 825
 826 int
 827 PerlSockGethostname(struct IPerlSock *I, char* name, int namelen)
 828 {
 829     return win32_gethostname(name, namelen);
 830 }
 831
 832 struct netent *
 833 PerlSockGetnetbyaddr(struct IPerlSock *I, long net, int type)
 834 {
 835     return win32_getnetbyaddr(net, type);
 836 }
 837
 838 struct netent *
 839 PerlSockGetnetbyname(struct IPerlSock *I, const char *name)
 840 {
 841     return win32_getnetbyname((char*)name);
 842 }
 843
 844 struct netent *
 845 PerlSockGetnetent(struct IPerlSock *I)
 846 {
 847     return win32_getnetent();
 848 }
 849
 850 int PerlSockGetpeername(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
 851 {
 852     return win32_getpeername(s, name, namelen);
 853 }
 854
 855 struct protoent*
 856 PerlSockGetprotobyname(struct IPerlSock *I, const char* name)
 857 {
 858     return win32_getprotobyname(name);
 859 }
 860
 861 struct protoent*
 862 PerlSockGetprotobynumber(struct IPerlSock *I, int number)
 863 {
 864     return win32_getprotobynumber(number);
 865 }
 866
 867 struct protoent*
 868 PerlSockGetprotoent(struct IPerlSock *I)
 869 {
 870     return win32_getprotoent();
 871 }
 872
 873 struct servent*
 874 PerlSockGetservbyname(struct IPerlSock *I, const char* name, const char* proto)
 875 {
 876     return win32_getservbyname(name, proto);
 877 }
 878
 879 struct servent*
 880 PerlSockGetservbyport(struct IPerlSock *I, int port, const char* proto)
 881 {
 882     return win32_getservbyport(port, proto);
 883 }
 884
 885 struct servent*
 886 PerlSockGetservent(struct IPerlSock *I)
 887 {
 888     return win32_getservent();
 889 }
 890
 891 int
 892 PerlSockGetsockname(struct IPerlSock *I, SOCKET s, struct sockaddr* name, int* namelen)
 893 {
 894     return win32_getsockname(s, name, namelen);
 895 }
 896
 897 int
 898 PerlSockGetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, char* optval, int* optlen)
 899 {
 900     return win32_getsockopt(s, level, optname, optval, optlen);
 901 }
 902
 903 unsigned long
 904 PerlSockInetAddr(struct IPerlSock *I, const char* cp)
 905 {
 906     return win32_inet_addr(cp);
 907 }
 908
 909 char*
 910 PerlSockInetNtoa(struct IPerlSock *I, struct in_addr in)
 911 {
 912     return win32_inet_ntoa(in);
 913 }
 914
 915 int
 916 PerlSockListen(struct IPerlSock *I, SOCKET s, int backlog)
 917 {
 918     return win32_listen(s, backlog);
 919 }
 920
 921 int
 922 PerlSockRecv(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags)
 923 {
 924     return win32_recv(s, buffer, len, flags);
 925 }
 926
 927 int
 928 PerlSockRecvfrom(struct IPerlSock *I, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen)
 929 {
 930     return win32_recvfrom(s, buffer, len, flags, from, fromlen);
 931 }
 932
 933 int
 934 PerlSockSelect(struct IPerlSock *I, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout)
 935 {
 936     return win32_select(nfds, (Perl_fd_set*)readfds, (Perl_fd_set*)writefds, (Perl_fd_set*)exceptfds, timeout);
 937 }
 938
 939 int
 940 PerlSockSend(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags)
 941 {
 942     return win32_send(s, buffer, len, flags);
 943 }
 944
 945 int
 946 PerlSockSendto(struct IPerlSock *I, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen)
 947 {
 948     return win32_sendto(s, buffer, len, flags, to, tolen);
 949 }
 950
 951 void
 952 PerlSockSethostent(struct IPerlSock *I, int stayopen)
 953 {
 954     win32_sethostent(stayopen);
 955 }
 956
 957 void
 958 PerlSockSetnetent(struct IPerlSock *I, int stayopen)
 959 {
 960     win32_setnetent(stayopen);
 961 }
 962
 963 void
 964 PerlSockSetprotoent(struct IPerlSock *I, int stayopen)
 965 {
 966     win32_setprotoent(stayopen);
 967 }
 968
 969 void
 970 PerlSockSetservent(struct IPerlSock *I, int stayopen)
 971 {
 972     win32_setservent(stayopen);
 973 }
 974
 975 int
 976 PerlSockSetsockopt(struct IPerlSock *I, SOCKET s, int level, int optname, const char* optval, int optlen)
 977 {
 978     return win32_setsockopt(s, level, optname, optval, optlen);
 979 }
 980
 981 int
 982 PerlSockShutdown(struct IPerlSock *I, SOCKET s, int how)
 983 {
 984     return win32_shutdown(s, how);
 985 }
 986
 987 SOCKET
 988 PerlSockSocket(struct IPerlSock *I, int af, int type, int protocol)
 989 {
 990     return win32_socket(af, type, protocol);
 991 }
 992
 993 int
 994 PerlSockSocketpair(struct IPerlSock *I, int domain, int type, int protocol, int* fds)
 995 {
 996     dTHXo;
 997     Perl_croak(aTHX_ "socketpair not implemented!\n");
 998     return 0;
 999 }
1000
1001 int
1002 PerlSockClosesocket(struct IPerlSock *I, SOCKET s)
1003 {
1004     return win32_closesocket(s);
1005 }
1006
1007 int
1008 PerlSockIoctlsocket(struct IPerlSock *I, SOCKET s, long cmd, u_long *argp)
1009 {
1010     return win32_ioctlsocket(s, cmd, argp);
1011 }
1012
1013 struct IPerlSock perlSock =
1014 {
1015     PerlSockHtonl,
1016     PerlSockHtons,
1017     PerlSockNtohl,
1018     PerlSockNtohs,
1019     PerlSockAccept,
1020     PerlSockBind,
1021     PerlSockConnect,
1022     PerlSockEndhostent,
1023     PerlSockEndnetent,
1024     PerlSockEndprotoent,
1025     PerlSockEndservent,
1026     PerlSockGethostname,
1027     PerlSockGetpeername,
1028     PerlSockGethostbyaddr,
1029     PerlSockGethostbyname,
1030     PerlSockGethostent,
1031     PerlSockGetnetbyaddr,
1032     PerlSockGetnetbyname,
1033     PerlSockGetnetent,
1034     PerlSockGetprotobyname,
1035     PerlSockGetprotobynumber,
1036     PerlSockGetprotoent,
1037     PerlSockGetservbyname,
1038     PerlSockGetservbyport,
1039     PerlSockGetservent,
1040     PerlSockGetsockname,
1041     PerlSockGetsockopt,
1042     PerlSockInetAddr,
1043     PerlSockInetNtoa,
1044     PerlSockListen,
1045     PerlSockRecv,
1046     PerlSockRecvfrom,
1047     PerlSockSelect,
1048     PerlSockSend,
1049     PerlSockSendto,
1050     PerlSockSethostent,
1051     PerlSockSetnetent,
1052     PerlSockSetprotoent,
1053     PerlSockSetservent,
1054     PerlSockSetsockopt,
1055     PerlSockShutdown,
1056     PerlSockSocket,
1057     PerlSockSocketpair,
1058     PerlSockClosesocket,
1059 };
1060
1061
1062 /* IPerlProc */
1063
1064 #define EXECF_EXEC 1
1065 #define EXECF_SPAWN 2
1066
1067 extern char *           g_getlogin(void);
1068 extern int              do_spawn2(char *cmd, int exectype);
1069 #ifdef PERL_OBJECT
1070 extern int              g_do_aspawn(void *vreally, void **vmark, void **vsp);
1071 #define do_aspawn g_do_aspawn
1072 #endif
1073 EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
1074                         struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
1075                         struct IPerlLIO* pLIO, struct IPerlDir* pDir,
1076                         struct IPerlSock* pSock, struct IPerlProc* pProc);
1077
1078 void
1079 PerlProcAbort(struct IPerlProc *I)
1080 {
1081     win32_abort();
1082 }
1083
1084 char *
1085 PerlProcCrypt(struct IPerlProc *I, const char* clear, const char* salt)
1086 {
1087     return win32_crypt(clear, salt);
1088 }
1089
1090 void
1091 PerlProcExit(struct IPerlProc *I, int status)
1092 {
1093     exit(status);
1094 }
1095
1096 void
1097 PerlProc_Exit(struct IPerlProc *I, int status)
1098 {
1099     _exit(status);
1100 }
1101
1102 int
1103 PerlProcExecl(struct IPerlProc *I, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3)
1104 {
1105     return execl(cmdname, arg0, arg1, arg2, arg3);
1106 }
1107
1108 int
1109 PerlProcExecv(struct IPerlProc *I, const char *cmdname, const char *const *argv)
1110 {
1111     return win32_execvp(cmdname, argv);
1112 }
1113
1114 int
1115 PerlProcExecvp(struct IPerlProc *I, const char *cmdname, const char *const *argv)
1116 {
1117     return win32_execvp(cmdname, argv);
1118 }
1119
1120 uid_t
1121 PerlProcGetuid(struct IPerlProc *I)
1122 {
1123     return getuid();
1124 }
1125
1126 uid_t
1127 PerlProcGeteuid(struct IPerlProc *I)
1128 {
1129     return geteuid();
1130 }
1131
1132 gid_t
1133 PerlProcGetgid(struct IPerlProc *I)
1134 {
1135     return getgid();
1136 }
1137
1138 gid_t
1139 PerlProcGetegid(struct IPerlProc *I)
1140 {
1141     return getegid();
1142 }
1143
1144 char *
1145 PerlProcGetlogin(struct IPerlProc *I)
1146 {
1147     return g_getlogin();
1148 }
1149
1150 int
1151 PerlProcKill(struct IPerlProc *I, int pid, int sig)
1152 {
1153     return win32_kill(pid, sig);
1154 }
1155
1156 int
1157 PerlProcKillpg(struct IPerlProc *I, int pid, int sig)
1158 {
1159     dTHXo;
1160     Perl_croak(aTHX_ "killpg not implemented!\n");
1161     return 0;
1162 }
1163
1164 int
1165 PerlProcPauseProc(struct IPerlProc *I)
1166 {
1167     return win32_sleep((32767L << 16) + 32767);
1168 }
1169
1170 PerlIO*
1171 PerlProcPopen(struct IPerlProc *I, const char *command, const char *mode)
1172 {
1173     dTHXo;
1174     PERL_FLUSHALL_FOR_CHILD;
1175     return (PerlIO*)win32_popen(command, mode);
1176 }
1177
1178 int
1179 PerlProcPclose(struct IPerlProc *I, PerlIO *stream)
1180 {
1181     return win32_pclose((FILE*)stream);
1182 }
1183
1184 int
1185 PerlProcPipe(struct IPerlProc *I, int *phandles)
1186 {
1187     return win32_pipe(phandles, 512, O_BINARY);
1188 }
1189
1190 int
1191 PerlProcSetuid(struct IPerlProc *I, uid_t u)
1192 {
1193     return setuid(u);
1194 }
1195
1196 int
1197 PerlProcSetgid(struct IPerlProc *I, gid_t g)
1198 {
1199     return setgid(g);
1200 }
1201
1202 int
1203 PerlProcSleep(struct IPerlProc *I, unsigned int s)
1204 {
1205     return win32_sleep(s);
1206 }
1207
1208 int
1209 PerlProcTimes(struct IPerlProc *I, struct tms *timebuf)
1210 {
1211     return win32_times(timebuf);
1212 }
1213
1214 int
1215 PerlProcWait(struct IPerlProc *I, int *status)
1216 {
1217     return win32_wait(status);
1218 }
1219
1220 int
1221 PerlProcWaitpid(struct IPerlProc *I, int pid, int *status, int flags)
1222 {
1223     return win32_waitpid(pid, status, flags);
1224 }
1225
1226 Sighandler_t
1227 PerlProcSignal(struct IPerlProc *I, int sig, Sighandler_t subcode)
1228 {
1229     return 0;
1230 }
1231
1232 void*
1233 PerlProcDynaLoader(struct IPerlProc *I, const char* filename)
1234 {
1235     return win32_dynaload(filename);
1236 }
1237
1238 void
1239 PerlProcGetOSError(struct IPerlProc *I, SV* sv, DWORD dwErr)
1240 {
1241     win32_str_os_error(sv, dwErr);
1242 }
1243
1244 BOOL
1245 PerlProcDoCmd(struct IPerlProc *I, char *cmd)
1246 {
1247     do_spawn2(cmd, EXECF_EXEC);
1248     return FALSE;
1249 }
1250
1251 int
1252 PerlProcSpawn(struct IPerlProc *I, char* cmds)
1253 {
1254     return do_spawn2(cmds, EXECF_SPAWN);
1255 }
1256
1257 int
1258 PerlProcSpawnvp(struct IPerlProc *I, int mode, const char *cmdname, const char *const *argv)
1259 {
1260     return win32_spawnvp(mode, cmdname, argv);
1261 }
1262
1263 int
1264 PerlProcASpawn(struct IPerlProc *I, void *vreally, void **vmark, void **vsp)
1265 {
1266     return do_aspawn(vreally, vmark, vsp);
1267 }
1268
1269 struct IPerlProc perlProc =
1270 {
1271     PerlProcAbort,
1272     PerlProcCrypt,
1273     PerlProcExit,
1274     PerlProc_Exit,
1275     PerlProcExecl,
1276     PerlProcExecv,
1277     PerlProcExecvp,
1278     PerlProcGetuid,
1279     PerlProcGeteuid,
1280     PerlProcGetgid,
1281     PerlProcGetegid,
1282     PerlProcGetlogin,
1283     PerlProcKill,
1284     PerlProcKillpg,
1285     PerlProcPauseProc,
1286     PerlProcPopen,
1287     PerlProcPclose,
1288     PerlProcPipe,
1289     PerlProcSetuid,
1290     PerlProcSetgid,
1291     PerlProcSleep,
1292     PerlProcTimes,
1293     PerlProcWait,
1294     PerlProcWaitpid,
1295     PerlProcSignal,
1296     PerlProcDynaLoader,
1297     PerlProcGetOSError,
1298     PerlProcDoCmd,
1299     PerlProcSpawn,
1300     PerlProcSpawnvp,
1301     PerlProcASpawn,
1302 };
1303
1304 /*#include "perlhost.h" */
1305
1306
1307 EXTERN_C void
1308 perl_get_host_info(struct IPerlMemInfo* perlMemInfo,
1309                    struct IPerlEnvInfo* perlEnvInfo,
1310                    struct IPerlStdIOInfo* perlStdIOInfo,
1311                    struct IPerlLIOInfo* perlLIOInfo,
1312                    struct IPerlDirInfo* perlDirInfo,
1313                    struct IPerlSockInfo* perlSockInfo,
1314                    struct IPerlProcInfo* perlProcInfo)
1315 {
1316     if(perlMemInfo) {
1317         Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*);
1318         perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*));
1319     }
1320     if(perlEnvInfo) {
1321         Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*);
1322         perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*));
1323     }
1324     if(perlStdIOInfo) {
1325         Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*);
1326         perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*));
1327     }
1328     if(perlLIOInfo) {
1329         Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*);
1330         perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*));
1331     }
1332     if(perlDirInfo) {
1333         Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*);
1334         perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*));
1335     }
1336     if(perlSockInfo) {
1337         Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*);
1338         perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*));
1339     }
1340     if(perlProcInfo) {
1341         Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*);
1342         perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*));
1343     }
1344 }
1345
1346 #ifdef PERL_OBJECT
1347
1348 EXTERN_C PerlInterpreter* perl_alloc_using(struct IPerlMem* pMem,
1349                         struct IPerlEnv* pEnv, struct IPerlStdIO* pStdIO,
1350                         struct IPerlLIO* pLIO, struct IPerlDir* pDir,
1351                         struct IPerlSock* pSock, struct IPerlProc* pProc)
1352 {
1353     CPerlObj* pPerl = NULL;
1354     try
1355     {
1356         pPerl = Perl_alloc(pMem, pEnv, pStdIO, pLIO, pDir, pSock, pProc);
1357     }
1358     catch(...)
1359     {
1360         win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
1361         pPerl = NULL;
1362     }
1363     if(pPerl)
1364     {
1365         SetPerlInterpreter(pPerl);
1366         return (PerlInterpreter*)pPerl;
1367     }
1368     SetPerlInterpreter(NULL);
1369     return NULL;
1370 }
1371
1372 #undef perl_alloc
1373 #undef perl_construct
1374 #undef perl_destruct
1375 #undef perl_free
1376 #undef perl_run
1377 #undef perl_parse
1378 EXTERN_C PerlInterpreter* perl_alloc(void)
1379 {
1380     CPerlObj* pPerl = NULL;
1381     try
1382     {
1383         pPerl = Perl_alloc(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
1384                            &perlDir, &perlSock, &perlProc);
1385     }
1386     catch(...)
1387     {
1388         win32_fprintf(stderr, "%s\n", "Error: Unable to allocate memory");
1389         pPerl = NULL;
1390     }
1391     if(pPerl)
1392     {
1393         SetPerlInterpreter(pPerl);
1394         return (PerlInterpreter*)pPerl;
1395     }
1396     SetPerlInterpreter(NULL);
1397     return NULL;
1398 }
1399
1400 EXTERN_C void perl_construct(PerlInterpreter* sv_interp)
1401 {
1402     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1403     try
1404     {
1405         pPerl->perl_construct();
1406     }
1407     catch(...)
1408     {
1409         win32_fprintf(stderr, "%s\n",
1410                       "Error: Unable to construct data structures");
1411         pPerl->perl_free();
1412         SetPerlInterpreter(NULL);
1413     }
1414 }
1415
1416 EXTERN_C void perl_destruct(PerlInterpreter* sv_interp)
1417 {
1418     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1419     try
1420     {
1421         pPerl->perl_destruct();
1422     }
1423     catch(...)
1424     {
1425     }
1426 }
1427
1428 EXTERN_C void perl_free(PerlInterpreter* sv_interp)
1429 {
1430     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1431     try
1432     {
1433         pPerl->perl_free();
1434     }
1435     catch(...)
1436     {
1437     }
1438     SetPerlInterpreter(NULL);
1439 }
1440
1441 EXTERN_C int perl_run(PerlInterpreter* sv_interp)
1442 {
1443     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1444     int retVal;
1445     try
1446     {
1447         retVal = pPerl->perl_run();
1448     }
1449 /*
1450     catch(int x)
1451     {
1452         // this is where exit() should arrive
1453         retVal = x;
1454     }
1455 */
1456     catch(...)
1457     {
1458         win32_fprintf(stderr, "Error: Runtime exception\n");
1459         retVal = -1;
1460     }
1461     return retVal;
1462 }
1463
1464 EXTERN_C int perl_parse(PerlInterpreter* sv_interp, void (*xsinit)(CPerlObj*), int argc, char** argv, char** env)
1465 {
1466     int retVal;
1467     CPerlObj* pPerl = (CPerlObj*)sv_interp;
1468     try
1469     {
1470         retVal = pPerl->perl_parse(xsinit, argc, argv, env);
1471     }
1472 /*
1473     catch(int x)
1474     {
1475         // this is where exit() should arrive
1476         retVal = x;
1477     }
1478 */
1479     catch(...)
1480     {
1481         win32_fprintf(stderr, "Error: Parse exception\n");
1482         retVal = -1;
1483     }
1484     *win32_errno() = 0;
1485     return retVal;
1486 }
1487
1488 #undef PL_perl_destruct_level
1489 #define PL_perl_destruct_level int dummy
1490
1491 #else /* !PERL_OBJECT */
1492
1493 EXTERN_C PerlInterpreter*
1494 perl_alloc(void)
1495 {
1496     return perl_alloc_using(&perlMem, &perlEnv, &perlStdIO, &perlLIO,
1497                            &perlDir, &perlSock, &perlProc);
1498 }
1499
1500 #endif /* PERL_OBJECT */
1501
1502 #endif /* PERL_IMPLICIT_SYS */
1503
1504 extern HANDLE w32_perldll_handle;
1505 static DWORD g_TlsAllocIndex;
1506
1507 EXTERN_C DllExport bool
1508 SetPerlInterpreter(void *interp)
1509 {
1510     return TlsSetValue(g_TlsAllocIndex, interp);
1511 }
1512
1513 EXTERN_C DllExport void*
1514 GetPerlInterpreter(void)
1515 {
1516     return TlsGetValue(g_TlsAllocIndex);
1517 }
1518
1519 EXTERN_C DllExport int
1520 RunPerl(int argc, char **argv, char **env)
1521 {
1522     int exitstatus;
1523     PerlInterpreter *my_perl;
1524     struct perl_thread *thr;
1525
1526 #ifndef __BORLANDC__
1527     /* XXX this _may_ be a problem on some compilers (e.g. Borland) that
1528      * want to free() argv after main() returns.  As luck would have it,
1529      * Borland's CRT does the right thing to argv[0] already. */
1530     char szModuleName[MAX_PATH];
1531     char *ptr;
1532
1533     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
1534     (void)win32_longpath(szModuleName);
1535     argv[0] = szModuleName;
1536 #endif
1537
1538 #ifdef PERL_GLOBAL_STRUCT
1539 #define PERLVAR(var,type) /**/
1540 #define PERLVARA(var,type) /**/
1541 #define PERLVARI(var,type,init) PL_Vars.var = init;
1542 #define PERLVARIC(var,type,init) PL_Vars.var = init;
1543 #include "perlvars.h"
1544 #undef PERLVAR
1545 #undef PERLVARA
1546 #undef PERLVARI
1547 #undef PERLVARIC
1548 #endif
1549
1550     PERL_SYS_INIT(&argc,&argv);
1551
1552     if (!(my_perl = perl_alloc()))
1553         return (1);
1554     perl_construct( my_perl );
1555     PL_perl_destruct_level = 0;
1556
1557     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
1558     if (!exitstatus) {
1559 #ifdef USE_ITHREADS             /* XXXXXX testing */
1560 extern PerlInterpreter * perl_clone(pTHXx_ IV flags);
1561
1562         PerlInterpreter *new_perl = perl_clone(my_perl, 0);
1563         Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */
1564         exitstatus = perl_run( new_perl );
1565         perl_destruct(new_perl); perl_free(new_perl);
1566         SetPerlInterpreter(my_perl);
1567 #else
1568         exitstatus = perl_run( my_perl );
1569 #endif
1570     }
1571
1572     perl_destruct( my_perl );
1573     perl_free( my_perl );
1574
1575     PERL_SYS_TERM();
1576
1577     return (exitstatus);
1578 }
1579
1580 BOOL APIENTRY
1581 DllMain(HANDLE hModule,         /* DLL module handle */
1582         DWORD fdwReason,        /* reason called */
1583         LPVOID lpvReserved)     /* reserved */
1584 {
1585     switch (fdwReason) {
1586         /* The DLL is attaching to a process due to process
1587          * initialization or a call to LoadLibrary.
1588          */
1589     case DLL_PROCESS_ATTACH:
1590 /* #define DEFAULT_BINMODE */
1591 #ifdef DEFAULT_BINMODE
1592         setmode( fileno( stdin  ), O_BINARY );
1593         setmode( fileno( stdout ), O_BINARY );
1594         setmode( fileno( stderr ), O_BINARY );
1595         _fmode = O_BINARY;
1596 #endif
1597         g_TlsAllocIndex = TlsAlloc();
1598         DisableThreadLibraryCalls(hModule);
1599         w32_perldll_handle = hModule;
1600         break;
1601
1602         /* The DLL is detaching from a process due to
1603          * process termination or call to FreeLibrary.
1604          */
1605     case DLL_PROCESS_DETACH:
1606         TlsFree(g_TlsAllocIndex);
1607         break;
1608
1609         /* The attached process creates a new thread. */
1610     case DLL_THREAD_ATTACH:
1611         break;
1612
1613         /* The thread of the attached process terminates. */
1614     case DLL_THREAD_DETACH:
1615         break;
1616
1617     default:
1618         break;
1619     }
1620     return TRUE;
1621 }
1622