recctrl/perlread.c

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