SimpleServer.xs

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