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