1 /* $Id: perlread.c,v 1.1 2002-11-15 21:26:01 adam Exp $ */
4 #define PERL_IMPLICIT_CONTEXT
15 #include <yaz/tpath.h>
21 #define GRS_PERL_MODULE_NAME_MAXLEN 255
23 // Context information for the filter
25 PerlInterpreter *perli;
26 PerlInterpreter *origi;
28 char filterClass[GRS_PERL_MODULE_NAME_MAXLEN];
31 int (*readf)(void *, char *, size_t);
32 off_t (*seekf)(void *, off_t);
33 off_t (*tellf)(void *);
34 void (*endf)(void *, off_t);
42 // Constructor call for the filter object
43 void Filter_create (struct perl_context *context)
49 XPUSHs(sv_2mortal(newSVpv(context->filterClass,
50 strlen(context->filterClass)))) ;
52 sv_setref_pv(msv, "_p_perl_context", (void*)context);
55 call_method("new", 0);
58 context->filterRef = POPs;
63 Execute the process call on the filter. This is a bit dirty.
64 The perl code is going to get dh and nmem from the context trough callbacks,
65 then call readf, to get the stream, and then set the res (d1 node)
66 in the context. However, it's safer, to let swig do as much of wrapping
69 int Filter_process (struct perl_context *context)
78 XPUSHs(context->filterRef);
80 call_method("_process", 0);
88 This one is called to transfer the results of a readf. It's going to create
89 a temporary variable there...
91 So the call stack is something like:
94 ->Filter_process(context) [C]
95 -> _process($context) [Perl]
96 -> grs_perl_get_dh($context) [Perl]
97 -> grs_perl_get_dh(context) [C]
98 -> grs_perl_get_mem($context) [Perl]
99 -> grs_perl_get_mem(context) [C]
102 -> grs_perl_readf($context,$len) [Perl]
103 -> grs_perl_readf(context, len) [C]
104 ->(*context->readf)(context->fh, buf, len) [C]
105 -> Filter_store_buff(context, buf, r) [C]
106 -> _store_buff($buff) [Perl]
107 [... returns buff and length ...]
109 [... returns d1 node ...]
110 -> grs_perl_set_res($context, $node) [Perl]
111 -> grs_perl_set_res(context, node) [C]
113 [... The result is in context->res ...]
115 Dirty, isn't it? It may become nicer, if I'll have some more time to work on
116 it. However, these changes are not going to hurt the filter api, as
117 Filter.pm, which is inherited into all specific filter implementations
118 can hide this whole compexity behind.
121 void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
124 XPUSHs(context->filterRef);
125 XPUSHs(sv_2mortal(newSVpv(buff, len)));
127 call_method("_store_buff", 0);
131 /* The "file" manipulation function wrappers */
132 int grs_perl_readf(struct perl_context *context, size_t len) {
134 char *buf = (char *) xmalloc (len+1);
135 r = (*context->readf)(context->fh, buf, len);
136 if (r > 0) Filter_store_buff (context, buf, r);
141 off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
142 return ((*context->seekf)(context->fh, offset));
145 off_t grs_perl_tellf(struct perl_context *context) {
146 return ((*context->tellf)(context->fh));
149 void grs_perl_endf(struct perl_context *context, off_t offset) {
150 (*context->endf)(context->fh, offset);
153 /* Get pointers from the context. Easyer to wrap this by SWIG */
154 data1_handle grs_perl_get_dh(struct perl_context *context) {
158 NMEM grs_perl_get_mem(struct perl_context *context) {
159 return(context->mem);
162 /* Set the result in the context */
163 void grs_perl_set_res(struct perl_context *context, data1_node *n) {
167 /* The filter handlers (init, destroy, read) */
168 static void *grs_init_perl(void)
170 struct perl_context *context =
171 (struct perl_context *) xmalloc (sizeof(*context));
173 // If there is an interpreter (context) running, - we are calling
174 // indexing and retrieval from the perl API - we don't create a new one.
175 context->origi = PERL_GET_CONTEXT;
176 if (context->origi == NULL) {
177 context->perli = perl_alloc();
178 PERL_SET_CONTEXT(context->perli);
179 logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
181 logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
183 context->perli_ready = 0;
184 strcpy(context->filterClass, "");
188 void grs_destroy_perl(void *clientData)
190 struct perl_context *context = (struct perl_context *) clientData;
192 logf (LOG_LOG, "Destroying perl interpreter context");
193 if (context->perli_ready) {
196 if (context->origi == NULL) perl_destruct(context->perli);
198 if (context->origi == NULL) perl_free(context->perli);
202 static data1_node *grs_read_perl (struct grs_read_info *p)
204 struct perl_context *context = (struct perl_context *) p->clientData;
205 char *filterClass = p->type;
207 // The "file" manipulation function wrappers
208 context->readf = p->readf;
209 context->seekf = p->seekf;
210 context->tellf = p->tellf;
211 context->endf = p->endf;
213 // The "file", data1 and NMEM handles
216 context->mem = p->mem;
218 // If the class was not interpreted before...
219 // This is not too efficient, when indexing with many different filters...
220 if (strcmp(context->filterClass,filterClass)) {
222 char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
223 char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
224 char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
226 if (context->perli_ready) {
229 if (context->origi == NULL) perl_destruct(context->perli);
231 if (context->origi == NULL) perl_construct(context->perli);
234 context->perli_ready = 1;
236 // parse, and run the init call
237 if (context->origi == NULL) {
238 logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
240 arglist[2] = (char *) data1_get_tabpath(p->dh);
241 sprintf(modarg,"-M%s",filterClass);
242 arglist[3] = (char *) &modarg;
243 sprintf(initarg,"%s->init;",filterClass);
244 arglist[5] = (char *) &initarg;
246 perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
247 perl_run(context->perli);
250 strcpy(context->filterClass, filterClass);
252 // create the filter object as a filterClass blessed reference
253 Filter_create(context);
256 // Wow... if calling with individual update_record calls from perl,
257 // the filter object reference may go out of scope...
258 if (!SvOK(context->filterRef)) Filter_create(context);
261 // call the process method
262 Filter_process(context);
264 // return the created data1 node
265 return (context->res);
268 static struct recTypeGrs perl_type = {
275 RecTypeGrs recTypeGrs_perl = &perl_type;