recctrl/perlread.c

   1 /* $Id: perlread.c,v 1.10 2004-09-27 10:44:50 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 /* Constructor call for the filter object */
  39 void Filter_create (struct perl_context *context)
  40 {
  41     dSP;
  42     SV *msv;
  43
  44     PUSHMARK(SP) ;
  45     XPUSHs(sv_2mortal(newSVpv(context->filterClass,
  46                             strlen(context->filterClass)))) ;
  47     msv = sv_newmortal();
  48     sv_setref_pv(msv, "_p_perl_context", (void*)context);
  49     XPUSHs(msv) ;
  50     PUTBACK ;
  51     call_method("new", G_EVAL);
  52
  53     SPAGAIN ;
  54     context->filterRef = POPs;
  55     PUTBACK ;
  56 }
  57
  58 /*
  59  Execute the process call on the filter. This is a bit dirty.
  60  The perl code is going to get dh and nmem from the context trough callbacks,
  61  then call readf, to get the stream, and then set the res (d1 node)
  62  in the context. However, it's safer, to let swig do as much of wrapping
  63  as possible.
  64  */
  65 int Filter_process (struct perl_context *context)
  66
  67 {
  68
  69     int res;
  70
  71     dSP;
  72
  73     ENTER;
  74     SAVETMPS;
  75
  76     PUSHMARK(SP) ;
  77     XPUSHs(context->filterRef);
  78     PUTBACK ;
  79     call_method("_process", 0);
  80     SPAGAIN ;
  81     res = POPi;
  82     PUTBACK ;
  83
  84     FREETMPS;
  85     LEAVE;
  86
  87     return (res);
  88 }
  89
  90 /*
  91  This one is called to transfer the results of a readf. It's going to create
  92  a temporary variable there...
  93
  94  So the call stack is something like:
  95
  96
  97  ->Filter_process(context)                            [C]
  98    -> _process($context)                              [Perl]
  99     -> grs_perl_get_dh($context)                      [Perl]
 100       -> grs_perl_get_dh(context)                     [C]
 101     -> grs_perl_get_mem($context)                     [Perl]
 102       -> grs_perl_get_mem(context)                    [C]
 103     -> process()                                      [Perl]
 104       ...
 105       -> grs_perl_readf($context,$len)                [Perl]
 106         -> grs_perl_readf(context, len)               [C]
 107            ->(*context->readf)(context->fh, buf, len) [C]
 108         -> Filter_store_buff(context, buf, r)         [C]
 109            -> _store_buff($buff)                      [Perl]
 110         [... returns buff and length ...]
 111       ...
 112       [... returns d1 node ...]
 113     -> grs_perl_set_res($context, $node)              [Perl]
 114       -> grs_perl_set_res(context, node)              [C]
 115
 116  [... The result is in context->res ...]
 117
 118   Dirty, isn't it? It may become nicer, if I'll have some more time to work on
 119   it. However, these changes are not going to hurt the filter api, as
 120   Filter.pm, which is inherited into all specific filter implementations
 121   can hide this whole compexity behind.
 122
 123 */
 124
 125 #if 0
 126 void Filter_store_buff (struct perl_context *context, char *buff, size_t len)
 127 {
 128     dSP;
 129
 130     ENTER;
 131     SAVETMPS;
 132
 133     PUSHMARK(SP) ;
 134     XPUSHs(context->filterRef);
 135     XPUSHs(sv_2mortal(newSVpv(buff, len)));
 136     PUTBACK ;
 137     call_method("_store_buff", 0);
 138     SPAGAIN ;
 139     PUTBACK ;
 140
 141     FREETMPS;
 142     LEAVE;
 143 }
 144
 145 /*  The "file" manipulation function wrappers */
 146 int grs_perl_readf(struct perl_context *context, size_t len)
 147 {
 148     int r;
 149     char *buf = (char *) xmalloc (len+1);
 150     r = (*context->readf)(context->fh, buf, len);
 151     if (r > 0) Filter_store_buff (context, buf, r);
 152     xfree (buf);
 153     return (r);
 154 }
 155
 156 int grs_perl_readline(struct perl_context *context)
 157 {
 158     int r;
 159     char *buf = (char *) xmalloc (4096);
 160     char *p = buf;
 161
 162     while ((r = (*context->readf)(context->fh,p,1)) && (p-buf < 4095)) {
 163         p++;
 164         if (*(p-1) == 10) break;
 165     }
 166
 167     *p = 0;
 168
 169     if (p != buf) Filter_store_buff (context, buf, p - buf);
 170     xfree (buf);
 171     return (p - buf);
 172 }
 173
 174 char grs_perl_getc(struct perl_context *context)
 175 {
 176     int r;
 177     char *p;
 178     if ((r = (*context->readf)(context->fh,p,1))) {
 179         return (*p);
 180     } else {
 181         return (0);
 182     }
 183 }
 184
 185 off_t grs_perl_seekf(struct perl_context *context, off_t offset)
 186 {
 187     return ((*context->seekf)(context->fh, offset));
 188 }
 189
 190 off_t grs_perl_tellf(struct perl_context *context)
 191 {
 192     return ((*context->tellf)(context->fh));
 193 }
 194
 195 void grs_perl_endf(struct perl_context *context, off_t offset)
 196 {
 197     (*context->endf)(context->fh, offset);
 198 }
 199
 200 /* Get pointers from the context. Easyer to wrap this by SWIG */
 201 data1_handle *grs_perl_get_dh(struct perl_context *context)
 202 {
 203     return(&context->dh);
 204 }
 205
 206 NMEM *grs_perl_get_mem(struct perl_context *context)
 207 {
 208     return(&context->mem);
 209 }
 210
 211 /* Set the result in the context */
 212 void grs_perl_set_res(struct perl_context *context, data1_node *n)
 213 {
 214     context->res = n;
 215 }
 216 #endif
 217
 218 /* The filter handlers (init, destroy, read) */
 219 static void *init_perl(Res res, RecType rt)
 220 {
 221     struct perl_context *context =
 222         (struct perl_context *) xmalloc (sizeof(*context));
 223
 224     /* If there is an interpreter (context) running, - we are calling
 225        indexing and retrieval from the perl API - we don't create a new one. */
 226     context->origi = PL_curinterp;
 227
 228     if (!context->origi) {
 229         context->perli = perl_alloc();
 230         PERL_SET_CONTEXT(context->perli);
 231         logf (LOG_LOG, "Initializing new perl interpreter context (%p)",context->perli);
 232     } else {
 233         logf (LOG_LOG, "Using existing perl interpreter context (%p)",context->origi);
 234     }
 235     context->perli_ready = 0;
 236     strcpy(context->filterClass, "");
 237     strcpy(context->type, "");
 238     return context;
 239 }
 240
 241 static void config_perl(void *clientData, Res res, const char *args)
 242 {
 243     struct perl_context *p = (struct perl_context*) clientData;
 244     if (strlen(args) < sizeof(p->type))
 245         strcpy(p->type, args);
 246 }
 247
 248 static void destroy_perl(void *clientData)
 249 {
 250     struct perl_context *context = (struct perl_context *) clientData;
 251
 252     logf (LOG_LOG, "Destroying perl interpreter context");
 253     if (context->perli_ready) {
 254         /*
 255           FREETMPS;
 256           LEAVE;
 257         */
 258         if (context->origi == NULL)  perl_destruct(context->perli);
 259     }
 260     if (context->origi == NULL) perl_free(context->perli);
 261     xfree (context);
 262 }
 263
 264 static data1_node *grs_read_perl (struct grs_read_info *p)
 265 {
 266     struct perl_context *context = (struct perl_context *) p->clientData;
 267     char *filterClass = context->type;
 268
 269     /* The "file" manipulation function wrappers */
 270     context->readf = p->readf;
 271     context->seekf = p->seekf;
 272     context->tellf = p->tellf;
 273     context->endf  = p->endf;
 274
 275     /* The "file", data1 and NMEM handles */
 276     context->fh  = p->fh;
 277     context->dh  = p->dh;
 278     context->mem = p->mem;
 279
 280     /* If the class was not interpreted before... */
 281     /* This is not too efficient, when indexing with many different filters... */
 282     if (strcmp(context->filterClass, filterClass)) {
 283
 284         char modarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 285         char initarg[GRS_PERL_MODULE_NAME_MAXLEN + 2];
 286         char *arglist[6] = { "", "-I", "", "-M", "-e", "" };
 287
 288         if (context->perli_ready) {
 289             /*
 290               FREETMPS;
 291               LEAVE;
 292             */
 293             if (context->origi == NULL) {
 294                 perl_destruct(context->perli);
 295             }
 296         }
 297         if (context->origi == NULL) {
 298             perl_construct(context->perli);
 299         }
 300
 301
 302         /*
 303           ENTER;
 304           SAVETMPS;
 305         */
 306         context->perli_ready = 1;
 307
 308         /* parse, and run the init call */
 309         if (context->origi == NULL) {
 310             logf (LOG_LOG, "Interpreting filter class:%s", filterClass);
 311
 312             arglist[2] = (char *) data1_get_tabpath(p->dh);
 313             sprintf(modarg,"-M%s",filterClass);
 314             arglist[3] = (char *) &modarg;
 315             sprintf(initarg,"%s->init;",filterClass);
 316             arglist[5] = (char *) &initarg;
 317
 318             perl_parse(context->perli, PERL_XS_INIT, 6, arglist, NULL);
 319             perl_run(context->perli);
 320         }
 321
 322         strcpy(context->filterClass, filterClass);
 323
 324         /* create the filter object as a filterClass blessed reference */
 325         Filter_create(context);
 326     }
 327
 328     /* Wow... if calling with individual update_record calls from perl,
 329        the filter object reference may go out of scope... */
 330     if (!sv_isa(context->filterRef, context->filterClass)) {
 331         Filter_create(context);
 332         logf (LOG_DEBUG,"Filter recreated");
 333     }
 334
 335     if (!SvTRUE(context->filterRef))
 336     {
 337         logf (LOG_WARN,"Failed to initialize perl filter %s",context->filterClass);
 338         return (0);
 339     }
 340
 341     /* call the process method */
 342     Filter_process(context);
 343
 344     /* return the created data1 node */
 345     return context->res;
 346 }
 347
 348 static int extract_perl(void *clientData, struct recExtractCtrl *ctrl)
 349 {
 350     return zebra_grs_extract(clientData, ctrl, grs_read_perl);
 351 }
 352
 353 static int retrieve_perl(void *clientData, struct recRetrieveCtrl *ctrl)
 354 {
 355     return zebra_grs_retrieve(clientData, ctrl, grs_read_perl);
 356 }
 357
 358 static struct recType perl_type = {
 359     "grs.perl",
 360     init_perl,
 361     config_perl,
 362     destroy_perl,
 363     extract_perl,
 364     retrieve_perl,
 365 };
 366
 367 RecType
 368 #ifdef IDZEBRA_STATIC_GRS_PERL
 369 idzebra_filter_grs_perl
 370 #else
 371 idzebra_filter
 372 #endif
 373
 374 [] = {
 375     &perl_type,
 376     0,
 377 };
 378
 379
 380 /* HAVE_PERL */
 381 #endif