recctrl/perlread.c

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