recctrl/perlread.c

   1 /* $Id: perlread.c,v 1.8.2.2 2004-09-03 10:36:26 adam Exp $
   2    Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
   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 {
 148     dSP;
 149
 150     ENTER;
 151     SAVETMPS;
 152
 153     PUSHMARK(SP) ;
 154     XPUSHs(context->filterRef);
 155     XPUSHs(sv_2mortal(newSVpv(buff, len)));
 156     PUTBACK ;
 157     call_method("_store_buff", 0);
 158     SPAGAIN ;
 159     PUTBACK ;
 160
 161     FREETMPS;
 162     LEAVE;
 163 }
 164
 165 /*  The "file" manipulation function wrappers */
 166 int grs_perl_readf(struct perl_context *context, size_t len)
 167 {
 168     int r;
 169     char *buf = (char *) xmalloc (len+1);
 170     r = (*context->readf)(context->fh, buf, len);
 171     if (r > 0) Filter_store_buff (context, buf, r);
 172     xfree (buf);
 173     return (r);
 174 }
 175
 176 int grs_perl_readline(struct perl_context *context)
 177 {
 178     int r;
 179     char *buf = (char *) xmalloc (4096);
 180     char *p = buf;
 181
 182     while ((r = (*context->readf)(context->fh,p,1)) && (p-buf < 4095)) {
 183         p++;
 184         if (*(p-1) == 10) break;
 185     }
 186
 187     *p = 0;
 188
 189     if (p != buf) Filter_store_buff (context, buf, p - buf);
 190     xfree (buf);
 191     return (p - buf);
 192 }
 193
 194 char grs_perl_getc(struct perl_context *context)
 195 {
 196     int r;
 197     char *p;
 198     if ((r = (*context->readf)(context->fh,p,1))) {
 199         return (*p);
 200     } else {
 201         return (0);
 202     }
 203 }
 204
 205 off_t grs_perl_seekf(struct perl_context *context, off_t offset)
 206 {
 207     return ((*context->seekf)(context->fh, offset));
 208 }
 209
 210 off_t grs_perl_tellf(struct perl_context *context)
 211 {
 212     return ((*context->tellf)(context->fh));
 213 }
 214
 215 void grs_perl_endf(struct perl_context *context, off_t offset)
 216 {
 217     (*context->endf)(context->fh, offset);
 218 }
 219
 220 /* Get pointers from the context. Easyer to wrap this by SWIG */
 221 data1_handle *grs_perl_get_dh(struct perl_context *context)
 222 {
 223     return(&context->dh);
 224 }
 225
 226 NMEM *grs_perl_get_mem(struct perl_context *context)
 227 {
 228     return(&context->mem);
 229 }
 230
 231 /* Set the result in the context */
 232 void grs_perl_set_res(struct perl_context *context, data1_node *n)
 233 {
 234     context->res = n;
 235 }
 236
 237 /* The filter handlers (init, destroy, read) */
 238 static void *grs_init_perl(void)
 239 {
 240     struct perl_context *context =
 241         (struct perl_context *) xmalloc (sizeof(*context));
 242
 243     /* If there is an interpreter (context) running, - we are calling
 244        indexing and retrieval from the perl API - we don't create a new one. */
 245 #if PERL_VERSION >= 8
 246     /* with Perl 5.8 context may be non-NULL even though it's not there! */
 247     context->origi = 0;
 248 #else
 249     context->origi = PERL_GET_CONTEXT;
 250 #endif
 251     if (context->origi == NULL) {
 252         context->perli = perl_alloc();
 253         PERL_SET_CONTEXT(context->perli);
 254         logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
 255     } else {
 256         logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
 257     }
 258     context->perli_ready = 0;
 259     strcpy(context->filterClass, "");
 260     return (context);
 261 }
 262
 263 void grs_destroy_perl(void *clientData)
 264 {
 265     struct perl_context *context = (struct perl_context *) clientData;
 266
 267     logf (LOG_LOG, "Destroying perl interpreter context");
 268     if (context->perli_ready) {
 269         /*
 270           FREETMPS;
 271           LEAVE;
 272         */
 273         if (context->origi == NULL)  perl_destruct(context->perli);
 274     }
 275     if (context->origi == NULL) perl_free(context->perli);
 276     xfree (context);
 277 }
 278
 279 static data1_node *grs_read_perl (struct grs_read_info *p)
 280 {
 281     struct perl_context *context = (struct perl_context *) p->clientData;
 282     char *filterClass = p->type;
 283
 284     /* The "file" manipulation function wrappers */
 285     context->readf = p->readf;
 286     context->seekf = p->seekf;
 287     context->tellf = p->tellf;
 288     context->endf  = p->endf;
 289
 290     /* The "file", data1 and NMEM handles */
 291     context->fh  = p->fh;
 292     context->dh  = p->dh;
 293     context->mem = p->mem;
 294
 295     /* If the class was not interpreted before... */
 296     /* This is not too efficient, when indexing with many different filters... */
 297     if (strcmp(context->filterClass,filterClass)) {
 298
 299         char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 300         char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 301         char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
 302
 303         if (context->perli_ready) {
 304             /*
 305               FREETMPS;
 306               LEAVE;
 307             */
 308             if (context->origi == NULL) {
 309                 perl_destruct(context->perli);
 310             }
 311         }
 312         if (context->origi == NULL) {
 313             perl_construct(context->perli);
 314         }
 315
 316
 317         /*
 318           ENTER;
 319           SAVETMPS;
 320         */
 321         context->perli_ready = 1;
 322
 323         /* parse, and run the init call */
 324         if (context->origi == NULL) {
 325             logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
 326
 327             arglist[2] = (char *) data1_get_tabpath(p->dh);
 328             sprintf(modarg,"-M%s",filterClass);
 329             arglist[3] = (char *) &modarg;
 330             sprintf(initarg,"%s->init;",filterClass);
 331             arglist[5] = (char *) &initarg;
 332
 333             perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
 334             perl_run(context->perli);
 335         }
 336
 337         strcpy(context->filterClass, filterClass);
 338
 339         /* create the filter object as a filterClass blessed reference */
 340         Filter_create(context);
 341     }
 342
 343     /* Wow... if calling with individual update_record calls from perl,
 344        the filter object reference may go out of scope... */
 345     if (!sv_isa(context->filterRef, context->filterClass)) {
 346         Filter_create(context);
 347         logf (LOG_DEBUG,"Filter recreated");
 348     }
 349
 350     if (!SvTRUE(context->filterRef))
 351     {
 352         logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
 353         return (0);
 354     }
 355
 356     /* call the process method */
 357     Filter_process(context);
 358
 359     /* return the created data1 node */
 360     return (context->res);
 361 }
 362
 363 static struct recTypeGrs perl_type = {
 364     "perl",
 365     grs_init_perl,
 366     grs_destroy_perl,
 367     grs_read_perl
 368 };
 369
 370 RecTypeGrs recTypeGrs_perl = &perl_type;
 371
 372 /* HAVE_PERL */
 373 #endif