-/* $Id: perlread.c,v 1.4 2002-11-18 13:11:30 pop Exp $
- Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002
+/* $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.
#include <ctype.h>
#include <yaz/tpath.h>
-#include <zebrautl.h>
-#include <dfa.h>
-#include "grsread.h"
-
-
-#define GRS_PERL_MODULE_NAME_MAXLEN 255
-
-/* Context information for the filter */
-struct perl_context {
- PerlInterpreter *perli;
- PerlInterpreter *origi;
- int perli_ready;
- char filterClass[GRS_PERL_MODULE_NAME_MAXLEN];
- SV *filterRef;
-
- int (*readf)(void *, char *, size_t);
- off_t (*seekf)(void *, off_t);
- off_t (*tellf)(void *);
- void (*endf)(void *, off_t);
-
- void *fh;
- data1_handle dh;
- NMEM mem;
- data1_node *res;
-};
+#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,
+ 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", 0);
-
- SPAGAIN ;
- context->filterRef = POPs;
- PUTBACK ;
+ 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 ;
}
/*
int Filter_process (struct perl_context *context)
{
-
- int res;
-
- dSP;
-
- PUSHMARK(SP) ;
- XPUSHs(context->filterRef);
- PUTBACK ;
- call_method("_process", 0);
- SPAGAIN ;
- res = POPi;
- PUTBACK ;
- return (res);
+
+ int res;
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(context->filterRef);
+ PUTBACK ;
+ call_method("_process", 0);
+ SPAGAIN ;
+ res = POPi;
+ PUTBACK ;
+
+ FREETMPS;
+ LEAVE;
+
+ return (res);
}
/*
can hide this whole compexity behind.
*/
-void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
- dSP;
- PUSHMARK(SP) ;
- XPUSHs(context->filterRef);
- XPUSHs(sv_2mortal(newSVpv(buff, len)));
- PUTBACK ;
- call_method("_store_buff", 0);
- SPAGAIN ;
- PUTBACK ;
+
+#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_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);
}
-off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
- return ((*context->seekf)(context->fh, offset));
+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);
}
-off_t grs_perl_tellf(struct perl_context *context) {
- return ((*context->tellf)(context->fh));
+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);
+ }
}
-void grs_perl_endf(struct perl_context *context, off_t offset) {
- (*context->endf)(context->fh, offset);
+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);
+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);
+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;
+void grs_perl_set_res(struct perl_context *context, data1_node *n)
+{
+ context->res = n;
}
+#endif
/* The filter handlers (init, destroy, read) */
-static void *grs_init_perl(void)
+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 = PERL_GET_CONTEXT;
- if (context->origi == NULL) {
- 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, "");
- return (context);
+ 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;
}
-void grs_destroy_perl(void *clientData)
+static void config_perl(void *clientData, Res res, const char *args)
{
- 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);
+ struct perl_context *p = (struct perl_context*) clientData;
+ if (strlen(args) < sizeof(p->type))
+ strcpy(p->type, args);
}
-static data1_node *grs_read_perl (struct grs_read_info *p)
+static void destroy_perl(void *clientData)
{
- struct perl_context *context = (struct perl_context *) p->clientData;
- char *filterClass = p->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", "" };
-
+ 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);
+ /*
+ 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);
- }
+ if (context->origi == NULL) perl_free(context->perli);
+ xfree (context);
+}
- /* Wow... if calling with individual update_record calls from perl,
- the filter object reference may go out of scope... */
- if (!SvOK(context->filterRef)) Filter_create(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;
+}
- /* call the process method */
- Filter_process(context);
+static int extract_perl(void *clientData, struct recExtractCtrl *ctrl)
+{
+ return zebra_grs_extract(clientData, ctrl, grs_read_perl);
+}
- /* return the created data1 node */
- return (context->res);
+static int retrieve_perl(void *clientData, struct recRetrieveCtrl *ctrl)
+{
+ return zebra_grs_retrieve(clientData, ctrl, grs_read_perl);
}
-static struct recTypeGrs perl_type = {
- "perl",
- grs_init_perl,
- grs_destroy_perl,
- grs_read_perl
+static struct recType perl_type = {
+ "grs.perl",
+ init_perl,
+ config_perl,
+ destroy_perl,
+ extract_perl,
+ retrieve_perl,
};
-RecTypeGrs recTypeGrs_perl = &perl_type;
+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