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