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