+++ /dev/null
-/* $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 <stdio.h>
-#include <string.h>
-#include <ctype.h>
-
-#include <yaz/tpath.h>
-#include <idzebra/recgrs.h>
-
-/* 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
projects / idzebra-moved-to-github.git / blobdiff