ir-tcl.c

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