recctrl/perlread.c

   1 /* $Id: perlread.c,v 1.6 2003-02-27 23:21:40 pop Exp $
   2    Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002
   3    Index Data Aps
   4
   5 This file is part of the Zebra server.
   6
   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
  10 version.
  11
  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
  15 for more details.
  16
  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
  20 02111-1307, USA.
  21 */
  22
  23 #if HAVE_PERL
  24 #include "perlread.h"
  25 #include "EXTERN.h"
  26 #include "perl.h"
  27 #include "XSUB.h"
  28
  29 #include <stdio.h>
  30 #include <string.h>
  31 #include <ctype.h>
  32
  33 #include <yaz/tpath.h>
  34 #include <zebrautl.h>
  35 #include <dfa.h>
  36 #include "grsread.h"
  37
  38
  39 #define GRS_PERL_MODULE_NAME_MAXLEN 255
  40
  41 /* Context information for the filter */
  42 struct perl_context {
  43   PerlInterpreter *perli;
  44   PerlInterpreter *origi;
  45   int perli_ready;
  46   char filterClass[GRS_PERL_MODULE_NAME_MAXLEN];
  47   SV *filterRef;
  48
  49   int (*readf)(void *, char *, size_t);
  50   off_t (*seekf)(void *, off_t);
  51   off_t (*tellf)(void *);
  52   void (*endf)(void *, off_t);
  53
  54   void *fh;
  55   data1_handle dh;
  56   NMEM mem;
  57   data1_node *res;
  58 };
  59
  60 /* Constructor call for the filter object */
  61 void Filter_create (struct perl_context *context)
  62 {
  63   dSP;
  64   SV *msv;
  65
  66   PUSHMARK(SP) ;
  67   XPUSHs(sv_2mortal(newSVpv(context->filterClass,
  68                             strlen(context->filterClass)))) ;
  69   msv = sv_newmortal();
  70   sv_setref_pv(msv, "_p_perl_context", (void*)context);
  71   XPUSHs(msv) ;
  72   PUTBACK ;
  73   call_method("new", G_EVAL);
  74
  75   SPAGAIN ;
  76   context->filterRef = POPs;
  77   PUTBACK ;
  78 }
  79
  80 /*
  81  Execute the process call on the filter. This is a bit dirty.
  82  The perl code is going to get dh and nmem from the context trough callbacks,
  83  then call readf, to get the stream, and then set the res (d1 node)
  84  in the context. However, it's safer, to let swig do as much of wrapping
  85  as possible.
  86  */
  87 int Filter_process (struct perl_context *context)
  88
  89 {
  90
  91   int res;
  92
  93   dSP;
  94
  95   ENTER;
  96   SAVETMPS;
  97
  98   PUSHMARK(SP) ;
  99   XPUSHs(context->filterRef);
 100   PUTBACK ;
 101   call_method("_process", 0);
 102   SPAGAIN ;
 103   res = POPi;
 104   PUTBACK ;
 105
 106   FREETMPS;
 107   LEAVE;
 108   return (res);
 109 }
 110
 111 /*
 112  This one is called to transfer the results of a readf. It's going to create
 113  a temporary variable there...
 114
 115  So the call stack is something like:
 116
 117
 118  ->Filter_process(context)                            [C]
 119    -> _process($context)                              [Perl]
 120     -> grs_perl_get_dh($context)                      [Perl]
 121       -> grs_perl_get_dh(context)                     [C]
 122     -> grs_perl_get_mem($context)                     [Perl]
 123       -> grs_perl_get_mem(context)                    [C]
 124     -> process()                                      [Perl]
 125       ...
 126       -> grs_perl_readf($context,$len)                [Perl]
 127         -> grs_perl_readf(context, len)               [C]
 128            ->(*context->readf)(context->fh, buf, len) [C]
 129         -> Filter_store_buff(context, buf, r)         [C]
 130            -> _store_buff($buff)                      [Perl]
 131         [... returns buff and length ...]
 132       ...
 133       [... returns d1 node ...]
 134     -> grs_perl_set_res($context, $node)              [Perl]
 135       -> grs_perl_set_res(context, node)              [C]
 136
 137  [... The result is in context->res ...]
 138
 139   Dirty, isn't it? It may become nicer, if I'll have some more time to work on
 140   it. However, these changes are not going to hurt the filter api, as
 141   Filter.pm, which is inherited into all specific filter implementations
 142   can hide this whole compexity behind.
 143
 144 */
 145 void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
 146   dSP;
 147
 148   ENTER;
 149   SAVETMPS;
 150
 151   PUSHMARK(SP) ;
 152   XPUSHs(context->filterRef);
 153   XPUSHs(sv_2mortal(newSVpv(buff, len)));
 154   PUTBACK ;
 155   call_method("_store_buff", 0);
 156   SPAGAIN ;
 157   PUTBACK ;
 158
 159   FREETMPS;
 160   LEAVE;
 161 }
 162 /*  The "file" manipulation function wrappers */
 163 int grs_perl_readf(struct perl_context *context, size_t len) {
 164   int r;
 165   char *buf = (char *) xmalloc (len+1);
 166   r = (*context->readf)(context->fh, buf, len);
 167   if (r > 0) Filter_store_buff (context, buf, r);
 168   xfree (buf);
 169   return (r);
 170 }
 171
 172 off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
 173   return ((*context->seekf)(context->fh, offset));
 174 }
 175
 176 off_t grs_perl_tellf(struct perl_context *context) {
 177   return ((*context->tellf)(context->fh));
 178 }
 179
 180 void grs_perl_endf(struct perl_context *context, off_t offset) {
 181   (*context->endf)(context->fh, offset);
 182 }
 183
 184 /* Get pointers from the context. Easyer to wrap this by SWIG */
 185 data1_handle *grs_perl_get_dh(struct perl_context *context) {
 186   return(&context->dh);
 187 }
 188
 189 NMEM *grs_perl_get_mem(struct perl_context *context) {
 190   return(&context->mem);
 191 }
 192
 193 /* Set the result in the context */
 194 void grs_perl_set_res(struct perl_context *context, data1_node *n) {
 195   context->res = n;
 196 }
 197
 198 /* The filter handlers (init, destroy, read) */
 199 static void *grs_init_perl(void)
 200 {
 201   struct perl_context *context =
 202     (struct perl_context *) xmalloc (sizeof(*context));
 203
 204   /* If there is an interpreter (context) running, - we are calling
 205      indexing and retrieval from the perl API - we don't create a new one. */
 206   context->origi = PERL_GET_CONTEXT;
 207   if (context->origi == NULL) {
 208     context->perli = perl_alloc();
 209     PERL_SET_CONTEXT(context->perli);
 210     logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
 211   } else {
 212     logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
 213   }
 214   context->perli_ready = 0;
 215   strcpy(context->filterClass, "");
 216   return (context);
 217 }
 218
 219 void grs_destroy_perl(void *clientData)
 220 {
 221   struct perl_context *context = (struct perl_context *) clientData;
 222
 223   logf (LOG_LOG, "Destroying perl interpreter context");
 224   if (context->perli_ready) {
 225     /*
 226     FREETMPS;
 227     LEAVE;
 228     */
 229     if (context->origi == NULL)  perl_destruct(context->perli);
 230    }
 231   if (context->origi == NULL) perl_free(context->perli);
 232   xfree (context);
 233 }
 234
 235 static data1_node *grs_read_perl (struct grs_read_info *p)
 236 {
 237   struct perl_context *context = (struct perl_context *) p->clientData;
 238   char *filterClass = p->type;
 239
 240   /* The "file" manipulation function wrappers */
 241   context->readf = p->readf;
 242   context->seekf = p->seekf;
 243   context->tellf = p->tellf;
 244   context->endf  = p->endf;
 245
 246   /* The "file", data1 and NMEM handles */
 247   context->fh  = p->fh;
 248   context->dh  = p->dh;
 249   context->mem = p->mem;
 250
 251   /* If the class was not interpreted before... */
 252   /* This is not too efficient, when indexing with many different filters... */
 253   if (strcmp(context->filterClass,filterClass)) {
 254
 255     char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 256     char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 257     char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
 258
 259     if (context->perli_ready) {
 260       /*
 261       FREETMPS;
 262       LEAVE;
 263       */
 264       if (context->origi == NULL) perl_destruct(context->perli);
 265     }
 266     if (context->origi == NULL) perl_construct(context->perli);
 267     /*
 268     ENTER;
 269     SAVETMPS;
 270     */
 271     context->perli_ready = 1;
 272
 273     /* parse, and run the init call */
 274     if (context->origi == NULL) {
 275       logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
 276
 277       arglist[2] = (char *) data1_get_tabpath(p->dh);
 278       sprintf(modarg,"-M%s",filterClass);
 279       arglist[3] = (char *) &modarg;
 280       sprintf(initarg,"%s->init;",filterClass);
 281       arglist[5] = (char *) &initarg;
 282
 283       perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
 284       perl_run(context->perli);
 285     }
 286
 287     strcpy(context->filterClass, filterClass);
 288
 289     /* create the filter object as a filterClass blessed reference */
 290     Filter_create(context);
 291   }
 292
 293   /* Wow... if calling with individual update_record calls from perl,
 294      the filter object reference may go out of scope... */
 295   if (!SvOK(context->filterRef)) Filter_create(context);
 296
 297   if (!SvTRUE(context->filterRef)) {
 298     logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
 299     return (0);
 300   }
 301
 302   /* call the process method */
 303   Filter_process(context);
 304
 305   /* return the created data1 node */
 306   return (context->res);
 307 }
 308
 309 static struct recTypeGrs perl_type = {
 310     "perl",
 311     grs_init_perl,
 312     grs_destroy_perl,
 313     grs_read_perl
 314 };
 315
 316 RecTypeGrs recTypeGrs_perl = &perl_type;
 317
 318 /* HAVE_PERL */
 319 #endif