ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  * Sebastian Hammer, Adam Dickmeiss
   5  *
   6  * $Log: ir-tcl.c,v $
   7  * Revision 1.19  1995-03-28 12:45:23  adam
   8  * New ir method failback: called on disconnect/protocol error.
   9  * New ir set/get method: protocol: SR / Z3950.
  10  * Simple popup and disconnect when failback is invoked.
  11  *
  12  * Revision 1.18  1995/03/21  15:50:12  adam
  13  * Minor changes.
  14  *
  15  * Revision 1.17  1995/03/21  13:41:03  adam
  16  * Comstack cs_create not used too often. Non-blocking connect.
  17  *
  18  * Revision 1.16  1995/03/21  08:26:06  adam
  19  * New method, setName, to specify the result set name (other than Default).
  20  * New method, responseStatus, which returns diagnostic info, if any, after
  21  * present response / search response.
  22  *
  23  * Revision 1.15  1995/03/20  15:24:07  adam
  24  * Diagnostic records saved on searchResponse.
  25  *
  26  * Revision 1.14  1995/03/20  08:53:22  adam
  27  * Event loop in tclmain.c rewritten. New method searchStatus.
  28  *
  29  * Revision 1.13  1995/03/17  18:26:17  adam
  30  * Non-blocking i/o used now. Database names popup as cascade items.
  31  *
  32  * Revision 1.12  1995/03/17  15:45:00  adam
  33  * Improved target/database setup.
  34  *
  35  * Revision 1.11  1995/03/16  17:54:03  adam
  36  * Minor changes really.
  37  *
  38  * Revision 1.10  1995/03/15  16:14:50  adam
  39  * Blocking arg in cs_create changed.
  40  *
  41  * Revision 1.9  1995/03/15  13:59:24  adam
  42  * Minor changes.
  43  *
  44  * Revision 1.8  1995/03/15  08:25:16  adam
  45  * New method presentStatus to check for error on present. Misc. cleanup
  46  * of IRRecordList manipulations. Full MARC record presentation in
  47  * search.tcl.
  48  *
  49  * Revision 1.7  1995/03/14  17:32:29  adam
  50  * Presentation of full Marc record in popup window.
  51  *
  52  * Revision 1.6  1995/03/12  19:31:55  adam
  53  * Pattern matching implemented when retrieving MARC records. More
  54  * diagnostic functions.
  55  *
  56  * Revision 1.5  1995/03/10  18:00:15  adam
  57  * Actual presentation in line-by-line format. RPN query support.
  58  *
  59  * Revision 1.4  1995/03/09  16:15:08  adam
  60  * First presentRequest attempts. Hot-target list.
  61  *
  62  */
  63
  64 #include <stdlib.h>
  65 #include <stdio.h>
  66 #include <sys/time.h>
  67 #include <assert.h>
  68
  69 #include <yaz-ccl.h>
  70 #include <iso2709p.h>
  71 #include <comstack.h>
  72 #include <tcpip.h>
  73
  74 #if MOSI
  75 #include <xmosi.h>
  76 #endif
  77
  78 #include <odr.h>
  79 #include <proto.h>
  80 #include <diagbib1.h>
  81
  82 #include <tcl.h>
  83
  84 #include "ir-tcl.h"
  85
  86 #define CS_BLOCK 0
  87
  88 typedef struct {
  89     char       *cs_type;
  90     char       *protocol_type;
  91     int         connectFlag;
  92     COMSTACK    cs_link;
  93
  94
  95     int         preferredMessageSize;
  96     int         maximumRecordSize;
  97     Odr_bitmask options;
  98     Odr_bitmask protocolVersion;
  99     char       *idAuthentication;
 100     char       *implementationName;
 101     char       *implementationId;
 102
 103     char       *hostname;
 104
 105     char       *buf_out;
 106     int         len_out;
 107
 108     char       *buf_in;
 109     int         len_in;
 110
 111     char       *sbuf;
 112     int         slen;
 113
 114     ODR         odr_in;
 115     ODR         odr_out;
 116     ODR         odr_pr;
 117
 118     Tcl_Interp *interp;
 119     char       *callback;
 120     char       *failback;
 121
 122     int         smallSetUpperBound;
 123     int         largeSetLowerBound;
 124     int         mediumSetPresentNumber;
 125     int         replaceIndicator;
 126     char      **databaseNames;
 127     int         num_databaseNames;
 128     char       *query_method;
 129
 130     CCL_bibset  bibset;
 131
 132     struct IRSetObj_ *child;
 133 } IRObj;
 134
 135 typedef struct IRRecordList_ {
 136     int no;
 137     int which;
 138     union {
 139         struct {
 140             Iso2709Rec rec;
 141         } marc;
 142         struct {
 143             int  condition;
 144             char *addinfo;
 145         } diag;
 146     } u;
 147     struct IRRecordList_ *next;
 148 } IRRecordList;
 149
 150 typedef struct IRSetObj_ {
 151     IRObj      *parent;
 152     int         searchStatus;
 153     int         resultCount;
 154     int         start;
 155     int         number;
 156     int         numberOfRecordsReturned;
 157     char       *setName;
 158     int         recordFlag;
 159     int         which;
 160     int         condition;
 161     char       *addinfo;
 162     IRRecordList *record_list;
 163 } IRSetObj;
 164
 165 typedef struct {
 166     int type;
 167     char *name;
 168     int (*method) (void *obj, Tcl_Interp *interp, int argc, char **argv);
 169 } IRMethod;
 170
 171 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
 172
 173 static IRRecordList *new_IR_record (IRSetObj *setobj, int no, int which)
 174 {
 175     IRRecordList *rl;
 176
 177     for (rl = setobj->record_list; rl; rl = rl->next)
 178     {
 179         if (no == rl->no)
 180         {
 181             switch (rl->which)
 182             {
 183             case Z_NamePlusRecord_databaseRecord:
 184                 iso2709_rm (rl->u.marc.rec);
 185                 break;
 186             case Z_NamePlusRecord_surrogateDiagnostic:
 187                 free (rl->u.diag.addinfo);
 188                 rl->u.diag.addinfo = NULL;
 189                 break;
 190             }
 191             break;
 192         }
 193     }
 194     if (!rl)
 195     {
 196         rl = malloc (sizeof(*rl));
 197         assert (rl);
 198         rl->next = setobj->record_list;
 199         rl->no = no;
 200         setobj->record_list = rl;
 201     }
 202     rl->which = which;
 203     return rl;
 204 }
 205
 206 static IRRecordList *find_IR_record (IRSetObj *setobj, int no)
 207 {
 208     IRRecordList *rl;
 209
 210     for (rl = setobj->record_list; rl; rl = rl->next)
 211         if (no == rl->no)
 212             return rl;
 213     return NULL;
 214 }
 215
 216 /*
 217  * get_parent_info: Returns information about parent object.
 218  */
 219 static int get_parent_info (Tcl_Interp *interp, const char *name,
 220                             Tcl_CmdInfo *parent_info)
 221 {
 222     char parent_name[128];
 223     const char *csep = strrchr (name, '.');
 224     int pos;
 225
 226     if (!csep)
 227     {
 228         interp->result = "missing .";
 229         return TCL_ERROR;
 230     }
 231     pos = csep-name;
 232     if (pos > 127)
 233         pos = 127;
 234     memcpy (parent_name, name, pos);
 235     parent_name[pos] = '\0';
 236     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
 237     {
 238         interp->result = "No parent";
 239         return TCL_ERROR;
 240     }
 241     return TCL_OK;
 242 }
 243
 244 /*
 245  * ir_method: Search for method in table and invoke method handler
 246  */
 247 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 248                IRMethod *tab)
 249 {
 250     IRMethod *t;
 251     for (t = tab; t->name; t++)
 252         if (!strcmp (t->name, argv[1]))
 253             return (*t->method)(obj, interp, argc, argv);
 254     Tcl_AppendResult (interp, "Bad method. Possible values:", NULL);
 255     for (t = tab; t->name; t++)
 256         Tcl_AppendResult (interp, " ", t->name, NULL);
 257     return TCL_ERROR;
 258 }
 259
 260 /*
 261  * ir_method_r: Get status for all readable elements
 262  */
 263 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,
 264                  IRMethod *tab)
 265 {
 266     char *argv_n[3];
 267     int argc_n;
 268
 269     argv_n[0] = argv[0];
 270     argc_n = 2;
 271     for (; tab->name; tab++)
 272         if (tab->type)
 273         {
 274             argv_n[1] = tab->name;
 275             Tcl_AppendResult (interp, "{", NULL);
 276             (*tab->method)(obj, interp, argc_n, argv_n);
 277             Tcl_AppendResult (interp, "} ", NULL);
 278         }
 279     return TCL_OK;
 280 }
 281
 282 /*
 283  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 284  */
 285 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 286 {
 287     const char *cp = asc + strlen(asc);
 288     int bitno = 0;
 289
 290     ODR_MASK_ZERO (ob);
 291     do
 292     {
 293         if (*--cp == '1')
 294             ODR_MASK_SET (ob, bitno);
 295         bitno++;
 296     } while (cp != asc);
 297     return bitno;
 298 }
 299
 300 /*
 301  * ir_strdup: Duplicate string
 302  */
 303 int ir_strdup (Tcl_Interp *interp, char** p, char *s)
 304 {
 305     *p = malloc (strlen(s)+1);
 306     if (!*p)
 307     {
 308         interp->result = "strdup fail";
 309         return TCL_ERROR;
 310     }
 311     strcpy (*p, s);
 312     return TCL_OK;
 313 }
 314
 315 /*
 316  * ir_malloc: Malloc function
 317  */
 318 void *ir_malloc (Tcl_Interp *interp, size_t size)
 319 {
 320     static char buf[128];
 321     void *p = malloc (size);
 322
 323     if (!p)
 324     {
 325         sprintf (buf, "Malloc fail. %ld bytes requested", (long) size);
 326         interp->result = buf;
 327         return NULL;
 328     }
 329     return p;
 330 }
 331
 332 /* ------------------------------------------------------- */
 333
 334 /*
 335  * do_init_request: init method on IR object
 336  */
 337 static int do_init_request (void *obj, Tcl_Interp *interp,
 338                        int argc, char **argv)
 339 {
 340     Z_APDU apdu, *apdup;
 341     IRObj *p = obj;
 342     Z_InitRequest req;
 343     int r;
 344
 345     req.referenceId = 0;
 346     req.options = &p->options;
 347     req.protocolVersion = &p->protocolVersion;
 348     req.preferredMessageSize = &p->preferredMessageSize;
 349     req.maximumRecordSize = &p->maximumRecordSize;
 350
 351     req.idAuthentication = p->idAuthentication;
 352     req.implementationId = p->implementationId;
 353     req.implementationName = p->implementationName;
 354     req.implementationVersion = "0.1";
 355     req.userInformationField = 0;
 356
 357     apdu.u.initRequest = &req;
 358     apdu.which = Z_APDU_initRequest;
 359     apdup = &apdu;
 360
 361     if (!z_APDU (p->odr_out, &apdup, 0))
 362     {
 363         Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
 364                           NULL);
 365         odr_reset (p->odr_out);
 366         return TCL_ERROR;
 367     }
 368     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
 369     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 370     {
 371         interp->result = "cs_put failed in init";
 372         return TCL_ERROR;
 373     }
 374     else if (r == 1)
 375     {
 376         ir_select_add_write (cs_fileno(p->cs_link), p);
 377         printf("Sent part of initializeRequest (%d bytes).\n", p->slen);
 378     }
 379     else
 380         printf("Sent whole initializeRequest (%d bytes).\n", p->slen);
 381     return TCL_OK;
 382 }
 383
 384 /*
 385  * do_protocolVersion: Set protocol Version
 386  */
 387 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 388                                int argc, char **argv)
 389 {
 390     if (argc == 3)
 391         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 392     return TCL_OK;
 393 }
 394
 395 /*
 396  * do_options: Set options
 397  */
 398 static int do_options (void *obj, Tcl_Interp *interp,
 399                        int argc, char **argv)
 400 {
 401     if (argc == 3)
 402         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 403     return TCL_OK;
 404 }
 405
 406 /*
 407  * do_preferredMessageSize: Set/get preferred message size
 408  */
 409 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 410                                     int argc, char **argv)
 411 {
 412     char buf[20];
 413     if (argc == 3)
 414     {
 415         if (Tcl_GetInt (interp, argv[2],
 416                         &((IRObj *)obj)->preferredMessageSize)==TCL_ERROR)
 417             return TCL_ERROR;
 418     }
 419     sprintf (buf, "%d", ((IRObj *)obj)->preferredMessageSize);
 420     Tcl_AppendResult (interp, buf, NULL);
 421     return TCL_OK;
 422 }
 423
 424 /*
 425  * do_maximumRecordSize: Set/get maximum record size
 426  */
 427 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 428                                     int argc, char **argv)
 429 {
 430     char buf[20];
 431     if (argc == 3)
 432     {
 433         if (Tcl_GetInt (interp, argv[2],
 434                         &((IRObj *)obj)->maximumRecordSize)==TCL_ERROR)
 435             return TCL_ERROR;
 436     }
 437     sprintf (buf, "%d", ((IRObj *)obj)->maximumRecordSize);
 438     Tcl_AppendResult (interp, buf, NULL);
 439     return TCL_OK;
 440 }
 441
 442
 443 /*
 444  * do_implementationName: Set/get Implementation Name.
 445  */
 446 static int do_implementationName (void *obj, Tcl_Interp *interp,
 447                                     int argc, char **argv)
 448 {
 449     if (argc == 3)
 450     {
 451         free (((IRObj*)obj)->implementationName);
 452         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 453             == TCL_ERROR)
 454             return TCL_ERROR;
 455     }
 456     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 457                       (char*) NULL);
 458     return TCL_OK;
 459 }
 460
 461 /*
 462  * do_implementationId: Set/get Implementation Id.
 463  */
 464 static int do_implementationId (void *obj, Tcl_Interp *interp,
 465                                 int argc, char **argv)
 466 {
 467     if (argc == 3)
 468     {
 469         free (((IRObj*)obj)->implementationId);
 470         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 471             == TCL_ERROR)
 472             return TCL_ERROR;
 473     }
 474     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 475                       (char*) NULL);
 476     return TCL_OK;
 477 }
 478
 479 /*
 480  * do_idAuthentication: Set/get id Authentication
 481  */
 482 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 483                                 int argc, char **argv)
 484 {
 485     if (argc == 3)
 486     {
 487         free (((IRObj*)obj)->idAuthentication);
 488         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 489             == TCL_ERROR)
 490             return TCL_ERROR;
 491     }
 492     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 493                       (char*) NULL);
 494     return TCL_OK;
 495 }
 496
 497 /*
 498  * do_connect: connect method on IR object
 499  */
 500 static int do_connect (void *obj, Tcl_Interp *interp,
 501                        int argc, char **argv)
 502 {
 503     void *addr;
 504     IRObj *p = obj;
 505     int r;
 506     int protocol_type = CS_Z3950;
 507
 508     if (argc == 3)
 509     {
 510         if (p->hostname)
 511         {
 512             interp->result = "already connected";
 513             return TCL_ERROR;
 514         }
 515         if (!strcmp (p->protocol_type, "Z3950"))
 516             protocol_type = CS_Z3950;
 517         else if (!strcmp (p->protocol_type, "SR"))
 518             protocol_type = CS_SR;
 519         else
 520         {
 521             interp->result = "bad protocol type";
 522             return TCL_ERROR;
 523         }
 524         if (!strcmp (p->cs_type, "tcpip"))
 525         {
 526             p->cs_link = cs_create (tcpip_type, CS_BLOCK, protocol_type);
 527             addr = tcpip_strtoaddr (argv[2]);
 528             if (!addr)
 529             {
 530                 interp->result = "tcpip_strtoaddr fail";
 531                 return TCL_ERROR;
 532             }
 533             printf ("tcp/ip connect %s\n", argv[2]);
 534         }
 535 #if MOSI
 536         else if (!strcmp (p->cs_type, "mosi"))
 537         {
 538             p->cs_link = cs_create (mosi_type, CS_BLOCK, protocol_type);
 539             addr = mosi_strtoaddr (argv[2]);
 540             if (!addr)
 541             {
 542                 interp->result = "mosi_strtoaddr fail";
 543                 return TCL_ERROR;
 544             }
 545             printf ("mosi connect %s\n", argv[2]);
 546         }
 547 #endif
 548         else
 549         {
 550             interp->result = "unknown comstack type";
 551             return TCL_ERROR;
 552         }
 553         if (ir_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 554             return TCL_ERROR;
 555         if ((r=cs_connect (p->cs_link, addr)) < 0)
 556         {
 557             interp->result = "cs_connect fail";
 558             return TCL_ERROR;
 559         }
 560         ir_select_add (cs_fileno (p->cs_link), p);
 561         if (r == 1)
 562         {
 563             ir_select_add_write (cs_fileno (p->cs_link), p);
 564             p->connectFlag = 1;
 565         }
 566         else
 567         {
 568             p->connectFlag = 0;
 569             if (p->callback)
 570                 Tcl_Eval (p->interp, p->callback);
 571         }
 572     }
 573     Tcl_AppendElement (interp, p->hostname);
 574     return TCL_OK;
 575 }
 576
 577 /*
 578  * do_disconnect: disconnect method on IR object
 579  */
 580 static int do_disconnect (void *obj, Tcl_Interp *interp,
 581                           int argc, char **argv)
 582 {
 583     IRObj *p = obj;
 584
 585     if (p->hostname)
 586     {
 587         free (p->hostname);
 588         p->hostname = NULL;
 589         ir_select_remove (cs_fileno (p->cs_link), p);
 590
 591         assert (p->cs_link);
 592         cs_close (p->cs_link);
 593         p->cs_link = NULL;
 594     }
 595     return TCL_OK;
 596 }
 597
 598 /*
 599  * do_comstack: Set/get comstack method on IR object
 600  */
 601 static int do_comstack (void *o, Tcl_Interp *interp,
 602                         int argc, char **argv)
 603 {
 604     IRObj *obj = o;
 605
 606     if (argc == 3)
 607     {
 608         free (obj->cs_type);
 609         if (ir_strdup (interp, &obj->cs_type, argv[2]) == TCL_ERROR)
 610             return TCL_ERROR;
 611     }
 612     Tcl_AppendElement (interp, obj->cs_type);
 613     return TCL_OK;
 614 }
 615
 616 /*
 617  * do_protocol: Set/get protocol method on IR object
 618  */
 619 static int do_protocol (void *o, Tcl_Interp *interp,
 620                         int argc, char **argv)
 621 {
 622     IRObj *obj = o;
 623
 624     if (argc == 3)
 625     {
 626         free (obj->protocol_type);
 627         if (ir_strdup (interp, &obj->protocol_type, argv[2]) == TCL_ERROR)
 628             return TCL_ERROR;
 629     }
 630     Tcl_AppendElement (interp, obj->protocol_type);
 631     return TCL_OK;
 632 }
 633
 634 /*
 635  * do_callback: add callback
 636  */
 637 static int do_callback (void *obj, Tcl_Interp *interp,
 638                           int argc, char **argv)
 639 {
 640     IRObj *p = obj;
 641
 642     if (argc == 3)
 643     {
 644         free (p->callback);
 645         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 646             return TCL_ERROR;
 647         p->interp = interp;
 648     }
 649     return TCL_OK;
 650 }
 651
 652 /*
 653  * do_failback: add error handle callback
 654  */
 655 static int do_failback (void *obj, Tcl_Interp *interp,
 656                           int argc, char **argv)
 657 {
 658     IRObj *p = obj;
 659
 660     if (argc == 3)
 661     {
 662         free (p->failback);
 663         if (ir_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
 664             return TCL_ERROR;
 665         p->interp = interp;
 666     }
 667     return TCL_OK;
 668 }
 669
 670 /*
 671  * do_databaseNames: specify database names
 672  */
 673 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 674                           int argc, char **argv)
 675 {
 676     int i;
 677     IRObj *p = obj;
 678
 679     if (argc < 3)
 680     {
 681         for (i=0; i<p->num_databaseNames; i++)
 682             Tcl_AppendElement (interp, p->databaseNames[i]);
 683         return TCL_OK;
 684     }
 685     if (p->databaseNames)
 686     {
 687         for (i=0; i<p->num_databaseNames; i++)
 688             free (p->databaseNames[i]);
 689         free (p->databaseNames);
 690     }
 691     p->num_databaseNames = argc - 2;
 692     if (!(p->databaseNames = ir_malloc (interp,
 693           sizeof(*p->databaseNames) * p->num_databaseNames)))
 694         return TCL_ERROR;
 695     for (i=0; i<p->num_databaseNames; i++)
 696     {
 697         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 698             == TCL_ERROR)
 699             return TCL_ERROR;
 700     }
 701     return TCL_OK;
 702 }
 703
 704 /*
 705  * do_query: Set/Get query mothod
 706  */
 707 static int do_query (void *obj, Tcl_Interp *interp,
 708                        int argc, char **argv)
 709 {
 710     IRObj *p = obj;
 711     if (argc == 3)
 712     {
 713         free (p->query_method);
 714         if (ir_strdup (interp, &p->query_method, argv[2]) == TCL_ERROR)
 715             return TCL_ERROR;
 716     }
 717     Tcl_AppendResult (interp, p->query_method, NULL);
 718     return TCL_OK;
 719 }
 720
 721 /*
 722  * do_replaceIndicator: Set/get replace Set indicator
 723  */
 724 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
 725                                 int argc, char **argv)
 726 {
 727     IRObj *p = obj;
 728     char buf[20];
 729
 730     if (argc == 3)
 731     {
 732         if (Tcl_GetInt (interp, argv[2],
 733                         &p->replaceIndicator)==TCL_ERROR)
 734             return TCL_ERROR;
 735     }
 736     sprintf (buf, "%d", p->replaceIndicator);
 737     Tcl_AppendResult (interp, buf, NULL);
 738     return TCL_OK;
 739 }
 740
 741 /*
 742  * ir_obj_method: IR Object methods
 743  */
 744 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 745                           int argc, char **argv)
 746 {
 747     static IRMethod tab[] = {
 748     { 1, "comstack",                do_comstack },
 749     { 1, "protocol",                do_protocol },
 750     { 1, "connect",                 do_connect },
 751     { 0, "protocolVersion",         do_protocolVersion },
 752     { 0, "options",                 do_options },
 753     { 1, "preferredMessageSize",    do_preferredMessageSize },
 754     { 1, "maximumRecordSize",       do_maximumRecordSize },
 755     { 1, "implementationName",      do_implementationName },
 756     { 1, "implementationId",        do_implementationId },
 757     { 1, "idAuthentication",        do_idAuthentication },
 758     { 0, "init",                    do_init_request },
 759     { 0, "disconnect",              do_disconnect },
 760     { 0, "callback",                do_callback },
 761     { 0, "failback",                do_failback },
 762     { 1, "databaseNames",           do_databaseNames},
 763     { 1, "replaceIndicator",        do_replaceIndicator},
 764     { 1, "query",                   do_query },
 765     { 0, NULL, NULL}
 766     };
 767     if (argc < 2)
 768         return ir_method_r (clientData, interp, argc, argv, tab);
 769     return ir_method (clientData, interp, argc, argv, tab);
 770 }
 771
 772 /*
 773  * ir_obj_delete: IR Object disposal
 774  */
 775 static void ir_obj_delete (ClientData clientData)
 776 {
 777     free ( (void*) clientData);
 778 }
 779
 780 /*
 781  * ir_obj_mk: IR Object creation
 782  */
 783 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 784               int argc, char **argv)
 785 {
 786     IRObj *obj;
 787     FILE *inf;
 788
 789     if (argc != 2)
 790     {
 791         interp->result = "wrong # args";
 792         return TCL_ERROR;
 793     }
 794     if (!(obj = ir_malloc (interp, sizeof(*obj))))
 795         return TCL_ERROR;
 796     if (ir_strdup (interp, &obj->cs_type, "tcpip") == TCL_ERROR)
 797         return TCL_ERROR;
 798     if (ir_strdup (interp, &obj->protocol_type, "Z3950") == TCL_ERROR)
 799         return TCL_ERROR;
 800     obj->cs_link = NULL;
 801
 802     obj->maximumRecordSize = 32768;
 803     obj->preferredMessageSize = 4096;
 804     obj->connectFlag = 0;
 805
 806     obj->idAuthentication = NULL;
 807
 808     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 809         == TCL_ERROR)
 810         return TCL_ERROR;
 811
 812     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 813         == TCL_ERROR)
 814         return TCL_ERROR;
 815
 816     obj->smallSetUpperBound = 0;
 817     obj->largeSetLowerBound = 2;
 818     obj->mediumSetPresentNumber = 0;
 819     obj->replaceIndicator = 1;
 820     obj->databaseNames = NULL;
 821     obj->num_databaseNames = 0;
 822
 823     obj->hostname = NULL;
 824
 825     if (ir_strdup (interp, &obj->query_method, "rpn") == TCL_ERROR)
 826         return TCL_ERROR;
 827     obj->bibset = ccl_qual_mk ();
 828     if ((inf = fopen ("default.bib", "r")))
 829     {
 830         ccl_qual_file (obj->bibset, inf);
 831         fclose (inf);
 832     }
 833     ODR_MASK_ZERO (&obj->protocolVersion);
 834     ODR_MASK_SET (&obj->protocolVersion, 0);
 835     ODR_MASK_SET (&obj->protocolVersion, 1);
 836
 837     ODR_MASK_ZERO (&obj->options);
 838     ODR_MASK_SET (&obj->options, 0);
 839
 840     obj->odr_in = odr_createmem (ODR_DECODE);
 841     obj->odr_out = odr_createmem (ODR_ENCODE);
 842     obj->odr_pr = odr_createmem (ODR_PRINT);
 843
 844     obj->len_out = 10000;
 845     if (!(obj->buf_out = ir_malloc (interp, obj->len_out)))
 846         return TCL_ERROR;
 847     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 848
 849     obj->len_in = 0;
 850     obj->buf_in = NULL;
 851
 852     obj->callback = NULL;
 853     obj->failback = NULL;
 854     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 855                        (ClientData) obj, ir_obj_delete);
 856     return TCL_OK;
 857 }
 858
 859 /* ------------------------------------------------------- */
 860 /*
 861  * do_search: Do search request
 862  */
 863 static int do_search (void *o, Tcl_Interp *interp,
 864                        int argc, char **argv)
 865 {
 866     Z_SearchRequest req;
 867     Z_Query query;
 868     Z_APDU apdu, *apdup;
 869     static Odr_oid bib1[] = {1, 2, 840, 10003, 3, 1, -1};
 870     Odr_oct ccl_query;
 871     IRSetObj *obj = o;
 872     IRObj *p = obj->parent;
 873     int r;
 874
 875     p->child = o;
 876     if (argc != 3)
 877     {
 878         interp->result = "wrong # args";
 879         return TCL_ERROR;
 880     }
 881     if (!p->num_databaseNames)
 882     {
 883         interp->result = "no databaseNames";
 884         return TCL_ERROR;
 885     }
 886     apdu.which = Z_APDU_searchRequest;
 887     apdu.u.searchRequest = &req;
 888     apdup = &apdu;
 889
 890     req.referenceId = 0;
 891     req.smallSetUpperBound = &p->smallSetUpperBound;
 892     req.largeSetLowerBound = &p->largeSetLowerBound;
 893     req.mediumSetPresentNumber = &p->mediumSetPresentNumber;
 894     req.replaceIndicator = &p->replaceIndicator;
 895     req.resultSetName = obj->setName ? obj->setName : "Default";
 896     req.num_databaseNames = p->num_databaseNames;
 897     req.databaseNames = p->databaseNames;
 898     printf ("Search:");
 899     for (r=0; r<p->num_databaseNames; r++)
 900     {
 901         printf (" %s", p->databaseNames[r]);
 902     }
 903     req.smallSetElementSetNames = 0;
 904     req.mediumSetElementSetNames = 0;
 905     req.preferredRecordSyntax = 0;
 906     req.query = &query;
 907
 908     if (!strcmp (p->query_method, "rpn"))
 909     {
 910         int error;
 911         int pos;
 912         struct ccl_rpn_node *rpn;
 913         Z_RPNQuery *RPNquery;
 914
 915         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
 916         if (error)
 917         {
 918             Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg(error),NULL);
 919             return TCL_ERROR;
 920         }
 921         query.which = Z_Query_type_1;
 922         assert((RPNquery = ccl_rpn_query(rpn)));
 923         RPNquery->attributeSetId = bib1;
 924         query.u.type_1 = RPNquery;
 925         printf ("- RPN\n");
 926     }
 927     else if (!strcmp (p->query_method, "ccl"))
 928     {
 929         query.which = Z_Query_type_2;
 930         query.u.type_2 = &ccl_query;
 931         ccl_query.buf = (unsigned char *) argv[2];
 932         ccl_query.len = strlen (argv[2]);
 933         printf ("- CCL\n");
 934     }
 935     else
 936     {
 937         interp->result = "unknown query method";
 938         return TCL_ERROR;
 939     }
 940     if (!z_APDU (p->odr_out, &apdup, 0))
 941     {
 942         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 943         odr_reset (p->odr_out);
 944         return TCL_ERROR;
 945     }
 946     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
 947     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 948     {
 949         interp->result = "cs_put failed in init";
 950         return TCL_ERROR;
 951     }
 952     else if (r == 1)
 953     {
 954         ir_select_add_write (cs_fileno(p->cs_link), p);
 955         printf("Sent part of searchRequest (%d bytes).\n", p->slen);
 956     }
 957     else
 958     {
 959         printf ("Whole search request\n");
 960     }
 961     return TCL_OK;
 962 }
 963
 964 /*
 965  * do_resultCount: Get number of hits
 966  */
 967 static int do_resultCount (void *o, Tcl_Interp *interp,
 968                        int argc, char **argv)
 969 {
 970     IRSetObj *obj = o;
 971
 972     sprintf (interp->result, "%d", obj->resultCount);
 973     return TCL_OK;
 974 }
 975
 976 /*
 977  * do_searchStatus: Get search status (after search response)
 978  */
 979 static int do_searchStatus (void *o, Tcl_Interp *interp,
 980                             int argc, char **argv)
 981 {
 982     IRSetObj *obj = o;
 983
 984     sprintf (interp->result, "%d", obj->searchStatus);
 985     return TCL_OK;
 986 }
 987
 988 /*
 989  * do_setName: Set result Set name
 990  */
 991 static int do_setName (void *o, Tcl_Interp *interp,
 992                        int argc, char **argv)
 993 {
 994     IRSetObj *obj = o;
 995
 996     if (argc == 3)
 997     {
 998         free (obj->setName);
 999         if (ir_strdup (interp, &obj->setName, argv[2])
1000             == TCL_ERROR)
1001             return TCL_ERROR;
1002     }
1003     Tcl_AppendElement (interp, obj->setName);
1004     return TCL_OK;
1005 }
1006
1007 /*
1008  * do_numberOfRecordsReturned: Get number of records returned
1009  */
1010 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
1011                        int argc, char **argv)
1012 {
1013     IRSetObj *obj = o;
1014
1015     sprintf (interp->result, "%d", obj->numberOfRecordsReturned);
1016     return TCL_OK;
1017 }
1018
1019 static int marc_cmp (const char *field, const char *pattern)
1020 {
1021     if (*pattern == '*')
1022         return 0;
1023     for (; *field && *pattern; field++, pattern++)
1024     {
1025         if (*pattern == '?')
1026             continue;
1027         if (*pattern != *field)
1028             break;
1029     }
1030     return *field - *pattern;
1031 }
1032
1033 static int get_marc_fields(Tcl_Interp *interp, Iso2709Rec rec,
1034                            int argc, char **argv)
1035 {
1036     struct iso2709_dir *dir;
1037     struct iso2709_field *field;
1038
1039     for (dir = rec->directory; dir; dir = dir->next)
1040     {
1041         if (argc > 4 && marc_cmp (dir->tag, argv[4]))
1042             continue;
1043         if (argc > 5 && marc_cmp (dir->indicator, argv[5]))
1044             continue;
1045         for (field = dir->fields; field; field = field->next)
1046         {
1047             if (argc > 6 && marc_cmp (field->identifier, argv[6]))
1048                 continue;
1049             Tcl_AppendElement (interp, field->data);
1050         }
1051     }
1052     return TCL_OK;
1053 }
1054
1055 static int get_marc_lines (Tcl_Interp *interp, Iso2709Rec rec,
1056                            int argc, char **argv)
1057 {
1058     struct iso2709_dir *dir;
1059     struct iso2709_field *field;
1060
1061     for (dir = rec->directory; dir; dir = dir->next)
1062     {
1063         if (argc > 4 && marc_cmp (dir->tag, argv[4]))
1064             continue;
1065         if (!dir->indicator)
1066             Tcl_AppendResult (interp, "{", dir->tag, " {} {", NULL);
1067         else
1068         {
1069             if (argc > 5 && marc_cmp (dir->indicator, argv[5]))
1070                 continue;
1071             Tcl_AppendResult (interp, "{", dir->tag, " {", dir->indicator,
1072                               "} {", NULL);
1073         }
1074         for (field = dir->fields; field; field = field->next)
1075         {
1076             if (!field->identifier)
1077                 Tcl_AppendResult (interp, "{{}", NULL);
1078             else
1079             {
1080                 if (argc > 6 && marc_cmp (field->identifier, argv[6]))
1081                     continue;
1082                 Tcl_AppendResult (interp, "{", field->identifier, NULL);
1083             }
1084             Tcl_AppendElement (interp, field->data);
1085             Tcl_AppendResult (interp, "} ", NULL);
1086         }
1087         Tcl_AppendResult (interp, "}} ", NULL);
1088     }
1089     return TCL_OK;
1090 }
1091
1092 /*
1093  * do_recordType: Return record type (if any) at position.
1094  */
1095 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
1096 {
1097     IRSetObj *obj = o;
1098     int offset;
1099     IRRecordList *rl;
1100
1101     if (argc < 3)
1102     {
1103         sprintf (interp->result, "wrong # args");
1104         return TCL_ERROR;
1105     }
1106     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1107         return TCL_ERROR;
1108     rl = find_IR_record (obj, offset);
1109     if (!rl)
1110         return TCL_OK;
1111     switch (rl->which)
1112     {
1113     case Z_NamePlusRecord_databaseRecord:
1114         interp->result = "databaseRecord";
1115         break;
1116     case Z_NamePlusRecord_surrogateDiagnostic:
1117         interp->result = "surrogateDiagnostic";
1118         break;
1119     }
1120     return TCL_OK;
1121 }
1122
1123 /*
1124  * do_recordDiag: Return diagnostic record info
1125  */
1126 static int do_recordDiag (void *o, Tcl_Interp *interp, int argc, char **argv)
1127 {
1128     IRSetObj *obj = o;
1129     int offset;
1130     IRRecordList *rl;
1131     char buf[20];
1132
1133     if (argc < 3)
1134     {
1135         sprintf (interp->result, "wrong # args");
1136         return TCL_ERROR;
1137     }
1138     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1139         return TCL_ERROR;
1140     rl = find_IR_record (obj, offset);
1141     if (!rl)
1142     {
1143         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1144         return TCL_ERROR;
1145     }
1146     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
1147     {
1148         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
1149         return TCL_ERROR;
1150     }
1151     sprintf (buf, "%d", rl->u.diag.condition);
1152     Tcl_AppendResult (interp, buf, " {",
1153                       (rl->u.diag.addinfo ? rl->u.diag.addinfo : ""),
1154                       "}", NULL);
1155     return TCL_OK;
1156 }
1157
1158 /*
1159  * do_recordMarc: Get ISO2709 Record lines/fields
1160  */
1161 static int do_recordMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
1162 {
1163     IRSetObj *obj = o;
1164     int offset;
1165     IRRecordList *rl;
1166
1167     if (argc < 4)
1168     {
1169         sprintf (interp->result, "wrong # args");
1170         return TCL_ERROR;
1171     }
1172     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1173         return TCL_ERROR;
1174     rl = find_IR_record (obj, offset);
1175     if (!rl)
1176     {
1177         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1178         return TCL_ERROR;
1179     }
1180     if (rl->which != Z_NamePlusRecord_databaseRecord)
1181     {
1182         Tcl_AppendResult (interp, "No MARC record at #", argv[2], NULL);
1183         return TCL_ERROR;
1184     }
1185     if (!strcmp (argv[3], "field"))
1186         return get_marc_fields (interp, rl->u.marc.rec, argc, argv);
1187     else if (!strcmp (argv[3], "line"))
1188         return get_marc_lines (interp, rl->u.marc.rec, argc, argv);
1189     else
1190     {
1191         Tcl_AppendResult (interp, "field/line expected", NULL);
1192         return TCL_ERROR;
1193     }
1194 }
1195
1196 /*
1197  * do_responseStatus: Return response status (present or search)
1198  */
1199 static int do_responseStatus (void *o, Tcl_Interp *interp,
1200                              int argc, char **argv)
1201 {
1202     IRSetObj *obj = o;
1203     const char *cp;
1204     char buf[28];
1205
1206     if (!obj->recordFlag)
1207         return TCL_OK;
1208     switch (obj->which)
1209     {
1210     case Z_Records_DBOSD:
1211         Tcl_AppendElement (interp, "DBOSD");
1212         break;
1213     case Z_Records_NSD:
1214         Tcl_AppendElement (interp, "NSD");
1215         sprintf (buf, "%d", obj->condition);
1216         Tcl_AppendElement (interp, buf);
1217         cp = diagbib1_str (obj->condition);
1218         if (cp)
1219             Tcl_AppendElement (interp, (char*) cp);
1220         else
1221             Tcl_AppendElement (interp, "");
1222         if (obj->addinfo)
1223             Tcl_AppendElement (interp, obj->addinfo);
1224         else
1225             Tcl_AppendElement (interp, "");
1226         break;
1227     }
1228     return TCL_OK;
1229 }
1230
1231 /*
1232  * do_present: Perform Present Request
1233  */
1234
1235 static int do_present (void *o, Tcl_Interp *interp,
1236                        int argc, char **argv)
1237 {
1238     IRSetObj *obj = o;
1239     IRObj *p = obj->parent;
1240     Z_APDU apdu, *apdup;
1241     Z_PresentRequest req;
1242     int start;
1243     int number;
1244     int r;
1245
1246     if (argc >= 3)
1247     {
1248         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
1249             return TCL_ERROR;
1250     }
1251     else
1252         start = 1;
1253     if (argc >= 4)
1254     {
1255         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
1256             return TCL_ERROR;
1257     }
1258     else
1259         number = 10;
1260     obj->start = start;
1261     obj->number = number;
1262
1263     apdup = &apdu;
1264     apdu.which = Z_APDU_presentRequest;
1265     apdu.u.presentRequest = &req;
1266     req.referenceId = 0;
1267     /* sprintf(setstring, "%d", setnumber); */
1268     req.resultSetId = "Default";
1269     req.resultSetStartPoint = &start;
1270     req.numberOfRecordsRequested = &number;
1271     req.elementSetNames = 0;
1272     req.preferredRecordSyntax = 0;
1273
1274     if (!z_APDU (p->odr_out, &apdup, 0))
1275     {
1276         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1277         odr_reset (p->odr_out);
1278         return TCL_ERROR;
1279     }
1280     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
1281     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1282     {
1283         interp->result = "cs_put failed in init";
1284         return TCL_ERROR;
1285     }
1286     else if (r == 1)
1287     {
1288         ir_select_add_write (cs_fileno(p->cs_link), p);
1289         printf ("Part of present request, start=%d, num=%d (%d bytes)\n",
1290                 start, number, p->slen);
1291     }
1292     else
1293     {
1294         printf ("Whole present request, start=%d, num=%d (%d bytes)\n",
1295                 start, number, p->slen);
1296     }
1297     return TCL_OK;
1298 }
1299
1300 /*
1301  * do_loadFile: Load result set from file
1302  */
1303
1304 static int do_loadFile (void *o, Tcl_Interp *interp,
1305                         int argc, char **argv)
1306 {
1307     IRSetObj *setobj = o;
1308     FILE *inf;
1309     int  no = 1;
1310     const char *buf;
1311
1312     if (argc < 3)
1313     {
1314         interp->result = "wrong # args";
1315         return TCL_ERROR;
1316     }
1317     inf = fopen (argv[2], "r");
1318     if (!inf)
1319     {
1320         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
1321         return TCL_ERROR;
1322     }
1323     while ((buf = iso2709_read (inf)))
1324     {
1325         IRRecordList *rl;
1326         Iso2709Rec rec;
1327
1328         rec = iso2709_cvt (buf);
1329         if (!rec)
1330             break;
1331         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
1332         rl->u.marc.rec = rec;
1333         no++;
1334     }
1335     setobj->numberOfRecordsReturned = no-1;
1336     fclose (inf);
1337     return TCL_OK;
1338 }
1339
1340
1341 /*
1342  * ir_set_obj_method: IR Set Object methods
1343  */
1344 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1345                           int argc, char **argv)
1346 {
1347     static IRMethod tab[] = {
1348     { 0, "search",                  do_search },
1349     { 0, "searchStatus",            do_searchStatus },
1350     { 0, "setName",                 do_setName },
1351     { 0, "resultCount",             do_resultCount },
1352     { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },
1353     { 0, "present",                 do_present },
1354     { 0, "recordType",              do_recordType },
1355     { 0, "recordMarc",              do_recordMarc },
1356     { 0, "recordDiag",              do_recordDiag },
1357     { 0, "responseStatus",          do_responseStatus },
1358     { 0, "loadFile",                do_loadFile },
1359     { 0, NULL, NULL}
1360     };
1361
1362     if (argc < 2)
1363     {
1364         interp->result = "wrong # args";
1365         return TCL_ERROR;
1366     }
1367     return ir_method (clientData, interp, argc, argv, tab);
1368 }
1369
1370 /*
1371  * ir_set_obj_delete: IR Set Object disposal
1372  */
1373 static void ir_set_obj_delete (ClientData clientData)
1374 {
1375     free ( (void*) clientData);
1376 }
1377
1378 /*
1379  * ir_set_obj_mk: IR Set Object creation
1380  */
1381 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1382                              int argc, char **argv)
1383 {
1384     Tcl_CmdInfo parent_info;
1385     IRSetObj *obj;
1386
1387     if (argc != 2)
1388     {
1389         interp->result = "wrong # args";
1390         return TCL_ERROR;
1391     }
1392     if (get_parent_info (interp, argv[1], &parent_info) == TCL_ERROR)
1393         return TCL_ERROR;
1394     if (!(obj = ir_malloc (interp, sizeof(*obj))))
1395         return TCL_ERROR;
1396     obj->setName = NULL;
1397     obj->record_list = NULL;
1398     obj->addinfo = NULL;
1399     obj->parent = (IRObj *) parent_info.clientData;
1400     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
1401                        (ClientData) obj, ir_set_obj_delete);
1402     return TCL_OK;
1403 }
1404
1405 /* ------------------------------------------------------- */
1406
1407 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
1408 {
1409     if (!*initrs->result)
1410         printf("Connection rejected by target.\n");
1411     else
1412         printf("Connection accepted by target.\n");
1413     if (initrs->implementationId)
1414             printf("ID     : %s\n", initrs->implementationId);
1415     if (initrs->implementationName)
1416         printf("Name   : %s\n", initrs->implementationName);
1417     if (initrs->implementationVersion)
1418         printf("Version: %s\n", initrs->implementationVersion);
1419     if (initrs->maximumRecordSize)
1420         printf ("MaximumRecordSize=%d\n", *initrs->maximumRecordSize);
1421     if (initrs->preferredMessageSize)
1422         printf ("PreferredMessageSize=%d\n", *initrs->preferredMessageSize);
1423 #if 0
1424     if (initrs->userInformationField)
1425     {
1426         printf("UserInformationfield:\n");
1427         odr_external(&print, (Odr_external**)&initrs->
1428                          userInformationField, 0);
1429     }
1430 #endif
1431 }
1432
1433 static void ir_handleRecords (void *o, Z_Records *zrs)
1434 {
1435     IRObj *p = o;
1436     IRSetObj *setobj = p->child;
1437
1438     setobj->which = zrs->which;
1439     setobj->recordFlag = 1;
1440     if (zrs->which == Z_Records_NSD)
1441     {
1442         const char *addinfo;
1443
1444         setobj->numberOfRecordsReturned = 0;
1445         setobj->condition = *zrs->u.nonSurrogateDiagnostic->condition;
1446         free (setobj->addinfo);
1447         setobj->addinfo = NULL;
1448         addinfo = zrs->u.nonSurrogateDiagnostic->addinfo;
1449         if (addinfo && (setobj->addinfo = malloc (strlen(addinfo) + 1)))
1450             strcpy (setobj->addinfo, addinfo);
1451         printf ("Diagnostic response. %s (%d): %s\n",
1452                 diagbib1_str (setobj->condition),
1453                 setobj->condition,
1454                 setobj->addinfo ? setobj->addinfo : "");
1455     }
1456     else
1457     {
1458         int offset;
1459         IRRecordList *rl;
1460
1461         setobj->numberOfRecordsReturned =
1462             zrs->u.databaseOrSurDiagnostics->num_records;
1463         printf ("Got %d records\n", setobj->numberOfRecordsReturned);
1464         for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
1465         {
1466             rl = new_IR_record (setobj, setobj->start + offset,
1467                                 zrs->u.databaseOrSurDiagnostics->
1468                                 records[offset]->which);
1469             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
1470             {
1471                 Z_DiagRec *diagrec;
1472
1473                 diagrec = zrs->u.databaseOrSurDiagnostics->
1474                     records[offset]->u.surrogateDiagnostic;
1475
1476                 rl->u.diag.condition = *diagrec->condition;
1477                 if (diagrec->addinfo && (rl->u.diag.addinfo =
1478                                          malloc (strlen (diagrec->addinfo)+1)))
1479                     strcpy (rl->u.diag.addinfo, diagrec->addinfo);
1480             }
1481             else
1482             {
1483                 Z_DatabaseRecord *zr;
1484                 Odr_external *oe;
1485
1486                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
1487                     ->u.databaseRecord;
1488                 oe = (Odr_external*) zr;
1489                 if (oe->which == ODR_EXTERNAL_octet
1490                     && zr->u.octet_aligned->len)
1491                 {
1492                     const char *buf = (char*) zr->u.octet_aligned->buf;
1493                     rl->u.marc.rec = iso2709_cvt (buf);
1494                 }
1495                 else
1496                     rl->u.marc.rec = NULL;
1497             }
1498         }
1499     }
1500 }
1501
1502 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
1503 {
1504     IRObj *p = o;
1505     IRSetObj *setobj = p->child;
1506     Z_Records *zrs = searchrs->records;
1507
1508     if (setobj)
1509     {
1510         setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
1511         setobj->resultCount = *searchrs->resultCount;
1512         printf ("Search response %d, %d hits\n",
1513                  setobj->searchStatus, setobj->resultCount);
1514         if (zrs)
1515             ir_handleRecords (o, zrs);
1516         else
1517             setobj->recordFlag = 0;
1518     }
1519     else
1520         printf ("Search response, no object!\n");
1521 }
1522
1523
1524 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
1525 {
1526     IRObj *p = o;
1527     IRSetObj *setobj = p->child;
1528     Z_Records *zrs = presrs->records;
1529
1530     printf ("Received presentResponse\n");
1531     if (zrs)
1532         ir_handleRecords (o, zrs);
1533     else
1534     {
1535         setobj->recordFlag = 0;
1536         printf ("No records!\n");
1537     }
1538 }
1539
1540 /*
1541  * ir_select_read: handle incoming packages
1542  */
1543 void ir_select_read (ClientData clientData)
1544 {
1545     IRObj *p = clientData;
1546     Z_APDU *apdu;
1547     int r;
1548
1549     if (p->connectFlag)
1550     {
1551         r = cs_rcvconnect (p->cs_link);
1552         if (r == 1)
1553             return;
1554         p->connectFlag = 0;
1555         ir_select_remove_write (cs_fileno (p->cs_link), p);
1556         if (r < 0)
1557         {
1558             printf ("cs_rcvconnect error\n");
1559             if (p->failback)
1560                 Tcl_Eval (p->interp, p->failback);
1561             return;
1562         }
1563         if (p->callback)
1564             Tcl_Eval (p->interp, p->callback);
1565         return;
1566     }
1567     do
1568     {
1569         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  <= 0)
1570         {
1571             printf ("cs_get failed\n");
1572             ir_select_remove (cs_fileno (p->cs_link), p);
1573             if (p->failback)
1574                 Tcl_Eval (p->interp, p->failback);
1575             return;
1576         }
1577         if (r == 1)
1578             return ;
1579         odr_setbuf (p->odr_in, p->buf_in, r);
1580         printf ("cs_get ok, got %d\n", r);
1581         if (!z_APDU (p->odr_in, &apdu, 0))
1582         {
1583             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
1584             if (p->failback)
1585                 Tcl_Eval (p->interp, p->failback);
1586             return;
1587         }
1588         switch(apdu->which)
1589         {
1590         case Z_APDU_initResponse:
1591             ir_initResponse (p, apdu->u.initResponse);
1592             break;
1593         case Z_APDU_searchResponse:
1594             ir_searchResponse (p, apdu->u.searchResponse);
1595             break;
1596         case Z_APDU_presentResponse:
1597             ir_presentResponse (p, apdu->u.presentResponse);
1598             break;
1599         default:
1600             printf("Received unknown APDU type (%d).\n",
1601                    apdu->which);
1602             if (p->failback)
1603                 Tcl_Eval (p->interp, p->failback);
1604         }
1605         if (p->callback)
1606             Tcl_Eval (p->interp, p->callback);
1607     } while (cs_more (p->cs_link));
1608 }
1609
1610 /*
1611  * ir_select_write: handle outgoing packages - not yet written.
1612  */
1613 void ir_select_write (ClientData clientData)
1614 {
1615     IRObj *p = clientData;
1616     int r;
1617
1618     printf ("In write handler.....\n");
1619     if (p->connectFlag)
1620     {
1621         r = cs_rcvconnect (p->cs_link);
1622         if (r == 1)
1623             return;
1624         p->connectFlag = 0;
1625         if (r < 0)
1626         {
1627             printf ("cs_rcvconnect error\n");
1628             ir_select_remove_write (cs_fileno (p->cs_link), p);
1629             if (p->failback)
1630                 Tcl_Eval (p->interp, p->failback);
1631             return;
1632         }
1633         ir_select_remove_write (cs_fileno (p->cs_link), p);
1634         if (p->callback)
1635             Tcl_Eval (p->interp, p->callback);
1636         return;
1637     }
1638     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1639     {
1640         printf ("select write fail\n");
1641         cs_close (p->cs_link);
1642         if (p->failback)
1643             Tcl_Eval (p->interp, p->failback);
1644     }
1645     else if (r == 0)            /* remove select bit */
1646     {
1647         ir_select_remove_write (cs_fileno (p->cs_link), p);
1648     }
1649 }
1650
1651 /* ------------------------------------------------------- */
1652
1653 /*
1654  * ir_tcl_init: Registration of TCL commands.
1655  */
1656 int ir_tcl_init (Tcl_Interp *interp)
1657 {
1658     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
1659                        (Tcl_CmdDeleteProc *) NULL);
1660     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
1661                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1662     return TCL_OK;
1663 }
1664
1665