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