recctrl/perlread.c

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