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