X-Git-Url: http://jsfdemo.indexdata.com/?a=blobdiff_plain;f=recctrl%2Fperlread.c;fp=recctrl%2Fperlread.c;h=0000000000000000000000000000000000000000;hb=5e9aca2e8f33fe023b6b9da6df55642f96efcb50;hp=ea8ac1ee3e09e200bb925fb61e9f82d35a2ebcf3;hpb=36f8c4a15cad06268b2d5621aed28ab16c015cc5;p=idzebra-moved-to-github.git diff --git a/recctrl/perlread.c b/recctrl/perlread.c deleted file mode 100644 index ea8ac1e..0000000 --- a/recctrl/perlread.c +++ /dev/null @@ -1,379 +0,0 @@ -/* $Id: perlread.c,v 1.11 2004-09-28 10:15:03 adam Exp $ - Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004 - Index Data Aps - -This file is part of the Zebra server. - -Zebra is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later -version. - -Zebra is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with Zebra; see the file LICENSE.zebra. If not, write to the -Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. -*/ - -#if HAVE_PERL -#include "perlread.h" -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include -#include -#include - -#include -#include - -/* Constructor call for the filter object */ -void Filter_create (struct perl_context *context) -{ - dSP; - SV *msv; - - PUSHMARK(SP) ; - XPUSHs(sv_2mortal(newSVpv(context->filterClass, - strlen(context->filterClass)))) ; - msv = sv_newmortal(); - sv_setref_pv(msv, "_p_perl_context", (void*)context); - XPUSHs(msv) ; - PUTBACK ; - call_method("new", G_EVAL); - - SPAGAIN ; - context->filterRef = POPs; - PUTBACK ; -} - -/* - Execute the process call on the filter. This is a bit dirty. - The perl code is going to get dh and nmem from the context trough callbacks, - then call readf, to get the stream, and then set the res (d1 node) - in the context. However, it's safer, to let swig do as much of wrapping - as possible. - */ -int Filter_process (struct perl_context *context) - -{ - - int res; - - dSP; - - ENTER; - SAVETMPS; - - PUSHMARK(SP) ; - XPUSHs(context->filterRef); - PUTBACK ; - call_method("_process", 0); - SPAGAIN ; - res = POPi; - PUTBACK ; - - FREETMPS; - LEAVE; - - return (res); -} - -/* - This one is called to transfer the results of a readf. It's going to create - a temporary variable there... - - So the call stack is something like: - - - ->Filter_process(context) [C] - -> _process($context) [Perl] - -> grs_perl_get_dh($context) [Perl] - -> grs_perl_get_dh(context) [C] - -> grs_perl_get_mem($context) [Perl] - -> grs_perl_get_mem(context) [C] - -> process() [Perl] - ... - -> grs_perl_readf($context,$len) [Perl] - -> grs_perl_readf(context, len) [C] - ->(*context->readf)(context->fh, buf, len) [C] - -> Filter_store_buff(context, buf, r) [C] - -> _store_buff($buff) [Perl] - [... returns buff and length ...] - ... - [... returns d1 node ...] - -> grs_perl_set_res($context, $node) [Perl] - -> grs_perl_set_res(context, node) [C] - - [... The result is in context->res ...] - - Dirty, isn't it? It may become nicer, if I'll have some more time to work on - it. However, these changes are not going to hurt the filter api, as - Filter.pm, which is inherited into all specific filter implementations - can hide this whole compexity behind. - -*/ - -#if 0 -void Filter_store_buff (struct perl_context *context, char *buff, size_t len) -{ - dSP; - - ENTER; - SAVETMPS; - - PUSHMARK(SP) ; - XPUSHs(context->filterRef); - XPUSHs(sv_2mortal(newSVpv(buff, len))); - PUTBACK ; - call_method("_store_buff", 0); - SPAGAIN ; - PUTBACK ; - - FREETMPS; - LEAVE; -} - -/* The "file" manipulation function wrappers */ -int grs_perl_readf(struct perl_context *context, size_t len) -{ - int r; - char *buf = (char *) xmalloc (len+1); - r = (*context->readf)(context->fh, buf, len); - if (r > 0) Filter_store_buff (context, buf, r); - xfree (buf); - return (r); -} - -int grs_perl_readline(struct perl_context *context) -{ - int r; - char *buf = (char *) xmalloc (4096); - char *p = buf; - - while ((r = (*context->readf)(context->fh,p,1)) && (p-buf < 4095)) { - p++; - if (*(p-1) == 10) break; - } - - *p = 0; - - if (p != buf) Filter_store_buff (context, buf, p - buf); - xfree (buf); - return (p - buf); -} - -char grs_perl_getc(struct perl_context *context) -{ - int r; - char *p; - if ((r = (*context->readf)(context->fh,p,1))) { - return (*p); - } else { - return (0); - } -} - -off_t grs_perl_seekf(struct perl_context *context, off_t offset) -{ - return ((*context->seekf)(context->fh, offset)); -} - -off_t grs_perl_tellf(struct perl_context *context) -{ - return ((*context->tellf)(context->fh)); -} - -void grs_perl_endf(struct perl_context *context, off_t offset) -{ - (*context->endf)(context->fh, offset); -} - -/* Get pointers from the context. Easyer to wrap this by SWIG */ -data1_handle *grs_perl_get_dh(struct perl_context *context) -{ - return(&context->dh); -} - -NMEM *grs_perl_get_mem(struct perl_context *context) -{ - return(&context->mem); -} - -/* Set the result in the context */ -void grs_perl_set_res(struct perl_context *context, data1_node *n) -{ - context->res = n; -} -#endif - -/* The filter handlers (init, destroy, read) */ -static void *init_perl(Res res, RecType rt) -{ - struct perl_context *context = - (struct perl_context *) xmalloc (sizeof(*context)); - - /* If there is an interpreter (context) running, - we are calling - indexing and retrieval from the perl API - we don't create a new one. */ - context->origi = PL_curinterp; - - if (!context->origi) { - context->perli = perl_alloc(); - PERL_SET_CONTEXT(context->perli); - logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli); - } else { - logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi); - } - context->perli_ready = 0; - strcpy(context->filterClass, ""); - strcpy(context->type, ""); - return context; -} - -static void config_perl(void *clientData, Res res, const char *args) -{ - struct perl_context *p = (struct perl_context*) clientData; - if (strlen(args) < sizeof(p->type)) - strcpy(p->type, args); -} - -static void destroy_perl(void *clientData) -{ - struct perl_context *context = (struct perl_context *) clientData; - - logf (LOG_LOG, "Destroying perl interpreter context"); - if (context->perli_ready) { - /* - FREETMPS; - LEAVE; - */ - if (context->origi == NULL) perl_destruct(context->perli); - } - if (context->origi == NULL) perl_free(context->perli); - xfree (context); -} - -static data1_node *grs_read_perl (struct grs_read_info *p) -{ - struct perl_context *context = (struct perl_context *) p->clientData; - char *filterClass = context->type; - - /* The "file" manipulation function wrappers */ - context->readf = p->readf; - context->seekf = p->seekf; - context->tellf = p->tellf; - context->endf = p->endf; - - /* The "file", data1 and NMEM handles */ - context->fh = p->fh; - context->dh = p->dh; - context->mem = p->mem; - - /* If the class was not interpreted before... */ - /* This is not too efficient, when indexing with many different filters... */ - if (strcmp(context->filterClass, filterClass)) { - - char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2]; - char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2]; - char *arglist[6] = { "", "-I", "", "-M", "-e", "" }; - - if (context->perli_ready) { - /* - FREETMPS; - LEAVE; - */ - if (context->origi == NULL) { - perl_destruct(context->perli); - } - } - if (context->origi == NULL) { - perl_construct(context->perli); - } - - - /* - ENTER; - SAVETMPS; - */ - context->perli_ready = 1; - - /* parse, and run the init call */ - if (context->origi == NULL) { - logf (LOG_LOG, "Interpreting filter class:%s", filterClass); - - arglist[2] = (char *) data1_get_tabpath(p->dh); - sprintf(modarg,"-M%s",filterClass); - arglist[3] = (char *) &modarg; - sprintf(initarg,"%s->init;",filterClass); - arglist[5] = (char *) &initarg; - - perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL); - perl_run(context->perli); - } - - strcpy(context->filterClass, filterClass); - - /* create the filter object as a filterClass blessed reference */ - Filter_create(context); - } - - /* Wow... if calling with individual update_record calls from perl, - the filter object reference may go out of scope... */ - if (!sv_isa(context->filterRef, context->filterClass)) { - Filter_create(context); - logf (LOG_DEBUG,"Filter recreated"); - } - - if (!SvTRUE(context->filterRef)) - { - logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass); - return (0); - } - - /* call the process method */ - Filter_process(context); - - /* return the created data1 node */ - return context->res; -} - -static int extract_perl(void *clientData, struct recExtractCtrl *ctrl) -{ - return zebra_grs_extract(clientData, ctrl, grs_read_perl); -} - -static int retrieve_perl(void *clientData, struct recRetrieveCtrl *ctrl) -{ - return zebra_grs_retrieve(clientData, ctrl, grs_read_perl); -} - -static struct recType perl_type = { - "grs.perl", - init_perl, - config_perl, - destroy_perl, - extract_perl, - retrieve_perl, -}; - -RecType -#ifdef IDZEBRA_STATIC_GRS_PERL -idzebra_filter_grs_perl -#else -idzebra_filter -#endif - -[] = { - &perl_type, - 0, -}; - - -/* HAVE_PERL */ -#endif