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