recctrl/perlread.c

   1 /* $Id: perlread.c,v 1.3 2002-11-16 00:24:36 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", 0);
  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   PUSHMARK(SP) ;
  96   XPUSHs(context->filterRef);
  97   PUTBACK ;
  98   call_method("_process", 0);
  99   SPAGAIN ;
 100   res = POPi;
 101   PUTBACK ;
 102   return (res);
 103 }
 104
 105 /*
 106  This one is called to transfer the results of a readf. It's going to create
 107  a temporary variable there...
 108
 109  So the call stack is something like:
 110
 111
 112  ->Filter_process(context)                            [C]
 113    -> _process($context)                              [Perl]
 114     -> grs_perl_get_dh($context)                      [Perl]
 115       -> grs_perl_get_dh(context)                     [C]
 116     -> grs_perl_get_mem($context)                     [Perl]
 117       -> grs_perl_get_mem(context)                    [C]
 118     -> process()                                      [Perl]
 119       ...
 120       -> grs_perl_readf($context,$len)                [Perl]
 121         -> grs_perl_readf(context, len)               [C]
 122            ->(*context->readf)(context->fh, buf, len) [C]
 123         -> Filter_store_buff(context, buf, r)         [C]
 124            -> _store_buff($buff)                      [Perl]
 125         [... returns buff and length ...]
 126       ...
 127       [... returns d1 node ...]
 128     -> grs_perl_set_res($context, $node)              [Perl]
 129       -> grs_perl_set_res(context, node)              [C]
 130
 131  [... The result is in context->res ...]
 132
 133   Dirty, isn't it? It may become nicer, if I'll have some more time to work on
 134   it. However, these changes are not going to hurt the filter api, as
 135   Filter.pm, which is inherited into all specific filter implementations
 136   can hide this whole compexity behind.
 137
 138 */
 139 void Filter_store_buff (struct perl_context *context, char *buff, size_t len) {
 140   dSP;
 141   PUSHMARK(SP) ;
 142   XPUSHs(context->filterRef);
 143   XPUSHs(sv_2mortal(newSVpv(buff, len)));
 144   PUTBACK ;
 145   call_method("_store_buff", 0);
 146   SPAGAIN ;
 147   PUTBACK ;
 148 }
 149 /*  The "file" manipulation function wrappers */
 150 int grs_perl_readf(struct perl_context *context, size_t len) {
 151   int r;
 152   char *buf = (char *) xmalloc (len+1);
 153   r = (*context->readf)(context->fh, buf, len);
 154   if (r > 0) Filter_store_buff (context, buf, r);
 155   xfree (buf);
 156   return (r);
 157 }
 158
 159 off_t grs_perl_seekf(struct perl_context *context, off_t offset) {
 160   return ((*context->seekf)(context->fh, offset));
 161 }
 162
 163 off_t grs_perl_tellf(struct perl_context *context) {
 164   return ((*context->tellf)(context->fh));
 165 }
 166
 167 void grs_perl_endf(struct perl_context *context, off_t offset) {
 168   (*context->endf)(context->fh, offset);
 169 }
 170
 171 /* Get pointers from the context. Easyer to wrap this by SWIG */
 172 data1_handle grs_perl_get_dh(struct perl_context *context) {
 173   return(context->dh);
 174 }
 175
 176 NMEM grs_perl_get_mem(struct perl_context *context) {
 177   return(context->mem);
 178 }
 179
 180 /* Set the result in the context */
 181 void grs_perl_set_res(struct perl_context *context, data1_node *n) {
 182   context->res = n;
 183 }
 184
 185 /* The filter handlers (init, destroy, read) */
 186 static void *grs_init_perl(void)
 187 {
 188   struct perl_context *context =
 189     (struct perl_context *) xmalloc (sizeof(*context));
 190
 191   /* If there is an interpreter (context) running, - we are calling
 192      indexing and retrieval from the perl API - we don't create a new one. */
 193   context->origi = PERL_GET_CONTEXT;
 194   if (context->origi == NULL) {
 195     context->perli = perl_alloc();
 196     PERL_SET_CONTEXT(context->perli);
 197     logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
 198   } else {
 199     logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
 200   }
 201   context->perli_ready = 0;
 202   strcpy(context->filterClass, "");
 203   return (context);
 204 }
 205
 206 void grs_destroy_perl(void *clientData)
 207 {
 208   struct perl_context *context = (struct perl_context *) clientData;
 209
 210   logf (LOG_LOG, "Destroying perl interpreter context");
 211   if (context->perli_ready) {
 212     FREETMPS;
 213     LEAVE;
 214     if (context->origi == NULL)  perl_destruct(context->perli);
 215    }
 216   if (context->origi == NULL) perl_free(context->perli);
 217   xfree (context);
 218 }
 219
 220 static data1_node *grs_read_perl (struct grs_read_info *p)
 221 {
 222   struct perl_context *context = (struct perl_context *) p->clientData;
 223   char *filterClass = p->type;
 224
 225   /* The "file" manipulation function wrappers */
 226   context->readf = p->readf;
 227   context->seekf = p->seekf;
 228   context->tellf = p->tellf;
 229   context->endf  = p->endf;
 230
 231   /* The "file", data1 and NMEM handles */
 232   context->fh  = p->fh;
 233   context->dh  = p->dh;
 234   context->mem = p->mem;
 235
 236   /* If the class was not interpreted before... */
 237   /* This is not too efficient, when indexing with many different filters... */
 238   if (strcmp(context->filterClass,filterClass)) {
 239
 240     char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 241     char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 242     char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
 243
 244     if (context->perli_ready) {
 245       FREETMPS;
 246       LEAVE;
 247       if (context->origi == NULL) perl_destruct(context->perli);
 248     }
 249     if (context->origi == NULL) perl_construct(context->perli);
 250     ENTER;
 251     SAVETMPS;
 252     context->perli_ready = 1;
 253
 254     /* parse, and run the init call */
 255     if (context->origi == NULL) {
 256       logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
 257
 258       arglist[2] = (char *) data1_get_tabpath(p->dh);
 259       sprintf(modarg,"-M%s",filterClass);
 260       arglist[3] = (char *) &modarg;
 261       sprintf(initarg,"%s->init;",filterClass);
 262       arglist[5] = (char *) &initarg;
 263
 264       perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
 265       perl_run(context->perli);
 266     }
 267
 268     strcpy(context->filterClass, filterClass);
 269
 270     /* create the filter object as a filterClass blessed reference */
 271     Filter_create(context);
 272   }
 273
 274   /* Wow... if calling with individual update_record calls from perl,
 275      the filter object reference may go out of scope... */
 276   if (!SvOK(context->filterRef)) Filter_create(context);
 277
 278
 279   /* call the process method */
 280   Filter_process(context);
 281
 282   /* return the created data1 node */
 283   return (context->res);
 284 }
 285
 286 static struct recTypeGrs perl_type = {
 287     "perl",
 288     grs_init_perl,
 289     grs_destroy_perl,
 290     grs_read_perl
 291 };
 292
 293 RecTypeGrs recTypeGrs_perl = &perl_type;
 294
 295 /* HAVE_PERL */
 296 #endif