1 /* $Id: perlread.c,v 1.6 2003-02-27 23:21:40 pop Exp $
2 Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002
5 This file is part of the Zebra server.
7 Zebra is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 Zebra is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with Zebra; see the file LICENSE.zebra. If not, write to the
19 Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
33 #include <yaz/tpath.h>
39 #define GRS_PERL_MODULE_NAME_MAXLEN 255
41 /* Context information for the filter */
43 PerlInterpreter *perli;
44 PerlInterpreter *origi;
46 char filterClass[GRS_PERL_MODULE_NAME_MAXLEN];
49 int (*readf)(void *, char *, size_t);
50 off_t (*seekf)(void *, off_t);
51 off_t (*tellf)(void *);
52 void (*endf)(void *, off_t);
60 /* Constructor call for the filter object */
61 void Filter_create (struct perl_context *context)
67 XPUSHs(sv_2mortal(newSVpv(context->filterClass,
68 strlen(context->filterClass)))) ;
70 sv_setref_pv(msv, "_p_perl_context", (void*)context);
73 call_method("new", G_EVAL);
76 context->filterRef = POPs;
81 Execute the process call on the filter. This is a bit dirty.
82 The perl code is going to get dh and nmem from the context trough callbacks,
83 then call readf, to get the stream, and then set the res (d1 node)
84 in the context. However, it's safer, to let swig do as much of wrapping
87 int Filter_process (struct perl_context *context)
99 XPUSHs(context->filterRef);
101 call_method("_process", 0);
112 This one is called to transfer the results of a readf. It's going to create
113 a temporary variable there...
115 So the call stack is something like:
118 ->Filter_process(context) [C]
119 -> _process($context) [Perl]
120 -> grs_perl_get_dh($context) [Perl]
121 -> grs_perl_get_dh(context) [C]
122 -> grs_perl_get_mem($context) [Perl]
123 -> grs_perl_get_mem(context) [C]
126 -> grs_perl_readf($context,$len) [Perl]
127 -> grs_perl_readf(context, len) [C]
128 ->(*context->readf)(context->fh, buf, len) [C]
129 -> Filter_store_buff(context, buf, r) [C]
130 -> _store_buff($buff) [Perl]
131 [... returns buff and length ...]
133 [... returns d1 node ...]
134 -> grs_perl_set_res($context, $node) [Perl]
135 -> grs_perl_set_res(context, node) [C]
137 [... The result is in context->res ...]
139 Dirty, isn't it? It may become nicer, if I'll have some more time to work on
140 it. However, these changes are not going to hurt the filter api, as
141 Filter.pm, which is inherited into all specific filter implementations
142 can hide this whole compexity behind.
145 void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
152 XPUSHs(context->filterRef);
153 XPUSHs(sv_2mortal(newSVpv(buff, len)));
155 call_method("_store_buff", 0);
162 /* The "file" manipulation function wrappers */
163 int grs_perl_readf(struct perl_context *context, size_t len) {
165 char *buf = (char *) xmalloc (len+1);
166 r = (*context->readf)(context->fh, buf, len);
167 if (r > 0) Filter_store_buff (context, buf, r);
172 off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
173 return ((*context->seekf)(context->fh, offset));
176 off_t grs_perl_tellf(struct perl_context *context) {
177 return ((*context->tellf)(context->fh));
180 void grs_perl_endf(struct perl_context *context, off_t offset) {
181 (*context->endf)(context->fh, offset);
184 /* Get pointers from the context. Easyer to wrap this by SWIG */
185 data1_handle *grs_perl_get_dh(struct perl_context *context) {
186 return(&context->dh);
189 NMEM *grs_perl_get_mem(struct perl_context *context) {
190 return(&context->mem);
193 /* Set the result in the context */
194 void grs_perl_set_res(struct perl_context *context, data1_node *n) {
198 /* The filter handlers (init, destroy, read) */
199 static void *grs_init_perl(void)
201 struct perl_context *context =
202 (struct perl_context *) xmalloc (sizeof(*context));
204 /* If there is an interpreter (context) running, - we are calling
205 indexing and retrieval from the perl API - we don't create a new one. */
206 context->origi = PERL_GET_CONTEXT;
207 if (context->origi == NULL) {
208 context->perli = perl_alloc();
209 PERL_SET_CONTEXT(context->perli);
210 logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
212 logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
214 context->perli_ready = 0;
215 strcpy(context->filterClass, "");
219 void grs_destroy_perl(void *clientData)
221 struct perl_context *context = (struct perl_context *) clientData;
223 logf (LOG_LOG, "Destroying perl interpreter context");
224 if (context->perli_ready) {
229 if (context->origi == NULL) perl_destruct(context->perli);
231 if (context->origi == NULL) perl_free(context->perli);
235 static data1_node *grs_read_perl (struct grs_read_info *p)
237 struct perl_context *context = (struct perl_context *) p->clientData;
238 char *filterClass = p->type;
240 /* The "file" manipulation function wrappers */
241 context->readf = p->readf;
242 context->seekf = p->seekf;
243 context->tellf = p->tellf;
244 context->endf = p->endf;
246 /* The "file", data1 and NMEM handles */
249 context->mem = p->mem;
251 /* If the class was not interpreted before... */
252 /* This is not too efficient, when indexing with many different filters... */
253 if (strcmp(context->filterClass,filterClass)) {
255 char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
256 char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
257 char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
259 if (context->perli_ready) {
264 if (context->origi == NULL) perl_destruct(context->perli);
266 if (context->origi == NULL) perl_construct(context->perli);
271 context->perli_ready = 1;
273 /* parse, and run the init call */
274 if (context->origi == NULL) {
275 logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
277 arglist[2] = (char *) data1_get_tabpath(p->dh);
278 sprintf(modarg,"-M%s",filterClass);
279 arglist[3] = (char *) &modarg;
280 sprintf(initarg,"%s->init;",filterClass);
281 arglist[5] = (char *) &initarg;
283 perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
284 perl_run(context->perli);
287 strcpy(context->filterClass, filterClass);
289 /* create the filter object as a filterClass blessed reference */
290 Filter_create(context);
293 /* Wow... if calling with individual update_record calls from perl,
294 the filter object reference may go out of scope... */
295 if (!SvOK(context->filterRef)) Filter_create(context);
297 if (!SvTRUE(context->filterRef)) {
298 logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
302 /* call the process method */
303 Filter_process(context);
305 /* return the created data1 node */
306 return (context->res);
309 static struct recTypeGrs perl_type = {
316 RecTypeGrs recTypeGrs_perl = &perl_type;