1 /* $Id: perlread.c,v 1.2 2002-11-15 22:01:42 adam 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
24 #define PERL_IMPLICIT_CONTEXT
34 #include <yaz/tpath.h>
40 #define GRS_PERL_MODULE_NAME_MAXLEN 255
42 /* Context information for the filter */
44 PerlInterpreter *perli;
45 PerlInterpreter *origi;
47 char filterClass[GRS_PERL_MODULE_NAME_MAXLEN];
50 int (*readf)(void *, char *, size_t);
51 off_t (*seekf)(void *, off_t);
52 off_t (*tellf)(void *);
53 void (*endf)(void *, off_t);
61 /* Constructor call for the filter object */
62 void Filter_create (struct perl_context *context)
68 XPUSHs(sv_2mortal(newSVpv(context->filterClass,
69 strlen(context->filterClass)))) ;
71 sv_setref_pv(msv, "_p_perl_context", (void*)context);
74 call_method("new", 0);
77 context->filterRef = POPs;
82 Execute the process call on the filter. This is a bit dirty.
83 The perl code is going to get dh and nmem from the context trough callbacks,
84 then call readf, to get the stream, and then set the res (d1 node)
85 in the context. However, it's safer, to let swig do as much of wrapping
88 int Filter_process (struct perl_context *context)
97 XPUSHs(context->filterRef);
99 call_method("_process", 0);
107 This one is called to transfer the results of a readf. It's going to create
108 a temporary variable there...
110 So the call stack is something like:
113 ->Filter_process(context) [C]
114 -> _process($context) [Perl]
115 -> grs_perl_get_dh($context) [Perl]
116 -> grs_perl_get_dh(context) [C]
117 -> grs_perl_get_mem($context) [Perl]
118 -> grs_perl_get_mem(context) [C]
121 -> grs_perl_readf($context,$len) [Perl]
122 -> grs_perl_readf(context, len) [C]
123 ->(*context->readf)(context->fh, buf, len) [C]
124 -> Filter_store_buff(context, buf, r) [C]
125 -> _store_buff($buff) [Perl]
126 [... returns buff and length ...]
128 [... returns d1 node ...]
129 -> grs_perl_set_res($context, $node) [Perl]
130 -> grs_perl_set_res(context, node) [C]
132 [... The result is in context->res ...]
134 Dirty, isn't it? It may become nicer, if I'll have some more time to work on
135 it. However, these changes are not going to hurt the filter api, as
136 Filter.pm, which is inherited into all specific filter implementations
137 can hide this whole compexity behind.
140 void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
143 XPUSHs(context->filterRef);
144 XPUSHs(sv_2mortal(newSVpv(buff, len)));
146 call_method("_store_buff", 0);
150 /* The "file" manipulation function wrappers */
151 int grs_perl_readf(struct perl_context *context, size_t len) {
153 char *buf = (char *) xmalloc (len+1);
154 r = (*context->readf)(context->fh, buf, len);
155 if (r > 0) Filter_store_buff (context, buf, r);
160 off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
161 return ((*context->seekf)(context->fh, offset));
164 off_t grs_perl_tellf(struct perl_context *context) {
165 return ((*context->tellf)(context->fh));
168 void grs_perl_endf(struct perl_context *context, off_t offset) {
169 (*context->endf)(context->fh, offset);
172 /* Get pointers from the context. Easyer to wrap this by SWIG */
173 data1_handle grs_perl_get_dh(struct perl_context *context) {
177 NMEM grs_perl_get_mem(struct perl_context *context) {
178 return(context->mem);
181 /* Set the result in the context */
182 void grs_perl_set_res(struct perl_context *context, data1_node *n) {
186 /* The filter handlers (init, destroy, read) */
187 static void *grs_init_perl(void)
189 struct perl_context *context =
190 (struct perl_context *) xmalloc (sizeof(*context));
192 /* If there is an interpreter (context) running, - we are calling
193 indexing and retrieval from the perl API - we don't create a new one. */
194 context->origi = PERL_GET_CONTEXT;
195 if (context->origi == NULL) {
196 context->perli = perl_alloc();
197 PERL_SET_CONTEXT(context->perli);
198 logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
200 logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
202 context->perli_ready = 0;
203 strcpy(context->filterClass, "");
207 void grs_destroy_perl(void *clientData)
209 struct perl_context *context = (struct perl_context *) clientData;
211 logf (LOG_LOG, "Destroying perl interpreter context");
212 if (context->perli_ready) {
215 if (context->origi == NULL) perl_destruct(context->perli);
217 if (context->origi == NULL) perl_free(context->perli);
221 static data1_node *grs_read_perl (struct grs_read_info *p)
223 struct perl_context *context = (struct perl_context *) p->clientData;
224 char *filterClass = p->type;
226 /* The "file" manipulation function wrappers */
227 context->readf = p->readf;
228 context->seekf = p->seekf;
229 context->tellf = p->tellf;
230 context->endf = p->endf;
232 /* The "file", data1 and NMEM handles */
235 context->mem = p->mem;
237 /* If the class was not interpreted before... */
238 /* This is not too efficient, when indexing with many different filters... */
239 if (strcmp(context->filterClass,filterClass)) {
241 char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
242 char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
243 char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
245 if (context->perli_ready) {
248 if (context->origi == NULL) perl_destruct(context->perli);
250 if (context->origi == NULL) perl_construct(context->perli);
253 context->perli_ready = 1;
255 /* parse, and run the init call */
256 if (context->origi == NULL) {
257 logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
259 arglist[2] = (char *) data1_get_tabpath(p->dh);
260 sprintf(modarg,"-M%s",filterClass);
261 arglist[3] = (char *) &modarg;
262 sprintf(initarg,"%s->init;",filterClass);
263 arglist[5] = (char *) &initarg;
265 perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
266 perl_run(context->perli);
269 strcpy(context->filterClass, filterClass);
271 /* create the filter object as a filterClass blessed reference */
272 Filter_create(context);
275 /* Wow... if calling with individual update_record calls from perl,
276 the filter object reference may go out of scope... */
277 if (!SvOK(context->filterRef)) Filter_create(context);
280 /* call the process method */
281 Filter_process(context);
283 /* return the created data1 node */
284 return (context->res);
287 static struct recTypeGrs perl_type = {
294 RecTypeGrs recTypeGrs_perl = &perl_type;