This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
yet more cleanups of the PERL_OBJECT, MULTIPLICITY and USE_THREADS
[perl5.git] / 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