1 #include <EXTERN.h>
2 #include <perl.h>
3 #include "exit.h"
4 #include "strerr.h"
5 #include "stralloc.h"
6 #include "str.h"
7
8 #ifndef eval_pv
9 #define eval_pv perl_eval_pv
10 #endif
11
12 #ifndef call_argv
13 #define call_argv perl_call_argv
14 #endif
15
16 extern const char *self;
17
18 /* ActiveState Perl requires this be called my_perl */
19 static PerlInterpreter *my_perl = 0;
20
usage(void)21 static void usage(void) {
22 strerr_warn4(self,": usage: ",self," sslargs file sub args",0);
23 _exit(100);
24 }
25
26 static stralloc newenv = {0};
27 static char *trivenv[] = { 0 };
28 static char **perlenv = trivenv;
29 static char **origenv = 0;
30
env_append(const char * c)31 void env_append(const char *c) {
32 if (!stralloc_append(&newenv,c))
33 strerr_die2x(111,self,"out of memory");
34 }
35
36 #define EXTERN_C extern
37
xs_init()38 EXTERN_C void xs_init() {
39 }
40
server(int argc,char ** argv)41 void server(int argc,char **argv) {
42 char *prog[] = { "", *argv };
43 int i;
44 int j;
45 int split;
46 const char *x;
47
48 ++argv; --argc;
49 if (!argv) usage();
50 if (!*argv) usage();
51
52 origenv = environ;
53 environ = perlenv;
54
55 if (!my_perl) {
56 my_perl = perl_alloc();
57 if (!my_perl) strerr_die2x(111,self,"out of memory");
58 perl_construct(my_perl);
59 if (perl_parse(my_perl,xs_init,2,prog,trivenv))
60 strerr_die2x(111,self,"perl_parse failed");
61
62 if (perl_run(my_perl))
63 strerr_die2x(111,self,"perl_run failed");
64 }
65
66 if (!stralloc_copys(&newenv,"%ENV=("))
67 strerr_die2x(111,self,"out of memory");
68 for(i = 0;origenv[i];++i) {
69 x = origenv[i];
70 if (!x) continue;
71 split = str_chr(x,'=');
72 env_append("'");
73 for (j = 0;j < split;++j) {
74 if (*x == '\'' || *x == '\\') env_append("\\");
75 env_append(x++);
76 }
77 env_append("'");
78 env_append(",");
79 env_append("'");
80 if (*x == '=') ++x;
81 while (*x) {
82 if (*x == '\'' || *x == '\\') env_append("\\");
83 env_append(x++);
84 }
85 env_append("'");
86 env_append(",");
87 }
88 env_append(")");
89 env_append("\0");
90
91 ENTER;
92 SAVETMPS;
93 eval_pv(newenv.s,TRUE);
94 FREETMPS;
95 LEAVE;
96
97 if (call_argv(*argv,G_VOID|G_DISCARD,argv + 1))
98 strerr_die2x(111,self,"interpreter failed");
99
100 perlenv = environ;
101 environ = origenv;
102 }
103