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