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