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