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