SimpleServer.xs

   1 /* This file is part of simpleserver.
   2  * Copyright (C) 2000-2015 Index Data.
   3  * All rights reserved.
   4  * Redistribution and use in source and binary forms, with or without
   5  * modification, are permitted provided that the following conditions are met:
   6  *
   7  *     * Redistributions of source code must retain the above copyright
   8  *       notice, this list of conditions and the following disclaimer.
   9  *     * Redistributions in binary form must reproduce the above copyright
  10  *       notice, this list of conditions and the following disclaimer in the
  11  *       documentation and/or other materials provided with the distribution.
  12  *     * Neither the name of Index Data nor the names of its contributors
  13  *       may be used to endorse or promote products derived from this
  14  *       software without specific prior written permission.
  15  *
  16  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY
  17  * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  19  * DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY
  20  * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  21  * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  22  * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  23  * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  24  * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  25  * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26  */
  27
  28 #include "EXTERN.h"
  29 #include "perl.h"
  30 #include "proto.h"
  31 #include "embed.h"
  32 #include "XSUB.h"
  33 #include <assert.h>
  34 #include <yaz/backend.h>
  35 #include <yaz/facet.h>
  36 #include <yaz/log.h>
  37 #include <yaz/wrbuf.h>
  38 #include <yaz/pquery.h>
  39 #include <yaz/querytowrbuf.h>
  40 #include <stdio.h>
  41 #include <yaz/mutex.h>
  42 #include <yaz/oid_db.h>
  43 #include <yaz/yaz-version.h>
  44 #ifdef WIN32
  45 #else
  46 #include <unistd.h>
  47 #endif
  48 #include <stdlib.h>
  49 #include <ctype.h>
  50 #define GRS_MAX_FIELDS 500
  51 #ifdef ASN_COMPILED
  52 #include <yaz/ill.h>
  53 #endif
  54 #ifndef sv_undef                /* To fix the problem with Perl 5.6.0 */
  55 #define sv_undef PL_sv_undef
  56 #endif
  57
  58 YAZ_MUTEX simpleserver_mutex;
  59
  60 typedef struct {
  61         SV *ghandle;    /* Global handle specified at creation */
  62         SV *handle;     /* Per-connection handle set at Init */
  63         NMEM nmem;
  64         int stop_flag;  /* is used to stop server prematurely .. */
  65 } Zfront_handle;
  66
  67 #define ENABLE_STOP_SERVER 0
  68
  69 SV *_global_ghandle = NULL; /* To be copied into zhandle then ignored */
  70 SV *init_ref = NULL;
  71 SV *close_ref = NULL;
  72 SV *sort_ref = NULL;
  73 SV *search_ref = NULL;
  74 SV *fetch_ref = NULL;
  75 SV *present_ref = NULL;
  76 SV *esrequest_ref = NULL;
  77 SV *delete_ref = NULL;
  78 SV *scan_ref = NULL;
  79 SV *explain_ref = NULL;
  80 SV *start_ref = NULL;
  81 PerlInterpreter *root_perl_context;
  82
  83 #define GRS_BUF_SIZE 8192
  84
  85
  86 /*
  87  * Inspects the SV indicated by svp, and returns a null pointer if
  88  * it's an undefined value, or a string allocation from `stream'
  89  * otherwise.  Using this when filling in addinfo avoids those
  90  * irritating "Use of uninitialized value in subroutine entry"
  91  * warnings from Perl.
  92  */
  93 char *string_or_undef(SV **svp, ODR stream) {
  94         STRLEN len;
  95         char *ptr;
  96
  97         if (!SvOK(*svp))
  98                 return 0;
  99
 100         ptr = SvPV(*svp, len);
 101         return odr_strdupn(stream, ptr, len);
 102 }
 103
 104
 105 CV * simpleserver_sv2cv(SV *handler) {
 106     STRLEN len;
 107     char *buf;
 108
 109     if (SvPOK(handler)) {
 110         CV *ret;
 111         buf = SvPV( handler, len);
 112         if ( !( ret = perl_get_cv(buf, FALSE ) ) ) {
 113             fprintf( stderr, "simpleserver_sv2cv: No such handler '%s'\n\n", buf );
 114             exit(1);
 115         }
 116
 117         return ret;
 118     } else {
 119         return (CV *) handler;
 120     }
 121 }
 122
 123 /* debugging routine to check for destruction of Perl interpreters */
 124 #ifdef USE_ITHREADS
 125 void tst_clones(void)
 126 {
 127     int i;
 128     PerlInterpreter *parent = PERL_GET_CONTEXT;
 129     for (i = 0; i<5000; i++)
 130     {
 131         PerlInterpreter *perl_interp;
 132
 133         PERL_SET_CONTEXT(parent);
 134         PL_perl_destruct_level = 2;
 135         perl_interp = perl_clone(parent, CLONEf_CLONE_HOST);
 136         PL_perl_destruct_level = 2;
 137         PERL_SET_CONTEXT(perl_interp);
 138         perl_destruct(perl_interp);
 139         perl_free(perl_interp);
 140     }
 141     exit (0);
 142 }
 143 #endif
 144
 145 int simpleserver_clone(void) {
 146 #ifdef USE_ITHREADS
 147      yaz_mutex_enter(simpleserver_mutex);
 148      if (1)
 149      {
 150          PerlInterpreter *current = PERL_GET_CONTEXT;
 151
 152          /* if current is unset, then we're in a new thread with
 153           * no Perl interpreter for it. So we must create one .
 154           * This will only happen when threaded is used..
 155           */
 156          if (!current) {
 157              PerlInterpreter *perl_interp;
 158              PERL_SET_CONTEXT( root_perl_context );
 159              perl_interp = perl_clone(root_perl_context, CLONEf_CLONE_HOST);
 160              PERL_SET_CONTEXT( perl_interp );
 161          }
 162      }
 163      yaz_mutex_leave(simpleserver_mutex);
 164 #endif
 165      return 0;
 166 }
 167
 168
 169 void simpleserver_free(void) {
 170     yaz_mutex_enter(simpleserver_mutex);
 171     if (1)
 172     {
 173         PerlInterpreter *current_interp = PERL_GET_CONTEXT;
 174
 175         /* If current Perl Interp is different from root interp, then
 176          * we're in threaded mode and we must destroy..
 177          */
 178         if (current_interp != root_perl_context) {
 179             PL_perl_destruct_level = 2;
 180             PERL_SET_CONTEXT(current_interp);
 181             perl_destruct(current_interp);
 182             perl_free(current_interp);
 183         }
 184     }
 185     yaz_mutex_leave(simpleserver_mutex);
 186 }
 187
 188
 189 Z_GenericRecord *read_grs1(char *str, ODR o)
 190 {
 191         int type, ivalue;
 192         char line[GRS_BUF_SIZE+1], *buf, *ptr, *original;
 193         char value[GRS_BUF_SIZE+1];
 194         Z_GenericRecord *r = 0;
 195
 196         original = str;
 197         r = (Z_GenericRecord *)odr_malloc(o, sizeof(*r));
 198         r->elements = (Z_TaggedElement **)
 199                 odr_malloc(o, sizeof(Z_TaggedElement*) * GRS_MAX_FIELDS);
 200         r->num_elements = 0;
 201
 202         for (;;)
 203         {
 204                 Z_TaggedElement *t;
 205                 Z_ElementData *c;
 206                 int len;
 207
 208                 ptr = strchr(str, '\n');
 209                 if (!ptr) {
 210                         return r;
 211                 }
 212                 len = ptr - str;
 213                 if (len > GRS_BUF_SIZE) {
 214                     yaz_log(YLOG_WARN, "GRS string too long - truncating (%d > %d)", len, GRS_BUF_SIZE);
 215                     len = GRS_BUF_SIZE;
 216                 }
 217                 strncpy(line, str, len);
 218                 line[len] = 0;
 219                 buf = line;
 220                 str = ptr + 1;
 221                 while (*buf && isspace(*buf))
 222                         buf++;
 223                 if (*buf == '}') {
 224                         memmove(original, str, strlen(str));
 225                         return r;
 226                 }
 227                 if (sscanf(buf, "(%d,%[^)])", &type, value) != 2)
 228                 {
 229                         yaz_log(YLOG_WARN, "Bad data in '%s'", buf);
 230                         return r;
 231                 }
 232                 if (!type && *value == '0')
 233                         return r;
 234                 if (!(buf = strchr(buf, ')')))
 235                         return r;
 236                 buf++;
 237                 while (*buf && isspace(*buf))
 238                         buf++;
 239                 if (r->num_elements >= GRS_MAX_FIELDS)
 240                 {
 241                         yaz_log(YLOG_WARN, "Max number of GRS-1 elements exceeded [GRS_MAX_FIELDS=%d]", GRS_MAX_FIELDS);
 242                         exit(0);
 243                 }
 244                 r->elements[r->num_elements] = t = (Z_TaggedElement *)
 245                         odr_malloc(o, sizeof(Z_TaggedElement));
 246                 t->tagType = odr_intdup(o, type);
 247                 t->tagValue = (Z_StringOrNumeric *)
 248                         odr_malloc(o, sizeof(Z_StringOrNumeric));
 249                 if ((ivalue = atoi(value)))
 250                 {
 251                         t->tagValue->which = Z_StringOrNumeric_numeric;
 252                         t->tagValue->u.numeric = odr_intdup(o, ivalue);
 253                 }
 254                 else
 255                 {
 256                         t->tagValue->which = Z_StringOrNumeric_string;
 257                         t->tagValue->u.string = odr_strdup(o, value);
 258                 }
 259                 t->tagOccurrence = 0;
 260                 t->metaData = 0;
 261                 t->appliedVariant = 0;
 262                 t->content = c = (Z_ElementData *)
 263                         odr_malloc(o, sizeof(Z_ElementData));
 264                 if (*buf == '{')
 265                 {
 266                         c->which = Z_ElementData_subtree;
 267                         c->u.subtree = read_grs1(str, o);
 268                 }
 269                 else
 270                 {
 271                         c->which = Z_ElementData_string;
 272                         c->u.string = odr_strdup(o, buf);
 273                 }
 274                 r->num_elements++;
 275         }
 276 }
 277
 278
 279
 280 static void oid2str(Odr_oid *o, WRBUF buf)
 281 {
 282     for (; *o >= 0; o++) {
 283         char ibuf[16];
 284         sprintf(ibuf, "%d", *o);
 285         wrbuf_puts(buf, ibuf);
 286         if (o[1] > 0)
 287             wrbuf_putc(buf, '.');
 288     }
 289 }
 290
 291 WRBUF oid2dotted(Odr_oid *oid)
 292 {
 293     WRBUF buf = wrbuf_alloc();
 294     oid2str(oid, buf);
 295     return buf;
 296 }
 297
 298
 299 WRBUF zquery2pquery(Z_Query *q)
 300 {
 301     WRBUF buf = wrbuf_alloc();
 302
 303     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101)
 304         return 0;
 305     yaz_rpnquery_to_wrbuf(buf, q->u.type_1);
 306     return buf;
 307 }
 308
 309
 310 /* Lifted verbatim from Net::Z3950 yazwrap/util.c */
 311 #include <stdarg.h>
 312 void fatal(char *fmt, ...)
 313 {
 314     va_list ap;
 315
 316     fprintf(stderr, "FATAL (SimpleServer): ");
 317     va_start(ap, fmt);
 318     vfprintf(stderr, fmt, ap);
 319     va_end(ap);
 320     fprintf(stderr, "\n");
 321     abort();
 322 }
 323
 324
 325 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 326 /*
 327  * Creates a new Perl object of type `class'; the newly-created scalar
 328  * that is a reference to the blessed thingy `referent' is returned.
 329  */
 330 static SV *newObject(char *class, SV *referent)
 331 {
 332     HV *stash;
 333     SV *sv;
 334
 335     sv = newRV_noinc((SV*) referent);
 336     stash = gv_stashpv(class, 0);
 337     if (stash == 0)
 338         fatal("attempt to create object of undefined class '%s'", class);
 339     /*assert(stash != 0);*/
 340     sv_bless(sv, stash);
 341     return sv;
 342 }
 343
 344
 345 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 346 static void setMember(HV *hv, char *name, SV *val)
 347 {
 348     /* We don't increment `val's reference count -- I think this is
 349      * right because it's created with a refcount of 1, and in fact
 350      * the reference via this hash is the only reference to it in
 351      * general.
 352      */
 353     if (!hv_store(hv, name, (U32) strlen(name), val, (U32) 0))
 354         fatal("couldn't store member in hash");
 355 }
 356
 357
 358 /* Lifted verbatim from Net::Z3950 yazwrap/receive.c */
 359 static SV *translateOID(Odr_oid *x)
 360 {
 361     /* Yaz represents an OID by an int array terminated by a negative
 362      * value, typically -1; we represent it as a reference to a
 363      * blessed scalar string of "."-separated elements.
 364      */
 365     char buf[1000];
 366     int i;
 367
 368     *buf = '\0';
 369     for (i = 0; x[i] >= 0; i++) {
 370         sprintf(buf + strlen(buf), "%d", (int) x[i]);
 371         if (x[i+1] >- 0)
 372             strcat(buf, ".");
 373     }
 374
 375     /*
 376      * ### We'd like to return a blessed scalar (string) here, but of
 377      *  course you can't do that in Perl: only references can be
 378      *  blessed, so we'd have to return a _reference_ to a string, and
 379      *  bless _that_.  Better to do without the blessing, I think.
 380      */
 381     if (1) {
 382         return newSVpv(buf, 0);
 383     } else {
 384         return newObject("Net::Z3950::APDU::OID", newSVpv(buf, 0));
 385     }
 386 }
 387
 388 static SV *attributes2perl(Z_AttributeList *list)
 389 {
 390     AV *av;
 391         int i;
 392         SV *attrs = newObject("Net::Z3950::RPN::Attributes",
 393                               (SV*) (av = newAV()));
 394         for (i = 0; i < list->num_attributes; i++) {
 395             Z_AttributeElement *elem = list->attributes[i];
 396             HV *hv2;
 397             SV *tmp = newObject("Net::Z3950::RPN::Attribute",
 398                                 (SV*) (hv2 = newHV()));
 399             if (elem->attributeSet)
 400                 setMember(hv2, "attributeSet",
 401                           translateOID(elem->attributeSet));
 402             setMember(hv2, "attributeType",
 403                       newSViv(*elem->attributeType));
 404             if (elem->which == Z_AttributeValue_numeric) {
 405                 setMember(hv2, "attributeValue",
 406                           newSViv(*elem->value.numeric));
 407             } else {
 408                 Z_ComplexAttribute *c;
 409                 Z_StringOrNumeric *son;
 410                 assert(elem->which == Z_AttributeValue_complex);
 411                 c = elem->value.complex;
 412                 /* We ignore semantic actions and multiple values */
 413                 assert(c->num_list > 0);
 414                 son = c->list[0];
 415                 if (son->which == Z_StringOrNumeric_numeric) {
 416                     setMember(hv2, "attributeValue",
 417                               newSViv(*son->u.numeric));
 418                 } else { /*Z_StringOrNumeric_string*/
 419                     setMember(hv2, "attributeValue",
 420                               newSVpv(son->u.string, 0));
 421                 }
 422             }
 423             av_push(av, tmp);
 424         }
 425         return attrs;
 426 }
 427
 428 static SV *f_Term_to_SV(Z_Term *term, Z_AttributeList *attributes)
 429 {
 430         HV *hv;
 431         SV *sv = newObject("Net::Z3950::RPN::Term", (SV*) (hv = newHV()));
 432
 433         if (term->which != Z_Term_general)
 434                 fatal("can't handle RPN terms other than general");
 435
 436         setMember(hv, "term", newSVpv((char*) term->u.general->buf,
 437                                   term->u.general->len));
 438
 439         if (attributes) {
 440                 setMember(hv, "attributes", attributes2perl(attributes));
 441         }
 442         return sv;
 443 }
 444
 445 static SV *rpn2perl(Z_RPNStructure *s)
 446 {
 447     SV *sv;
 448     HV *hv;
 449     AV *av;
 450     Z_Operand *o;
 451
 452     switch (s->which) {
 453     case Z_RPNStructure_simple:
 454         o = s->u.simple;
 455         switch (o->which) {
 456         case Z_Operand_resultSetId: {
 457             /* This code causes a SIGBUS on my machine, and I have no
 458                idea why.  It seems as clear as day to me */
 459             SV *sv2;
 460             char *rsid = (char*) o->u.resultSetId;
 461             /*printf("Encoding resultSetId '%s'\n", rsid);*/
 462             sv = newObject("Net::Z3950::RPN::RSID", (SV*) (hv = newHV()));
 463             /*printf("Made sv=0x%lx, hv=0x%lx\n", (unsigned long) sv ,(unsigned long) hv);*/
 464             sv2 = newSVpv(rsid, strlen(rsid));
 465             setMember(hv, "id", sv2);
 466             /*printf("Set hv{id} to 0x%lx\n", (unsigned long) sv2);*/
 467             return sv;
 468         }
 469
 470         case  Z_Operand_APT:
 471             return f_Term_to_SV(o->u.attributesPlusTerm->term,
 472                         o->u.attributesPlusTerm->attributes);
 473         default:
 474             fatal("unknown RPN simple type %d", (int) o->which);
 475         }
 476
 477     case Z_RPNStructure_complex: {
 478         SV *tmp;
 479         Z_Complex *c = s->u.complex;
 480         char *type = 0;         /* vacuous assignment satisfies gcc -Wall */
 481         switch (c->roperator->which) {
 482         case Z_Operator_and:     type = "Net::Z3950::RPN::And";    break;
 483         case Z_Operator_or:      type = "Net::Z3950::RPN::Or";     break;
 484         case Z_Operator_and_not: type = "Net::Z3950::RPN::AndNot"; break;
 485         case Z_Operator_prox:    type = "Net::Z3950::RPN::Prox"; break;
 486         default: fatal("unknown RPN operator %d", (int) c->roperator->which);
 487         }
 488         sv = newObject(type, (SV*) (av = newAV()));
 489         if ((tmp = rpn2perl(c->s1)) == 0)
 490             return 0;
 491         av_push(av, tmp);
 492         if ((tmp = rpn2perl(c->s2)) == 0)
 493             return 0;
 494         av_push(av, tmp);
 495         if (c->roperator->which == Z_Operator_prox) {
 496                 Z_ProximityOperator prox = *c->roperator->u.prox;
 497                 HV *hv;
 498                 tmp = newObject("Net::Z3950::RPN::Prox::Attributes", (SV*) (hv = newHV()));
 499                 setMember(hv, "exclusion", newSViv(*prox.exclusion));
 500                 setMember(hv, "distance", newSViv(*prox.distance));
 501                 setMember(hv, "ordered", newSViv(*prox.ordered));
 502                 setMember(hv, "relationType", newSViv(*prox.relationType));
 503                 if (prox.which == Z_ProximityOperator_known) {
 504                         setMember(hv, "known", newSViv(*prox.u.known));
 505                 } else {
 506                         setMember(hv, "zprivate", newSViv(*prox.u.zprivate));
 507                 }
 508                 av_push(av, tmp);
 509         }
 510         return sv;
 511     }
 512
 513     default:
 514         fatal("unknown RPN node type %d", (int) s->which);
 515     }
 516
 517     return 0;
 518 }
 519
 520
 521 /* Decode the Z_SortAttributes struct and store the whole thing into the
 522  * hash by reference
 523  */
 524 int simpleserver_ExpandSortAttributes (HV *sort_spec, Z_SortAttributes *sattr)
 525 {
 526     WRBUF attrset_wr = wrbuf_alloc();
 527     AV *list = newAV();
 528     Z_AttributeList *attr_list = sattr->list;
 529     int i;
 530
 531     oid2str(sattr->id, attrset_wr);
 532     hv_store(sort_spec, "ATTRSET", 7,
 533              newSVpv(attrset_wr->buf, attrset_wr->pos), 0);
 534     wrbuf_destroy(attrset_wr);
 535
 536     hv_store(sort_spec, "SORT_ATTR", 9, newRV( sv_2mortal( (SV*) list ) ), 0);
 537
 538     for (i = 0; i < attr_list->num_attributes; i++)
 539     {
 540         Z_AttributeElement *attr = *attr_list->attributes++;
 541         HV *attr_spec = newHV();
 542
 543         av_push(list, newRV( sv_2mortal( (SV*) attr_spec ) ));
 544         hv_store(attr_spec, "ATTR_TYPE", 9, newSViv(*attr->attributeType), 0);
 545
 546         if (attr->which == Z_AttributeValue_numeric)
 547         {
 548             hv_store(attr_spec, "ATTR_VALUE", 10,
 549                      newSViv(*attr->value.numeric), 0);
 550         } else {
 551             return 0;
 552         }
 553     }
 554
 555     return 1;
 556 }
 557
 558
 559 /* Decode the Z_SortKeySpec struct and store the whole thing in a perl hash */
 560 int simpleserver_SortKeySpecToHash (HV *sort_spec, Z_SortKeySpec *spec)
 561 {
 562     Z_SortElement *element = spec->sortElement;
 563
 564     hv_store(sort_spec, "RELATION", 8, newSViv(*spec->sortRelation), 0);
 565     hv_store(sort_spec, "CASE", 4, newSViv(*spec->caseSensitivity), 0);
 566     hv_store(sort_spec, "MISSING", 7, newSViv(spec->which), 0);
 567
 568     if (element->which == Z_SortElement_generic)
 569     {
 570         Z_SortKey *key = element->u.generic;
 571
 572         if (key->which == Z_SortKey_sortField)
 573         {
 574             hv_store(sort_spec, "SORTFIELD", 9,
 575                      newSVpv((char *) key->u.sortField, 0), 0);
 576         }
 577         else if (key->which == Z_SortKey_elementSpec)
 578         {
 579             Z_Specification *zspec = key->u.elementSpec;
 580
 581             hv_store(sort_spec, "ELEMENTSPEC_TYPE", 16,
 582                      newSViv(zspec->which), 0);
 583
 584             if (zspec->which == Z_Schema_oid)
 585             {
 586                 WRBUF elementSpec = wrbuf_alloc();
 587
 588                 oid2str(zspec->schema.oid, elementSpec);
 589                 hv_store(sort_spec, "ELEMENTSPEC_VALUE", 17,
 590                          newSVpv(elementSpec->buf, elementSpec->pos), 0);
 591                 wrbuf_destroy(elementSpec);
 592             }
 593             else if (zspec->which == Z_Schema_uri)
 594             {
 595                 hv_store(sort_spec, "ELEMENTSPEC_VALUE", 17,
 596                          newSVpv((char *) zspec->schema.uri, 0), 0);
 597             }
 598         }
 599         else if (key->which == Z_SortKey_sortAttributes)
 600         {
 601             return simpleserver_ExpandSortAttributes(sort_spec,
 602                                                      key->u.sortAttributes);
 603         }
 604         else
 605         {
 606             return 0;
 607         }
 608     }
 609     else
 610     {
 611         return 0;
 612     }
 613
 614     return 1;
 615 }
 616
 617
 618 static SV *zquery2perl(Z_Query *q)
 619 {
 620     SV *sv;
 621     HV *hv;
 622
 623     if (q->which != Z_Query_type_1 && q->which != Z_Query_type_101)
 624         return 0;
 625     sv = newObject("Net::Z3950::APDU::Query", (SV*) (hv = newHV()));
 626     if (q->u.type_1->attributeSetId)
 627         setMember(hv, "attributeSet",
 628                   translateOID(q->u.type_1->attributeSetId));
 629     setMember(hv, "query", rpn2perl(q->u.type_1->RPNStructure));
 630     return sv;
 631 }
 632
 633
 634 int bend_sort(void *handle, bend_sort_rr *rr)
 635 {
 636         HV *href;
 637         AV *aref;
 638         AV *sort_seq;
 639         SV **temp;
 640         SV *err_code;
 641         SV *err_str;
 642         SV *status;
 643         SV *point;
 644         STRLEN len;
 645         char *ptr;
 646         char **input_setnames;
 647         Zfront_handle *zhandle = (Zfront_handle *)handle;
 648         Z_SortKeySpecList *sort_spec = rr->sort_sequence;
 649         int i;
 650
 651         dSP;
 652         ENTER;
 653         SAVETMPS;
 654
 655         aref = newAV();
 656         input_setnames = rr->input_setnames;
 657         for (i = 0; i < rr->num_input_setnames; i++)
 658         {
 659             av_push(aref, newSVpv(*input_setnames++, 0));
 660         }
 661
 662         sort_seq = newAV();
 663         for (i = 0; i < sort_spec->num_specs; i++)
 664         {
 665             Z_SortKeySpec *spec = *sort_spec->specs++;
 666             HV *sort_spec = newHV();
 667
 668             if ( simpleserver_SortKeySpecToHash(sort_spec, spec) )
 669                 av_push(sort_seq, newRV( sv_2mortal( (SV*) sort_spec ) ));
 670             else
 671             {
 672                 rr->errcode = 207;
 673                 return 0;
 674             }
 675         }
 676
 677         href = newHV();
 678         hv_store(href, "INPUT", 5, newRV( (SV*) aref), 0);
 679         hv_store(href, "OUTPUT", 6, newSVpv(rr->output_setname, 0), 0);
 680         hv_store(href, "SEQUENCE", 8, newRV( (SV*) sort_seq), 0);
 681         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
 682         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 683         hv_store(href, "STATUS", 6, newSViv(0), 0);
 684         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
 685         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
 686
 687         PUSHMARK(sp);
 688
 689         XPUSHs(sv_2mortal(newRV( (SV*) href)));
 690
 691         PUTBACK;
 692
 693         perl_call_sv(sort_ref, G_SCALAR | G_DISCARD);
 694
 695         SPAGAIN;
 696
 697         temp = hv_fetch(href, "ERR_CODE", 8, 1);
 698         err_code = newSVsv(*temp);
 699
 700         temp = hv_fetch(href, "ERR_STR", 7, 1);
 701         err_str = newSVsv(*temp);
 702
 703         temp = hv_fetch(href, "STATUS", 6, 1);
 704         status = newSVsv(*temp);
 705
 706         temp = hv_fetch(href, "HANDLE", 6, 1);
 707         point = newSVsv(*temp);
 708
 709         hv_undef(href);
 710         av_undef(aref);
 711         av_undef(sort_seq);
 712
 713         sv_free( (SV*) aref);
 714         sv_free( (SV*) href);
 715         sv_free( (SV*) sort_seq);
 716
 717         rr->errcode = SvIV(err_code);
 718         rr->sort_status = SvIV(status);
 719
 720         ptr = SvPV(err_str, len);
 721         rr->errstring = odr_strdupn(rr->stream, ptr, len);
 722         zhandle->handle = point;
 723
 724         sv_free(err_code);
 725         sv_free(err_str);
 726         sv_free(status);
 727
 728         PUTBACK;
 729         FREETMPS;
 730         LEAVE;
 731
 732         return 0;
 733 }
 734
 735 static SV *f_FacetField_to_SV(Z_FacetField *facet_field)
 736 {
 737         HV *hv;
 738         AV *av;
 739         SV *terms;
 740         int i;
 741         SV *sv = newObject("Net::Z3950::FacetField", (SV *) (hv = newHV()));
 742         if (facet_field->attributes) {
 743                 setMember(hv, "attributes",
 744                      attributes2perl(facet_field->attributes));
 745         }
 746         terms = newObject("Net::Z3950::FacetTerms", (SV *) (av = newAV()));
 747
 748         for (i = 0; i < facet_field->num_terms; i++) {
 749             Z_Term *z_term = facet_field->terms[i]->term;
 750             HV *hv;
 751             SV *sv_count = newSViv(*facet_field->terms[i]->count);
 752             SV *sv_term;
 753             SV *tmp;
 754             if (z_term->which == Z_Term_general) {
 755                 sv_term = newSVpv((char*) z_term->u.general->buf,
 756                                    z_term->u.general->len);
 757             } else if (z_term->which == Z_Term_characterString) {
 758                 sv_term = newSVpv(z_term->u.characterString,
 759                                   strlen(z_term->u.characterString));
 760             }
 761             tmp = newObject("Net::Z3950::FacetTerm", (SV *) (hv = newHV()));
 762
 763             setMember(hv, "count", sv_count);
 764             setMember(hv, "term", sv_term);
 765
 766             av_push(av, tmp);
 767         }
 768         setMember(hv, "terms", terms);
 769         return sv;
 770 }
 771
 772 static SV *f_FacetList_to_SV(Z_FacetList *facet_list)
 773 {
 774         SV *sv = 0;
 775         if (facet_list) {
 776                 AV *av;
 777                 int i;
 778                 sv = newObject("Net::Z3950::FacetList", (SV *) (av = newAV()));
 779
 780                 for (i = 0; i < facet_list->num; i++) {
 781                        SV *sv = f_FacetField_to_SV(facet_list->elements[i]);
 782                        av_push(av, sv);
 783                 }
 784         }
 785         return sv;
 786 }
 787
 788
 789 static void f_SV_to_FacetField(HV *facet_field_hv, Z_FacetField **fl, ODR odr)
 790 {
 791         int i;
 792         int num_terms, num_attributes;
 793         SV **temp;
 794         Z_AttributeList *attributes = odr_malloc(odr, sizeof(*attributes));
 795
 796         AV *sv_terms, *sv_attributes;
 797
 798         temp = hv_fetch(facet_field_hv, "attributes", 10, 1);
 799         sv_attributes = (AV *) SvRV(*temp);
 800         num_attributes = av_len(sv_attributes) + 1;
 801         attributes->num_attributes = num_attributes;
 802         attributes->attributes = (Z_AttributeElement **)
 803              odr_malloc(odr, sizeof(*attributes->attributes) * num_attributes);
 804
 805         for (i = 0; i < num_attributes; i++) {
 806             HV *hv_elem = (HV*) SvRV(sv_2mortal(av_shift(sv_attributes)));
 807             Z_AttributeElement *elem;
 808             elem = (Z_AttributeElement *) odr_malloc(odr, sizeof(*elem));
 809             attributes->attributes[i] = elem;
 810
 811             elem->attributeSet = 0;
 812
 813             temp = hv_fetch(hv_elem, "attributeType", 13, 1);
 814             elem->attributeType = odr_intdup(odr, SvIV(*temp));
 815
 816             temp = hv_fetch(hv_elem, "attributeValue", 14, 1);
 817
 818             if (SvIOK(*temp)) {
 819                     elem->which = Z_AttributeValue_numeric;
 820                     elem->value.numeric = odr_intdup(odr, SvIV(*temp));
 821             } else {
 822                     STRLEN s_len;
 823                     char *s_buf = SvPV(*temp, s_len);
 824                     Z_ComplexAttribute *c = odr_malloc(odr, sizeof *c);
 825                     elem->which = Z_AttributeValue_complex;
 826                     elem->value.complex = c;
 827
 828                     c->num_list = 1;
 829                     c->list = (Z_StringOrNumeric **) odr_malloc(odr,
 830                           sizeof(*c->list));
 831                     c->list[0] = (Z_StringOrNumeric *) odr_malloc(odr,
 832                           sizeof(**c->list));
 833                     c->list[0]->which = Z_StringOrNumeric_string;
 834                     c->list[0]->u.string = odr_strdupn(odr, s_buf, s_len);
 835                     c->num_semanticAction = 0;
 836                     c->semanticAction = 0;
 837             }
 838             hv_undef(hv_elem);
 839         }
 840
 841         temp = hv_fetch(facet_field_hv, "terms", 5, 1);
 842
 843         sv_terms = (AV *) SvRV(*temp);
 844         if (SvTYPE(sv_terms) == SVt_PVAV) {
 845             num_terms = av_len(sv_terms) + 1;
 846         } else {
 847             num_terms = 0;
 848         }
 849         *fl = facet_field_create(odr, attributes, num_terms);
 850         for (i = 0; i < num_terms; i++) {
 851             STRLEN s_len;
 852             char *s_buf;
 853             HV *hv_elem = (HV*) SvRV(sv_2mortal(av_shift(sv_terms)));
 854
 855             Z_FacetTerm *facet_term =
 856              (Z_FacetTerm *) odr_malloc(odr, sizeof(*facet_term));
 857             (*fl)->terms[i] = facet_term;
 858
 859             temp = hv_fetch(hv_elem, "count", 5, 1);
 860             facet_term->count = odr_intdup(odr, SvIV(*temp));
 861
 862             temp = hv_fetch(hv_elem, "term", 4, 1);
 863
 864             s_buf = SvPV(*temp, s_len);
 865             facet_term->term = z_Term_create(odr, Z_Term_general, s_buf, s_len);
 866             hv_undef(hv_elem);
 867         }
 868 }
 869
 870 static void f_SV_to_FacetList(SV *sv, Z_OtherInformation **oip, ODR odr)
 871 {
 872         AV *entries = (AV *) SvRV(sv);
 873         int num_facets;
 874         if (entries && SvTYPE(entries) == SVt_PVAV &&
 875                 (num_facets = av_len(entries) + 1) > 0)
 876         {
 877             Z_OtherInformation *oi;
 878             Z_OtherInformationUnit *oiu;
 879             Z_FacetList *facet_list = facet_list_create(odr, num_facets);
 880             int i;
 881             for (i = 0; i < num_facets; i++) {
 882                 HV *facet_field = (HV*) SvRV(sv_2mortal(av_shift(entries)));
 883                 f_SV_to_FacetField(facet_field, &facet_list->elements[i], odr);
 884                 hv_undef(facet_field);
 885             }
 886             oi = odr_malloc(odr, sizeof(*oi));
 887             oiu = odr_malloc(odr, sizeof(*oiu));
 888             oi->num_elements = 1;
 889             oi->list = odr_malloc(odr, oi->num_elements * sizeof(*oi->list));
 890             oiu->category = 0;
 891             oiu->which = Z_OtherInfo_externallyDefinedInfo;
 892             oiu->information.externallyDefinedInfo = odr_malloc(odr, sizeof(*oiu->information.externallyDefinedInfo));
 893             oiu->information.externallyDefinedInfo->direct_reference = odr_oiddup(odr, yaz_oid_userinfo_facet_1);
 894             oiu->information.externallyDefinedInfo->descriptor = 0;
 895             oiu->information.externallyDefinedInfo->indirect_reference = 0;
 896             oiu->information.externallyDefinedInfo->which = Z_External_userFacets;
 897             oiu->information.externallyDefinedInfo->u.facetList = facet_list;
 898             oi->list[0] = oiu;
 899             *oip = oi;
 900         }
 901 }
 902
 903 static HV *parse_extra_args(Z_SRW_extra_arg *args)
 904 {
 905         HV *href = newHV();
 906
 907         for (; args; args = args->next)
 908         {
 909                 hv_store(href, args->name, strlen(args->name),
 910                         newSVpv(args->value, 0), 0);
 911         }
 912         return href;
 913 }
 914
 915 int bend_search(void *handle, bend_search_rr *rr)
 916 {
 917         HV *href;
 918         AV *aref;
 919         SV **temp;
 920         int i;
 921         char **basenames;
 922         WRBUF query;
 923         SV *point;
 924         Zfront_handle *zhandle = (Zfront_handle *)handle;
 925         CV* handler_cv = 0;
 926         SV *rpnSV;
 927         SV *facetSV;
 928         char *ptr;
 929         STRLEN len;
 930
 931         dSP;
 932         ENTER;
 933         SAVETMPS;
 934
 935         aref = newAV();
 936         basenames = rr->basenames;
 937         for (i = 0; i < rr->num_bases; i++)
 938         {
 939                 av_push(aref, newSVpv(*basenames++, 0));
 940         }
 941 #if ENABLE_STOP_SERVER
 942         if (rr->num_bases == 1 && !strcmp(rr->basenames[0], "XXstop"))
 943         {
 944                 zhandle->stop_flag = 1;
 945         }
 946 #endif
 947         href = newHV();
 948
 949         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
 950         if (rr->srw_sortKeys && *rr->srw_sortKeys)
 951             hv_store(href, "SRW_SORTKEYS", 12, newSVpv(rr->srw_sortKeys, 0), 0);
 952         hv_store(href, "REPL_SET", 8, newSViv(rr->replace_set), 0);
 953         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
 954         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
 955         hv_store(href, "HITS", 4, newSViv(0), 0);
 956         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
 957         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
 958         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
 959         hv_store(href, "PID", 3, newSViv(getpid()), 0);
 960         hv_store(href, "PRESENT_NUMBER", 14, newSViv(rr->present_number), 0);
 961         hv_store(href, "EXTRA_ARGS", 10,
 962                 newRV( (SV*) parse_extra_args(rr->extra_args)), 0);
 963         if ((rpnSV = zquery2perl(rr->query)) != 0) {
 964             hv_store(href, "RPN", 3, rpnSV, 0);
 965         }
 966         facetSV = f_FacetList_to_SV(yaz_oi_get_facetlist(&rr->search_input));
 967         if (facetSV) {
 968             hv_store(href, "INPUTFACETS", 11, facetSV, 0);
 969         }
 970
 971         query = zquery2pquery(rr->query);
 972         if (query)
 973         {
 974                 hv_store(href, "QUERY", 5, newSVpv((char *)query->buf, query->pos), 0);
 975         }
 976         else if (rr->query->which == Z_Query_type_104 &&
 977                  rr->query->u.type_104->which == Z_External_CQL) {
 978             hv_store(href, "CQL", 3,
 979                      newSVpv(rr->query->u.type_104->u.cql, 0), 0);
 980         }
 981         else
 982         {
 983                 rr->errcode = 108;
 984                 return 0;
 985         }
 986         PUSHMARK(sp);
 987
 988         XPUSHs(sv_2mortal(newRV( (SV*) href)));
 989
 990         PUTBACK;
 991
 992         handler_cv = simpleserver_sv2cv( search_ref );
 993         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
 994
 995         SPAGAIN;
 996
 997         temp = hv_fetch(href, "HITS", 4, 1);
 998         rr->hits = SvIV(*temp);
 999
1000         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1001         rr->errcode = SvIV(*temp);
1002
1003         temp = hv_fetch(href, "ERR_STR", 7, 1);
1004         rr->errstring = string_or_undef(temp, rr->stream);
1005
1006         temp = hv_fetch(href, "HANDLE", 6, 1);
1007         point = newSVsv(*temp);
1008
1009         temp = hv_fetch(href, "OUTPUTFACETS", 12, 1);
1010         if (SvTYPE(*temp) != SVt_NULL)
1011             f_SV_to_FacetList(*temp, &rr->search_info, rr->stream);
1012
1013         temp = hv_fetch(href, "EXTRA_RESPONSE_DATA", 19, 0);
1014         if (temp)
1015         {
1016                 ptr = SvPV(*temp, len);
1017                 rr->extra_response_data = odr_strdupn(rr->stream, ptr, len);
1018         }
1019
1020         temp = hv_fetch(href, "ESTIMATED" "_HIT_" "COUNT", 19, 0);
1021         if (temp)
1022         {
1023                 rr->estimated_hit_count = SvIV(*temp);
1024         }
1025         hv_undef(href);
1026         av_undef(aref);
1027
1028         zhandle->handle = point;
1029         sv_free( (SV*) aref);
1030         sv_free( (SV*) href);
1031         if (query)
1032             wrbuf_destroy(query);
1033         PUTBACK;
1034         FREETMPS;
1035         LEAVE;
1036         return 0;
1037 }
1038
1039
1040 /* ### I am not 100% about the memory management in this handler */
1041 int bend_delete(void *handle, bend_delete_rr *rr)
1042 {
1043         Zfront_handle *zhandle = (Zfront_handle *)handle;
1044         HV *href;
1045         CV* handler_cv;
1046         int i;
1047         SV **temp;
1048         SV *point;
1049
1050         dSP;
1051         ENTER;
1052         SAVETMPS;
1053
1054         href = newHV();
1055         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1056         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1057         hv_store(href, "STATUS", 6, newSViv(0), 0);
1058
1059         PUSHMARK(sp);
1060         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1061         PUTBACK;
1062
1063         handler_cv = simpleserver_sv2cv(delete_ref);
1064
1065         if (rr->function == 1) {
1066             /* Delete all result sets in the session */
1067             perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1068             temp = hv_fetch(href, "STATUS", 6, 1);
1069             rr->delete_status = SvIV(*temp);
1070         } else {
1071             rr->delete_status = 0;
1072             /*
1073              * For some reason, deleting two or more result-sets in
1074              * one operation goes horribly wrong, and ### I don't have
1075              * time to debug it right now.
1076              */
1077             if (rr->num_setnames > 1) {
1078                 rr->delete_status = 3; /* "System problem at target" */
1079                 /* There's no way to sent delete-msg using the GFS */
1080                 return 0;
1081             }
1082
1083             for (i = 0; i < rr->num_setnames; i++) {
1084                 hv_store(href, "SETNAME", 7, newSVpv(rr->setnames[i], 0), 0);
1085                 perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1086                 temp = hv_fetch(href, "STATUS", 6, 1);
1087                 rr->statuses[i] = SvIV(*temp);
1088                 if (rr->statuses[i] != 0)
1089                     rr->delete_status = rr->statuses[i];
1090             }
1091         }
1092
1093         SPAGAIN;
1094
1095         temp = hv_fetch(href, "HANDLE", 6, 1);
1096         point = newSVsv(*temp);
1097
1098         hv_undef(href);
1099
1100         zhandle->handle = point;
1101
1102         sv_free( (SV*) href);
1103
1104         PUTBACK;
1105         FREETMPS;
1106         LEAVE;
1107
1108         return 0;
1109 }
1110
1111
1112 int bend_fetch(void *handle, bend_fetch_rr *rr)
1113 {
1114         HV *href;
1115         SV **temp;
1116         SV *basename;
1117         SV *last;
1118         SV *err_code;
1119         SV *err_string;
1120         SV *sur_flag;
1121         SV *point;
1122         SV *rep_form;
1123         SV *schema = 0;
1124         char *ptr;
1125         WRBUF oid_dotted;
1126         Zfront_handle *zhandle = (Zfront_handle *)handle;
1127         CV* handler_cv = 0;
1128
1129         Z_RecordComposition *composition;
1130         Z_ElementSetNames *simple;
1131         Z_CompSpec *complex;
1132         STRLEN length;
1133
1134         dSP;
1135         ENTER;
1136         SAVETMPS;
1137
1138         rr->errcode = 0;
1139         href = newHV();
1140         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
1141         if (rr->schema)
1142                 hv_store(href, "SCHEMA", 6, newSVpv(rr->schema, 0), 0);
1143         else
1144                 hv_store(href, "SCHEMA", 6, newSVpv("", 0), 0);
1145
1146         temp = hv_store(href, "OFFSET", 6, newSViv(rr->number), 0);
1147         if (rr->request_format != 0) {
1148             oid_dotted = oid2dotted(rr->request_format);
1149         } else {
1150             /* Probably an SRU request: assume XML is required */
1151             oid_dotted = wrbuf_alloc();
1152             wrbuf_puts(oid_dotted, "1.2.840.10003.5.109.10");
1153         }
1154         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
1155         hv_store(href, "REP_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);
1156         hv_store(href, "BASENAME", 8, newSVpv("", 0), 0);
1157         hv_store(href, "LAST", 4, newSViv(0), 0);
1158         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1159         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
1160         hv_store(href, "SUR_FLAG", 8, newSViv(0), 0);
1161         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1162         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1163         hv_store(href, "PID", 3, newSViv(getpid()), 0);
1164         if (rr->comp)
1165         {
1166                 composition = rr->comp;
1167                 if (composition->which == Z_RecordComp_simple)
1168                 {
1169                         simple = composition->u.simple;
1170                         if (simple->which == Z_ElementSetNames_generic)
1171                         {
1172                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
1173                         }
1174                         else
1175                         {
1176                                 rr->errcode = 26;
1177                                 rr->errstring = odr_strdup(rr->stream, "non-generic 'simple' composition");
1178                                 return 0;
1179                         }
1180                 }
1181                 else if (composition->which == Z_RecordComp_complex)
1182                 {
1183                         if (composition->u.complex->generic &&
1184
1185                                         composition->u.complex->generic &&
1186                                         composition->u.complex->generic->elementSpec &&
1187                                         composition->u.complex->generic->elementSpec->which ==
1188                                         Z_ElementSpec_elementSetName)
1189                         {
1190                                 complex = composition->u.complex;
1191                                 hv_store(href, "COMP", 4,
1192                                         newSVpv(complex->generic->elementSpec->u.elementSetName, 0), 0);
1193                         }
1194                         else
1195                         {
1196 #if 0   /* For now ignore this error, which is ubiquitous in SRU */
1197                                 rr->errcode = 26;
1198                                 rr->errstring = odr_strdup(rr->stream, "'complex' composition is not generic ESN");
1199                                 return 0;
1200 #endif /*0*/
1201                         }
1202                 }
1203                 else
1204                 {
1205                         rr->errcode = 26;
1206                         rr->errstring = odr_strdup(rr->stream, "composition neither simple nor complex");
1207                         return 0;
1208                 }
1209         }
1210
1211         PUSHMARK(sp);
1212
1213         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1214
1215         PUTBACK;
1216
1217         handler_cv = simpleserver_sv2cv( fetch_ref );
1218         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1219
1220         SPAGAIN;
1221
1222         temp = hv_fetch(href, "BASENAME", 8, 1);
1223         basename = newSVsv(*temp);
1224
1225
1226         temp = hv_fetch(href, "LAST", 4, 1);
1227         last = newSVsv(*temp);
1228
1229         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1230         err_code = newSVsv(*temp);
1231
1232         temp = hv_fetch(href, "ERR_STR", 7, 1),
1233         err_string = newSVsv(*temp);
1234
1235         temp = hv_fetch(href, "SUR_FLAG", 8, 1);
1236         sur_flag = newSVsv(*temp);
1237
1238         temp = hv_fetch(href, "REP_FORM", 8, 1);
1239         rep_form = newSVsv(*temp);
1240
1241         temp = hv_fetch(href, "SCHEMA", 6, 0);
1242         if (temp != 0)
1243         {
1244                 schema = newSVsv(*temp);
1245                 ptr = SvPV(schema, length);
1246                 if (length > 0)
1247                         rr->schema = odr_strdupn(rr->stream, ptr, length);
1248         }
1249
1250         temp = hv_fetch(href, "HANDLE", 6, 1);
1251         point = newSVsv(*temp);
1252
1253         ptr = SvPV(basename, length);
1254         rr->basename = odr_strdupn(rr->stream, ptr, length);
1255
1256         ptr = SvPV(rep_form, length);
1257
1258         rr->output_format = yaz_string_to_oid_odr(yaz_oid_std(),
1259                                         CLASS_RECSYN, ptr, rr->stream);
1260         if (!rr->output_format)
1261         {
1262                 printf("Net::Z3950::SimpleServer: WARNING: Bad OID %s\n", ptr);
1263                 rr->output_format =
1264                         odr_oiddup(rr->stream, yaz_oid_recsyn_sutrs);
1265         }
1266         temp = hv_fetch(href, "RECORD", 6, 0);
1267         if (temp)
1268         {
1269                 SV *record = newSVsv(*temp);
1270                 ptr = SvPV(record, length);
1271                 /* Treat GRS-1 records separately */
1272                 if (!oid_oidcmp(rr->output_format, yaz_oid_recsyn_grs_1))
1273                 {
1274                         rr->record = (char *) read_grs1(ptr, rr->stream);
1275                         rr->len = -1;
1276                 }
1277                 else
1278                 {
1279                         rr->record = odr_strdupn(rr->stream, ptr, length);
1280                         rr->len = length;
1281                 }
1282                 sv_free(record);
1283         }
1284         hv_undef(href);
1285
1286         zhandle->handle = point;
1287         handle = zhandle;
1288         rr->last_in_set = SvIV(last);
1289
1290         if (!(rr->errcode))
1291         {
1292                 rr->errcode = SvIV(err_code);
1293                 ptr = SvPV(err_string, length);
1294                 rr->errstring = odr_strdupn(rr->stream, ptr, length);
1295         }
1296         rr->surrogate_flag = SvIV(sur_flag);
1297
1298         wrbuf_destroy(oid_dotted);
1299         sv_free((SV*) href);
1300         sv_free(basename);
1301         sv_free(last);
1302         sv_free(err_string);
1303         sv_free(err_code),
1304         sv_free(sur_flag);
1305         sv_free(rep_form);
1306
1307         if (schema)
1308                 sv_free(schema);
1309
1310         PUTBACK;
1311         FREETMPS;
1312         LEAVE;
1313
1314         return 0;
1315 }
1316
1317
1318 int bend_present(void *handle, bend_present_rr *rr)
1319 {
1320         HV *href;
1321         SV **temp;
1322         SV *err_code;
1323         SV *err_string;
1324         SV *point;
1325         STRLEN len;
1326         Z_RecordComposition *composition;
1327         Z_ElementSetNames *simple;
1328         Z_CompSpec *complex;
1329         char *ptr;
1330         Zfront_handle *zhandle = (Zfront_handle *)handle;
1331         CV* handler_cv = 0;
1332
1333 /*      WRBUF oid_dotted; */
1334
1335         dSP;
1336         ENTER;
1337         SAVETMPS;
1338
1339         href = newHV();
1340         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1341         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1342         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1343         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
1344         hv_store(href, "START", 5, newSViv(rr->start), 0);
1345         hv_store(href, "SETNAME", 7, newSVpv(rr->setname, 0), 0);
1346         hv_store(href, "NUMBER", 6, newSViv(rr->number), 0);
1347         /*oid_dotted = oid2dotted(rr->request_format_raw);
1348         hv_store(href, "REQ_FORM", 8, newSVpv((char *)oid_dotted->buf, oid_dotted->pos), 0);*/
1349         hv_store(href, "PID", 3, newSViv(getpid()), 0);
1350         if (rr->comp)
1351         {
1352                 composition = rr->comp;
1353                 if (composition->which == Z_RecordComp_simple)
1354                 {
1355                         simple = composition->u.simple;
1356                         if (simple->which == Z_ElementSetNames_generic)
1357                         {
1358                                 hv_store(href, "COMP", 4, newSVpv(simple->u.generic, 0), 0);
1359                         }
1360                         else
1361                         {
1362                                 rr->errcode = 26;
1363                                 rr->errstring = odr_strdup(rr->stream, "non-generic 'simple' composition");
1364                                 return 0;
1365                         }
1366                 }
1367                 else if (composition->which == Z_RecordComp_complex)
1368                 {
1369                         if (composition->u.complex->generic &&
1370
1371                                         composition->u.complex->generic &&
1372                                         composition->u.complex->generic->elementSpec &&
1373                                         composition->u.complex->generic->elementSpec->which ==
1374                                         Z_ElementSpec_elementSetName)
1375                         {
1376                                 complex = composition->u.complex;
1377                                 hv_store(href, "COMP", 4,
1378                                         newSVpv(complex->generic->elementSpec->u.elementSetName, 0), 0);
1379                         }
1380                         else
1381                         {
1382                                 rr->errcode = 26;
1383                                 rr->errstring = odr_strdup(rr->stream, "'complex' composition is not generic ESN");
1384                                 return 0;
1385                         }
1386                 }
1387                 else
1388                 {
1389                         rr->errcode = 26;
1390                         rr->errstring = odr_strdup(rr->stream, "composition neither simple nor complex");
1391                         return 0;
1392                 }
1393         }
1394
1395         PUSHMARK(sp);
1396
1397         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1398
1399         PUTBACK;
1400
1401         handler_cv = simpleserver_sv2cv( present_ref );
1402         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1403
1404         SPAGAIN;
1405
1406         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1407         err_code = newSVsv(*temp);
1408
1409         temp = hv_fetch(href, "ERR_STR", 7, 1);
1410         err_string = newSVsv(*temp);
1411
1412         temp = hv_fetch(href, "HANDLE", 6, 1);
1413         point = newSVsv(*temp);
1414
1415         PUTBACK;
1416         FREETMPS;
1417         LEAVE;
1418
1419         hv_undef(href);
1420         rr->errcode = SvIV(err_code);
1421
1422         ptr = SvPV(err_string, len);
1423         rr->errstring = odr_strdupn(rr->stream, ptr, len);
1424 /*      wrbuf_free(oid_dotted, 1);*/
1425         zhandle->handle = point;
1426         handle = zhandle;
1427         sv_free(err_code);
1428         sv_free(err_string);
1429         sv_free( (SV*) href);
1430
1431         return 0;
1432 }
1433
1434
1435 int bend_esrequest(void *handle, bend_esrequest_rr *rr)
1436 {
1437         perl_call_sv(esrequest_ref, G_VOID | G_DISCARD | G_NOARGS);
1438         return 0;
1439 }
1440
1441
1442 int bend_scan(void *handle, bend_scan_rr *rr)
1443 {
1444         HV *href;
1445         AV *aref;
1446         AV *list;
1447         AV *entries;
1448         HV *scan_item;
1449         struct scan_entry *buffer;
1450         int *step_size = rr->step_size;
1451         int scan_list_size = rr->num_entries;
1452         int i;
1453         char **basenames;
1454         SV **temp;
1455         SV *err_code = sv_newmortal();
1456         SV *err_str = sv_newmortal();
1457         SV *point = sv_newmortal();
1458         SV *status = sv_newmortal();
1459         SV *number = sv_newmortal();
1460         char *ptr;
1461         STRLEN len;
1462         SV *entries_ref;
1463         Zfront_handle *zhandle = (Zfront_handle *)handle;
1464         CV* handler_cv = 0;
1465         SV *rpnSV;
1466
1467         dSP;
1468         ENTER;
1469         SAVETMPS;
1470         href = newHV();
1471         list = newAV();
1472
1473         /* RPN is better than TERM since it includes attributes */
1474         if ((rpnSV = f_Term_to_SV(rr->term->term, rr->term->attributes)) != 0) {
1475             setMember(href, "RPN", rpnSV);
1476         }
1477
1478         if (rr->term->term->which == Z_Term_general)
1479         {
1480                 Odr_oct *oterm = rr->term->term->u.general;
1481                 hv_store(href, "TERM", 4, newSVpv((char*) oterm->buf,
1482                         oterm->len), 0);
1483         } else {
1484                 rr->errcode = 229;      /* Unsupported term type */
1485                 return 0;
1486         }
1487         hv_store(href, "STEP", 4, newSViv(*step_size), 0);
1488         hv_store(href, "NUMBER", 6, newSViv(rr->num_entries), 0);
1489         hv_store(href, "POS", 3, newSViv(rr->term_position), 0);
1490         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1491         hv_store(href, "ERR_STR", 7, newSVpv("", 0), 0);
1492         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1493         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1494         hv_store(href, "STATUS", 6, newSViv(BEND_SCAN_SUCCESS), 0);
1495         hv_store(href, "ENTRIES", 7, newRV((SV *) list), 0);
1496         hv_store(href, "EXTRA_ARGS", 10,
1497                 newRV( (SV*) parse_extra_args(rr->extra_args)), 0);
1498         aref = newAV();
1499         basenames = rr->basenames;
1500         for (i = 0; i < rr->num_bases; i++)
1501         {
1502                 av_push(aref, newSVpv(*basenames++, 0));
1503         }
1504         hv_store(href, "DATABASES", 9, newRV( (SV*) aref), 0);
1505
1506         PUSHMARK(sp);
1507
1508         XPUSHs(sv_2mortal(newRV( (SV*) href)));
1509
1510         PUTBACK;
1511
1512         handler_cv = simpleserver_sv2cv( scan_ref );
1513         perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1514
1515         SPAGAIN;
1516
1517         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1518         err_code = newSVsv(*temp);
1519
1520         temp = hv_fetch(href, "ERR_STR", 7, 1);
1521         err_str = newSVsv(*temp);
1522
1523         temp = hv_fetch(href, "HANDLE", 6, 1);
1524         point = newSVsv(*temp);
1525
1526         temp = hv_fetch(href, "STATUS", 6, 1);
1527         status = newSVsv(*temp);
1528
1529         temp = hv_fetch(href, "NUMBER", 6, 1);
1530         number = newSVsv(*temp);
1531
1532         temp = hv_fetch(href, "ENTRIES", 7, 1);
1533         entries_ref = newSVsv(*temp);
1534
1535         temp = hv_fetch(href, "EXTRA_RESPONSE_DATA", 19, 0);
1536         if (temp)
1537         {
1538                 ptr = SvPV(*temp, len);
1539                 rr->extra_response_data = odr_strdupn(rr->stream, ptr, len);
1540         }
1541
1542         PUTBACK;
1543         FREETMPS;
1544         LEAVE;
1545
1546         ptr = SvPV(err_str, len);
1547         rr->errstring = odr_strdupn(rr->stream, ptr, len);
1548         rr->errcode = SvIV(err_code);
1549         rr->num_entries = SvIV(number);
1550         rr->status = SvIV(status);
1551         buffer = rr->entries;
1552         entries = (AV *)SvRV(entries_ref);
1553         if (rr->errcode == 0) for (i = 0; i < rr->num_entries; i++)
1554         {
1555                 scan_item = (HV *)SvRV(sv_2mortal(av_shift(entries)));
1556                 temp = hv_fetch(scan_item, "TERM", 4, 1);
1557                 ptr = SvPV(*temp, len);
1558                 buffer->term = odr_strdupn(rr->stream, ptr, len);
1559                 temp = hv_fetch(scan_item, "OCCURRENCE", 10, 1);
1560                 buffer->occurrences = SvIV(*temp);
1561                 temp = hv_fetch(scan_item, "DISPLAY_TERM", 12, 0);
1562                 if (temp)
1563                 {
1564                         ptr = SvPV(*temp, len);
1565                         buffer->display_term = odr_strdupn(rr->stream, ptr,len);
1566                 }
1567                 buffer++;
1568                 hv_undef(scan_item);
1569         }
1570
1571         zhandle->handle = point;
1572         handle = zhandle;
1573         sv_free(err_code);
1574         sv_free(err_str);
1575         sv_free(status);
1576         sv_free(number);
1577         hv_undef(href);
1578         sv_free((SV *)href);
1579         av_undef(aref);
1580         sv_free((SV *)aref);
1581         av_undef(list);
1582         sv_free((SV *)list);
1583         av_undef(entries);
1584         /*sv_free((SV *)entries);*/
1585         sv_free(entries_ref);
1586
1587         return 0;
1588 }
1589
1590 int bend_explain(void *handle, bend_explain_rr *q)
1591 {
1592         HV *href;
1593         CV *handler_cv = 0;
1594         SV **temp;
1595         char *explain;
1596         SV *explainsv;
1597         STRLEN len;
1598         Zfront_handle *zhandle = (Zfront_handle *)handle;
1599
1600         dSP;
1601         ENTER;
1602         SAVETMPS;
1603
1604         href = newHV();
1605         hv_store(href, "EXPLAIN", 7, newSVpv("", 0), 0);
1606         hv_store(href, "DATABASE", 8, newSVpv(q->database, 0), 0);
1607         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1608         hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1609
1610         PUSHMARK(sp);
1611         XPUSHs(sv_2mortal(newRV((SV*) href)));
1612         PUTBACK;
1613
1614         handler_cv = simpleserver_sv2cv(explain_ref);
1615         perl_call_sv((SV*) handler_cv, G_SCALAR | G_DISCARD);
1616
1617         SPAGAIN;
1618
1619         temp = hv_fetch(href, "EXPLAIN", 7, 1);
1620         explainsv = newSVsv(*temp);
1621
1622         PUTBACK;
1623         FREETMPS;
1624         LEAVE;
1625
1626         explain = SvPV(explainsv, len);
1627         q->explain_buf = odr_strdupn(q->stream, explain, len);
1628
1629         return 0;
1630 }
1631
1632
1633 /*
1634  * You'll laugh when I tell you this ...  Astonishingly, it turns out
1635  * that ActivePerl (which is widely used on Windows) has, in the
1636  * header file Perl\lib\CORE\XSUB.h, the following heinous crime:
1637  *          #    define open            PerlLIO_open
1638  * This of course screws up the use of the "open" member of the
1639  * Z_IdAuthentication structure below, so we have to undo this
1640  * brain-damage.
1641  */
1642 #ifdef open
1643 #undef open
1644 #endif
1645
1646
1647 bend_initresult *bend_init(bend_initrequest *q)
1648 {
1649         int dummy = simpleserver_clone();
1650         bend_initresult *r = (bend_initresult *)
1651                 odr_malloc (q->stream, sizeof(*r));
1652         char *ptr;
1653         CV* handler_cv = 0;
1654         dSP;
1655         STRLEN len;
1656         NMEM nmem = nmem_create();
1657         Zfront_handle *zhandle = (Zfront_handle *)
1658                 nmem_malloc(nmem, sizeof(*zhandle));
1659         SV *handle;
1660         HV *href;
1661         SV **temp;
1662
1663         ENTER;
1664         SAVETMPS;
1665
1666         zhandle->ghandle = _global_ghandle;
1667         zhandle->nmem = nmem;
1668         zhandle->stop_flag = 0;
1669
1670         if (sort_ref)
1671         {
1672                 q->bend_sort = bend_sort;
1673         }
1674         if (search_ref)
1675         {
1676                 q->bend_search = bend_search;
1677         }
1678         if (present_ref)
1679         {
1680                 q->bend_present = bend_present;
1681         }
1682         /*q->bend_esrequest = bend_esrequest;*/
1683         if (delete_ref)
1684         {
1685                 q->bend_delete = bend_delete;
1686         }
1687         if (fetch_ref)
1688         {
1689                 q->bend_fetch = bend_fetch;
1690         }
1691         if (scan_ref)
1692         {
1693                 q->bend_scan = bend_scan;
1694         }
1695         if (explain_ref)
1696         {
1697                 q->bend_explain = bend_explain;
1698         }
1699
1700         href = newHV();
1701
1702         /* ### These should be given initial values from the client */
1703         hv_store(href, "IMP_ID", 6, newSVpv("", 0), 0);
1704         hv_store(href, "IMP_NAME", 8, newSVpv("", 0), 0);
1705         hv_store(href, "IMP_VER", 7, newSVpv("", 0), 0);
1706
1707         hv_store(href, "ERR_CODE", 8, newSViv(0), 0);
1708         hv_store(href, "ERR_STR", 7, newSViv(0), 0);
1709         hv_store(href, "PEER_NAME", 9, newSVpv(q->peer_name, 0), 0);
1710         hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1711         hv_store(href, "HANDLE", 6, newSVsv(&sv_undef), 0);
1712         hv_store(href, "PID", 3, newSViv(getpid()), 0);
1713         if (q->auth) {
1714             char *user = NULL;
1715             char *passwd = NULL;
1716             if (q->auth->which == Z_IdAuthentication_open) {
1717                 char *cp;
1718                 user = nmem_strdup (odr_getmem (q->stream), q->auth->u.open);
1719                 cp = strchr (user, '/');
1720                 if (cp) {
1721                     /* password after / given */
1722                     *cp = '\0';
1723                     passwd = cp+1;
1724                 }
1725             } else if (q->auth->which == Z_IdAuthentication_idPass) {
1726                 user = q->auth->u.idPass->userId;
1727                 passwd = q->auth->u.idPass->password;
1728             }
1729             /* ### some code paths have user/password unassigned here */
1730             if (user)
1731                 hv_store(href, "USER", 4, newSVpv(user, 0), 0);
1732             if (passwd)
1733                 hv_store(href, "PASS", 4, newSVpv(passwd, 0), 0);
1734         }
1735
1736         PUSHMARK(sp);
1737
1738         XPUSHs(sv_2mortal(newRV((SV*) href)));
1739
1740         PUTBACK;
1741
1742         if (init_ref != NULL)
1743         {
1744              handler_cv = simpleserver_sv2cv( init_ref );
1745              perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1746         }
1747
1748         SPAGAIN;
1749
1750         temp = hv_fetch(href, "IMP_ID", 6, 1);
1751         ptr = SvPV(*temp, len);
1752         q->implementation_id = nmem_strdup(nmem, ptr);
1753
1754         temp = hv_fetch(href, "IMP_NAME", 8, 1);
1755         ptr = SvPV(*temp, len);
1756         q->implementation_name = nmem_strdup(nmem, ptr);
1757
1758         temp = hv_fetch(href, "IMP_VER", 7, 1);
1759         ptr = SvPV(*temp, len);
1760         q->implementation_version = nmem_strdup(nmem, ptr);
1761
1762         temp = hv_fetch(href, "ERR_CODE", 8, 1);
1763         r->errcode = SvIV(*temp);
1764
1765         temp = hv_fetch(href, "ERR_STR", 7, 1);
1766         ptr = SvPV(*temp, len);
1767         r->errstring = odr_strdupn(q->stream, ptr, len);
1768
1769         temp = hv_fetch(href, "HANDLE", 6, 1);
1770         handle= newSVsv(*temp);
1771         zhandle->handle = handle;
1772
1773         r->handle = zhandle;
1774
1775         hv_undef(href);
1776         sv_free((SV*) href);
1777
1778         PUTBACK;
1779         FREETMPS;
1780         LEAVE;
1781
1782         return r;
1783 }
1784
1785 void bend_close(void *handle)
1786 {
1787         HV *href;
1788         Zfront_handle *zhandle = (Zfront_handle *)handle;
1789         CV* handler_cv = 0;
1790         int stop_flag = 0;
1791         dSP;
1792         ENTER;
1793         SAVETMPS;
1794
1795         if (close_ref)
1796         {
1797                 href = newHV();
1798                 hv_store(href, "GHANDLE", 7, newSVsv(zhandle->ghandle), 0);
1799                 hv_store(href, "HANDLE", 6, zhandle->handle, 0);
1800
1801                 PUSHMARK(sp);
1802
1803                 XPUSHs(sv_2mortal(newRV((SV *)href)));
1804
1805                 PUTBACK;
1806
1807                 handler_cv = simpleserver_sv2cv( close_ref );
1808                 perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1809
1810                 SPAGAIN;
1811
1812                 sv_free((SV*) href);
1813         }
1814         else
1815                 sv_free(zhandle->handle);
1816         PUTBACK;
1817         FREETMPS;
1818         LEAVE;
1819         stop_flag = zhandle->stop_flag;
1820         nmem_destroy(zhandle->nmem);
1821         simpleserver_free();
1822
1823         if (stop_flag)
1824                 exit(0);
1825         return;
1826 }
1827
1828 static void start_stop(struct statserv_options_block *sob, SV *handler_ref)
1829 {
1830         HV *href;
1831         dSP;
1832         ENTER;
1833         SAVETMPS;
1834
1835         href = newHV();
1836         hv_store(href, "CONFIG", 6, newSVpv(sob->configname, 0), 0);
1837
1838         PUSHMARK(sp);
1839
1840         XPUSHs(sv_2mortal(newRV((SV*) href)));
1841
1842         PUTBACK;
1843
1844         if (handler_ref != NULL)
1845         {
1846                 CV* handler_cv = simpleserver_sv2cv( handler_ref );
1847                 perl_call_sv( (SV *) handler_cv, G_SCALAR | G_DISCARD);
1848         }
1849
1850         SPAGAIN;
1851
1852         PUTBACK;
1853         FREETMPS;
1854         LEAVE;
1855
1856
1857 }
1858
1859 void bend_start(struct statserv_options_block *sob)
1860 {
1861         start_stop(sob, start_ref);
1862 }
1863
1864 MODULE = Net::Z3950::SimpleServer       PACKAGE = Net::Z3950::SimpleServer
1865
1866 PROTOTYPES: DISABLE
1867
1868
1869 void
1870 set_ghandle(arg)
1871                 SV *arg
1872         CODE:
1873                 _global_ghandle = newSVsv(arg);
1874
1875
1876 void
1877 set_init_handler(arg)
1878                 SV *arg
1879         CODE:
1880                 init_ref = newSVsv(arg);
1881
1882
1883 void
1884 set_close_handler(arg)
1885                 SV *arg
1886         CODE:
1887                 close_ref = newSVsv(arg);
1888
1889
1890 void
1891 set_sort_handler(arg)
1892                 SV *arg
1893         CODE:
1894                 sort_ref = newSVsv(arg);
1895
1896 void
1897 set_search_handler(arg)
1898                 SV *arg
1899         CODE:
1900                 search_ref = newSVsv(arg);
1901
1902
1903 void
1904 set_fetch_handler(arg)
1905                 SV *arg
1906         CODE:
1907                 fetch_ref = newSVsv(arg);
1908
1909
1910 void
1911 set_present_handler(arg)
1912                 SV *arg
1913         CODE:
1914                 present_ref = newSVsv(arg);
1915
1916
1917 void
1918 set_esrequest_handler(arg)
1919                 SV *arg
1920         CODE:
1921                 esrequest_ref = newSVsv(arg);
1922
1923
1924 void
1925 set_delete_handler(arg)
1926                 SV *arg
1927         CODE:
1928                 delete_ref = newSVsv(arg);
1929
1930
1931 void
1932 set_scan_handler(arg)
1933                 SV *arg
1934         CODE:
1935                 scan_ref = newSVsv(arg);
1936
1937 void
1938 set_explain_handler(arg)
1939                 SV *arg
1940         CODE:
1941                 explain_ref = newSVsv(arg);
1942
1943 void
1944 set_start_handler(arg)
1945                 SV *arg
1946         CODE:
1947                 start_ref = newSVsv(arg);
1948
1949 int
1950 start_server(...)
1951         PREINIT:
1952                 char **argv;
1953                 char **argv_buf;
1954                 char *ptr;
1955                 int i;
1956                 STRLEN len;
1957                 struct statserv_options_block *sob;
1958         CODE:
1959                 argv_buf = (char **)xmalloc((items + 1) * sizeof(char *));
1960                 argv = argv_buf;
1961                 for (i = 0; i < items; i++)
1962                 {
1963                         ptr = SvPV(ST(i), len);
1964                         *argv_buf = (char *)xmalloc(len + 1);
1965                         strcpy(*argv_buf++, ptr);
1966                 }
1967                 *argv_buf = NULL;
1968
1969                 sob = statserv_getcontrol();
1970                 sob->bend_start = bend_start;
1971                 statserv_setcontrol(sob);
1972
1973                 root_perl_context = PERL_GET_CONTEXT;
1974                 yaz_mutex_create(&simpleserver_mutex);
1975 #if 0
1976                 /* only for debugging perl_clone .. */
1977                 tst_clones();
1978 #endif
1979
1980                 RETVAL = statserv_main(items, argv, bend_init, bend_close);
1981         OUTPUT:
1982                 RETVAL
1983
1984
1985 int
1986 ScanSuccess()
1987         CODE:
1988                 RETVAL = BEND_SCAN_SUCCESS;
1989         OUTPUT:
1990                 RETVAL
1991
1992 int
1993 ScanPartial()
1994         CODE:
1995                 RETVAL = BEND_SCAN_PARTIAL;
1996         OUTPUT:
1997                 RETVAL
1998
1999
2000 void
2001 yazlog(arg)
2002                 SV *arg
2003         CODE:
2004                 STRLEN len;
2005                 char *ptr;
2006                 ptr = SvPV(arg, len);
2007                 yaz_log(YLOG_LOG, "%.*s", (int) len, ptr);
2008
2009 int
2010 yaz_diag_srw_to_bib1(srw_code)
2011         int srw_code
2012
2013 int
2014 yaz_diag_bib1_to_srw(bib1_code)
2015         int bib1_code
2016