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