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