recctrl/perlread.c

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