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