1 /* $Id: perlread.c,v 1.11 2004-09-28 10:15:03 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>
34 #include <idzebra/recgrs.h>
36 /* Constructor call for the filter object */
37 void Filter_create (struct perl_context *context)
43 XPUSHs(sv_2mortal(newSVpv(context->filterClass,
44 strlen(context->filterClass)))) ;
46 sv_setref_pv(msv, "_p_perl_context", (void*)context);
49 call_method("new", G_EVAL);
52 context->filterRef = POPs;
57 Execute the process call on the filter. This is a bit dirty.
58 The perl code is going to get dh and nmem from the context trough callbacks,
59 then call readf, to get the stream, and then set the res (d1 node)
60 in the context. However, it's safer, to let swig do as much of wrapping
63 int Filter_process (struct perl_context *context)
75 XPUSHs(context->filterRef);
77 call_method("_process", 0);
89 This one is called to transfer the results of a readf. It's going to create
90 a temporary variable there...
92 So the call stack is something like:
95 ->Filter_process(context) [C]
96 -> _process($context) [Perl]
97 -> grs_perl_get_dh($context) [Perl]
98 -> grs_perl_get_dh(context) [C]
99 -> grs_perl_get_mem($context) [Perl]
100 -> grs_perl_get_mem(context) [C]
103 -> grs_perl_readf($context,$len) [Perl]
104 -> grs_perl_readf(context, len) [C]
105 ->(*context->readf)(context->fh, buf, len) [C]
106 -> Filter_store_buff(context, buf, r) [C]
107 -> _store_buff($buff) [Perl]
108 [... returns buff and length ...]
110 [... returns d1 node ...]
111 -> grs_perl_set_res($context, $node) [Perl]
112 -> grs_perl_set_res(context, node) [C]
114 [... The result is in context->res ...]
116 Dirty, isn't it? It may become nicer, if I'll have some more time to work on
117 it. However, these changes are not going to hurt the filter api, as
118 Filter.pm, which is inherited into all specific filter implementations
119 can hide this whole compexity behind.
124 void Filter_store_buff (struct perl_context *context, char *buff, size_t len)
132 XPUSHs(context->filterRef);
133 XPUSHs(sv_2mortal(newSVpv(buff, len)));
135 call_method("_store_buff", 0);
143 /* The "file" manipulation function wrappers */
144 int grs_perl_readf(struct perl_context *context, size_t len)
147 char *buf = (char *) xmalloc (len+1);
148 r = (*context->readf)(context->fh, buf, len);
149 if (r > 0) Filter_store_buff (context, buf, r);
154 int grs_perl_readline(struct perl_context *context)
157 char *buf = (char *) xmalloc (4096);
160 while ((r = (*context->readf)(context->fh,p,1)) && (p-buf < 4095)) {
162 if (*(p-1) == 10) break;
167 if (p != buf) Filter_store_buff (context, buf, p - buf);
172 char grs_perl_getc(struct perl_context *context)
176 if ((r = (*context->readf)(context->fh,p,1))) {
183 off_t grs_perl_seekf(struct perl_context *context, off_t offset)
185 return ((*context->seekf)(context->fh, offset));
188 off_t grs_perl_tellf(struct perl_context *context)
190 return ((*context->tellf)(context->fh));
193 void grs_perl_endf(struct perl_context *context, off_t offset)
195 (*context->endf)(context->fh, offset);
198 /* Get pointers from the context. Easyer to wrap this by SWIG */
199 data1_handle *grs_perl_get_dh(struct perl_context *context)
201 return(&context->dh);
204 NMEM *grs_perl_get_mem(struct perl_context *context)
206 return(&context->mem);
209 /* Set the result in the context */
210 void grs_perl_set_res(struct perl_context *context, data1_node *n)
216 /* The filter handlers (init, destroy, read) */
217 static void *init_perl(Res res, RecType rt)
219 struct perl_context *context =
220 (struct perl_context *) xmalloc (sizeof(*context));
222 /* If there is an interpreter (context) running, - we are calling
223 indexing and retrieval from the perl API - we don't create a new one. */
224 context->origi = PL_curinterp;
226 if (!context->origi) {
227 context->perli = perl_alloc();
228 PERL_SET_CONTEXT(context->perli);
229 logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
231 logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
233 context->perli_ready = 0;
234 strcpy(context->filterClass, "");
235 strcpy(context->type, "");
239 static void config_perl(void *clientData, Res res, const char *args)
241 struct perl_context *p = (struct perl_context*) clientData;
242 if (strlen(args) < sizeof(p->type))
243 strcpy(p->type, args);
246 static void destroy_perl(void *clientData)
248 struct perl_context *context = (struct perl_context *) clientData;
250 logf (LOG_LOG, "Destroying perl interpreter context");
251 if (context->perli_ready) {
256 if (context->origi == NULL) perl_destruct(context->perli);
258 if (context->origi == NULL) perl_free(context->perli);
262 static data1_node *grs_read_perl (struct grs_read_info *p)
264 struct perl_context *context = (struct perl_context *) p->clientData;
265 char *filterClass = context->type;
267 /* The "file" manipulation function wrappers */
268 context->readf = p->readf;
269 context->seekf = p->seekf;
270 context->tellf = p->tellf;
271 context->endf = p->endf;
273 /* The "file", data1 and NMEM handles */
276 context->mem = p->mem;
278 /* If the class was not interpreted before... */
279 /* This is not too efficient, when indexing with many different filters... */
280 if (strcmp(context->filterClass, filterClass)) {
282 char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
283 char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
284 char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
286 if (context->perli_ready) {
291 if (context->origi == NULL) {
292 perl_destruct(context->perli);
295 if (context->origi == NULL) {
296 perl_construct(context->perli);
304 context->perli_ready = 1;
306 /* parse, and run the init call */
307 if (context->origi == NULL) {
308 logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
310 arglist[2] = (char *) data1_get_tabpath(p->dh);
311 sprintf(modarg,"-M%s",filterClass);
312 arglist[3] = (char *) &modarg;
313 sprintf(initarg,"%s->init;",filterClass);
314 arglist[5] = (char *) &initarg;
316 perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
317 perl_run(context->perli);
320 strcpy(context->filterClass, filterClass);
322 /* create the filter object as a filterClass blessed reference */
323 Filter_create(context);
326 /* Wow... if calling with individual update_record calls from perl,
327 the filter object reference may go out of scope... */
328 if (!sv_isa(context->filterRef, context->filterClass)) {
329 Filter_create(context);
330 logf (LOG_DEBUG,"Filter recreated");
333 if (!SvTRUE(context->filterRef))
335 logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
339 /* call the process method */
340 Filter_process(context);
342 /* return the created data1 node */
346 static int extract_perl(void *clientData, struct recExtractCtrl *ctrl)
348 return zebra_grs_extract(clientData, ctrl, grs_read_perl);
351 static int retrieve_perl(void *clientData, struct recRetrieveCtrl *ctrl)
353 return zebra_grs_retrieve(clientData, ctrl, grs_read_perl);
356 static struct recType perl_type = {
366 #ifdef IDZEBRA_STATIC_GRS_PERL
367 idzebra_filter_grs_perl