SimpleServer.xs

   1 /*
   2  * $Id: SimpleServer.xs,v 1.37 2006-03-09 17:13:43 mike Exp $
   3  * ----------------------------------------------------------------------
   4  *
   5  * Copyright (c) 2000-2004, Index Data.
   6  *
   7  * Permission to use, copy, modify, distribute, and sell this software and
   8  * its documentation, in whole or in part, for any purpose, is hereby granted,
   9  * provided that:
  10  *
  11  * 1. This copyright and permission notice appear in all copies of the
  12  * software and its documentation. Notices of copyright or attribution
  13  * which appear at the beginning of any file must remain unchanged.
  14  *
  15  * 2. The name of Index Data or the individual authors may not be used to
  16  * endorse or promote products derived from this software without specific
  17  * prior written permission.
  18  *
  19  * THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT WARRANTY OF ANY KIND,
  20  * EXPRESS, IMPLIED, OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
  21  * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
  22  * IN NO EVENT SHALL INDEX DATA BE LIABLE FOR ANY SPECIAL, INCIDENTAL,
  23  * INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND, OR ANY DAMAGES
  24  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER OR
  25  * NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
  26  * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
  27  * OF THIS SOFTWARE.
  28  */
  29
  30 #include "EXTERN.h"
  31 #include "perl.h"
  32 #include "proto.h"
  33 #include "embed.h"
  34 #include "XSUB.h"
  35 #include <yaz/backend.h>
  36 #include <yaz/log.h>
  37 #include <yaz/wrbuf.h>
  38 #include <stdio.h>
  39 #ifdef WIN32
  40 #else
  41 #include <unistd.h>
  42 #endif
  43 #include <stdlib.h>
  44 #include <ctype.h>
  45 #define GRS_MAX_FIELDS 500
  46 #ifdef ASN_COMPILED
  47 #include <yaz/ill.h>
  48 #endif
  49 #ifndef sv_undef                /* To fix the problem with Perl 5.6.0 */
  50 #define sv_undef PL_sv_undef
  51 #endif
  52
  53 NMEM_MUTEX simpleserver_mutex;
  54
  55 typedef struct {
  56         SV *handle;
  57
  58         SV *init_ref;
  59         SV *close_ref;
  60         SV *sort_ref;
  61         SV *search_ref;
  62         SV *fetch_ref;
  63         SV *present_ref;
  64         SV *esrequest_ref;
  65         SV *delete_ref;
  66         SV *scan_ref;
  67         NMEM nmem;
  68         int stop_flag;  /* is used to stop server prematurely .. */
  69 } Zfront_handle;
  70
  71 #define ENABLE_STOP_SERVER 0
  72
  73 SV *init_ref = NULL;
  74 SV *close_ref = NULL;
  75 SV *sort_ref = NULL;
  76 SV *search_ref = NULL;
  77 SV *fetch_ref = NULL;
  78 SV *present_ref = NULL;
  79 SV *esrequest_ref = NULL;
  80 SV *delete_ref = NULL;
  81 SV *scan_ref = NULL;
  82 PerlInterpreter *root_perl_context;
  83 int MAX_OID = 15;
  84
  85 #define GRS_BUF_SIZE 512
  86
  87 CV * simpleserver_sv2cv(SV *handler) {
  88     STRLEN len;
  89     char *buf;
  90
  91     if (SvPOK(handler)) {
  92         CV *ret;
  93         buf = SvPV( handler, len);
  94         if ( !( ret = perl_get_cv(buf, FALSE ) ) ) {
  95             fprintf( stderr, "simpleserver_sv2cv: No such handler '%s'\n\n", buf );
  96             exit(1);
  97         }
  98
  99         return ret;
 100     } else {
 101         return (CV *) handler;
 102     }
 103 }
 104
 105 /* debugging routine to check for destruction of Perl interpreters */
 106 #ifdef USE_ITHREADS
 107 void tst_clones(void)
 108 {
 109     int i;
 110     PerlInterpreter *parent = PERL_GET_CONTEXT;
 111     for (i = 0; i<5000; i++)
 112     {
 113         PerlInterpreter *perl_interp;
 114
 115         PERL_SET_CONTEXT(parent);
 116         PL_perl_destruct_level = 2;
 117         perl_interp = perl_clone(parent, CLONEf_CLONE_HOST);
 118         PL_perl_destruct_level = 2;
 119         PERL_SET_CONTEXT(perl_interp);
 120         perl_destruct(perl_interp);
 121         perl_free(perl_interp);
 122     }
 123     exit (0);
 124 }
 125 #endif
 126
 127 int simpleserver_clone(void) {
 128 #ifdef USE_ITHREADS
 129      nmem_mutex_enter(simpleserver_mutex);
 130      if (1)
 131      {
 132          PerlInterpreter *current = PERL_GET_CONTEXT;
 133
 134          /* if current is unset, then we're in a new thread with
 135           * no Perl interpreter for it. So we must create one .
 136           * This will only happen when threaded is used..
 137           */
 138          if (!current) {
 139              PerlInterpreter *perl_interp;
 140              PERL_SET_CONTEXT( root_perl_context );
 141              perl_interp = perl_clone(root_perl_context, CLONEf_CLONE_HOST);
 142              PERL_SET_CONTEXT( perl_interp );
 143          }
 144      }
 145      nmem_mutex_leave(simpleserver_mutex);
 146 #endif
 147      return 0;
 148 }
 149
 150
 151 void simpleserver_free(void) {
 152     nmem_mutex_enter(simpleserver_mutex);
 153     if (1)
 154     {
 155         PerlInterpreter *current_interp = PERL_GET_CONTEXT;
 156
 157         /* If current Perl Interp is different from root interp, then
 158          * we're in threaded mode and we must destroy..
 159          */
 160         if (current_interp != root_perl_context) {
 161             PL_perl_destruct_level = 2;
 162             PERL_SET_CONTEXT(current_interp);
 163             perl_destruct(current_interp);
 164             perl_free(current_interp);
 165         }
 166     }
 167     nmem_mutex_leave(simpleserver_mutex);
 168 }
 169
 170
 171 Z_GenericRecord *read_grs1(char *str, ODR o)
 172 {
 173         int type, ivalue;
 174         char line[GRS_BUF_SIZE+1], *buf, *ptr, *original;
 175         char value[GRS_BUF_SIZE+1];
 176         Z_GenericRecord *r = 0;
 177
 178         original = str;
 179         r = (Z_GenericRecord *)odr_malloc(o, sizeof(*r));
 180         r->elements = (Z_TaggedElement **) odr_malloc(o, sizeof(Z_TaggedElement*) * GRS_MAX_FIELDS);
 181         r->num_elements = 0;
 182
 183         for (;;)
 184         {
 185                 Z_TaggedElement *t;
 186                 Z_ElementData *c;
 187                 int len;
 188
 189                 ptr = strchr(str, '\n');
 190                 if (!ptr) {
 191                         return r;
 192                 }
 193                 len = ptr - str;
 194                 if (len > GRS_BUF_SIZE) {
 195                     yaz_log(LOG_WARN, "GRS string too long - truncating (%d > %d)", len, GRS_BUF_SIZE);
 196                     len = GRS_BUF_SIZE;
 197                 }
 198                 strncpy(line, str, len);
 199                 line[len] = 0;
 200                 buf = line;
 201                 str = ptr + 1;
 202                 while (*buf && isspace(*buf))
 203                         buf++;
 204                 if (*buf == '}') {
 205                         memmove(original, str, strlen(str));
 206                         return r;
 207                 }
 208                 if (sscanf(buf, "(%d,%[^)])", &type, value) != 2)
 209                 {
 210                         yaz_log(LOG_WARN, "Bad data in '%s'", buf);
 211                         return r;
 212                 }
 213                 if (!type && *value == '0')
 214                         return r;
 215                 if (!(buf = strchr(buf, ')')))
 216                         return r;
 217                 buf++;
 218                 while (*buf && isspace(*buf))
 219                         buf++;
 220                 if (r->num_elements >= GRS_MAX_FIELDS)
 221                 {
 222                         yaz_log(LOG_WARN, "Max number of GRS-1 elements exceeded [GRS_MAX_FIELDS=%d]", GRS_MAX_FIELDS);
 223                         exit(0);
 224                 }
 225                 r->elements[r->num_elements] = t = (Z_TaggedElement *) odr_malloc(o, sizeof(Z_TaggedElement));
 226                 t->tagType = (int *)odr_malloc(o, sizeof(int));
 227                 *t->tagType = type;
 228                 t->tagValue = (Z_StringOrNumeric *)
 229                         odr_malloc(o, sizeof(Z_StringOrNumeric));
 230                 if ((ivalue = atoi(value)))
 231                 {
 232                         t->tagValue->which = Z_StringOrNumeric_numeric;
 233                         t->tagValue->u.numeric = (int *)odr_malloc(o, sizeof(int));
 234                         *t->tagValue->u.numeric = ivalue;
 235                 }
 236                 else
 237                 {
 238                         t->tagValue->which = Z_StringOrNumeric_string;
 239                         t->tagValue->u.string = (char *)odr_malloc(o, strlen(value)+1);
 240                         strcpy(t->tagValue->u.string, value);
 241                 }
 242                 t->tagOccurrence = 0;
 243                 t->metaData = 0;
 244                 t->appliedVariant = 0;
 245                 t->content = c = (Z_ElementData *)odr_malloc(o, sizeof(Z_ElementData));
 246                 if (*buf == '{')
 247                 {
 248                         c->which = Z_ElementData_subtree;
 249                         c->u.subtree = read_grs1(str, o);
 250                 }
 251                 else
 252                 {
 253                         c->which = Z_ElementData_string;
 254                         c->u.string = odr_strdup(o, buf);
 255                 }
 256                 r->num_elements++;
 257         }
 258 }
 259
 260
 261
 262
 263 static void oid2str(Odr_oid *o, WRBUF buf)
 264 {
 265     for (; *o >= 0; o++) {
 266         char ibuf[16];
 267         sprintf(ibuf, "%d", *o);
 268         wrbuf_puts(buf, ibuf);
 269         if (o[1] > 0)
 270             wrbuf_putc(buf, '.');
 271     }
 272 }
 273
 274
 275 static int rpn2pquery(Z_RPNStructure *s, WRBUF buf)
 276 {
 277     switch (s->which) {
 278         case Z_RPNStructure_simple: {
 279             Z_Operand *o = s->u.simple;
 280
 281             switch (o->which) {
 282                 case Z_Operand_APT: {
 283                     Z_AttributesPlusTerm *at = o->u.attributesPlusTerm;
 284
 285                     if (at->attributes) {
 286                         int i;
 287                         char ibuf[16];
 288
 289                         for (i = 0; i < at->attributes->num_attributes; i++) {
 290                             wrbuf_puts(buf, "@attr ");
 291                             if (at->attributes->attributes[i]->attributeSet) {
 292                                 oid2str(at->attributes->attributes[i]->attributeSet, buf);
 293                                 wrbuf_putc(buf, ' ');
 294                             }
 295                             sprintf(ibuf, "%d=", *at->attributes->attributes[i]->attributeType);
 296                             assert(at->attributes->attributes[i]->which == Z_AttributeValue_numeric);
 297                             wrbuf_puts(buf, ibuf);
 298                             sprintf(ibuf, "%d ", *at->attributes->attributes[i]->value.numeric);
 299                             wrbuf_puts(buf, ibuf);
 300                         }
 301                     }
 302                     switch (at->term->which) {
 303                         case Z_Term_general: {
 304                             wrbuf_putc(buf, '"');
 305                             wrbuf_write(buf, (char*) at->term->u.general->buf, at->term->u.general->len);
 306                             wrbuf_puts(buf, "\" ");
 307                             break;
 308                         }
 309                         default: abort();
 310                     }
 311                     break;
 312                 }
 313                 default: abort();
 314             }
 315             break;
 316         }
 317         case Z_RPNStructure_complex: {
 318             Z_Complex *c = s->u.complex;
 319
 320             switch (c->roperator->which) {
 321                 case Z_Operator_and: wrbuf_puts(buf, "@and "); break;
 322                 case Z_Operator_or: wrbuf_puts(buf, "@or "); break;
 323                 case Z_Operator_and_not: wrbuf_puts(buf, "@not "); break;
 324                 case Z_Operator_prox: abort();
 325                 default: abort();
 326             }
 327             if (!rpn2pquery(c->s1, buf))
 328                 return 0;
 329             if (!rpn2pquery(c->s2, buf))
 330                 return 0;
 331             break;
 332         }
 333         default: abort();
 334     }
 335     return 1;
 336 }
 337
 338
 339 WRBUF zquery2pquery(Z_Query *q)
 340 {
 341     WRBUF buf = wrbuf_alloc();
 342
 343     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101)
 344         return 0;
 345     if (q->u.type_1->attributeSetId) {
 346         /* Output attribute set ID */
 347         wrbuf_puts(buf, "@attrset ");
 348         oid2str(q->u.type_1->attributeSetId, buf);
 349         wrbuf_putc(buf, ' ');
 350     }
 351     return rpn2pquery(q->u.type_1->RPNStructure, buf) ? buf : 0;
 352 }
 353
 354
 355 /* Lifted verbatim from Net::Z3950 yazwrap/util.c */
 356 #include <stdarg.h>
 357 void fatal(char *fmt, ...)
 358 {
 359     va_list ap;
 360
 361     fprintf(stderr, "FATAL (SimpleServer): ");
 362     va_start(ap, fmt);
 363     vfprintf(stderr, fmt, ap);
 364     va_end(ap);
 365     fprintf(stderr, "\n");
 366     abort();
 367 }
 368
 369
 370 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 371 /*
 372  * Creates a new Perl object of type `class'; the newly-created scalar
 373  * that is a reference to the blessed thingy `referent' is returned.
 374  */
 375 static SV *newObject(char *class, SV *referent)
 376 {
 377     HV *stash;
 378     SV *sv;
 379
 380     sv = newRV_noinc((SV*) referent);
 381     stash = gv_stashpv(class, 0);
 382     if (stash == 0)
 383         fatal("attempt to create object of undefined class '%s'", class);
 384     /*assert(stash != 0);*/
 385     sv_bless(sv, stash);
 386     return sv;
 387 }
 388
 389
 390 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 391 static void setMember(HV *hv, char *name, SV *val)
 392 {
 393     /* We don't increment `val's reference count -- I think this is
 394      * right because it's created with a refcount of 1, and in fact
 395      * the reference via this hash is the only reference to it in
 396      * general.
 397      */
 398     if (!hv_store(hv, name, (U32) strlen(name), val, (U32) 0))
 399         fatal("couldn't store member in hash");
 400 }
 401
 402
 403 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 404 static SV *translateOID(Odr_oid *x)
 405 {
 406     /* Yaz represents an OID by an int array terminated by a negative
 407      * value, typically -1; we represent it as a reference to a
 408      * blessed scalar string of "."-separated elements.
 409      */
 410     char buf[1000];
 411     int i;
 412
 413     *buf = '\0';
 414     for (i = 0; x[i] >= 0; i++) {
 415         sprintf(buf + strlen(buf), "%d", (int) x[i]);
 416         if (x[i+1] >- 0)
 417             strcat(buf, ".");
 418     }
 419
 420     /*
 421      * ### We'd like to return a blessed scalar (string) here, but of
 422      *  course you can't do that in Perl: only references can be
 423      *  blessed, so we'd have to return a _reference_ to a string, and
 424      *  bless _that_.  Better to do without the blessing, I think.
 425      */
 426     if (1) {
 427         return newSVpv(buf, 0);
 428     } else {
 429         return newObject("Net::Z3950::APDU::OID", newSVpv(buf, 0));
 430     }
 431 }
 432
 433
 434 static SV *rpn2perl(Z_RPNStructure *s)
 435 {
 436     SV *sv;
 437     HV *hv;
 438     AV *av;
 439
 440     switch (s->which) {
 441     case Z_RPNStructure_simple: {
 442         Z_Operand *o = s->u.simple;
 443         Z_AttributesPlusTerm *at;
 444         if (o->which == Z_Operand_resultSetId) {
 445             SV *sv2;
 446             /* This code causes a SIGBUS on my machine, and I have no
 447                idea why.  It seems as clear as day to me */
 448             char *rsid = (char*) o->u.resultSetId;
 449             printf("Encoding resultSetId '%s'\n", rsid);
 450             sv = newObject("Net::Z3950::RPN::RSID", (SV*) (hv = newHV()));
 451             printf("Made sv=0x%lx, hv=0x%lx\n",
 452                    (unsigned long) sv ,(unsigned long) hv);
 453             sv2 = newSVpv(rsid, strlen(rsid));
 454             setMember(hv, "id", sv2);
 455             printf("Set hv{id} to 0x%lx\n", (unsigned long) sv2);
 456             return sv;
 457         }
 458         if (o->which != Z_Operand_APT)
 459             fatal("can't handle RPN simples other than APT and RSID");
 460         at = o->u.attributesPlusTerm;
 461         if (at->term->which != Z_Term_general)
 462             fatal("can't handle RPN terms other than general");
 463
 464         sv = newObject("Net::Z3950::RPN::Term", (SV*) (hv = newHV()));
 465         if (at->attributes) {
 466             int i;
 467             SV *attrs = newObject("Net::Z3950::RPN::Attributes",
 468                                   (SV*) (av = newAV()));
 469             for (i = 0; i < at->attributes->num_attributes; i++) {
 470                 Z_AttributeElement *elem = at->attributes->attributes[i];
 471                 HV *hv2;
 472                 SV *tmp = newObject("Net::Z3950::RPN::Attribute",
 473                                     (SV*) (hv2 = newHV()));
 474                 if (elem->attributeSet)
 475                     setMember(hv2, "attributeSet",
 476                               translateOID(elem->attributeSet));
 477                 setMember(hv2, "attributeType",
 478                           newSViv(*elem->attributeType));
 479                 assert(elem->which == Z_AttributeValue_numeric);
 480                 setMember(hv2, "attributeValue",
 481                           newSViv(*elem->value.numeric));
 482                 av_push(av, tmp);
 483             }
 484             setMember(hv, "attributes", attrs);
 485         }
 486         setMember(hv, "term", newSVpv((char*) at->term->u.general->buf,
 487                                       at->term->u.general->len));
 488         return sv;
 489     }
 490     case Z_RPNStructure_complex: {
 491         SV *tmp;
 492         Z_Complex *c = s->u.complex;
 493         char *type = 0;         /* vacuous assignment satisfies gcc -Wall */
 494         switch (c->roperator->which) {
 495         case Z_Operator_and:     type = "Net::Z3950::RPN::And"; break;
 496         case Z_Operator_or:      type = "Net::Z3950::RPN::Or"; break;
 497         case Z_Operator_and_not: type = "Net::Z3950::RPN::AndNot"; break;
 498         case Z_Operator_prox:    fatal("proximity not yet supported");
 499         default: fatal("unknown RPN operator %d", (int) c->roperator->which);
 500         }
 501         sv = newObject(type, (SV*) (av = newAV()));
 502         if ((tmp = rpn2perl(c->s1)) == 0)
 503             return 0;
 504         av_push(av, tmp);
 505         if ((tmp = rpn2perl(c->s2)) == 0)
 506             return 0;
 507         av_push(av, tmp);
 508         return sv;
 509     }
 510     default: fatal("unknown RPN node type %d", (int) s->which);
 511     }
 512
 513     return 0;
 514 }
 515
 516
 517 static SV *zquery2perl(Z_Query *q)
 518 {
 519     SV *sv;
 520     HV *hv;
 521
 522     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101)
 523         return 0;
 524     sv = newObject("Net::Z3950::APDU::Query", (SV*) (hv = newHV()));
 525     if (q->u.type_1->attributeSetId)
 526         setMember(hv, "attributeSet",
 527                   translateOID(q->u.type_1->attributeSetId));
 528     setMember(hv, "query", rpn2perl(q->u.type_1->RPNStructure));
 529     return sv;
 530 }
 531
 532
 533 int bend_sort(void *handle, bend_sort_rr *rr)
 534 {
 535         HV *href;
 536         AV *aref;
 537         SV **temp;
 538         SV *err_code;
 539         SV *err_str;
 540         SV *status;
 541         STRLEN len;
 542         char *ptr;
 543         char *ODR_err_str;
 544         char **input_setnames;
 545         Zfront_handle *zhandle = (Zfront_handle *)handle;
 546         int i;
 547
 548         dSP;
 549         ENTER;
 550         SAVETMPS;
 551
 552         aref = newAV();
 553         input_setnames = rr->input_setnames;
 554         for (i = 0; i < rr->num_input_setnames; i++)
 555         {
 556                 av_push(aref, newSVpv(*input_setnames++, 0));
 557         }
 558         href = newHV();
 559         hv_store(href, "INPUT", 5, newRV( (SV*) aref), 0);
 560         hv_store(href, "OUTPUT", 6, newSVpv(rr->output_setname, 0), 0);
 561         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 562         hv_store(href, "STATUS", 6, newSViv(0), 0);
 563
 564         PUSHMARK(sp);
 565
 566         XPUSHs(sv_2mortal(newRV( (SV*) href)));
 567
 568         PUTBACK;
 569
 570         perl_call_sv(sort_ref, G_SCALAR | G_DISCARD);
 571
 572         SPAGAIN;
 573
 574         temp = hv_fetch(href, "ERR_CODE", 8, 1);
 575         err_code = newSVsv(*temp);
 576
 577         temp = hv_fetch(href, "ERR_STR", 7, 1);
 578         err_str = newSVsv(*temp);
 579
 580         temp = hv_fetch(href, "STATUS", 6, 1);
 581         status = newSVsv(*temp);
 582
 583         PUTBACK;
 584         FREETMPS;
 585         LEAVE;
 586
 587         hv_undef(href),
 588         av_undef(aref);
 589         rr->errcode = SvIV(err_code);
 590         rr->sort_status = SvIV(status);
 591         ptr = SvPV(err_str, len);
 592         ODR_err_str = (char *)odr_malloc(rr->stream, len + 1);
 593         strcpy(ODR_err_str, ptr);
 594         rr->errstring = ODR_err_str;
 595
 596         sv_free(err_code);
 597         sv_free(err_str);
 598         sv_free(status);
 599
 600         return 0;
 601 }
 602
 603
 604 int bend_search(void *handle, bend_search_rr *rr)
 605 {
 606         HV *href;
 607         AV *aref;
 608         SV **temp;
 609         char *ODR_errstr;
 610         STRLEN len;
 611         int i;
 612         char **basenames;
 613         WRBUF query;
 614         char *ptr;
 615         SV *point;
 616         Zfront_handle *zhandle = (Zfront_handle *)handle;
 617         CV* handler_cv = 0;
 618         SV *rpnSV;
 619
 620         dSP;
 621         ENTER;
 622         SAVETMPS;
 623
 624         aref = newAV();
 625         basenames = rr->basenames;
 626         for (i = 0; i < rr->num_bases; i++)
 627         {
 628                 av_push(aref, newSVpv(*basenames++, 0));
 629         }
 630 #if ENABLE_STOP_SERVER
 631         if (rr->num_bases == 1 && !strcmp(rr->basenames[0], "XXstop"))
 632         {
 633                 zhandle->stop_flag = 1;
 634         }
 635 #endif
 636         href = newHV();
 637         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
 638         hv_store(href, "REPL_SET", 8, newSViv(rr->replace_set), 0);
 639         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
 640         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
 641         hv_store(href, "HITS", 4, newSViv(0), 0);
 642         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
 643         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 644         hv_store(href, "PID", 3, newSViv(getpid()), 0);
 645         if ((rpnSV = zquery2perl(rr->query)) != 0) {
 646             hv_store(href, "RPN", 3, rpnSV, 0);
 647         }
 648         query = zquery2pquery(rr->query);
 649         if (query)
 650         {
 651                 hv_store(href, "QUERY", 5, newSVpv((char *)query->buf, query->pos), 0);
 652         }
 653         else if (rr->query->which == Z_Query_type_104 &&
 654                  rr->query->u.type_104->which == Z_External_CQL) {
 655             hv_store(href, "CQL", 3,
 656                      newSVpv(rr->query->u.type_104->u.cql, 0), 0);
 657         }
 658         else
 659         {
 660                 rr->errcode = 108;
 661                 return 0;
 662         }
 663         PUSHMARK(sp);
 664
 665         XPUSHs(sv_2mortal(newRV( (SV*) href)));
 666
 667         PUTBACK;
 668
 669         handler_cv = simpleserver_sv2cv( search_ref );
 670         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
 671
 672         SPAGAIN;
 673
 674         temp = hv_fetch(href, "HITS", 4, 1);
 675         rr->hits = SvIV(*temp);
 676
 677         temp = hv_fetch(href, "ERR_CODE", 8, 1);
 678         rr->errcode = SvIV(*temp);
 679
 680         temp = hv_fetch(href, "ERR_STR", 7, 1);
 681         ptr = SvPV(*temp, len);
 682         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
 683         strcpy(ODR_errstr, ptr);
 684         rr->errstring = ODR_errstr;
 685
 686         temp = hv_fetch(href, "HANDLE", 6, 1);
 687         point = newSVsv(*temp);
 688
 689         hv_undef(href);
 690         av_undef(aref);
 691
 692         zhandle->handle = point;
 693         sv_free( (SV*) aref);
 694         sv_free( (SV*) href);
 695         if (query)
 696             wrbuf_free(query, 1);
 697         PUTBACK;
 698         FREETMPS;
 699         LEAVE;
 700         return 0;
 701 }
 702
 703
 704 /* ### this is worryingly similar to oid2str() */
 705 WRBUF oid2dotted(int *oid)
 706 {
 707
 708         WRBUF buf = wrbuf_alloc();
 709         int dot = 0;
 710
 711         for (; *oid != -1 ; oid++)
 712         {
 713                 char ibuf[16];
 714                 if (dot)
 715                 {
 716                         wrbuf_putc(buf, '.');
 717                 }
 718                 else
 719                 {
 720                         dot = 1;
 721                 }
 722                 sprintf(ibuf, "%d", *oid);
 723                 wrbuf_puts(buf, ibuf);
 724         }
 725         return buf;
 726 }
 727
 728
 729 int dotted2oid(char *dotted, int *buffer)
 730 {
 731         int *oid;
 732         char ibuf[16];
 733         char *ptr;
 734         int n = 0;
 735
 736         ptr = ibuf;
 737         oid = buffer;
 738         while (*dotted)
 739         {
 740                 if (*dotted == '.')
 741                 {
 742                         n++;
 743                         if (n == MAX_OID)  /* Terminate if more than MAX_OID entries */
 744                         {
 745                                 *oid = -1;
 746                                 return -1;
 747                         }
 748                         *ptr = 0;
 749                         sscanf(ibuf, "%d", oid++);
 750                         ptr = ibuf;
 751                         dotted++;
 752
 753                 }
 754                 else
 755                 {
 756                         *ptr++ = *dotted++;
 757                 }
 758         }
 759         if (n < MAX_OID)
 760         {
 761                 *ptr = 0;
 762                 sscanf(ibuf, "%d", oid++);
 763         }
 764         *oid = -1;
 765         return 0;
 766 }
 767
 768
 769 int bend_fetch(void *handle, bend_fetch_rr *rr)
 770 {
 771         HV *href;
 772         SV **temp;
 773         SV *basename;
 774         SV *record;
 775         SV *last;
 776         SV *err_code;
 777         SV *err_string;
 778         SV *sur_flag;
 779         SV *point;
 780         SV *rep_form;
 781         char *ptr;
 782         char *ODR_record;
 783         char *ODR_basename;
 784         char *ODR_errstr;
 785         int *ODR_oid_buf;
 786         oident *oid;
 787         WRBUF oid_dotted;
 788         Zfront_handle *zhandle = (Zfront_handle *)handle;
 789         CV* handler_cv = 0;
 790
 791         Z_RecordComposition *composition;
 792         Z_ElementSetNames *simple;
 793         STRLEN length;
 794
 795         dSP;
 796         ENTER;
 797         SAVETMPS;
 798
 799         rr->errcode = 0;
 800         href = newHV();
 801         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
 802         temp = hv_store(href, "OFFSET", 6, newSViv(rr->number), 0);
 803         if (rr->request_format_raw != 0) {
 804             oid_dotted = oid2dotted(rr->request_format_raw);
 805         } else {
 806             /* Probably an SRU request: assume XML is required */
 807             oid_dotted = wrbuf_alloc();
 808             wrbuf_puts(oid_dotted, "1.2.840.10003.5.109.10");
 809         }
 810         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
 811         hv_store(href, "REP_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
 812         hv_store(href, "BASENAME", 8, newSVpv("", 0), 0);
 813         hv_store(href, "RECORD", 6, newSVpv("", 0), 0);
 814         hv_store(href, "LAST", 4, newSViv(0), 0);
 815         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
 816         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
 817         hv_store(href, "SUR_FLAG", 8, newSViv(0), 0);
 818         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 819         hv_store(href, "PID", 3, newSViv(getpid()), 0);
 820         if (rr->comp)
 821         {
 822                 composition = rr->comp;
 823                 if (composition->which == Z_RecordComp_simple)
 824                 {
 825                         simple = composition->u.simple;
 826                         if (simple->which == Z_ElementSetNames_generic)
 827                         {
 828                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
 829                         }
 830                         else
 831                         {
 832                                 rr->errcode = 26;
 833                         }
 834                 }
 835                 else
 836                 {
 837                         /* This is where we end up in the case of
 838                          * SRU.  Since record composition ("element
 839                          * sets") are meaningless in SRU anyway, we
 840                          * just skip this.
 841                          */
 842                 }
 843         }
 844
 845         PUSHMARK(sp);
 846
 847         XPUSHs(sv_2mortal(newRV( (SV*) href)));
 848
 849         PUTBACK;
 850
 851         handler_cv = simpleserver_sv2cv( fetch_ref );
 852         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
 853
 854         SPAGAIN;
 855
 856         temp = hv_fetch(href, "BASENAME", 8, 1);
 857         basename = newSVsv(*temp);
 858
 859         temp = hv_fetch(href, "RECORD", 6, 1);
 860         record = newSVsv(*temp);
 861
 862         temp = hv_fetch(href, "LAST", 4, 1);
 863         last = newSVsv(*temp);
 864
 865         temp = hv_fetch(href, "ERR_CODE", 8, 1);
 866         err_code = newSVsv(*temp);
 867
 868         temp = hv_fetch(href, "ERR_STR", 7, 1),
 869         err_string = newSVsv(*temp);
 870
 871         temp = hv_fetch(href, "SUR_FLAG", 8, 1);
 872         sur_flag = newSVsv(*temp);
 873
 874         temp = hv_fetch(href, "REP_FORM", 8, 1);
 875         rep_form = newSVsv(*temp);
 876
 877         temp = hv_fetch(href, "HANDLE", 6, 1);
 878         point = newSVsv(*temp);
 879
 880
 881         hv_undef(href);
 882
 883         ptr = SvPV(basename, length);
 884         ODR_basename = (char *)odr_malloc(rr->stream, length + 1);
 885         strcpy(ODR_basename, ptr);
 886         rr->basename = ODR_basename;
 887
 888         ptr = SvPV(rep_form, length);
 889         ODR_oid_buf = (int *)odr_malloc(rr->stream, (MAX_OID + 1) * sizeof(int));
 890         if (dotted2oid(ptr, ODR_oid_buf) == -1)         /* Maximum number of OID elements exceeded */
 891         {
 892                 printf("Net::Z3950::SimpleServer: WARNING: OID structure too long, max length is %d\n", MAX_OID);
 893         }
 894         rr->output_format_raw = ODR_oid_buf;
 895
 896         ptr = SvPV(record, length);
 897         oid = oid_getentbyoid(ODR_oid_buf);
 898         if (oid->value == VAL_GRS1)             /* Treat GRS-1 records separately */
 899         {
 900                 rr->record = (char *) read_grs1(ptr, rr->stream);
 901                 rr->len = -1;
 902         }
 903         else
 904         {
 905                 ODR_record = (char *)odr_malloc(rr->stream, length + 1);
 906                 strcpy(ODR_record, ptr);
 907                 rr->record = ODR_record;
 908                 rr->len = length;
 909         }
 910         zhandle->handle = point;
 911         handle = zhandle;
 912         rr->last_in_set = SvIV(last);
 913
 914         if (!(rr->errcode))
 915         {
 916                 rr->errcode = SvIV(err_code);
 917                 ptr = SvPV(err_string, length);
 918                 ODR_errstr = (char *)odr_malloc(rr->stream, length + 1);
 919                 strcpy(ODR_errstr, ptr);
 920                 rr->errstring = ODR_errstr;
 921         }
 922         rr->surrogate_flag = SvIV(sur_flag);
 923
 924         wrbuf_free(oid_dotted, 1);
 925         sv_free((SV*) href);
 926         sv_free(basename);
 927         sv_free(record);
 928         sv_free(last);
 929         sv_free(err_string);
 930         sv_free(err_code),
 931         sv_free(sur_flag);
 932         sv_free(rep_form);
 933
 934         PUTBACK;
 935         FREETMPS;
 936         LEAVE;
 937
 938         return 0;
 939 }
 940
 941
 942 int bend_present(void *handle, bend_present_rr *rr)
 943 {
 944         HV *href;
 945         SV **temp;
 946         SV *err_code;
 947         SV *err_string;
 948         SV *hits;
 949         SV *point;
 950         STRLEN len;
 951         Z_RecordComposition *composition;
 952         Z_ElementSetNames *simple;
 953         char *ODR_errstr;
 954         char *ptr;
 955         Zfront_handle *zhandle = (Zfront_handle *)handle;
 956         CV* handler_cv = 0;
 957
 958 /*      WRBUF oid_dotted; */
 959
 960         dSP;
 961         ENTER;
 962         SAVETMPS;
 963
 964         href = newHV();
 965         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 966         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
 967         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
 968         hv_store(href, "START", 5, newSViv(rr->start), 0);
 969         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
 970         hv_store(href, "NUMBER", 6, newSViv(rr->number), 0);
 971         /*oid_dotted = oid2dotted(rr->request_format_raw);
 972         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);*/
 973         hv_store(href, "HITS", 4, newSViv(0), 0);
 974         hv_store(href, "PID", 3, newSViv(getpid()), 0);
 975         if (rr->comp)
 976         {
 977                 composition = rr->comp;
 978                 if (composition->which == Z_RecordComp_simple)
 979                 {
 980                         simple = composition->u.simple;
 981                         if (simple->which == Z_ElementSetNames_generic)
 982                         {
 983                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
 984                         }
 985                         else
 986                         {
 987                                 rr->errcode = 26;
 988                                 return 0;
 989                         }
 990                 }
 991                 else
 992                 {
 993                         rr->errcode = 26;
 994                         return 0;
 995                 }
 996         }
 997
 998         PUSHMARK(sp);
 999
1000         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1001
1002         PUTBACK;
1003
1004         handler_cv = simpleserver_sv2cv( present_ref );
1005         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1006
1007         SPAGAIN;
1008
1009         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1010         err_code = newSVsv(*temp);
1011
1012         temp = hv_fetch(href, "ERR_STR", 7, 1);
1013         err_string = newSVsv(*temp);
1014
1015         temp = hv_fetch(href, "HITS", 4, 1);
1016         hits = newSVsv(*temp);
1017
1018         temp = hv_fetch(href, "HANDLE", 6, 1);
1019         point = newSVsv(*temp);
1020
1021         PUTBACK;
1022         FREETMPS;
1023         LEAVE;
1024
1025         hv_undef(href);
1026         rr->errcode = SvIV(err_code);
1027         rr->hits = SvIV(hits);
1028
1029         ptr = SvPV(err_string, len);
1030         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
1031         strcpy(ODR_errstr, ptr);
1032         rr->errstring = ODR_errstr;
1033 /*      wrbuf_free(oid_dotted, 1);*/
1034         zhandle->handle = point;
1035         handle = zhandle;
1036         sv_free(err_code);
1037         sv_free(err_string);
1038         sv_free(hits);
1039         sv_free( (SV*) href);
1040
1041         return 0;
1042 }
1043
1044
1045 int bend_esrequest(void *handle, bend_esrequest_rr *rr)
1046 {
1047         perl_call_sv(esrequest_ref, G_VOID | G_DISCARD | G_NOARGS);
1048         return 0;
1049 }
1050
1051
1052 int bend_delete(void *handle, bend_delete_rr *rr)
1053 {
1054         perl_call_sv(delete_ref, G_VOID | G_DISCARD | G_NOARGS);
1055         return 0;
1056 }
1057
1058
1059 int bend_scan(void *handle, bend_scan_rr *rr)
1060 {
1061         HV *href;
1062         AV *aref;
1063         AV *list;
1064         AV *entries;
1065         HV *scan_item;
1066         struct scan_entry *scan_list;
1067         struct scan_entry *buffer;
1068         int *step_size = rr->step_size;
1069         int i;
1070         char **basenames;
1071         SV **temp;
1072         SV *err_code = sv_newmortal();
1073         SV *err_str = sv_newmortal();
1074         SV *point = sv_newmortal();
1075         SV *status = sv_newmortal();
1076         SV *number = sv_newmortal();
1077         char *ptr;
1078         char *ODR_errstr;
1079         STRLEN len;
1080         int term_len;
1081         SV *entries_ref;
1082         Zfront_handle *zhandle = (Zfront_handle *)handle;
1083         CV* handler_cv = 0;
1084
1085         dSP;
1086         ENTER;
1087         SAVETMPS;
1088         href = newHV();
1089         list = newAV();
1090         if (rr->term->term->which == Z_Term_general)
1091         {
1092                 term_len = rr->term->term->u.general->len;
1093                 hv_store(href, "TERM", 4, newSVpv(rr->term->term->u.general->buf, term_len), 0);
1094         } else {
1095                 rr->errcode = 229;      /* Unsupported term type */
1096                 return 0;
1097         }
1098         hv_store(href, "STEP", 4, newSViv(*step_size), 0);
1099         hv_store(href, "NUMBER", 6, newSViv(rr->num_entries), 0);
1100         hv_store(href, "POS", 3, newSViv(rr->term_position), 0);
1101         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1102         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
1103         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1104         hv_store(href, "STATUS", 6, newSViv(BEND_SCAN_SUCCESS), 0);
1105         hv_store(href, "ENTRIES", 7, newRV((SV *) list), 0);
1106         aref = newAV();
1107         basenames = rr->basenames;
1108         for (i = 0; i < rr->num_bases; i++)
1109         {
1110                 av_push(aref, newSVpv(*basenames++, 0));
1111         }
1112         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
1113
1114         PUSHMARK(sp);
1115
1116         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1117
1118         PUTBACK;
1119
1120         handler_cv = simpleserver_sv2cv( scan_ref );
1121         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1122
1123         SPAGAIN;
1124
1125         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1126         err_code = newSVsv(*temp);
1127
1128         temp = hv_fetch(href, "ERR_STR", 7, 1);
1129         err_str = newSVsv(*temp);
1130
1131         temp = hv_fetch(href, "HANDLE", 6, 1);
1132         point = newSVsv(*temp);
1133
1134         temp = hv_fetch(href, "STATUS", 6, 1);
1135         status = newSVsv(*temp);
1136
1137         temp = hv_fetch(href, "NUMBER", 6, 1);
1138         number = newSVsv(*temp);
1139
1140         temp = hv_fetch(href, "ENTRIES", 7, 1);
1141         entries_ref = newSVsv(*temp);
1142
1143         PUTBACK;
1144         FREETMPS;
1145         LEAVE;
1146
1147         ptr = SvPV(err_str, len);
1148         ODR_errstr = (char *)odr_malloc(rr->stream, len + 1);
1149         strcpy(ODR_errstr, ptr);
1150         rr->errstring = ODR_errstr;
1151         rr->errcode = SvIV(err_code);
1152         rr->num_entries = SvIV(number);
1153         rr->status = SvIV(status);
1154         scan_list = (struct scan_entry *) odr_malloc (rr->stream, rr->num_entries * sizeof(*scan_list));
1155         buffer = scan_list;
1156         entries = (AV *)SvRV(entries_ref);
1157         for (i = 0; i < rr->num_entries; i++)
1158         {
1159                 scan_item = (HV *)SvRV(sv_2mortal(av_shift(entries)));
1160                 temp = hv_fetch(scan_item, "TERM", 4, 1);
1161                 ptr = SvPV(*temp, len);
1162                 buffer->term = (char *) odr_malloc (rr->stream, len + 1);
1163                 strcpy(buffer->term, ptr);
1164                 temp = hv_fetch(scan_item, "OCCURRENCE", 10, 1);
1165                 buffer->occurrences = SvIV(*temp);
1166                 buffer++;
1167                 hv_undef(scan_item);
1168         }
1169         rr->entries = scan_list;
1170         zhandle->handle = point;
1171         handle = zhandle;
1172         sv_free(err_code);
1173         sv_free(err_str);
1174         sv_free(status);
1175         sv_free(number);
1176         hv_undef(href);
1177         sv_free((SV *)href);
1178         av_undef(aref);
1179         sv_free((SV *)aref);
1180         av_undef(list);
1181         sv_free((SV *)list);
1182         av_undef(entries);
1183         /*sv_free((SV *)entries);*/
1184         sv_free(entries_ref);
1185
1186         return 0;
1187 }
1188
1189 bend_initresult *bend_init(bend_initrequest *q)
1190 {
1191         int dummy = simpleserver_clone();
1192         bend_initresult *r = (bend_initresult *)
1193                 odr_malloc (q->stream, sizeof(*r));
1194         char *ptr;
1195         char *user = NULL;
1196         char *passwd = NULL;
1197         CV* handler_cv = 0;
1198         dSP;
1199         STRLEN len;
1200         NMEM nmem = nmem_create();
1201         Zfront_handle *zhandle =  (Zfront_handle *) nmem_malloc (nmem,
1202                         sizeof(*zhandle));
1203         SV *handle;
1204         HV *href;
1205         SV **temp;
1206
1207         ENTER;
1208         SAVETMPS;
1209
1210         zhandle->nmem = nmem;
1211         zhandle->stop_flag = 0;
1212         /*q->bend_sort = bend_sort;*/
1213         if (search_ref)
1214         {
1215                 q->bend_search = bend_search;
1216         }
1217         if (present_ref)
1218         {
1219                 q->bend_present = bend_present;
1220         }
1221         /*q->bend_esrequest = bend_esrequest;*/
1222         /*q->bend_delete = bend_delete;*/
1223         if (fetch_ref)
1224         {
1225                 q->bend_fetch = bend_fetch;
1226         }
1227         if (scan_ref)
1228         {
1229                 q->bend_scan = bend_scan;
1230         }
1231
1232         href = newHV();
1233         hv_store(href, "IMP_ID", 6, newSVpv("", 0), 0);
1234         hv_store(href, "IMP_NAME", 8, newSVpv("", 0), 0);
1235         hv_store(href, "IMP_VER", 7, newSVpv("", 0), 0);
1236         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1237         hv_store(href, "ERR_STR", 7, newSViv(0), 0);
1238         hv_store(href, "PEER_NAME", 9, newSVpv(q->peer_name, 0), 0);
1239         hv_store(href, "HANDLE", 6, newSVsv(&sv_undef), 0);
1240         hv_store(href, "PID", 3, newSViv(getpid()), 0);
1241         if (q->auth) {
1242             if (q->auth->which == Z_IdAuthentication_open) {
1243                 char *openpass = xstrdup (q->auth->u.open);
1244                 char *cp = strchr (openpass, '/');
1245                 if (cp) {
1246                     *cp = '\0';
1247                     user = nmem_strdup (odr_getmem (q->stream), openpass);
1248                     passwd = nmem_strdup (odr_getmem (q->stream), cp + 1);
1249                 }
1250                 xfree(openpass);
1251             } else if (q->auth->which == Z_IdAuthentication_idPass) {
1252                 user = q->auth->u.idPass->userId;
1253                 passwd = q->auth->u.idPass->password;
1254             }
1255             /* ### some code paths have user/password unassigned here */
1256             hv_store(href, "USER", 4, newSVpv(user, 0), 0);
1257             hv_store(href, "PASS", 4, newSVpv(passwd, 0), 0);
1258         }
1259
1260         PUSHMARK(sp);
1261
1262         XPUSHs(sv_2mortal(newRV((SV*) href)));
1263
1264         PUTBACK;
1265
1266         if (init_ref != NULL)
1267         {
1268              handler_cv = simpleserver_sv2cv( init_ref );
1269              perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1270         }
1271
1272         SPAGAIN;
1273
1274         temp = hv_fetch(href, "IMP_ID", 6, 1);
1275         ptr = SvPV(*temp, len);
1276         q->implementation_id = nmem_strdup(nmem, ptr);
1277
1278         temp = hv_fetch(href, "IMP_NAME", 8, 1);
1279         ptr = SvPV(*temp, len);
1280         q->implementation_name = nmem_strdup(nmem, ptr);
1281
1282         temp = hv_fetch(href, "IMP_VER", 7, 1);
1283         ptr = SvPV(*temp, len);
1284         q->implementation_version = nmem_strdup(nmem, ptr);
1285
1286         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1287         r->errcode = SvIV(*temp);
1288
1289         temp = hv_fetch(href, "ERR_STR", 7, 1);
1290         ptr = SvPV(*temp, len);
1291         r->errstring = (char *)odr_malloc(q->stream, len + 1);
1292         strcpy(r->errstring, ptr);
1293
1294         temp = hv_fetch(href, "HANDLE", 6, 1);
1295         handle= newSVsv(*temp);
1296         zhandle->handle = handle;
1297
1298         r->handle = zhandle;
1299
1300         hv_undef(href);
1301         sv_free((SV*) href);
1302
1303         PUTBACK;
1304         FREETMPS;
1305         LEAVE;
1306
1307         return r;
1308 }
1309
1310 void bend_close(void *handle)
1311 {
1312         HV *href;
1313         Zfront_handle *zhandle = (Zfront_handle *)handle;
1314         CV* handler_cv = 0;
1315         int stop_flag = 0;
1316         dSP;
1317         ENTER;
1318         SAVETMPS;
1319
1320         if (close_ref)
1321         {
1322                 href = newHV();
1323                 hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1324
1325                 PUSHMARK(sp);
1326
1327                 XPUSHs(sv_2mortal(newRV((SV *)href)));
1328
1329                 PUTBACK;
1330
1331                 handler_cv = simpleserver_sv2cv( close_ref );
1332                 perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1333
1334                 SPAGAIN;
1335
1336                 sv_free((SV*) href);
1337         }
1338         else
1339                 sv_free(zhandle->handle);
1340         PUTBACK;
1341         FREETMPS;
1342         LEAVE;
1343         stop_flag = zhandle->stop_flag;
1344         nmem_destroy(zhandle->nmem);
1345         simpleserver_free();
1346
1347         if (stop_flag)
1348                 exit(0);
1349         return;
1350 }
1351
1352
1353 MODULE = Net::Z3950::SimpleServer       PACKAGE = Net::Z3950::SimpleServer
1354
1355 PROTOTYPES: DISABLE
1356
1357
1358 void
1359 set_init_handler(arg)
1360                 SV *arg
1361         CODE:
1362                 init_ref = newSVsv(arg);
1363
1364
1365 void
1366 set_close_handler(arg)
1367                 SV *arg
1368         CODE:
1369                 close_ref = newSVsv(arg);
1370
1371
1372 void
1373 set_sort_handler(arg)
1374                 SV *arg
1375         CODE:
1376                 sort_ref = newSVsv(arg);
1377
1378 void
1379 set_search_handler(arg)
1380                 SV *arg
1381         CODE:
1382                 search_ref = newSVsv(arg);
1383
1384
1385 void
1386 set_fetch_handler(arg)
1387                 SV *arg
1388         CODE:
1389                 fetch_ref = newSVsv(arg);
1390
1391
1392 void
1393 set_present_handler(arg)
1394                 SV *arg
1395         CODE:
1396                 present_ref = newSVsv(arg);
1397
1398
1399 void
1400 set_esrequest_handler(arg)
1401                 SV *arg
1402         CODE:
1403                 esrequest_ref = newSVsv(arg);
1404
1405
1406 void
1407 set_delete_handler(arg)
1408                 SV *arg
1409         CODE:
1410                 delete_ref = newSVsv(arg);
1411
1412
1413 void
1414 set_scan_handler(arg)
1415                 SV *arg
1416         CODE:
1417                 scan_ref = newSVsv(arg);
1418
1419
1420 int
1421 start_server(...)
1422         PREINIT:
1423                 char **argv;
1424                 char **argv_buf;
1425                 char *ptr;
1426                 int i;
1427                 STRLEN len;
1428         CODE:
1429                 argv_buf = (char **)xmalloc((items + 1) * sizeof(char *));
1430                 argv = argv_buf;
1431                 for (i = 0; i < items; i++)
1432                 {
1433                         ptr = SvPV(ST(i), len);
1434                         *argv_buf = (char *)xmalloc(len + 1);
1435                         strcpy(*argv_buf++, ptr);
1436                 }
1437                 *argv_buf = NULL;
1438                 root_perl_context = PERL_GET_CONTEXT;
1439                 nmem_mutex_create(&simpleserver_mutex);
1440 #if 0
1441                 /* only for debugging perl_clone .. */
1442                 tst_clones();
1443 #endif
1444
1445                 RETVAL = statserv_main(items, argv, bend_init, bend_close);
1446         OUTPUT:
1447                 RETVAL
1448
1449
1450 int
1451 ScanSuccess()
1452         CODE:
1453                 RETVAL = BEND_SCAN_SUCCESS;
1454         OUTPUT:
1455                 RETVAL
1456
1457 int
1458 ScanPartial()
1459         CODE:
1460                 RETVAL = BEND_SCAN_PARTIAL;
1461         OUTPUT:
1462                 RETVAL
1463
1464
1465 void
1466 yazlog(arg)
1467                 SV *arg
1468         CODE:
1469                 STRLEN len;
1470                 char *ptr;
1471                 ptr = SvPV(arg, len);
1472                 yaz_log(YLOG_LOG, "%.*s", len, ptr);