1 /* $Id: perlread.c,v 1.10 2004-09-27 10:44:50 adam Exp $
2 Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
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>
38 /* Constructor call for the filter object */
39 void Filter_create (struct perl_context *context)
45 XPUSHs(sv_2mortal(newSVpv(context->filterClass,
46 strlen(context->filterClass)))) ;
48 sv_setref_pv(msv, "_p_perl_context", (void*)context);
51 call_method("new", G_EVAL);
54 context->filterRef = POPs;
59 Execute the process call on the filter. This is a bit dirty.
60 The perl code is going to get dh and nmem from the context trough callbacks,
61 then call readf, to get the stream, and then set the res (d1 node)
62 in the context. However, it's safer, to let swig do as much of wrapping
65 int Filter_process (struct perl_context *context)
77 XPUSHs(context->filterRef);
79 call_method("_process", 0);
91 This one is called to transfer the results of a readf. It's going to create
92 a temporary variable there...
94 So the call stack is something like:
97 ->Filter_process(context) [C]
98 -> _process($context) [Perl]
99 -> grs_perl_get_dh($context) [Perl]
100 -> grs_perl_get_dh(context) [C]
101 -> grs_perl_get_mem($context) [Perl]
102 -> grs_perl_get_mem(context) [C]
105 -> grs_perl_readf($context,$len) [Perl]
106 -> grs_perl_readf(context, len) [C]
107 ->(*context->readf)(context->fh, buf, len) [C]
108 -> Filter_store_buff(context, buf, r) [C]
109 -> _store_buff($buff) [Perl]
110 [... returns buff and length ...]
112 [... returns d1 node ...]
113 -> grs_perl_set_res($context, $node) [Perl]
114 -> grs_perl_set_res(context, node) [C]
116 [... The result is in context->res ...]
118 Dirty, isn't it? It may become nicer, if I'll have some more time to work on
119 it. However, these changes are not going to hurt the filter api, as
120 Filter.pm, which is inherited into all specific filter implementations
121 can hide this whole compexity behind.
126 void Filter_store_buff (struct perl_context *context, char *buff, size_t len)
134 XPUSHs(context->filterRef);
135 XPUSHs(sv_2mortal(newSVpv(buff, len)));
137 call_method("_store_buff", 0);
145 /* The "file" manipulation function wrappers */
146 int grs_perl_readf(struct perl_context *context, size_t len)
149 char *buf = (char *) xmalloc (len+1);
150 r = (*context->readf)(context->fh, buf, len);
151 if (r > 0) Filter_store_buff (context, buf, r);
156 int grs_perl_readline(struct perl_context *context)
159 char *buf = (char *) xmalloc (4096);
162 while ((r = (*context->readf)(context->fh,p,1)) && (p-buf < 4095)) {
164 if (*(p-1) == 10) break;
169 if (p != buf) Filter_store_buff (context, buf, p - buf);
174 char grs_perl_getc(struct perl_context *context)
178 if ((r = (*context->readf)(context->fh,p,1))) {
185 off_t grs_perl_seekf(struct perl_context *context, off_t offset)
187 return ((*context->seekf)(context->fh, offset));
190 off_t grs_perl_tellf(struct perl_context *context)
192 return ((*context->tellf)(context->fh));
195 void grs_perl_endf(struct perl_context *context, off_t offset)
197 (*context->endf)(context->fh, offset);
200 /* Get pointers from the context. Easyer to wrap this by SWIG */
201 data1_handle *grs_perl_get_dh(struct perl_context *context)
203 return(&context->dh);
206 NMEM *grs_perl_get_mem(struct perl_context *context)
208 return(&context->mem);
211 /* Set the result in the context */
212 void grs_perl_set_res(struct perl_context *context, data1_node *n)
218 /* The filter handlers (init, destroy, read) */
219 static void *init_perl(Res res, RecType rt)
221 struct perl_context *context =
222 (struct perl_context *) xmalloc (sizeof(*context));
224 /* If there is an interpreter (context) running, - we are calling
225 indexing and retrieval from the perl API - we don't create a new one. */
226 context->origi = PL_curinterp;
228 if (!context->origi) {
229 context->perli = perl_alloc();
230 PERL_SET_CONTEXT(context->perli);
231 logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
233 logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
235 context->perli_ready = 0;
236 strcpy(context->filterClass, "");
237 strcpy(context->type, "");
241 static void config_perl(void *clientData, Res res, const char *args)
243 struct perl_context *p = (struct perl_context*) clientData;
244 if (strlen(args) < sizeof(p->type))
245 strcpy(p->type, args);
248 static void destroy_perl(void *clientData)
250 struct perl_context *context = (struct perl_context *) clientData;
252 logf (LOG_LOG, "Destroying perl interpreter context");
253 if (context->perli_ready) {
258 if (context->origi == NULL) perl_destruct(context->perli);
260 if (context->origi == NULL) perl_free(context->perli);
264 static data1_node *grs_read_perl (struct grs_read_info *p)
266 struct perl_context *context = (struct perl_context *) p->clientData;
267 char *filterClass = context->type;
269 /* The "file" manipulation function wrappers */
270 context->readf = p->readf;
271 context->seekf = p->seekf;
272 context->tellf = p->tellf;
273 context->endf = p->endf;
275 /* The "file", data1 and NMEM handles */
278 context->mem = p->mem;
280 /* If the class was not interpreted before... */
281 /* This is not too efficient, when indexing with many different filters... */
282 if (strcmp(context->filterClass, filterClass)) {
284 char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
285 char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
286 char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
288 if (context->perli_ready) {
293 if (context->origi == NULL) {
294 perl_destruct(context->perli);
297 if (context->origi == NULL) {
298 perl_construct(context->perli);
306 context->perli_ready = 1;
308 /* parse, and run the init call */
309 if (context->origi == NULL) {
310 logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
312 arglist[2] = (char *) data1_get_tabpath(p->dh);
313 sprintf(modarg,"-M%s",filterClass);
314 arglist[3] = (char *) &modarg;
315 sprintf(initarg,"%s->init;",filterClass);
316 arglist[5] = (char *) &initarg;
318 perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
319 perl_run(context->perli);
322 strcpy(context->filterClass, filterClass);
324 /* create the filter object as a filterClass blessed reference */
325 Filter_create(context);
328 /* Wow... if calling with individual update_record calls from perl,
329 the filter object reference may go out of scope... */
330 if (!sv_isa(context->filterRef, context->filterClass)) {
331 Filter_create(context);
332 logf (LOG_DEBUG,"Filter recreated");
335 if (!SvTRUE(context->filterRef))
337 logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
341 /* call the process method */
342 Filter_process(context);
344 /* return the created data1 node */
348 static int extract_perl(void *clientData, struct recExtractCtrl *ctrl)
350 return zebra_grs_extract(clientData, ctrl, grs_read_perl);
353 static int retrieve_perl(void *clientData, struct recRetrieveCtrl *ctrl)
355 return zebra_grs_retrieve(clientData, ctrl, grs_read_perl);
358 static struct recType perl_type = {
368 #ifdef IDZEBRA_STATIC_GRS_PERL
369 idzebra_filter_grs_perl