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.90  1996-06-27 14:21:00  adam
   9  * Yet another Windows port.
  10  *
  11  * Revision 1.89  1996/06/11  15:27:15  adam
  12  * Event type set to connect a little earlier in the do_connect function.
  13  *
  14  * Revision 1.88  1996/06/03  09:04:22  adam
  15  * Changed a few logf calls.
  16  *
  17  * Revision 1.87  1996/05/29  06:37:51  adam
  18  * Function ir_tcl_get_grs_r enhanced so that specific elements can be
  19  * extracted.
  20  *
  21  * Revision 1.86  1996/03/20 13:54:04  adam
  22  * The Tcl_File structure is only manipulated in the Tk-event interface
  23  * in tkinit.c.
  24  *
  25  * Revision 1.85  1996/03/15  11:15:48  adam
  26  * Modified to use new prototypes for p_query_rpn and p_query_scan.
  27  *
  28  * Revision 1.84  1996/03/07  12:42:49  adam
  29  * Better logging when callback is invoked.
  30  *
  31  * Revision 1.83  1996/03/05  09:21:09  adam
  32  * Bug fix: memory used by GRS records wasn't freed.
  33  * Rewrote some of the error handling code - the connection is always
  34  * closed before failback is called.
  35  * If failback is defined the send APDU methods (init, search, ...) will
  36  * return OK but invoke failback (as is the case if the write operation
  37  * fails).
  38  * Bug fix: ref_count in assoc object could grow if fraction of PDU was
  39  * read.
  40  *
  41  * Revision 1.82  1996/02/29  15:30:21  adam
  42  * Export of IrTcl functionality to extensions.
  43  *
  44  * Revision 1.81  1996/02/26  18:38:32  adam
  45  * Work on export of set methods.
  46  *
  47  * Revision 1.80  1996/02/23  17:31:39  adam
  48  * More functions made available to the wais tcl extension.
  49  *
  50  * Revision 1.79  1996/02/23  13:41:38  adam
  51  * Work on public access to simple ir class system.
  52  *
  53  * Revision 1.78  1996/02/21  10:16:08  adam
  54  * Simplified select handling. Only one function ir_tcl_select_set has
  55  * to be externally defined.
  56  *
  57  * Revision 1.77  1996/02/20  17:52:58  adam
  58  * Uses the YAZ oid system to name record syntax object identifiers.
  59  *
  60  * Revision 1.76  1996/02/20  16:09:51  adam
  61  * Bug fix: didn't set element set names stamp correctly on result
  62  * set records when element set names were set to the empty string.
  63  *
  64  * Revision 1.75  1996/02/19  15:41:53  adam
  65  * Better log messages.
  66  * Minor improvement of connect method.
  67  *
  68  * Revision 1.74  1996/02/05  17:58:03  adam
  69  * Ported ir-tcl to use the beta releases of tcl7.5/tk4.1.
  70  *
  71  * Revision 1.73  1996/01/29  11:35:19  adam
  72  * Bug fix: cs_type member renamed to comstackType to avoid conflict with
  73  * cs_type macro defined by YAZ.
  74  *
  75  * Revision 1.72  1996/01/19  17:45:34  quinn
  76  * Added debugging output
  77  *
  78  * Revision 1.71  1996/01/19  16:22:38  adam
  79  * New method: apduDump - returns information about last incoming APDU.
  80  *
  81  * Revision 1.70  1996/01/10  09:18:34  adam
  82  * PDU specific callbacks implemented: initRespnse, searchResponse,
  83  *  presentResponse and scanResponse.
  84  * Bug fix in the command line shell (tclmain.c) - discovered on OSF/1.
  85  *
  86  * Revision 1.69  1996/01/04  16:12:12  adam
  87  * Setting PDUType renamed to eventType.
  88  *
  89  * Revision 1.68  1996/01/04  11:05:22  adam
  90  * New setting: PDUType - returns type of last PDU returned from the target.
  91  * Fixed a bug in configure/Makefile.
  92  *
  93  * Revision 1.67  1996/01/03  09:00:51  adam
  94  * Updated to use new version of Yaz (names changed to avoid C++ conflict).
  95  *
  96  * Revision 1.66  1995/11/28  17:26:39  adam
  97  * Removed Carriage return from ir-tcl.c!
  98  * Removed misc. debug logs.
  99  *
 100  * Revision 1.65  1995/11/28  13:53:00  quinn
 101  * Windows port.
 102  *
 103  * Revision 1.64  1995/11/13  15:39:18  adam
 104  * Bug fix: {small,medium}SetElementSetNames weren't set correctly.
 105  * Bug fix: idAuthentication weren't set correctly.
 106  *
 107  * Revision 1.63  1995/11/13  09:55:39  adam
 108  * Multiple records at a position in a result-set with differnt
 109  * element specs.
 110  *
 111  * Revision 1.62  1995/10/18  17:20:33  adam
 112  * Work on target setup in client.tcl.
 113  *
 114  * Revision 1.61  1995/10/18  16:42:42  adam
 115  * New settings: smallSetElementSetNames and mediumSetElementSetNames.
 116  *
 117  * Revision 1.60  1995/10/18  15:43:31  adam
 118  * In search: mediumSetElementSetNames and smallSetElementSetNames are
 119  * set to elementSetNames.
 120  *
 121  * Revision 1.59  1995/10/17  12:18:58  adam
 122  * Bug fix: when target connection closed, the connection was not
 123  * properly reestablished.
 124  *
 125  * Revision 1.58  1995/10/16  17:00:55  adam
 126  * New setting: elementSetNames.
 127  * Various client improvements. Medium presentation format looks better.
 128  *
 129  * Revision 1.57  1995/09/21  13:11:51  adam
 130  * Support of dynamic loading.
 131  * Test script uses load command if necessary.
 132  *
 133  * Revision 1.56  1995/08/29  15:30:14  adam
 134  * Work on GRS records.
 135  *
 136  * Revision 1.55  1995/08/28  09:43:25  adam
 137  * Minor changes. configure only searches for yaz beta 3 and versions after
 138  * that.
 139  *
 140  * Revision 1.54  1995/08/24  12:25:16  adam
 141  * Modified to work with yaz 1.0b3.
 142  *
 143  * Revision 1.53  1995/08/04  12:49:26  adam
 144  * Bug fix: reading uninitialized variable p.
 145  *
 146  * Revision 1.52  1995/08/04  11:32:38  adam
 147  * More work on output queue. Memory related routines moved
 148  * to mem.c
 149  *
 150  * Revision 1.51  1995/08/03  13:22:54  adam
 151  * Request queue.
 152  *
 153  * Revision 1.50  1995/07/20  08:09:49  adam
 154  * client.tcl: Targets removed from hotTargets list when targets
 155  *  are removed/modified.
 156  * ir-tcl.c: More work on triggerResourceControl.
 157  *
 158  * Revision 1.49  1995/06/30  12:39:21  adam
 159  * Bug fix: loadFile didn't set record type.
 160  * The MARC routines are a little less strict in the interpretation.
 161  * Script display.tcl replaces the old marc.tcl.
 162  * New interactive script: shell.tcl.
 163  *
 164  * Revision 1.48  1995/06/27  19:03:50  adam
 165  * Bug fix in do_present in ir-tcl.c: p->set_child member weren't set.
 166  * nextResultSetPosition used instead of setOffset.
 167  *
 168  * Revision 1.47  1995/06/25  10:25:04  adam
 169  * Working on triggerResourceControl. Description of compile/install
 170  * procedure moved to ir-tcl.sgml.
 171  *
 172  * Revision 1.46  1995/06/22  13:15:06  adam
 173  * Feature: SUTRS. Setting getSutrs implemented.
 174  * Work on display formats.
 175  * Preferred record syntax can be set by the user.
 176  *
 177  * Revision 1.45  1995/06/20  08:07:30  adam
 178  * New setting: failInfo.
 179  * Working on better cancel mechanism.
 180  *
 181  * Revision 1.44  1995/06/19  17:01:20  adam
 182  * Minor changes.
 183  *
 184  * Revision 1.43  1995/06/19  13:06:08  adam
 185  * New define: IR_TCL_VERSION.
 186  *
 187  * Revision 1.42  1995/06/19  08:08:52  adam
 188  * client.tcl: hotTargets now contain both database and target name.
 189  * ir-tcl.c: setting protocol edited. Errors in callbacks are logged
 190  * by logf(LOG_WARN, ...) calls.
 191  *
 192  * Revision 1.41  1995/06/16  12:28:16  adam
 193  * Implemented preferredRecordSyntax.
 194  * Minor changes in diagnostic handling.
 195  * Record list deleted when connection closes.
 196  *
 197  * Revision 1.40  1995/06/14  13:37:18  adam
 198  * Setting recordType implemented.
 199  * Setting implementationVersion implemented.
 200  * Settings implementationId / implementationName edited.
 201  *
 202  * Revision 1.39  1995/06/08  10:26:32  adam
 203  * Bug fix in ir_strdup.
 204  *
 205  * Revision 1.38  1995/06/01  16:36:47  adam
 206  * About buttons. Minor bug fixes.
 207  *
 208  * Revision 1.37  1995/06/01  07:31:20  adam
 209  * Rename of many typedefs -> IrTcl_...
 210  *
 211  * Revision 1.36  1995/05/31  13:09:59  adam
 212  * Client searches/presents may be interrupted.
 213  * New moving book-logo.
 214  *
 215  * Revision 1.35  1995/05/31  08:36:33  adam
 216  * Bug fix in client.tcl: didn't save options on clientrc.tcl.
 217  * New method: referenceId. More work on scan.
 218  *
 219  * Revision 1.34  1995/05/29  10:33:42  adam
 220  * README and rename of startup script.
 221  *
 222  * Revision 1.33  1995/05/29  09:15:11  quinn
 223  * Changed CS_SR to PROTO_SR, etc.
 224  *
 225  * Revision 1.32  1995/05/29  08:44:16  adam
 226  * Work on delete of objects.
 227  *
 228  * Revision 1.31  1995/05/26  11:44:10  adam
 229  * Bugs fixed. More work on MARC utilities and queries. Test
 230  * client is up-to-date again.
 231  *
 232  * Revision 1.30  1995/05/26  08:54:11  adam
 233  * New MARC utilities. Uses prefix query.
 234  *
 235  * Revision 1.29  1995/05/24  14:10:22  adam
 236  * Work on idAuthentication, protocolVersion and options.
 237  *
 238  * Revision 1.28  1995/05/23  15:34:48  adam
 239  * Many new settings, userInformationField, smallSetUpperBound, etc.
 240  * A number of settings are inherited when ir-set is executed.
 241  * This version is incompatible with the graphical test client (client.tcl).
 242  *
 243  * Revision 1.27  1995/05/11  15:34:47  adam
 244  * Scan request changed a bit. This version works with RLG.
 245  *
 246  * Revision 1.26  1995/04/18  16:11:51  adam
 247  * First version of graphical Scan. Some work on query-by-form.
 248  *
 249  * Revision 1.25  1995/04/17  09:37:17  adam
 250  * Further development of scan.
 251  *
 252  * Revision 1.24  1995/04/11  14:16:42  adam
 253  * Further work on scan. Response works. Entries aren't saved yet.
 254  *
 255  * Revision 1.23  1995/04/10  10:50:27  adam
 256  * Result-set name defaults to suffix of ir-set name.
 257  * Started working on scan. Not finished at this point.
 258  *
 259  * Revision 1.22  1995/03/31  10:43:03  adam
 260  * More robust when getting bad MARC records.
 261  *
 262  * Revision 1.21  1995/03/31  08:56:37  adam
 263  * New button "Search".
 264  *
 265  * Revision 1.20  1995/03/29  16:07:09  adam
 266  * Bug fix: Didn't use setName in present request.
 267  *
 268  * Revision 1.19  1995/03/28  12:45:23  adam
 269  * New ir method failback: called on disconnect/protocol error.
 270  * New ir set/get method: protocol: SR / Z3950.
 271  * Simple popup and disconnect when failback is invoked.
 272  *
 273  * Revision 1.18  1995/03/21  15:50:12  adam
 274  * Minor changes.
 275  *
 276  * Revision 1.17  1995/03/21  13:41:03  adam
 277  * Comstack cs_create not used too often. Non-blocking connect.
 278  *
 279  * Revision 1.16  1995/03/21  08:26:06  adam
 280  * New method, setName, to specify the result set name (other than Default).
 281  * New method, responseStatus, which returns diagnostic info, if any, after
 282  * present response / search response.
 283  *
 284  * Revision 1.15  1995/03/20  15:24:07  adam
 285  * Diagnostic records saved on searchResponse.
 286  *
 287  * Revision 1.14  1995/03/20  08:53:22  adam
 288  * Event loop in tclmain.c rewritten. New method searchStatus.
 289  *
 290  * Revision 1.13  1995/03/17  18:26:17  adam
 291  * Non-blocking i/o used now. Database names popup as cascade items.
 292  *
 293  * Revision 1.12  1995/03/17  15:45:00  adam
 294  * Improved target/database setup.
 295  *
 296  * Revision 1.11  1995/03/16  17:54:03  adam
 297  * Minor changes really.
 298  *
 299  * Revision 1.10  1995/03/15  16:14:50  adam
 300  * Blocking arg in cs_create changed.
 301  *
 302  * Revision 1.9  1995/03/15  13:59:24  adam
 303  * Minor changes.
 304  *
 305  * Revision 1.8  1995/03/15  08:25:16  adam
 306  * New method presentStatus to check for error on present. Misc. cleanup
 307  * of IrTcl_RecordList manipulations. Full MARC record presentation in
 308  * search.tcl.
 309  *
 310  * Revision 1.7  1995/03/14  17:32:29  adam
 311  * Presentation of full Marc record in popup window.
 312  *
 313  * Revision 1.6  1995/03/12  19:31:55  adam
 314  * Pattern matching implemented when retrieving MARC records. More
 315  * diagnostic functions.
 316  *
 317  * Revision 1.5  1995/03/10  18:00:15  adam
 318  * Actual presentation in line-by-line format. RPN query support.
 319  *
 320  * Revision 1.4  1995/03/09  16:15:08  adam
 321  * First presentRequest attempts. Hot-target list.
 322  *
 323  */
 324
 325 #include <stdlib.h>
 326 #include <stdio.h>
 327 #include <unistd.h>
 328 #include <time.h>
 329 #include <assert.h>
 330
 331 #define CS_BLOCK 0
 332
 333 #include "ir-tclp.h"
 334
 335 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num);
 336
 337 static void ir_select_notify (ClientData clientData, int r, int w, int e);
 338
 339 void ir_select_add (int fd, void *obj)
 340 {
 341     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 0, 0);
 342 }
 343
 344 void ir_select_add_write (int fd, void *obj)
 345 {
 346     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 1, 0);
 347 }
 348
 349 void ir_select_remove (int fd, void *obj)
 350 {
 351     ir_tcl_select_set (NULL, fd, obj, 0, 0, 0);
 352 }
 353
 354 void ir_select_remove_write (int fd, void *obj)
 355 {
 356     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 0, 0);
 357 }
 358
 359 static void delete_IR_record (IrTcl_RecordList *rl)
 360 {
 361     switch (rl->which)
 362     {
 363     case Z_NamePlusRecord_databaseRecord:
 364         switch (rl->u.dbrec.type)
 365         {
 366         case VAL_GRS1:
 367             ir_tcl_grs_del (&rl->u.dbrec.u.grs1);
 368             break;
 369         default:
 370             break;
 371         }
 372         free (rl->u.dbrec.buf);
 373         break;
 374     case Z_NamePlusRecord_surrogateDiagnostic:
 375         ir_deleteDiags (&rl->u.surrogateDiagnostics.list,
 376                         &rl->u.surrogateDiagnostics.num);
 377         break;
 378     }
 379     free (rl->elements);
 380 }
 381
 382 static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj,
 383                                         int no, int which,
 384                                         const char *elements)
 385 {
 386     IrTcl_RecordList *rl;
 387
 388     if (elements && !*elements)
 389         elements = NULL;
 390     for (rl = setobj->record_list; rl; rl = rl->next)
 391     {
 392         if (no == rl->no && (!rl->elements || !elements ||
 393                              !strcmp(elements, rl->elements)))
 394         {
 395             delete_IR_record (rl);
 396             break;
 397         }
 398     }
 399     if (!rl)
 400     {
 401         rl = ir_tcl_malloc (sizeof(*rl));
 402         rl->next = setobj->record_list;
 403         rl->no = no;
 404         setobj->record_list = rl;
 405     }
 406     rl->which = which;
 407     ir_tcl_strdup (NULL, &rl->elements, elements);
 408     return rl;
 409 }
 410
 411 /*
 412  * ir_tcl_eval
 413  */
 414 int ir_tcl_eval (Tcl_Interp *interp, const char *command)
 415 {
 416     char *tmp = ir_tcl_malloc (strlen(command)+1);
 417     int r;
 418
 419     logf (LOG_DEBUG, "Invoking %.23s ...", command);
 420     strcpy (tmp, command);
 421     r = Tcl_Eval (interp, tmp);
 422     if (r == TCL_ERROR)
 423     {
 424         logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine,
 425               interp->result);
 426     }
 427     Tcl_FreeResult (interp);
 428     free (tmp);
 429     return r;
 430 }
 431
 432 /*
 433  * IrTcl_getRecordSyntaxStr: Return record syntax name of object id
 434  */
 435 static char *IrTcl_getRecordSyntaxStr (enum oid_value value)
 436 {
 437     int *o;
 438     struct oident ent, *entp;
 439
 440     ent.proto = PROTO_Z3950;
 441     ent.oclass = CLASS_RECSYN;
 442     ent.value = value;
 443
 444     o = oid_getoidbyent (&ent);
 445     entp = oid_getentbyoid (o);
 446
 447     if (!entp)
 448         return "";
 449     return entp->desc;
 450 }
 451
 452 /*
 453  * IrTcl_getRecordSyntaxVal: Return record syntax value of string
 454  */
 455 static enum oid_value IrTcl_getRecordSyntaxVal (const char *name)
 456 {
 457     return oid_getvalbyname (name);
 458 }
 459
 460 static IrTcl_RecordList *find_IR_record (IrTcl_SetObj *setobj, int no)
 461 {
 462     IrTcl_RecordList *rl;
 463
 464     for (rl = setobj->record_list; rl; rl = rl->next)
 465         if (no == rl->no &&
 466             (!setobj->recordElements || !rl->elements ||
 467              !strcmp (setobj->recordElements, rl->elements)))
 468             return rl;
 469     return NULL;
 470 }
 471
 472 static void delete_IR_records (IrTcl_SetObj *setobj)
 473 {
 474     IrTcl_RecordList *rl, *rl1;
 475
 476     for (rl = setobj->record_list; rl; rl = rl1)
 477     {
 478         delete_IR_record (rl);
 479         rl1 = rl->next;
 480         free (rl);
 481     }
 482     setobj->record_list = NULL;
 483 }
 484
 485 /*
 486  * ir_tcl_get_set_int: Set/get integer value
 487  */
 488 int ir_tcl_get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)
 489 {
 490     char buf[20];
 491
 492     if (argc == 3)
 493     {
 494         if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)
 495             return TCL_ERROR;
 496     }
 497     sprintf (buf, "%d", *val);
 498     Tcl_AppendResult (interp, buf, NULL);
 499     return TCL_OK;
 500 }
 501
 502 /*
 503  * ir_tcl_method: Search for method in table and invoke method handler
 504  */
 505 int ir_tcl_method (Tcl_Interp *interp, int argc, char **argv,
 506                    IrTcl_Methods *tab, int *ret)
 507 {
 508     IrTcl_Methods *tab_i = tab;
 509     IrTcl_Method *t;
 510
 511     for (tab_i = tab; tab_i->tab; tab_i++)
 512         for (t = tab_i->tab; t->name; t++)
 513             if (argc <= 0)
 514             {
 515                 if ((*t->method)(tab_i->obj, interp, argc, argv) == TCL_ERROR)
 516                     return TCL_ERROR;
 517             }
 518             else
 519                 if (!strcmp (t->name, argv[1]))
 520                 {
 521                     *ret = (*t->method)(tab_i->obj, interp, argc, argv);
 522                     return TCL_OK;
 523                 }
 524
 525     if (argc <= 0)
 526         return TCL_OK;
 527 #if 0
 528     Tcl_AppendResult (interp, "Bad method: ", argv[1],
 529                       ". Possible methods:", NULL);
 530     for (tab_i = tab; tab_i->tab; tab_i++)
 531         for (t = tab_i->tab; t->name; t++)
 532             Tcl_AppendResult (interp, " ", t->name, NULL);
 533 #endif
 534     *ret = TCL_ERROR;
 535     return TCL_ERROR;
 536 }
 537
 538 /*
 539  *  ir_tcl_named_bits: get/set named bits
 540  */
 541 int ir_tcl_named_bits (struct ir_named_entry *tab, Odr_bitmask *ob,
 542                        Tcl_Interp *interp, int argc, char **argv)
 543 {
 544     struct ir_named_entry *ti;
 545     if (argc > 0)
 546     {
 547         int no;
 548         ODR_MASK_ZERO (ob);
 549         for (no = 0; no < argc; no++)
 550         {
 551             for (ti = tab; ti->name; ti++)
 552                 if (!strcmp (argv[no], ti->name))
 553                 {
 554                     ODR_MASK_SET (ob, ti->pos);
 555                     break;
 556                 }
 557             if (!ti->name)
 558             {
 559                 Tcl_AppendResult (interp, "Bad bit mask: ", argv[no], NULL);
 560                 return TCL_ERROR;
 561             }
 562         }
 563         return TCL_OK;
 564     }
 565     for (ti = tab; ti->name; ti++)
 566         if (ODR_MASK_GET (ob, ti->pos))
 567             Tcl_AppendElement (interp, ti->name);
 568     return TCL_OK;
 569 }
 570
 571 static void set_referenceId (ODR o, Z_ReferenceId **dst, const char *src)
 572 {
 573     if (!src || !*src)
 574         *dst = NULL;
 575     else
 576     {
 577         *dst = odr_malloc (o, sizeof(**dst));
 578         (*dst)->size = (*dst)->len = strlen(src);
 579         (*dst)->buf = odr_malloc (o, (*dst)->len);
 580         memcpy ((*dst)->buf, src, (*dst)->len);
 581     }
 582 }
 583
 584 static void get_referenceId (char **dst, Z_ReferenceId *src)
 585 {
 586     free (*dst);
 587     if (!src)
 588     {
 589         *dst = NULL;
 590         return;
 591     }
 592     *dst = ir_tcl_malloc (src->len+1);
 593     memcpy (*dst, src->buf, src->len);
 594     (*dst)[src->len] = '\0';
 595 }
 596
 597 /* ------------------------------------------------------- */
 598
 599 /*
 600  * do_init_request: init method on IR object
 601  */
 602 static int do_init_request (void *obj, Tcl_Interp *interp,
 603                             int argc, char **argv)
 604 {
 605     Z_APDU *apdu;
 606     IrTcl_Obj *p = obj;
 607     Z_InitRequest *req;
 608
 609     if (argc <= 0)
 610         return TCL_OK;
 611     logf (LOG_DEBUG, "init %s", *argv);
 612     if (!p->cs_link)
 613     {
 614         interp->result = "init: not connected";
 615         return TCL_ERROR;
 616     }
 617     apdu = zget_APDU (p->odr_out, Z_APDU_initRequest);
 618     req = apdu->u.initRequest;
 619
 620     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
 621     req->options = &p->options;
 622     req->protocolVersion = &p->protocolVersion;
 623     req->preferredMessageSize = &p->preferredMessageSize;
 624     req->maximumRecordSize = &p->maximumRecordSize;
 625
 626     if (p->idAuthenticationGroupId)
 627     {
 628         Z_IdPass *pass = odr_malloc (p->odr_out, sizeof(*pass));
 629         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
 630
 631         logf (LOG_DEBUG, "using pass authentication");
 632
 633         auth->which = Z_IdAuthentication_idPass;
 634         auth->u.idPass = pass;
 635         if (p->idAuthenticationGroupId && *p->idAuthenticationGroupId)
 636             pass->groupId = p->idAuthenticationGroupId;
 637         else
 638             pass->groupId = NULL;
 639         if (p->idAuthenticationUserId && *p->idAuthenticationUserId)
 640             pass->userId = p->idAuthenticationUserId;
 641         else
 642             pass->userId = NULL;
 643         if (p->idAuthenticationPassword && *p->idAuthenticationPassword)
 644             pass->password = p->idAuthenticationPassword;
 645         else
 646             pass->password = NULL;
 647         req->idAuthentication = auth;
 648     }
 649     else if (!p->idAuthenticationOpen || !*p->idAuthenticationOpen)
 650         req->idAuthentication = NULL;
 651     else
 652     {
 653         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
 654
 655         logf (LOG_DEBUG, "using open authentication");
 656         auth->which = Z_IdAuthentication_open;
 657         auth->u.open = p->idAuthenticationOpen;
 658         req->idAuthentication = auth;
 659     }
 660     req->implementationId = p->implementationId;
 661     req->implementationName = p->implementationName;
 662     req->implementationVersion = p->implementationVersion;
 663     req->userInformationField = 0;
 664
 665     return ir_tcl_send_APDU (interp, p, apdu, "init", *argv);
 666 }
 667
 668 /*
 669  * do_protocolVersion: Set protocol Version
 670  */
 671 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 672                                int argc, char **argv)
 673 {
 674     int version, i;
 675     char buf[10];
 676     IrTcl_Obj *p = obj;
 677
 678     if (argc <= 0)
 679     {
 680         ODR_MASK_ZERO (&p->protocolVersion);
 681         ODR_MASK_SET (&p->protocolVersion, 0);
 682         ODR_MASK_SET (&p->protocolVersion, 1);
 683         return TCL_OK;
 684     }
 685     if (argc == 3)
 686     {
 687         if (Tcl_GetInt (interp, argv[2], &version)==TCL_ERROR)
 688             return TCL_ERROR;
 689         ODR_MASK_ZERO (&p->protocolVersion);
 690         for (i = 0; i<version; i++)
 691             ODR_MASK_SET (&p->protocolVersion, i);
 692     }
 693     for (i = 4; --i >= 0; )
 694         if (ODR_MASK_GET (&p->protocolVersion, i))
 695             break;
 696     sprintf (buf, "%d", i+1);
 697     interp->result = buf;
 698     return TCL_OK;
 699 }
 700
 701 /*
 702  * do_options: Set options
 703  */
 704 static int do_options (void *obj, Tcl_Interp *interp,
 705                        int argc, char **argv)
 706 {
 707     static struct ir_named_entry options_tab[] = {
 708     { "search", 0 },
 709     { "present", 1 },
 710     { "delSet", 2 },
 711     { "resourceReport", 3 },
 712     { "triggerResourceCtrl", 4},
 713     { "resourceCtrl", 5},
 714     { "accessCtrl", 6},
 715     { "scan", 7},
 716     { "sort", 8},
 717     { "extendedServices", 10},
 718     { "level-1Segmentation", 11},
 719     { "level-2Segmentation", 12},
 720     { "concurrentOperations", 13},
 721     { "namedResultSets", 14},
 722     { NULL, 0}
 723     };
 724     IrTcl_Obj *p = obj;
 725
 726     if (argc <= 0)
 727     {
 728         ODR_MASK_ZERO (&p->options);
 729         ODR_MASK_SET (&p->options, 0);
 730         ODR_MASK_SET (&p->options, 1);
 731         ODR_MASK_SET (&p->options, 4);
 732         ODR_MASK_SET (&p->options, 7);
 733         ODR_MASK_SET (&p->options, 14);
 734         return TCL_OK;
 735     }
 736     return ir_tcl_named_bits (options_tab, &p->options, interp, argc-2, argv+2);
 737 }
 738
 739 /*
 740  * do_apduInfo: Get APDU information
 741  */
 742 static int do_apduInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)
 743 {
 744     char buf[16];
 745     FILE *apduf;
 746     IrTcl_Obj *p = obj;
 747
 748     if (argc <= 0)
 749         return TCL_OK;
 750     sprintf (buf, "%d", p->apduLen);
 751     Tcl_AppendElement (interp, buf);
 752     sprintf (buf, "%d", p->apduOffset);
 753     Tcl_AppendElement (interp, buf);
 754     if (!p->buf_in)
 755     {
 756         Tcl_AppendElement (interp, "");
 757         return TCL_OK;
 758     }
 759     apduf = fopen ("apdu.tmp", "w");
 760     if (!apduf)
 761     {
 762         Tcl_AppendElement (interp, "");
 763         return TCL_OK;
 764     }
 765     odr_dumpBER (apduf, p->buf_in, p->apduLen);
 766     fclose (apduf);
 767     if (!(apduf = fopen ("apdu.tmp", "r")))
 768         Tcl_AppendElement (interp, "");
 769     else
 770     {
 771         int c;
 772
 773         Tcl_AppendResult (interp, " {", NULL);
 774         while ((c = getc (apduf)) != EOF)
 775         {
 776             buf[0] = c;
 777             buf[1] = '\0';
 778             Tcl_AppendResult (interp, buf, NULL);
 779         }
 780         fclose (apduf);
 781         Tcl_AppendResult (interp, "}", NULL);
 782     }
 783     unlink ("apdu.tmp");
 784     return TCL_OK;
 785 }
 786
 787 /*
 788  * do_failInfo: Get fail information
 789  */
 790 static int do_failInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)
 791 {
 792     char buf[16], *cp;
 793     IrTcl_Obj *p = obj;
 794
 795     if (argc <= 0)
 796     {
 797         p->failInfo = 0;
 798         return TCL_OK;
 799     }
 800     sprintf (buf, "%d", p->failInfo);
 801     switch (p->failInfo)
 802     {
 803     case 0:
 804         cp = "ok";
 805         break;
 806     case IR_TCL_FAIL_CONNECT:
 807         cp = "connect failed";
 808         break;
 809     case IR_TCL_FAIL_READ:
 810         cp = "connection closed";
 811         break;
 812     case IR_TCL_FAIL_WRITE:
 813         cp = "connection closed";
 814         break;
 815     case IR_TCL_FAIL_IN_APDU:
 816         cp = "failed to decode incoming APDU";
 817         break;
 818     case IR_TCL_FAIL_UNKNOWN_APDU:
 819         cp = "unknown APDU";
 820         break;
 821     default:
 822         cp = "";
 823     }
 824     Tcl_AppendElement (interp, buf);
 825     Tcl_AppendElement (interp, cp);
 826     return TCL_OK;
 827 }
 828
 829 /*
 830  * do_preferredMessageSize: Set/get preferred message size
 831  */
 832 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 833                                     int argc, char **argv)
 834 {
 835     IrTcl_Obj *p = obj;
 836
 837     if (argc <= 0)
 838     {
 839         p->preferredMessageSize = 30000;
 840         return TCL_OK;
 841     }
 842     return ir_tcl_get_set_int (&p->preferredMessageSize, interp, argc, argv);
 843 }
 844
 845 /*
 846  * do_maximumRecordSize: Set/get maximum record size
 847  */
 848 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 849                                  int argc, char **argv)
 850 {
 851     IrTcl_Obj *p = obj;
 852
 853     if (argc <= 0)
 854     {
 855         p->maximumRecordSize = 30000;
 856         return TCL_OK;
 857     }
 858     return ir_tcl_get_set_int (&p->maximumRecordSize, interp, argc, argv);
 859 }
 860
 861 /*
 862  * do_initResult: Get init result
 863  */
 864 static int do_initResult (void *obj, Tcl_Interp *interp,
 865                           int argc, char **argv)
 866 {
 867     IrTcl_Obj *p = obj;
 868
 869     if (argc <= 0)
 870         return TCL_OK;
 871     return ir_tcl_get_set_int (&p->initResult, interp, argc, argv);
 872 }
 873
 874
 875 /*
 876  * do_implementationName: Set/get Implementation Name.
 877  */
 878 static int do_implementationName (void *obj, Tcl_Interp *interp,
 879                                     int argc, char **argv)
 880 {
 881     IrTcl_Obj *p = obj;
 882
 883     if (argc == 0)
 884         return ir_tcl_strdup (interp, &p->implementationName,
 885                           "Index Data/IrTcl on YAZ");
 886     else if (argc == -1)
 887         return ir_tcl_strdel (interp, &p->implementationName);
 888     if (argc == 3)
 889     {
 890         free (p->implementationName);
 891         if (ir_tcl_strdup (interp, &p->implementationName, argv[2])
 892             == TCL_ERROR)
 893             return TCL_ERROR;
 894     }
 895     Tcl_AppendResult (interp, p->implementationName, (char*) NULL);
 896     return TCL_OK;
 897 }
 898
 899 /*
 900  * do_implementationId: Get Implementation Id.
 901  */
 902 static int do_implementationId (void *obj, Tcl_Interp *interp,
 903                                 int argc, char **argv)
 904 {
 905     IrTcl_Obj *p = obj;
 906
 907     if (argc == 0)
 908         return ir_tcl_strdup (interp, &p->implementationId, "YAZ (id=81)");
 909     else if (argc == -1)
 910         return ir_tcl_strdel (interp, &p->implementationId);
 911     Tcl_AppendResult (interp, p->implementationId, (char*) NULL);
 912     return TCL_OK;
 913 }
 914
 915 /*
 916  * do_implementationVersion: get Implementation Version.
 917  */
 918 static int do_implementationVersion (void *obj, Tcl_Interp *interp,
 919                                      int argc, char **argv)
 920 {
 921     IrTcl_Obj *p = obj;
 922
 923     if (argc == 0)
 924         return ir_tcl_strdup (interp, &p->implementationVersion,
 925                           "YAZ: " YAZ_VERSION " / IrTcl: " IR_TCL_VERSION);
 926     else if (argc == -1)
 927         return ir_tcl_strdel (interp, &p->implementationVersion);
 928     Tcl_AppendResult (interp, p->implementationVersion, (char*) NULL);
 929     return TCL_OK;
 930 }
 931
 932 /*
 933  * do_targetImplementationName: Get Implementation Name of target.
 934  */
 935 static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
 936                                         int argc, char **argv)
 937 {
 938     IrTcl_Obj *p = obj;
 939
 940     if (argc == 0)
 941     {
 942         p->targetImplementationName = NULL;
 943         return TCL_OK;
 944     }
 945     else if (argc == -1)
 946         return ir_tcl_strdel (interp, &p->targetImplementationName);
 947     Tcl_AppendResult (interp, p->targetImplementationName, (char*) NULL);
 948     return TCL_OK;
 949 }
 950
 951 /*
 952  * do_targetImplementationId: Get Implementation Id of target
 953  */
 954 static int do_targetImplementationId (void *obj, Tcl_Interp *interp,
 955                                       int argc, char **argv)
 956 {
 957     IrTcl_Obj *p = obj;
 958
 959     if (argc == 0)
 960     {
 961         p->targetImplementationId = NULL;
 962         return TCL_OK;
 963     }
 964     else if (argc == -1)
 965         return ir_tcl_strdel (interp, &p->targetImplementationId);
 966     Tcl_AppendResult (interp, p->targetImplementationId, (char*) NULL);
 967     return TCL_OK;
 968 }
 969
 970 /*
 971  * do_targetImplementationVersion: Get Implementation Version of target
 972  */
 973 static int do_targetImplementationVersion (void *obj, Tcl_Interp *interp,
 974                                            int argc, char **argv)
 975 {
 976     IrTcl_Obj *p = obj;
 977
 978     if (argc == 0)
 979     {
 980         p->targetImplementationVersion = NULL;
 981         return TCL_OK;
 982     }
 983     else if (argc == -1)
 984         return ir_tcl_strdel (interp, &p->targetImplementationVersion);
 985     Tcl_AppendResult (interp, p->targetImplementationVersion, (char*) NULL);
 986     return TCL_OK;
 987 }
 988
 989 /*
 990  * do_idAuthentication: Set/get id Authentication
 991  */
 992 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 993                                 int argc, char **argv)
 994 {
 995     IrTcl_Obj *p = obj;
 996
 997     if (argc >= 3 || argc == -1)
 998     {
 999         free (p->idAuthenticationOpen);
1000         free (p->idAuthenticationGroupId);
1001         free (p->idAuthenticationUserId);
1002         free (p->idAuthenticationPassword);
1003     }
1004     if (argc >= 3 || argc <= 0)
1005     {
1006         p->idAuthenticationOpen = NULL;
1007         p->idAuthenticationGroupId = NULL;
1008         p->idAuthenticationUserId = NULL;
1009         p->idAuthenticationPassword = NULL;
1010     }
1011     if (argc <= 0)
1012         return TCL_OK;
1013     if (argc >= 3)
1014     {
1015         if (argc == 3)
1016         {
1017             if (argv[2][0] &&
1018                 ir_tcl_strdup (interp, &p->idAuthenticationOpen, argv[2])
1019                 == TCL_ERROR)
1020                 return TCL_ERROR;
1021         }
1022         else if (argc == 5)
1023         {
1024             if (argv[2][0] &&
1025                 ir_tcl_strdup (interp, &p->idAuthenticationGroupId, argv[2])
1026                 == TCL_ERROR)
1027                 return TCL_ERROR;
1028             if (argv[3][0] &&
1029                 ir_tcl_strdup (interp, &p->idAuthenticationUserId, argv[3])
1030                 == TCL_ERROR)
1031                 return TCL_ERROR;
1032             if (argv[4][0] &&
1033                 ir_tcl_strdup (interp, &p->idAuthenticationPassword, argv[4])
1034                 == TCL_ERROR)
1035                 return TCL_ERROR;
1036         }
1037     }
1038     if (p->idAuthenticationOpen)
1039         Tcl_AppendElement (interp, p->idAuthenticationOpen);
1040     else if (p->idAuthenticationGroupId)
1041     {
1042         Tcl_AppendElement (interp, p->idAuthenticationGroupId);
1043         Tcl_AppendElement (interp, p->idAuthenticationUserId);
1044         Tcl_AppendElement (interp, p->idAuthenticationPassword);
1045     }
1046     return TCL_OK;
1047 }
1048
1049 /*
1050  * do_connect: connect method on IR object
1051  */
1052 static int do_connect (void *obj, Tcl_Interp *interp,
1053                        int argc, char **argv)
1054 {
1055     void *addr;
1056     IrTcl_Obj *p = obj;
1057     int r;
1058
1059     if (argc <= 0)
1060         return TCL_OK;
1061     if (argc == 3)
1062     {
1063         logf (LOG_DEBUG, "connect %s %s", *argv, argv[2]);
1064         if (p->hostname)
1065         {
1066             interp->result = "already connected";
1067             return TCL_ERROR;
1068         }
1069         if (!strcmp (p->comstackType, "tcpip"))
1070         {
1071             p->cs_link = cs_create (tcpip_type, CS_BLOCK, p->protocol_type);
1072             addr = tcpip_strtoaddr (argv[2]);
1073             if (!addr)
1074             {
1075                 interp->result = "tcpip_strtoaddr fail";
1076                 return TCL_ERROR;
1077             }
1078             logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]);
1079         }
1080         else if (!strcmp (p->comstackType, "mosi"))
1081         {
1082 #if MOSI
1083             p->cs_link = cs_create (mosi_type, CS_BLOCK, p->protocol_type);
1084             addr = mosi_strtoaddr (argv[2]);
1085             if (!addr)
1086             {
1087                 interp->result = "mosi_strtoaddr fail";
1088                 return TCL_ERROR;
1089             }
1090             logf (LOG_DEBUG, "mosi connect %s", argv[2]);
1091 #else
1092             interp->result = "MOSI support not there";
1093             return TCL_ERROR;
1094 #endif
1095         }
1096         else
1097         {
1098             Tcl_AppendResult (interp, "Bad comstack type: ",
1099                               p->comstackType, NULL);
1100             return TCL_ERROR;
1101         }
1102         if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
1103             return TCL_ERROR;
1104         p->eventType = "connect";
1105         if ((r=cs_connect (p->cs_link, addr)) < 0)
1106         {
1107             interp->result = "connect fail";
1108             ir_tcl_disconnect (p);
1109             return TCL_ERROR;
1110         }
1111         ir_select_add (cs_fileno (p->cs_link), p);
1112         if (r == 1)
1113         {
1114             logf (LOG_DEBUG, "connect pending fd=%d", cs_fileno(p->cs_link));
1115             ir_select_add_write (cs_fileno (p->cs_link), p);
1116             p->state = IR_TCL_R_Connecting;
1117         }
1118         else
1119         {
1120             logf (LOG_DEBUG, "connect ok fd=%d", cs_fileno(p->cs_link));
1121             p->state = IR_TCL_R_Idle;
1122             if (p->callback)
1123                 ir_tcl_eval (p->interp, p->callback);
1124         }
1125     }
1126     else
1127         Tcl_AppendResult (interp, p->hostname, NULL);
1128     return TCL_OK;
1129 }
1130
1131 /*
1132  * ir_tcl_disconnect: close connection
1133  */
1134 void ir_tcl_disconnect (IrTcl_Obj *p)
1135 {
1136     if (p->hostname)
1137     {
1138         logf(LOG_DEBUG, "Closing connection to %s", p->hostname);
1139         free (p->hostname);
1140         p->hostname = NULL;
1141         ir_select_remove_write (cs_fileno (p->cs_link), p);
1142         ir_select_remove (cs_fileno (p->cs_link), p);
1143
1144         odr_reset (p->odr_in);
1145
1146         assert (p->cs_link);
1147         cs_close (p->cs_link);
1148         p->cs_link = NULL;
1149
1150         ODR_MASK_ZERO (&p->options);
1151         ODR_MASK_SET (&p->options, 0);
1152         ODR_MASK_SET (&p->options, 1);
1153         ODR_MASK_SET (&p->options, 4);
1154         ODR_MASK_SET (&p->options, 7);
1155         ODR_MASK_SET (&p->options, 14);
1156
1157         ODR_MASK_ZERO (&p->protocolVersion);
1158         ODR_MASK_SET (&p->protocolVersion, 0);
1159         ODR_MASK_SET (&p->protocolVersion, 1);
1160         ir_tcl_del_q (p);
1161     }
1162     assert (!p->cs_link);
1163 }
1164
1165 /*
1166  * do_disconnect: disconnect method on IR object
1167  */
1168 static int do_disconnect (void *obj, Tcl_Interp *interp,
1169                           int argc, char **argv)
1170 {
1171     IrTcl_Obj *p = obj;
1172
1173     if (argc == 0)
1174     {
1175         p->state = IR_TCL_R_Idle;
1176         p->eventType = NULL;
1177         p->hostname = NULL;
1178         p->cs_link = NULL;
1179         return TCL_OK;
1180     }
1181     ir_tcl_disconnect (p);
1182     return TCL_OK;
1183 }
1184
1185 /*
1186  * do_comstack: Set/get comstack method on IR object
1187  */
1188 static int do_comstack (void *o, Tcl_Interp *interp,
1189                         int argc, char **argv)
1190 {
1191     IrTcl_Obj *obj = o;
1192
1193     if (argc == 0)
1194         return ir_tcl_strdup (interp, &obj->comstackType, "tcpip");
1195     else if (argc == -1)
1196         return ir_tcl_strdel (interp, &obj->comstackType);
1197     else if (argc == 3)
1198     {
1199         free (obj->comstackType);
1200         if (ir_tcl_strdup (interp, &obj->comstackType, argv[2]) == TCL_ERROR)
1201             return TCL_ERROR;
1202     }
1203     Tcl_AppendElement (interp, obj->comstackType);
1204     return TCL_OK;
1205 }
1206
1207 /*
1208  * do_logLevel: Set log level
1209  */
1210 static int do_logLevel (void *o, Tcl_Interp *interp,
1211                         int argc, char **argv)
1212 {
1213     if (argc <= 2)
1214         return TCL_OK;
1215     if (argc == 3)
1216         log_init (log_mask_str (argv[2]), "", NULL);
1217     else if (argc == 4)
1218         log_init (log_mask_str (argv[2]), argv[3], NULL);
1219     else if (argc == 5)
1220         log_init (log_mask_str (argv[2]), argv[3], argv[4]);
1221     return TCL_OK;
1222 }
1223
1224
1225 /*
1226  * do_eventType: Return type of last event
1227  */
1228 static int do_eventType (void *obj, Tcl_Interp *interp,
1229                          int argc, char **argv)
1230 {
1231     IrTcl_Obj *p = obj;
1232
1233     if (argc <= 0)
1234     {
1235         p->eventType = NULL;
1236         return TCL_OK;
1237     }
1238     Tcl_AppendElement (interp, p->eventType ? p->eventType : "");
1239     return TCL_OK;
1240 }
1241
1242
1243 /*
1244  * do_callback: add callback
1245  */
1246 static int do_callback (void *obj, Tcl_Interp *interp,
1247                         int argc, char **argv)
1248 {
1249     IrTcl_Obj *p = obj;
1250
1251     if (argc == 0)
1252     {
1253         p->callback = NULL;
1254         return TCL_OK;
1255     }
1256     else if (argc == -1)
1257         return ir_tcl_strdel (interp, &p->callback);
1258     if (argc == 3)
1259     {
1260         free (p->callback);
1261         if (argv[2][0])
1262         {
1263             if (ir_tcl_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
1264                 return TCL_ERROR;
1265         }
1266         else
1267             p->callback = NULL;
1268     }
1269     return TCL_OK;
1270 }
1271
1272 /*
1273  * do_failback: add error handle callback
1274  */
1275 static int do_failback (void *obj, Tcl_Interp *interp,
1276                           int argc, char **argv)
1277 {
1278     IrTcl_Obj *p = obj;
1279
1280     if (argc == 0)
1281     {
1282         p->failback = NULL;
1283         return TCL_OK;
1284     }
1285     else if (argc == -1)
1286         return ir_tcl_strdel (interp, &p->failback);
1287     else if (argc == 3)
1288     {
1289         free (p->failback);
1290         if (argv[2][0])
1291         {
1292             if (ir_tcl_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
1293                 return TCL_ERROR;
1294         }
1295         else
1296             p->failback = NULL;
1297     }
1298     return TCL_OK;
1299 }
1300
1301 /*
1302  * do_initResponse: add init response handler
1303  */
1304 static int do_initResponse (void *obj, Tcl_Interp *interp,
1305                             int argc, char **argv)
1306 {
1307     IrTcl_Obj *p = obj;
1308
1309     if (argc == 0)
1310     {
1311         p->initResponse = NULL;
1312         return TCL_OK;
1313     }
1314     else if (argc == -1)
1315         return ir_tcl_strdel (interp, &p->initResponse);
1316     if (argc == 3)
1317     {
1318         free (p->initResponse);
1319         if (argv[2][0])
1320         {
1321             if (ir_tcl_strdup (interp, &p->initResponse, argv[2]) == TCL_ERROR)
1322                 return TCL_ERROR;
1323         }
1324         else
1325             p->initResponse = NULL;
1326     }
1327     return TCL_OK;
1328 }
1329 /*
1330  * do_protocol: Set/get protocol method on IR object
1331  */
1332 static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv)
1333 {
1334     IrTcl_Obj *p = o;
1335
1336     if (argc <= 0)
1337     {
1338         p->protocol_type = PROTO_Z3950;
1339         return TCL_OK;
1340     }
1341     else if (argc == 3)
1342     {
1343         if (!strcmp (argv[2], "Z39"))
1344             p->protocol_type = PROTO_Z3950;
1345         else if (!strcmp (argv[2], "SR"))
1346             p->protocol_type = PROTO_SR;
1347         else
1348         {
1349             Tcl_AppendResult (interp, "Bad protocol: ", argv[2], NULL);
1350             return TCL_ERROR;
1351         }
1352         return TCL_OK;
1353     }
1354     switch (p->protocol_type)
1355     {
1356     case PROTO_Z3950:
1357         Tcl_AppendElement (interp, "Z39");
1358         break;
1359     case PROTO_SR:
1360         Tcl_AppendElement (interp, "SR");
1361         break;
1362     }
1363     return TCL_OK;
1364 }
1365
1366 /*
1367  * do_triggerResourceControl:
1368  */
1369 static int do_triggerResourceControl (void *obj, Tcl_Interp *interp,
1370                                       int argc, char **argv)
1371 {
1372     IrTcl_Obj *p = obj;
1373     Z_APDU *apdu;
1374     Z_TriggerResourceControlRequest *req;
1375     bool_t is_false = 0;
1376
1377     if (argc <= 0)
1378         return TCL_OK;
1379     if (!p->cs_link)
1380     {
1381         interp->result = "triggerResourceControl: not connected";
1382         return TCL_ERROR;
1383     }
1384     apdu = zget_APDU (p->odr_out, Z_APDU_triggerResourceControlRequest);
1385     req = apdu->u.triggerResourceControlRequest;
1386     *req->requestedAction = Z_TriggerResourceCtrl_cancel;
1387     req->resultSetWanted = &is_false;
1388
1389     return ir_tcl_send_APDU (interp, p, apdu, "triggerResourceControl",
1390                              argv[0]);
1391 }
1392
1393 /*
1394  * do_databaseNames: specify database names
1395  */
1396 static int do_databaseNames (void *obj, Tcl_Interp *interp,
1397                              int argc, char **argv)
1398 {
1399     int i;
1400     IrTcl_SetCObj *p = obj;
1401
1402     if (argc == -1)
1403     {
1404         for (i=0; i<p->num_databaseNames; i++)
1405             free (p->databaseNames[i]);
1406         free (p->databaseNames);
1407     }
1408     if (argc <= 0)
1409     {
1410         p->num_databaseNames = 0;
1411         p->databaseNames = NULL;
1412         return TCL_OK;
1413     }
1414     if (argc < 3)
1415     {
1416         for (i=0; i<p->num_databaseNames; i++)
1417             Tcl_AppendElement (interp, p->databaseNames[i]);
1418         return TCL_OK;
1419     }
1420     if (p->databaseNames)
1421     {
1422         for (i=0; i<p->num_databaseNames; i++)
1423             free (p->databaseNames[i]);
1424         free (p->databaseNames);
1425     }
1426     p->num_databaseNames = argc - 2;
1427     p->databaseNames =
1428         ir_tcl_malloc (sizeof(*p->databaseNames) * (1+p->num_databaseNames));
1429     for (i=0; i<p->num_databaseNames; i++)
1430     {
1431         if (ir_tcl_strdup (interp, &p->databaseNames[i], argv[2+i])
1432             == TCL_ERROR)
1433             return TCL_ERROR;
1434     }
1435     p->databaseNames[i] = NULL;
1436     return TCL_OK;
1437 }
1438
1439 /*
1440  * do_replaceIndicator: Set/get replace Set indicator
1441  */
1442 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
1443                                 int argc, char **argv)
1444 {
1445     IrTcl_SetCObj *p = obj;
1446
1447     if (argc <= 0)
1448     {
1449         p->replaceIndicator = 1;
1450         return TCL_OK;
1451     }
1452     return ir_tcl_get_set_int (&p->replaceIndicator, interp, argc, argv);
1453 }
1454
1455 /*
1456  * do_queryType: Set/Get query method
1457  */
1458 static int do_queryType (void *obj, Tcl_Interp *interp,
1459                        int argc, char **argv)
1460 {
1461     IrTcl_SetCObj *p = obj;
1462
1463     if (argc == 0)
1464         return ir_tcl_strdup (interp, &p->queryType, "rpn");
1465     else if (argc == -1)
1466         return ir_tcl_strdel (interp, &p->queryType);
1467     if (argc == 3)
1468     {
1469         free (p->queryType);
1470         if (ir_tcl_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR)
1471             return TCL_ERROR;
1472     }
1473     Tcl_AppendResult (interp, p->queryType, NULL);
1474     return TCL_OK;
1475 }
1476
1477 /*
1478  * do_userInformationField: Get User information field
1479  */
1480 static int do_userInformationField (void *obj, Tcl_Interp *interp,
1481                                     int argc, char **argv)
1482 {
1483     IrTcl_Obj *p = obj;
1484
1485     if (argc == 0)
1486     {
1487         p->userInformationField = NULL;
1488         return TCL_OK;
1489     }
1490     else if (argc == -1)
1491         return ir_tcl_strdel (interp, &p->userInformationField);
1492     Tcl_AppendResult (interp, p->userInformationField, NULL);
1493     return TCL_OK;
1494 }
1495
1496 /*
1497  * do_smallSetUpperBound: Set/get small set upper bound
1498  */
1499 static int do_smallSetUpperBound (void *o, Tcl_Interp *interp,
1500                        int argc, char **argv)
1501 {
1502     IrTcl_SetCObj *p = o;
1503
1504     if (argc <= 0)
1505     {
1506         p->smallSetUpperBound = 0;
1507         return TCL_OK;
1508     }
1509     return ir_tcl_get_set_int (&p->smallSetUpperBound, interp, argc, argv);
1510 }
1511
1512 /*
1513  * do_largeSetLowerBound: Set/get large set lower bound
1514  */
1515 static int do_largeSetLowerBound (void *o, Tcl_Interp *interp,
1516                                   int argc, char **argv)
1517 {
1518     IrTcl_SetCObj *p = o;
1519
1520     if (argc <= 0)
1521     {
1522         p->largeSetLowerBound = 2;
1523         return TCL_OK;
1524     }
1525     return ir_tcl_get_set_int (&p->largeSetLowerBound, interp, argc, argv);
1526 }
1527
1528 /*
1529  * do_mediumSetPresentNumber: Set/get large set lower bound
1530  */
1531 static int do_mediumSetPresentNumber (void *o, Tcl_Interp *interp,
1532                                       int argc, char **argv)
1533 {
1534     IrTcl_SetCObj *p = o;
1535
1536     if (argc <= 0)
1537     {
1538         p->mediumSetPresentNumber = 0;
1539         return TCL_OK;
1540     }
1541     return ir_tcl_get_set_int (&p->mediumSetPresentNumber, interp, argc, argv);
1542 }
1543
1544 /*
1545  * do_referenceId: Set/Get referenceId
1546  */
1547 static int do_referenceId (void *obj, Tcl_Interp *interp,
1548                            int argc, char **argv)
1549 {
1550     IrTcl_SetCObj *p = obj;
1551
1552     if (argc == 0)
1553     {
1554         p->referenceId = NULL;
1555         return TCL_OK;
1556     }
1557     else if (argc == -1)
1558         return ir_tcl_strdel (interp, &p->referenceId);
1559     if (argc == 3)
1560     {
1561         free (p->referenceId);
1562         if (ir_tcl_strdup (interp, &p->referenceId, argv[2]) == TCL_ERROR)
1563             return TCL_ERROR;
1564     }
1565     Tcl_AppendResult (interp, p->referenceId, NULL);
1566     return TCL_OK;
1567 }
1568
1569 /*
1570  * do_preferredRecordSyntax: Set/get preferred record syntax
1571  */
1572 static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp,
1573                                      int argc, char **argv)
1574 {
1575     IrTcl_SetCObj *p = obj;
1576
1577     if (argc == 0)
1578     {
1579         p->preferredRecordSyntax = NULL;
1580         return TCL_OK;
1581     }
1582     else if (argc == -1)
1583     {
1584         free (p->preferredRecordSyntax);
1585         p->preferredRecordSyntax = NULL;
1586         return TCL_OK;
1587     }
1588     if (argc == 3)
1589     {
1590         free (p->preferredRecordSyntax);
1591         p->preferredRecordSyntax = NULL;
1592         if (argv[2][0] && (p->preferredRecordSyntax =
1593                            ir_tcl_malloc (sizeof(*p->preferredRecordSyntax))))
1594             *p->preferredRecordSyntax = IrTcl_getRecordSyntaxVal (argv[2]);
1595     }
1596     else if (argc == 2)
1597     {
1598         Tcl_AppendElement
1599             (interp,!p->preferredRecordSyntax ? "" :
1600              IrTcl_getRecordSyntaxStr(*p->preferredRecordSyntax));
1601     }
1602     return TCL_OK;
1603
1604 }
1605
1606 /*
1607  * do_elementSetNames: Set/Get element Set Names
1608  */
1609 static int do_elementSetNames (void *obj, Tcl_Interp *interp,
1610                                int argc, char **argv)
1611 {
1612     IrTcl_SetCObj *p = obj;
1613
1614     if (argc == 0)
1615     {
1616         p->elementSetNames = NULL;
1617         return TCL_OK;
1618     }
1619     else if (argc == -1)
1620         return ir_tcl_strdel (interp, &p->elementSetNames);
1621     if (argc == 3)
1622     {
1623         free (p->elementSetNames);
1624         if (ir_tcl_strdup (interp, &p->elementSetNames, argv[2]) == TCL_ERROR)
1625             return TCL_ERROR;
1626     }
1627     Tcl_AppendResult (interp, p->elementSetNames, NULL);
1628     return TCL_OK;
1629 }
1630
1631 /*
1632  * do_smallSetElementSetNames: Set/Get small Set Element Set Names
1633  */
1634 static int do_smallSetElementSetNames (void *obj, Tcl_Interp *interp,
1635                                int argc, char **argv)
1636 {
1637     IrTcl_SetCObj *p = obj;
1638
1639     if (argc == 0)
1640     {
1641         p->smallSetElementSetNames = NULL;
1642         return TCL_OK;
1643     }
1644     else if (argc == -1)
1645         return ir_tcl_strdel (interp, &p->smallSetElementSetNames);
1646     if (argc == 3)
1647     {
1648         free (p->smallSetElementSetNames);
1649         if (ir_tcl_strdup (interp, &p->smallSetElementSetNames,
1650                            argv[2]) == TCL_ERROR)
1651             return TCL_ERROR;
1652     }
1653     Tcl_AppendResult (interp, p->smallSetElementSetNames, NULL);
1654     return TCL_OK;
1655 }
1656
1657 /*
1658  * do_mediumSetElementSetNames: Set/Get medium Set Element Set Names
1659  */
1660 static int do_mediumSetElementSetNames (void *obj, Tcl_Interp *interp,
1661                                int argc, char **argv)
1662 {
1663     IrTcl_SetCObj *p = obj;
1664
1665     if (argc == 0)
1666     {
1667         p->mediumSetElementSetNames = NULL;
1668         return TCL_OK;
1669     }
1670     else if (argc == -1)
1671         return ir_tcl_strdel (interp, &p->mediumSetElementSetNames);
1672     if (argc == 3)
1673     {
1674         free (p->mediumSetElementSetNames);
1675         if (ir_tcl_strdup (interp, &p->mediumSetElementSetNames,
1676                            argv[2]) == TCL_ERROR)
1677             return TCL_ERROR;
1678     }
1679     Tcl_AppendResult (interp, p->mediumSetElementSetNames, NULL);
1680     return TCL_OK;
1681 }
1682
1683 static IrTcl_Method ir_method_tab[] = {
1684 { "comstack",                    do_comstack, NULL },
1685 { "protocol",                    do_protocol, NULL },
1686 { "failback",                    do_failback, NULL },
1687 { "failInfo",                    do_failInfo, NULL },
1688 { "apduInfo",                    do_apduInfo, NULL },
1689 { "logLevel",                    do_logLevel, NULL },
1690
1691 { "eventType",                   do_eventType, NULL },
1692 { "connect",                     do_connect, NULL },
1693 { "protocolVersion",             do_protocolVersion, NULL },
1694 { "preferredMessageSize",        do_preferredMessageSize, NULL },
1695 { "maximumRecordSize",           do_maximumRecordSize, NULL },
1696 { "implementationName",          do_implementationName, NULL },
1697 { "implementationId",            do_implementationId, NULL },
1698 { "implementationVersion",       do_implementationVersion, NULL },
1699 { "targetImplementationName",    do_targetImplementationName, NULL },
1700 { "targetImplementationId",      do_targetImplementationId, NULL },
1701 { "targetImplementationVersion", do_targetImplementationVersion, NULL},
1702 { "userInformationField",        do_userInformationField, NULL},
1703 { "idAuthentication",            do_idAuthentication, NULL},
1704 { "options",                     do_options, NULL},
1705 { "init",                        do_init_request, NULL},
1706 { "initResult",                  do_initResult, NULL},
1707 { "disconnect",                  do_disconnect, NULL},
1708 { "callback",                    do_callback, NULL},
1709 { "initResponse",                do_initResponse, NULL},
1710 { "triggerResourceControl",      do_triggerResourceControl, NULL},
1711 { "initResponse",                do_initResponse, NULL},
1712 { NULL, NULL}
1713 };
1714
1715 static IrTcl_Method ir_set_c_method_tab[] = {
1716 { "databaseNames",               do_databaseNames, NULL},
1717 { "replaceIndicator",            do_replaceIndicator, NULL},
1718 { "queryType",                   do_queryType, NULL},
1719 { "preferredRecordSyntax",       do_preferredRecordSyntax, NULL},
1720 { "smallSetUpperBound",          do_smallSetUpperBound, NULL},
1721 { "largeSetLowerBound",          do_largeSetLowerBound, NULL},
1722 { "mediumSetPresentNumber",      do_mediumSetPresentNumber, NULL},
1723 { "referenceId",                 do_referenceId, NULL},
1724 { "elementSetNames",             do_elementSetNames, NULL},
1725 { "smallSetElementSetNames",     do_smallSetElementSetNames, NULL},
1726 { "mediumSetElementSetNames",    do_mediumSetElementSetNames, NULL},
1727 { NULL, NULL}
1728 };
1729
1730 /*
1731  * ir_obj_method: IR Object methods
1732  */
1733 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
1734                           int argc, char **argv)
1735 {
1736     IrTcl_Methods tab[3];
1737     IrTcl_Obj *p = clientData;
1738     int r;
1739
1740     if (argc < 2)
1741         return TCL_ERROR;
1742
1743     tab[0].tab = ir_method_tab;
1744     tab[0].obj = p;
1745     tab[1].tab = ir_set_c_method_tab;
1746     tab[1].obj = &p->set_inher;
1747     tab[2].tab = NULL;
1748
1749     ir_tcl_method (interp, argc, argv, tab, &r);
1750     return r;
1751 }
1752
1753 /*
1754  * ir_obj_delete: IR Object disposal
1755  */
1756 static void ir_obj_delete (ClientData clientData)
1757 {
1758     IrTcl_Obj *obj = clientData;
1759     IrTcl_Methods tab[3];
1760
1761     --(obj->ref_count);
1762     if (obj->ref_count > 0)
1763         return;
1764     assert (obj->ref_count == 0);
1765
1766     logf (LOG_DEBUG, "ir object delete");
1767     tab[0].tab = ir_method_tab;
1768     tab[0].obj = obj;
1769     tab[1].tab = ir_set_c_method_tab;
1770     tab[1].obj = &obj->set_inher;
1771     tab[2].tab = NULL;
1772
1773     ir_tcl_method (NULL, -1, NULL, tab, NULL);
1774
1775     ir_tcl_del_q (obj);
1776     odr_destroy (obj->odr_in);
1777     odr_destroy (obj->odr_out);
1778     odr_destroy (obj->odr_pr);
1779     free (obj);
1780 }
1781
1782 /*
1783  * ir_obj_init: IR Object initialization
1784  */
1785 int ir_obj_init (ClientData clientData, Tcl_Interp *interp,
1786                  int argc, char **argv, ClientData *subData,
1787                  ClientData parentData)
1788 {
1789     IrTcl_Methods tab[3];
1790     IrTcl_Obj *obj;
1791 #if CCL2RPN
1792     FILE *inf;
1793 #endif
1794
1795     if (argc != 2)
1796     {
1797         interp->result = "wrong # args";
1798         return TCL_ERROR;
1799     }
1800     obj = ir_tcl_malloc (sizeof(*obj));
1801     obj->ref_count = 1;
1802 #if CCL2RPN
1803     obj->bibset = ccl_qual_mk ();
1804     if ((inf = fopen ("default.bib", "r")))
1805     {
1806         ccl_qual_file (obj->bibset, inf);
1807         fclose (inf);
1808     }
1809 #endif
1810
1811     logf (LOG_DEBUG, "ir object create %s", argv[1]);
1812     obj->odr_in = odr_createmem (ODR_DECODE);
1813     obj->odr_out = odr_createmem (ODR_ENCODE);
1814     obj->odr_pr = odr_createmem (ODR_PRINT);
1815     obj->state = IR_TCL_R_Idle;
1816     obj->interp = interp;
1817
1818     obj->len_in = 0;
1819     obj->buf_in = NULL;
1820     obj->request_queue = NULL;
1821
1822     tab[0].tab = ir_method_tab;
1823     tab[0].obj = obj;
1824     tab[1].tab = ir_set_c_method_tab;
1825     tab[1].obj = &obj->set_inher;
1826     tab[2].tab = NULL;
1827
1828     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
1829     {
1830         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
1831         return TCL_ERROR;
1832     }
1833     *subData = obj;
1834     return TCL_OK;
1835 }
1836
1837
1838 /*
1839  * ir_obj_mk: IR Object creation
1840  */
1841 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
1842                       int argc, char **argv)
1843 {
1844     ClientData subData;
1845     int r = ir_obj_init (clientData, interp, argc, argv, &subData, 0);
1846
1847     if (r == TCL_ERROR)
1848         return TCL_ERROR;
1849     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
1850                        subData, ir_obj_delete);
1851     return TCL_OK;
1852 }
1853
1854 IrTcl_Class ir_obj_class = {
1855     "ir",
1856     ir_obj_init,
1857     ir_obj_method,
1858     ir_obj_delete
1859 };
1860
1861
1862 /* ------------------------------------------------------- */
1863 /*
1864  * do_search: Do search request
1865  */
1866 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
1867 {
1868     Z_SearchRequest *req;
1869     Z_Query query;
1870     Z_APDU *apdu;
1871     Odr_oct ccl_query;
1872     IrTcl_SetObj *obj = o;
1873     IrTcl_Obj *p;
1874     int r;
1875
1876     if (argc <= 0)
1877         return TCL_OK;
1878
1879     p = obj->parent;
1880     if (argc != 3)
1881     {
1882         logf (LOG_DEBUG, "search %s", *argv);
1883         interp->result = "wrong # args";
1884         return TCL_ERROR;
1885     }
1886     logf (LOG_DEBUG, "search %s %s", *argv, argv[2]);
1887     if (!obj->set_inher.num_databaseNames)
1888     {
1889         interp->result = "no databaseNames";
1890         return TCL_ERROR;
1891     }
1892     if (!p->cs_link)
1893     {
1894         interp->result = "search: not connected";
1895         return TCL_ERROR;
1896     }
1897     apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest);
1898     req = apdu->u.searchRequest;
1899
1900     obj->start = 1;
1901
1902     set_referenceId (p->odr_out, &req->referenceId,
1903                      obj->set_inher.referenceId);
1904
1905     req->smallSetUpperBound = &obj->set_inher.smallSetUpperBound;
1906     req->largeSetLowerBound = &obj->set_inher.largeSetLowerBound;
1907     req->mediumSetPresentNumber = &obj->set_inher.mediumSetPresentNumber;
1908     req->replaceIndicator = &obj->set_inher.replaceIndicator;
1909     req->resultSetName = obj->setName ? obj->setName : "Default";
1910     logf (LOG_DEBUG, "Search, resultSetName %s", req->resultSetName);
1911     req->num_databaseNames = obj->set_inher.num_databaseNames;
1912     req->databaseNames = obj->set_inher.databaseNames;
1913     for (r=0; r < obj->set_inher.num_databaseNames; r++)
1914         logf (LOG_DEBUG, " Database %s", obj->set_inher.databaseNames[r]);
1915     if (obj->set_inher.preferredRecordSyntax)
1916     {
1917         struct oident ident;
1918
1919         ident.proto = p->protocol_type;
1920         ident.oclass = CLASS_RECSYN;
1921         ident.value = *obj->set_inher.preferredRecordSyntax;
1922         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
1923         req->preferredRecordSyntax = odr_oiddup (p->odr_out,
1924                                                  oid_getoidbyent (&ident));
1925     }
1926     else
1927         req->preferredRecordSyntax = 0;
1928
1929     if (obj->set_inher.smallSetElementSetNames &&
1930         *obj->set_inher.smallSetElementSetNames)
1931     {
1932         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
1933
1934         esn->which = Z_ElementSetNames_generic;
1935         esn->u.generic = obj->set_inher.smallSetElementSetNames;
1936         req->smallSetElementSetNames = esn;
1937     }
1938     else
1939         req->smallSetElementSetNames = NULL;
1940
1941     if (obj->set_inher.mediumSetElementSetNames &&
1942         *obj->set_inher.mediumSetElementSetNames)
1943     {
1944         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
1945
1946         esn->which = Z_ElementSetNames_generic;
1947         esn->u.generic = obj->set_inher.mediumSetElementSetNames;
1948         req->mediumSetElementSetNames = esn;
1949     }
1950     else
1951         req->mediumSetElementSetNames = NULL;
1952
1953     req->query = &query;
1954
1955     logf (LOG_DEBUG, "queryType %s", obj->set_inher.queryType);
1956     if (!strcmp (obj->set_inher.queryType, "rpn"))
1957     {
1958         Z_RPNQuery *RPNquery;
1959
1960         RPNquery = p_query_rpn (p->odr_out, p->protocol_type, argv[2]);
1961         if (!RPNquery)
1962         {
1963             Tcl_AppendResult (interp, "Syntax error in query", NULL);
1964             return TCL_ERROR;
1965         }
1966         query.which = Z_Query_type_1;
1967         query.u.type_1 = RPNquery;
1968     }
1969 #if CCL2RPN
1970     else if (!strcmp (obj->set_inher.queryType, "cclrpn"))
1971     {
1972         int error;
1973         int pos;
1974         struct ccl_rpn_node *rpn;
1975         Z_RPNQuery *RPNquery;
1976         oident bib1;
1977
1978         bib1.proto = p->protocol_type;
1979         bib1.oclass = CLASS_ATTSET;
1980         bib1.value = VAL_BIB1;
1981
1982         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
1983         if (error)
1984         {
1985             Tcl_AppendResult (interp, "CCL error: ",
1986                               ccl_err_msg(error), NULL);
1987             return TCL_ERROR;
1988         }
1989 #if 0
1990         ccl_pr_tree (rpn, stderr);
1991         fprintf (stderr, "\n");
1992 #endif
1993         assert((RPNquery = ccl_rpn_query(rpn)));
1994         RPNquery->attributeSetId = oid_getoidbyent (&bib1);
1995         query.which = Z_Query_type_1;
1996         query.u.type_1 = RPNquery;
1997     }
1998 #endif
1999     else if (!strcmp (obj->set_inher.queryType, "ccl"))
2000     {
2001         query.which = Z_Query_type_2;
2002         query.u.type_2 = &ccl_query;
2003         ccl_query.buf = (unsigned char *) argv[2];
2004         ccl_query.len = strlen (argv[2]);
2005     }
2006     else
2007     {
2008         interp->result = "unknown query method";
2009         return TCL_ERROR;
2010     }
2011     return ir_tcl_send_APDU (interp, p, apdu, "search", *argv);
2012 }
2013
2014 /*
2015  * do_searchResponse: add search response handler
2016  */
2017 static int do_searchResponse (void *o, Tcl_Interp *interp,
2018                               int argc, char **argv)
2019 {
2020     IrTcl_SetObj *obj = o;
2021
2022     if (argc == 0)
2023     {
2024         obj->searchResponse = NULL;
2025         return TCL_OK;
2026     }
2027     else if (argc == -1)
2028         return ir_tcl_strdel (interp, &obj->searchResponse);
2029     if (argc == 3)
2030     {
2031         free (obj->searchResponse);
2032         if (argv[2][0])
2033         {
2034             if (ir_tcl_strdup (interp, &obj->searchResponse, argv[2])
2035                 == TCL_ERROR)
2036                 return TCL_ERROR;
2037         }
2038         else
2039             obj->searchResponse = NULL;
2040     }
2041     return TCL_OK;
2042 }
2043
2044 /*
2045  * do_presentResponse: add present response handler
2046  */
2047 static int do_presentResponse (void *o, Tcl_Interp *interp,
2048                                int argc, char **argv)
2049 {
2050     IrTcl_SetObj *obj = o;
2051
2052     if (argc == 0)
2053     {
2054         obj->presentResponse = NULL;
2055         return TCL_OK;
2056     }
2057     else if (argc == -1)
2058         return ir_tcl_strdel (interp, &obj->presentResponse);
2059     if (argc == 3)
2060     {
2061         free (obj->presentResponse);
2062         if (argv[2][0])
2063         {
2064             if (ir_tcl_strdup (interp, &obj->presentResponse, argv[2])
2065                 == TCL_ERROR)
2066                 return TCL_ERROR;
2067         }
2068         else
2069             obj->presentResponse = NULL;
2070     }
2071     return TCL_OK;
2072 }
2073
2074 /*
2075  * do_resultCount: Get number of hits
2076  */
2077 static int do_resultCount (void *o, Tcl_Interp *interp,
2078                        int argc, char **argv)
2079 {
2080     IrTcl_SetObj *obj = o;
2081
2082     if (argc <= 0)
2083     {
2084         obj->resultCount = 0;
2085         return TCL_OK;
2086     }
2087     return ir_tcl_get_set_int (&obj->resultCount, interp, argc, argv);
2088 }
2089
2090 /*
2091  * do_searchStatus: Get search status (after search response)
2092  */
2093 static int do_searchStatus (void *o, Tcl_Interp *interp,
2094                             int argc, char **argv)
2095 {
2096     IrTcl_SetObj *obj = o;
2097
2098     if (argc <= 0)
2099         return TCL_OK;
2100     return ir_tcl_get_set_int (&obj->searchStatus, interp, argc, argv);
2101 }
2102
2103 /*
2104  * do_presentStatus: Get search status (after search/present response)
2105  */
2106 static int do_presentStatus (void *o, Tcl_Interp *interp,
2107                             int argc, char **argv)
2108 {
2109     IrTcl_SetObj *obj = o;
2110
2111     if (argc <= 0)
2112         return TCL_OK;
2113     return ir_tcl_get_set_int (&obj->presentStatus, interp, argc, argv);
2114 }
2115
2116 /*
2117  * do_nextResultSetPosition: Get next result set position
2118  *       (after search/present response)
2119  */
2120 static int do_nextResultSetPosition (void *o, Tcl_Interp *interp,
2121                                      int argc, char **argv)
2122 {
2123     IrTcl_SetObj *obj = o;
2124
2125     if (argc <= 0)
2126     {
2127         obj->nextResultSetPosition = 0;
2128         return TCL_OK;
2129     }
2130     return ir_tcl_get_set_int (&obj->nextResultSetPosition, interp,
2131                                argc, argv);
2132 }
2133
2134 /*
2135  * do_setName: Set result Set name
2136  */
2137 static int do_setName (void *o, Tcl_Interp *interp,
2138                        int argc, char **argv)
2139 {
2140     IrTcl_SetObj *obj = o;
2141
2142     if (argc == 0)
2143         return ir_tcl_strdup (interp, &obj->setName, "Default");
2144     else if (argc == -1)
2145         return ir_tcl_strdel (interp, &obj->setName);
2146     if (argc == 3)
2147     {
2148         free (obj->setName);
2149         if (ir_tcl_strdup (interp, &obj->setName, argv[2])
2150             == TCL_ERROR)
2151             return TCL_ERROR;
2152     }
2153     Tcl_AppendElement (interp, obj->setName);
2154     return TCL_OK;
2155 }
2156
2157 /*
2158  * do_numberOfRecordsReturned: Get number of records returned
2159  */
2160 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
2161                                        int argc, char **argv)
2162 {
2163     IrTcl_SetObj *obj = o;
2164
2165     if (argc <= 0)
2166     {
2167         obj->numberOfRecordsReturned = 0;
2168         return TCL_OK;
2169     }
2170     return ir_tcl_get_set_int (&obj->numberOfRecordsReturned, interp,
2171                                argc, argv);
2172 }
2173
2174 /*
2175  * do_type: Return type (if any) at position.
2176  */
2177 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)
2178 {
2179     IrTcl_SetObj *obj = o;
2180     int offset;
2181     IrTcl_RecordList *rl;
2182
2183     if (argc == 0)
2184     {
2185         obj->record_list = NULL;
2186         return TCL_OK;
2187     }
2188     else if (argc == -1)
2189     {
2190         delete_IR_records (obj);
2191         return TCL_OK;
2192     }
2193     if (argc != 3)
2194     {
2195         sprintf (interp->result, "wrong # args");
2196         return TCL_ERROR;
2197     }
2198     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2199         return TCL_ERROR;
2200     rl = find_IR_record (obj, offset);
2201     if (!rl)
2202     {
2203         logf (LOG_DEBUG, "No record at position %d", offset);
2204         return TCL_OK;
2205     }
2206     switch (rl->which)
2207     {
2208     case Z_NamePlusRecord_databaseRecord:
2209         interp->result = "DB";
2210         break;
2211     case Z_NamePlusRecord_surrogateDiagnostic:
2212         interp->result = "SD";
2213         break;
2214     }
2215     return TCL_OK;
2216 }
2217
2218
2219 /*
2220  * do_recordType: Return record type (if any) at position.
2221  */
2222 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
2223 {
2224     IrTcl_SetObj *obj = o;
2225     int offset;
2226     IrTcl_RecordList *rl;
2227
2228     if (argc == 0)
2229     {
2230         return TCL_OK;
2231     }
2232     else if (argc == -1)
2233     {
2234         return TCL_OK;
2235     }
2236     if (argc != 3)
2237     {
2238         sprintf (interp->result, "wrong # args");
2239         return TCL_ERROR;
2240     }
2241     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2242         return TCL_ERROR;
2243     rl = find_IR_record (obj, offset);
2244     if (!rl)
2245         return TCL_OK;
2246     if (rl->which != Z_NamePlusRecord_databaseRecord)
2247     {
2248         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2249         return TCL_ERROR;
2250     }
2251     Tcl_AppendElement (interp, (char*)
2252                        IrTcl_getRecordSyntaxStr (rl->u.dbrec.type));
2253     return TCL_OK;
2254 }
2255
2256 /*
2257  * set record elements (for record extraction)
2258  */
2259 static int do_recordElements (void *o, Tcl_Interp *interp,
2260                               int argc, char **argv)
2261 {
2262     IrTcl_SetObj *obj = o;
2263
2264     if (argc == 0)
2265     {
2266         obj->recordElements = NULL;
2267         return TCL_OK;
2268     }
2269     else if (argc == -1)
2270         return ir_tcl_strdel (NULL, &obj->recordElements);
2271     if (argc > 3)
2272     {
2273         sprintf (interp->result, "wrong # args");
2274         return TCL_ERROR;
2275     }
2276     if (argc == 3)
2277     {
2278         free (obj->recordElements);
2279         return ir_tcl_strdup (NULL, &obj->recordElements,
2280                               (*argv[2] ? argv[2] : NULL));
2281     }
2282     Tcl_AppendResult (interp, obj->recordElements, NULL);
2283     return TCL_OK;
2284 }
2285
2286 /*
2287  * ir_diagResult
2288  */
2289 static int ir_diagResult (Tcl_Interp *interp, IrTcl_Diagnostic *list, int num)
2290 {
2291     char buf[20];
2292     int i;
2293     const char *cp;
2294
2295     for (i = 0; i<num; i++)
2296     {
2297         sprintf (buf, "%d", list[i].condition);
2298         Tcl_AppendElement (interp, buf);
2299         cp = diagbib1_str (list[i].condition);
2300         if (cp)
2301             Tcl_AppendElement (interp, (char*) cp);
2302         else
2303             Tcl_AppendElement (interp, "");
2304         if (list[i].addinfo)
2305             Tcl_AppendElement (interp, (char*) list[i].addinfo);
2306         else
2307             Tcl_AppendElement (interp, "");
2308     }
2309     return TCL_OK;
2310 }
2311
2312 /*
2313  * do_diag: Return diagnostic record info
2314  */
2315 static int do_diag (void *o, Tcl_Interp *interp, int argc, char **argv)
2316 {
2317     IrTcl_SetObj *obj = o;
2318     int offset;
2319     IrTcl_RecordList *rl;
2320
2321     if (argc <= 0)
2322         return TCL_OK;
2323     if (argc != 3)
2324     {
2325         sprintf (interp->result, "wrong # args");
2326         return TCL_ERROR;
2327     }
2328     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2329         return TCL_ERROR;
2330     rl = find_IR_record (obj, offset);
2331     if (!rl)
2332     {
2333         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2334         return TCL_ERROR;
2335     }
2336     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
2337     {
2338         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
2339         return TCL_ERROR;
2340     }
2341     return ir_diagResult (interp, rl->u.surrogateDiagnostics.list,
2342                           rl->u.surrogateDiagnostics.num);
2343 }
2344
2345 /*
2346  * do_getMarc: Get ISO2709 Record lines/fields
2347  */
2348 static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
2349 {
2350     IrTcl_SetObj *obj = o;
2351     int offset;
2352     IrTcl_RecordList *rl;
2353
2354     if (argc <= 0)
2355         return TCL_OK;
2356     if (argc < 7)
2357     {
2358         sprintf (interp->result, "wrong # args");
2359         return TCL_ERROR;
2360     }
2361     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2362         return TCL_ERROR;
2363     rl = find_IR_record (obj, offset);
2364     if (!rl)
2365     {
2366         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2367         return TCL_ERROR;
2368     }
2369     if (rl->which != Z_NamePlusRecord_databaseRecord)
2370     {
2371         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2372         return TCL_ERROR;
2373     }
2374     return ir_tcl_get_marc (interp, rl->u.dbrec.buf, argc, argv);
2375 }
2376
2377 /*
2378  * do_getSutrs: Get SUTRS Record
2379  */
2380 static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv)
2381 {
2382     IrTcl_SetObj *obj = o;
2383     int offset;
2384     IrTcl_RecordList *rl;
2385
2386     if (argc <= 0)
2387         return TCL_OK;
2388     if (argc != 3)
2389     {
2390         sprintf (interp->result, "wrong # args");
2391         return TCL_ERROR;
2392     }
2393     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2394         return TCL_ERROR;
2395     rl = find_IR_record (obj, offset);
2396     if (!rl)
2397     {
2398         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2399         return TCL_ERROR;
2400     }
2401     if (rl->which != Z_NamePlusRecord_databaseRecord)
2402     {
2403         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2404         return TCL_ERROR;
2405     }
2406     if (rl->u.dbrec.type != VAL_SUTRS)
2407         return TCL_OK;
2408     Tcl_AppendElement (interp, rl->u.dbrec.buf);
2409     return TCL_OK;
2410 }
2411
2412
2413 /*
2414  * do_getGrs: Get a GRS1 Record
2415  */
2416 static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv)
2417 {
2418     IrTcl_SetObj *obj = o;
2419     int offset;
2420     IrTcl_RecordList *rl;
2421
2422     if (argc <= 0)
2423         return TCL_OK;
2424     if (argc < 3)
2425     {
2426         sprintf (interp->result, "wrong # args");
2427         return TCL_ERROR;
2428     }
2429     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2430         return TCL_ERROR;
2431     rl = find_IR_record (obj, offset);
2432     if (!rl)
2433     {
2434         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2435         return TCL_ERROR;
2436     }
2437     if (rl->which != Z_NamePlusRecord_databaseRecord)
2438     {
2439         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2440         return TCL_ERROR;
2441     }
2442     if (rl->u.dbrec.type != VAL_GRS1)
2443         return TCL_OK;
2444     return ir_tcl_get_grs (interp, rl->u.dbrec.u.grs1, argc, argv);
2445 }
2446
2447
2448 /*
2449  * do_responseStatus: Return response status (present or search)
2450  */
2451 static int do_responseStatus (void *o, Tcl_Interp *interp,
2452                              int argc, char **argv)
2453 {
2454     IrTcl_SetObj *obj = o;
2455
2456     if (argc == 0)
2457     {
2458         obj->recordFlag = 0;
2459         obj->nonSurrogateDiagnosticNum = 0;
2460         obj->nonSurrogateDiagnosticList = NULL;
2461         return TCL_OK;
2462     }
2463     else if (argc == -1)
2464     {
2465         ir_deleteDiags (&obj->nonSurrogateDiagnosticList,
2466                         &obj->nonSurrogateDiagnosticNum);
2467         return TCL_OK;
2468     }
2469     if (!obj->recordFlag)
2470     {
2471         Tcl_AppendElement (interp, "OK");
2472         return TCL_OK;
2473     }
2474     switch (obj->which)
2475     {
2476     case Z_Records_DBOSD:
2477         Tcl_AppendElement (interp, "DBOSD");
2478         break;
2479     case Z_Records_NSD:
2480         Tcl_AppendElement (interp, "NSD");
2481         return ir_diagResult (interp, obj->nonSurrogateDiagnosticList,
2482                               obj->nonSurrogateDiagnosticNum);
2483     }
2484     return TCL_OK;
2485 }
2486
2487 /*
2488  * do_present: Perform Present Request
2489  */
2490
2491 static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv)
2492 {
2493     IrTcl_SetObj *obj = o;
2494     IrTcl_Obj *p;
2495     Z_APDU *apdu;
2496     Z_PresentRequest *req;
2497     int start;
2498     int number;
2499
2500     if (argc <= 0)
2501         return TCL_OK;
2502     if (argc >= 3)
2503     {
2504         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
2505             return TCL_ERROR;
2506     }
2507     else
2508         start = 1;
2509     if (argc >= 4)
2510     {
2511         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
2512             return TCL_ERROR;
2513     }
2514     else
2515         number = 10;
2516     logf (LOG_DEBUG, "present %s %d %d", *argv, start, number);
2517     p = obj->parent;
2518     if (!p->cs_link)
2519     {
2520         interp->result = "present: not connected";
2521         return TCL_ERROR;
2522     }
2523
2524     obj->start = start;
2525     obj->number = number;
2526
2527     apdu = zget_APDU (p->odr_out, Z_APDU_presentRequest);
2528     req = apdu->u.presentRequest;
2529
2530     set_referenceId (p->odr_out, &req->referenceId,
2531                      obj->set_inher.referenceId);
2532
2533     req->resultSetId = obj->setName ? obj->setName : "Default";
2534
2535     req->resultSetStartPoint = &start;
2536     req->numberOfRecordsRequested = &number;
2537     if (obj->set_inher.preferredRecordSyntax)
2538     {
2539         struct oident ident;
2540
2541         ident.proto = p->protocol_type;
2542         ident.oclass = CLASS_RECSYN;
2543         ident.value = *obj->set_inher.preferredRecordSyntax;
2544         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
2545         req->preferredRecordSyntax = odr_oiddup (p->odr_out,
2546                                                  oid_getoidbyent (&ident));
2547     }
2548     else
2549         req->preferredRecordSyntax = 0;
2550
2551     if (obj->set_inher.elementSetNames && *obj->set_inher.elementSetNames)
2552     {
2553         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
2554         Z_RecordComposition *compo = odr_malloc (p->odr_out, sizeof(*compo));
2555
2556         esn->which = Z_ElementSetNames_generic;
2557         esn->u.generic = obj->set_inher.elementSetNames;
2558
2559         req->recordComposition = compo;
2560         compo->which = Z_RecordComp_simple;
2561         compo->u.simple = esn;
2562     }
2563     else
2564         req->recordComposition = NULL;
2565     return ir_tcl_send_APDU (interp, p, apdu, "present", *argv);
2566 }
2567
2568 /*
2569  * do_loadFile: Load result set from file
2570  */
2571
2572 static int do_loadFile (void *o, Tcl_Interp *interp,
2573                         int argc, char **argv)
2574 {
2575     IrTcl_SetObj *setobj = o;
2576     FILE *inf;
2577     size_t size;
2578     int  no = 1;
2579     char *buf;
2580
2581     if (argc <= 0)
2582         return TCL_OK;
2583     if (argc != 3)
2584     {
2585         interp->result = "wrong # args";
2586         return TCL_ERROR;
2587     }
2588     inf = fopen (argv[2], "r");
2589     if (!inf)
2590     {
2591         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
2592         return TCL_ERROR;
2593     }
2594     while ((buf = ir_tcl_fread_marc (inf, &size)))
2595     {
2596         IrTcl_RecordList *rl;
2597
2598         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord, "F");
2599         rl->u.dbrec.type = VAL_USMARC;
2600         rl->u.dbrec.buf = buf;
2601         rl->u.dbrec.size = size;
2602         no++;
2603     }
2604     setobj->numberOfRecordsReturned = no-1;
2605     fclose (inf);
2606     return TCL_OK;
2607 }
2608
2609 static IrTcl_Method ir_set_method_tab[] = {
2610     { "search",                  do_search, NULL},
2611     { "searchResponse",          do_searchResponse, NULL},
2612     { "presentResponse",         do_presentResponse, NULL},
2613     { "searchStatus",            do_searchStatus, NULL},
2614     { "presentStatus",           do_presentStatus, NULL},
2615     { "nextResultSetPosition",   do_nextResultSetPosition, NULL},
2616     { "setName",                 do_setName, NULL},
2617     { "resultCount",             do_resultCount, NULL},
2618     { "numberOfRecordsReturned", do_numberOfRecordsReturned, NULL},
2619     { "present",                 do_present, NULL},
2620     { "type",                    do_type, NULL},
2621     { "getMarc",                 do_getMarc, NULL},
2622     { "getSutrs",                do_getSutrs, NULL},
2623     { "getGrs",                  do_getGrs, NULL},
2624     { "recordType",              do_recordType, NULL},
2625     { "recordElements",          do_recordElements, NULL},
2626     { "diag",                    do_diag, NULL},
2627     { "responseStatus",          do_responseStatus, NULL},
2628     { "loadFile",                do_loadFile, NULL},
2629     { NULL, NULL}
2630 };
2631
2632 /*
2633  * ir_set_obj_method: IR Set Object methods
2634  */
2635 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
2636                           int argc, char **argv)
2637 {
2638     IrTcl_Methods tabs[3];
2639     IrTcl_SetObj *p = clientData;
2640     int r;
2641
2642     if (argc < 2)
2643     {
2644         interp->result = "wrong # args";
2645         return TCL_ERROR;
2646     }
2647     tabs[0].tab = ir_set_method_tab;
2648     tabs[0].obj = p;
2649     tabs[1].tab = ir_set_c_method_tab;
2650     tabs[1].obj = &p->set_inher;
2651     tabs[2].tab = NULL;
2652
2653     ir_tcl_method (interp, argc, argv, tabs, &r);
2654     return r;
2655 }
2656
2657 /*
2658  * ir_set_obj_delete: IR Set Object disposal
2659  */
2660 static void ir_set_obj_delete (ClientData clientData)
2661 {
2662     IrTcl_Methods tabs[3];
2663     IrTcl_SetObj *p = clientData;
2664
2665     logf (LOG_DEBUG, "ir set delete");
2666
2667     tabs[0].tab = ir_set_method_tab;
2668     tabs[0].obj = p;
2669     tabs[1].tab = ir_set_c_method_tab;
2670     tabs[1].obj = &p->set_inher;
2671     tabs[2].tab = NULL;
2672
2673     ir_tcl_method (NULL, -1, NULL, tabs, NULL);
2674
2675     free (p);
2676 }
2677
2678 /*
2679  * ir_set_obj_init: IR Set Object initialization
2680  */
2681 static int ir_set_obj_init (ClientData clientData, Tcl_Interp *interp,
2682                             int argc, char **argv, ClientData *subData,
2683                             ClientData parentData)
2684 {
2685     IrTcl_Methods tabs[3];
2686     IrTcl_SetObj *obj;
2687
2688     if (argc < 2 || argc > 3)
2689     {
2690         interp->result = "wrong # args";
2691         return TCL_ERROR;
2692     }
2693     obj = ir_tcl_malloc (sizeof(*obj));
2694     logf (LOG_DEBUG, "ir set create %s", argv[1]);
2695     if (parentData)
2696     {
2697         int i;
2698         IrTcl_SetCObj *dst;
2699         IrTcl_SetCObj *src;
2700
2701         obj->parent = (IrTcl_Obj *) parentData;
2702
2703         dst = &obj->set_inher;
2704         src = &obj->parent->set_inher;
2705
2706         if ((dst->num_databaseNames = src->num_databaseNames))
2707         {
2708             dst->databaseNames =
2709                 ir_tcl_malloc (sizeof (*dst->databaseNames)
2710                                * (1+dst->num_databaseNames));
2711             for (i = 0; i < dst->num_databaseNames; i++)
2712                 if (ir_tcl_strdup (interp, &dst->databaseNames[i],
2713                                    src->databaseNames[i]) == TCL_ERROR)
2714                     return TCL_ERROR;
2715             dst->databaseNames[i] = NULL;
2716         }
2717         else
2718             dst->databaseNames = NULL;
2719         if (ir_tcl_strdup (interp, &dst->queryType, src->queryType)
2720             == TCL_ERROR)
2721             return TCL_ERROR;
2722
2723         if (ir_tcl_strdup (interp, &dst->referenceId, src->referenceId)
2724             == TCL_ERROR)
2725             return TCL_ERROR;
2726
2727         if (ir_tcl_strdup (interp, &dst->elementSetNames, src->elementSetNames)
2728             == TCL_ERROR)
2729             return TCL_ERROR;
2730
2731         if (ir_tcl_strdup (interp, &dst->smallSetElementSetNames,
2732                            src->smallSetElementSetNames)
2733             == TCL_ERROR)
2734             return TCL_ERROR;
2735
2736         if (ir_tcl_strdup (interp, &dst->mediumSetElementSetNames,
2737                            src->mediumSetElementSetNames)
2738             == TCL_ERROR)
2739             return TCL_ERROR;
2740
2741         if (src->preferredRecordSyntax &&
2742             (dst->preferredRecordSyntax
2743              = ir_tcl_malloc (sizeof(*dst->preferredRecordSyntax))))
2744             *dst->preferredRecordSyntax = *src->preferredRecordSyntax;
2745         else
2746             dst->preferredRecordSyntax = NULL;
2747         dst->replaceIndicator = src->replaceIndicator;
2748         dst->smallSetUpperBound = src->smallSetUpperBound;
2749         dst->largeSetLowerBound = src->largeSetLowerBound;
2750         dst->mediumSetPresentNumber = src->mediumSetPresentNumber;
2751     }
2752     else
2753         obj->parent = NULL;
2754
2755     tabs[0].tab = ir_set_method_tab;
2756     tabs[0].obj = obj;
2757     tabs[1].tab = NULL;
2758
2759     if (ir_tcl_method (interp, 0, NULL, tabs, NULL) == TCL_ERROR)
2760         return TCL_ERROR;
2761
2762     *subData = obj;
2763     return TCL_OK;
2764 }
2765
2766 /*
2767  * ir_set_obj_mk: IR Set Object creation
2768  */
2769 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
2770                           int argc, char **argv)
2771 {
2772     ClientData subData;
2773     ClientData parentData = 0;
2774     int r;
2775
2776     if (argc == 3)
2777     {
2778         Tcl_CmdInfo parent_info;
2779         if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
2780         {
2781             interp->result = "No parent";
2782             return TCL_ERROR;
2783         }
2784         parentData = parent_info.clientData;
2785     }
2786     r = ir_set_obj_init (clientData, interp, argc, argv, &subData, parentData);
2787     if (r == TCL_ERROR)
2788         return TCL_ERROR;
2789     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
2790                        subData, ir_set_obj_delete);
2791     return TCL_OK;
2792 }
2793
2794 IrTcl_Class ir_set_obj_class = {
2795     "ir-set",
2796     ir_set_obj_init,
2797     ir_set_obj_method,
2798     ir_set_obj_delete
2799 };
2800
2801 /* ------------------------------------------------------- */
2802
2803 /*
2804  * do_scan: Perform scan
2805  */
2806 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
2807 {
2808     Z_ScanRequest *req;
2809     Z_APDU *apdu;
2810     IrTcl_ScanObj *obj = o;
2811     IrTcl_Obj *p = obj->parent;
2812 #if CCL2RPN
2813     oident bib1;
2814     struct ccl_rpn_node *rpn;
2815     int pos;
2816 #endif
2817
2818     if (argc <= 0)
2819         return TCL_OK;
2820     if (argc != 3)
2821     {
2822         interp->result = "wrong # args";
2823         return TCL_ERROR;
2824     }
2825     logf (LOG_DEBUG, "scan %s %s", *argv, argv[2]);
2826     if (!p->set_inher.num_databaseNames)
2827     {
2828         interp->result = "no databaseNames";
2829         return TCL_ERROR;
2830     }
2831     if (!p->cs_link)
2832     {
2833         interp->result = "scan: not connected";
2834         return TCL_ERROR;
2835     }
2836
2837     apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest);
2838     req = apdu->u.scanRequest;
2839
2840     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
2841     req->num_databaseNames = p->set_inher.num_databaseNames;
2842     req->databaseNames = p->set_inher.databaseNames;
2843
2844 #if !CCL2RPN
2845     if (!(req->termListAndStartPoint =
2846           p_query_scan (p->odr_out, p->protocol_type,
2847                         &req->attributeSet, argv[2])))
2848     {
2849         Tcl_AppendResult (interp, "Syntax error in query", NULL);
2850         return TCL_ERROR;
2851     }
2852 #else
2853     rpn = ccl_find_str(p->bibset, argv[2], &r, &pos);
2854     if (r)
2855     {
2856         Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL);
2857         return TCL_ERROR;
2858     }
2859     bib1.proto = p->protocol_type;
2860     bib1.oclass = CLASS_ATTSET;
2861     bib1.value = VAL_BIB1;
2862
2863     req->attributeSet = oid_getoidbyent (&bib1);
2864     if (!(req->termListAndStartPoint = ccl_scan_query (rpn)))
2865         return TCL_ERROR;
2866 #endif
2867     req->stepSize = &obj->stepSize;
2868     req->numberOfTermsRequested = &obj->numberOfTermsRequested;
2869     req->preferredPositionInResponse = &obj->preferredPositionInResponse;
2870     logf (LOG_DEBUG, "stepSize=%d", *req->stepSize);
2871     logf (LOG_DEBUG, "numberOfTermsRequested=%d",
2872           *req->numberOfTermsRequested);
2873     logf (LOG_DEBUG, "preferredPositionInResponse=%d",
2874           *req->preferredPositionInResponse);
2875
2876     return ir_tcl_send_APDU (interp, p, apdu, "scan", *argv);
2877 }
2878
2879 /*
2880  * do_scanResponse: add scan response handler
2881  */
2882 static int do_scanResponse (void *o, Tcl_Interp *interp,
2883                             int argc, char **argv)
2884 {
2885     IrTcl_ScanObj *obj = o;
2886
2887     if (argc == 0)
2888     {
2889         obj->scanResponse = NULL;
2890         return TCL_OK;
2891     }
2892     else if (argc == -1)
2893         return ir_tcl_strdel (interp, &obj->scanResponse);
2894     if (argc == 3)
2895     {
2896         free (obj->scanResponse);
2897         if (argv[2][0])
2898         {
2899             if (ir_tcl_strdup (interp, &obj->scanResponse, argv[2])
2900                 == TCL_ERROR)
2901                 return TCL_ERROR;
2902         }
2903         else
2904             obj->scanResponse = NULL;
2905     }
2906     return TCL_OK;
2907 }
2908
2909 /*
2910  * do_stepSize: Set/get replace Step Size
2911  */
2912 static int do_stepSize (void *obj, Tcl_Interp *interp,
2913                         int argc, char **argv)
2914 {
2915     IrTcl_ScanObj *p = obj;
2916     if (argc <= 0)
2917     {
2918         p->stepSize = 0;
2919         return TCL_OK;
2920     }
2921     return ir_tcl_get_set_int (&p->stepSize, interp, argc, argv);
2922 }
2923
2924 /*
2925  * do_numberOfTermsRequested: Set/get Number of Terms requested
2926  */
2927 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,
2928                                       int argc, char **argv)
2929 {
2930     IrTcl_ScanObj *p = obj;
2931
2932     if (argc <= 0)
2933     {
2934         p->numberOfTermsRequested = 20;
2935         return TCL_OK;
2936     }
2937     return ir_tcl_get_set_int (&p->numberOfTermsRequested, interp, argc, argv);
2938 }
2939
2940
2941 /*
2942  * do_preferredPositionInResponse: Set/get preferred Position
2943  */
2944 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,
2945                                            int argc, char **argv)
2946 {
2947     IrTcl_ScanObj *p = obj;
2948
2949     if (argc <= 0)
2950     {
2951         p->preferredPositionInResponse = 1;
2952         return TCL_OK;
2953     }
2954     return ir_tcl_get_set_int (&p->preferredPositionInResponse, interp,
2955                                argc, argv);
2956 }
2957
2958 /*
2959  * do_scanStatus: Get scan status
2960  */
2961 static int do_scanStatus (void *obj, Tcl_Interp *interp,
2962                           int argc, char **argv)
2963 {
2964     IrTcl_ScanObj *p = obj;
2965
2966     if (argc <= 0)
2967         return TCL_OK;
2968     return ir_tcl_get_set_int (&p->scanStatus, interp, argc, argv);
2969 }
2970
2971 /*
2972  * do_numberOfEntriesReturned: Get number of Entries returned
2973  */
2974 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,
2975                                        int argc, char **argv)
2976 {
2977     IrTcl_ScanObj *p = obj;
2978
2979     if (argc <= 0)
2980         return TCL_OK;
2981     return ir_tcl_get_set_int (&p->numberOfEntriesReturned, interp,
2982                                argc, argv);
2983 }
2984
2985 /*
2986  * do_positionOfTerm: Get position of Term
2987  */
2988 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,
2989                               int argc, char **argv)
2990 {
2991     IrTcl_ScanObj *p = obj;
2992
2993     if (argc <= 0)
2994         return TCL_OK;
2995     return ir_tcl_get_set_int (&p->positionOfTerm, interp, argc, argv);
2996 }
2997
2998 /*
2999  * do_scanLine: get Scan Line (surrogate or normal) after response
3000  */
3001 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)
3002 {
3003     IrTcl_ScanObj *p = obj;
3004     int i;
3005     char numstr[20];
3006
3007     if (argc == 0)
3008     {
3009         p->entries_flag = 0;
3010         p->entries = NULL;
3011         p->nonSurrogateDiagnosticNum = 0;
3012         p->nonSurrogateDiagnosticList = 0;
3013         return TCL_OK;
3014     }
3015     else if (argc == -1)
3016     {
3017         p->entries_flag = 0;
3018         /* release entries */
3019         p->entries = NULL;
3020
3021         ir_deleteDiags (&p->nonSurrogateDiagnosticList,
3022                         &p->nonSurrogateDiagnosticNum);
3023         return TCL_OK;
3024     }
3025     if (argc != 3)
3026     {
3027         interp->result = "wrong # args";
3028         return TCL_ERROR;
3029     }
3030     if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)
3031         return TCL_ERROR;
3032     if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries
3033         || i >= p->num_entries || i < 0)
3034         return TCL_OK;
3035     switch (p->entries[i].which)
3036     {
3037     case Z_Entry_termInfo:
3038         Tcl_AppendElement (interp, "T");
3039         if (p->entries[i].u.term.buf)
3040             Tcl_AppendElement (interp, p->entries[i].u.term.buf);
3041         else
3042             Tcl_AppendElement (interp, "");
3043         sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);
3044         Tcl_AppendElement (interp, numstr);
3045         break;
3046     case Z_Entry_surrogateDiagnostic:
3047         Tcl_AppendElement (interp, "SD");
3048         return ir_diagResult (interp, p->entries[i].u.diag.list,
3049                               p->entries[i].u.diag.num);
3050         break;
3051     }
3052     return TCL_OK;
3053 }
3054
3055 static IrTcl_Method ir_scan_method_tab[] = {
3056     { "scan",                    do_scan, NULL},
3057     { "scanResponse",            do_scanResponse, NULL},
3058     { "stepSize",                do_stepSize, NULL},
3059     { "numberOfTermsRequested",  do_numberOfTermsRequested, NULL},
3060     { "preferredPositionInResponse", do_preferredPositionInResponse, NULL},
3061     { "scanStatus",              do_scanStatus, NULL},
3062     { "numberOfEntriesReturned", do_numberOfEntriesReturned, NULL},
3063     { "positionOfTerm",          do_positionOfTerm, NULL},
3064     { "scanLine",                do_scanLine, NULL},
3065     { NULL, NULL}
3066 };
3067
3068 /*
3069  * ir_scan_obj_method: IR Scan Object methods
3070  */
3071 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,
3072                                int argc, char **argv)
3073 {
3074     IrTcl_Methods tabs[2];
3075     int r;
3076
3077     if (argc < 2)
3078     {
3079         interp->result = "wrong # args";
3080         return TCL_ERROR;
3081     }
3082     tabs[0].tab = ir_scan_method_tab;
3083     tabs[0].obj = clientData;
3084     tabs[1].tab = NULL;
3085
3086     ir_tcl_method (interp, argc, argv, tabs, &r);
3087     return r;
3088 }
3089
3090 /*
3091  * ir_scan_obj_delete: IR Scan Object disposal
3092  */
3093 static void ir_scan_obj_delete (ClientData clientData)
3094 {
3095     IrTcl_Methods tabs[2];
3096     IrTcl_ScanObj *obj = clientData;
3097
3098     tabs[0].tab = ir_scan_method_tab;
3099     tabs[0].obj = obj;
3100     tabs[1].tab = NULL;
3101
3102     ir_tcl_method (NULL, -1, NULL, tabs, NULL);
3103     free (obj);
3104 }
3105
3106 /*
3107  * ir_scan_obj_mk: IR Scan Object creation
3108  */
3109 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,
3110                            int argc, char **argv)
3111 {
3112     Tcl_CmdInfo parent_info;
3113     IrTcl_ScanObj *obj;
3114     IrTcl_Methods tabs[2];
3115
3116     if (argc != 3)
3117     {
3118         interp->result = "wrong # args";
3119         return TCL_ERROR;
3120     }
3121     logf (LOG_DEBUG, "ir scan create %s", argv[1]);
3122     if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
3123     {
3124         interp->result = "No parent";
3125         return TCL_ERROR;
3126     }
3127     obj = ir_tcl_malloc (sizeof(*obj));
3128     obj->parent = (IrTcl_Obj *) parent_info.clientData;
3129
3130     tabs[0].tab = ir_scan_method_tab;
3131     tabs[0].obj = obj;
3132     tabs[1].tab = NULL;
3133
3134     if (ir_tcl_method (interp, 0, NULL, tabs, NULL) == TCL_ERROR)
3135         return TCL_ERROR;
3136     Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,
3137                        (ClientData) obj, ir_scan_obj_delete);
3138     return TCL_OK;
3139 }
3140
3141 /* ------------------------------------------------------- */
3142
3143 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
3144 {
3145     IrTcl_Obj *p = obj;
3146
3147     p->initResult = *initrs->result ? 1 : 0;
3148     if (!*initrs->result)
3149         logf (LOG_DEBUG, "Connection rejected by target");
3150     else
3151         logf (LOG_DEBUG, "Connection accepted by target");
3152
3153     get_referenceId (&p->set_inher.referenceId, initrs->referenceId);
3154
3155     free (p->targetImplementationId);
3156     ir_tcl_strdup (p->interp, &p->targetImplementationId,
3157                initrs->implementationId);
3158     free (p->targetImplementationName);
3159     ir_tcl_strdup (p->interp, &p->targetImplementationName,
3160                initrs->implementationName);
3161     free (p->targetImplementationVersion);
3162     ir_tcl_strdup (p->interp, &p->targetImplementationVersion,
3163                initrs->implementationVersion);
3164
3165     p->maximumRecordSize = *initrs->maximumRecordSize;
3166     p->preferredMessageSize = *initrs->preferredMessageSize;
3167
3168     memcpy (&p->options, initrs->options, sizeof(initrs->options));
3169     memcpy (&p->protocolVersion, initrs->protocolVersion,
3170             sizeof(initrs->protocolVersion));
3171     free (p->userInformationField);
3172     p->userInformationField = NULL;
3173     if (initrs->userInformationField)
3174     {
3175         int len;
3176
3177         if (initrs->userInformationField->which == ODR_EXTERNAL_octet &&
3178             (p->userInformationField =
3179              ir_tcl_malloc ((len =
3180                              initrs->userInformationField->
3181                              u.octet_aligned->len) +1)))
3182         {
3183             memcpy (p->userInformationField,
3184                     initrs->userInformationField->u.octet_aligned->buf,
3185                         len);
3186             (p->userInformationField)[len] = '\0';
3187         }
3188     }
3189 }
3190
3191 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num)
3192 {
3193     int i;
3194     for (i = 0; i<*dst_num; i++)
3195         free (dst_list[i]->addinfo);
3196     free (*dst_list);
3197     *dst_list = NULL;
3198     *dst_num = 0;
3199 }
3200
3201 static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num,
3202                     Z_DiagRec **list, int num)
3203 {
3204     int i;
3205     char *addinfo;
3206
3207     *dst_num = num;
3208     *dst_list = ir_tcl_malloc (sizeof(**dst_list) * num);
3209     for (i = 0; i<num; i++)
3210     {
3211         const char *cp;
3212         switch (list[i]->which)
3213         {
3214         case Z_DiagRec_defaultFormat:
3215             (*dst_list)[i].condition = *list[i]->u.defaultFormat->condition;
3216             addinfo = list[i]->u.defaultFormat->addinfo;
3217             if (addinfo &&
3218                 ((*dst_list)[i].addinfo = ir_tcl_malloc (strlen(addinfo)+1)))
3219                 strcpy ((*dst_list)[i].addinfo, addinfo);
3220             cp = diagbib1_str ((*dst_list)[i].condition);
3221             logf (LOG_DEBUG, "Diag %d %s %s", (*dst_list)[i].condition,
3222                   cp ? cp : "", addinfo ? addinfo : "");
3223             break;
3224         default:
3225             (*dst_list)[i].addinfo = NULL;
3226             (*dst_list)[i].condition = 0;
3227         }
3228     }
3229 }
3230
3231 static void ir_handleRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj,
3232                               const char *elements)
3233 {
3234     IrTcl_Obj *p = o;
3235
3236     int offset;
3237     IrTcl_RecordList *rl;
3238
3239     setobj->which = zrs->which;
3240     setobj->recordFlag = 1;
3241
3242     ir_deleteDiags (&setobj->nonSurrogateDiagnosticList,
3243                     &setobj->nonSurrogateDiagnosticNum);
3244     if (zrs->which == Z_Records_DBOSD)
3245     {
3246         setobj->numberOfRecordsReturned =
3247             zrs->u.databaseOrSurDiagnostics->num_records;
3248         logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned);
3249         for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
3250         {
3251             rl = new_IR_record (setobj, setobj->start + offset,
3252                                 zrs->u.databaseOrSurDiagnostics->
3253                                 records[offset]->which,
3254                                 elements);
3255             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
3256             {
3257                 ir_handleDiags (&rl->u.surrogateDiagnostics.list,
3258                                 &rl->u.surrogateDiagnostics.num,
3259                                 &zrs->u.databaseOrSurDiagnostics->
3260                                 records[offset]->u.surrogateDiagnostic,
3261                                 1);
3262             }
3263             else
3264             {
3265                 Z_DatabaseRecord *zr;
3266                 Z_External *oe;
3267                 struct oident *ident;
3268
3269                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
3270                     ->u.databaseRecord;
3271                 oe = (Z_External*) zr;
3272                 rl->u.dbrec.size = zr->u.octet_aligned->len;
3273
3274                 if ((ident = oid_getentbyoid (oe->direct_reference)))
3275                     rl->u.dbrec.type = ident->value;
3276                 else
3277                     rl->u.dbrec.type = VAL_USMARC;
3278
3279                 if (oe->which == ODR_EXTERNAL_octet && rl->u.dbrec.size > 0)
3280                 {
3281                     char *buf = (char*) zr->u.octet_aligned->buf;
3282                     if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size)))
3283                         memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size);
3284                 }
3285                 else if (rl->u.dbrec.type == VAL_SUTRS &&
3286                          oe->which == Z_External_sutrs)
3287                 {
3288                     odr_setbuf (p->odr_in, (char*) oe->u.single_ASN1_type->buf,
3289                                 oe->u.single_ASN1_type->len, 0);
3290                     if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1)))
3291                     {
3292                         memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf,
3293                                 oe->u.sutrs->len);
3294                         rl->u.dbrec.buf[oe->u.sutrs->len] = '\0';
3295                     }
3296                     rl->u.dbrec.size = oe->u.sutrs->len;
3297                 }
3298                 else if (rl->u.dbrec.type == VAL_GRS1 &&
3299                          oe->which == Z_External_grs1)
3300                 {
3301                     ir_tcl_grs_mk (oe->u.grs1, &rl->u.dbrec.u.grs1);
3302                     rl->u.dbrec.buf = NULL;
3303                 }
3304                 else
3305                     rl->u.dbrec.buf = NULL;
3306             }
3307         }
3308     }
3309     else if (zrs->which == Z_Records_multipleNSD)
3310     {
3311         logf (LOG_DEBUG, "multipleNonSurrogateDiagnostic %d",
3312               zrs->u.multipleNonSurDiagnostics->num_diagRecs);
3313         setobj->numberOfRecordsReturned = 0;
3314         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
3315                         &setobj->nonSurrogateDiagnosticNum,
3316                         zrs->u.multipleNonSurDiagnostics->diagRecs,
3317                         zrs->u.multipleNonSurDiagnostics->num_diagRecs);
3318     }
3319     else
3320     {
3321         logf (LOG_DEBUG, "NonSurrogateDiagnostic");
3322         setobj->numberOfRecordsReturned = 0;
3323         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
3324                         &setobj->nonSurrogateDiagnosticNum,
3325                         &zrs->u.nonSurrogateDiagnostic,
3326                         1);
3327     }
3328 }
3329
3330 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs,
3331                                IrTcl_SetObj *setobj)
3332 {
3333     Z_Records *zrs = searchrs->records;
3334
3335     logf (LOG_DEBUG, "Received search response");
3336     if (!setobj)
3337     {
3338         logf (LOG_DEBUG, "Search response, no object!");
3339         return;
3340     }
3341     setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
3342     get_referenceId (&setobj->set_inher.referenceId, searchrs->referenceId);
3343     setobj->resultCount = *searchrs->resultCount;
3344     if (searchrs->presentStatus)
3345         setobj->presentStatus = *searchrs->presentStatus;
3346     if (searchrs->nextResultSetPosition)
3347         setobj->nextResultSetPosition = *searchrs->nextResultSetPosition;
3348
3349     logf (LOG_DEBUG, "status %d hits %d",
3350           setobj->searchStatus, setobj->resultCount);
3351     if (zrs)
3352     {
3353         const char *es;
3354         if (setobj->resultCount <= setobj->set_inher.smallSetUpperBound)
3355             es = setobj->set_inher.smallSetElementSetNames;
3356         else
3357             es = setobj->set_inher.mediumSetElementSetNames;
3358         ir_handleRecords (o, zrs, setobj, es);
3359     }
3360     else
3361         setobj->recordFlag = 0;
3362 }
3363
3364
3365 static void ir_presentResponse (void *o, Z_PresentResponse *presrs,
3366                                 IrTcl_SetObj *setobj)
3367 {
3368     Z_Records *zrs = presrs->records;
3369
3370     logf (LOG_DEBUG, "Received present response");
3371     if (!setobj)
3372     {
3373         logf (LOG_DEBUG, "Present response, no object!");
3374         return;
3375     }
3376     setobj->presentStatus = *presrs->presentStatus;
3377     get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId);
3378     setobj->nextResultSetPosition = *presrs->nextResultSetPosition;
3379     if (zrs)
3380         ir_handleRecords (o, zrs, setobj, setobj->set_inher.elementSetNames);
3381     else
3382     {
3383         setobj->recordFlag = 0;
3384         logf (LOG_DEBUG, "No records!");
3385     }
3386 }
3387
3388 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs,
3389                              IrTcl_ScanObj *scanobj)
3390 {
3391     IrTcl_Obj *p = o;
3392
3393     logf (LOG_DEBUG, "Received scanResponse");
3394
3395     get_referenceId (&p->set_inher.referenceId, scanrs->referenceId);
3396     scanobj->scanStatus = *scanrs->scanStatus;
3397     logf (LOG_DEBUG, "scanStatus=%d", scanobj->scanStatus);
3398
3399     if (scanrs->stepSize)
3400         scanobj->stepSize = *scanrs->stepSize;
3401     logf (LOG_DEBUG, "stepSize=%d", scanobj->stepSize);
3402
3403     scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;
3404     logf (LOG_DEBUG, "numberOfEntriesReturned=%d",
3405           scanobj->numberOfEntriesReturned);
3406
3407     if (scanrs->positionOfTerm)
3408         scanobj->positionOfTerm = *scanrs->positionOfTerm;
3409     else
3410         scanobj->positionOfTerm = -1;
3411     logf (LOG_DEBUG, "positionOfTerm=%d", scanobj->positionOfTerm);
3412
3413     free (scanobj->entries);
3414     scanobj->entries = NULL;
3415
3416     ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList,
3417                     &scanobj->nonSurrogateDiagnosticNum);
3418     if (scanrs->entries)
3419     {
3420         int i;
3421         Z_Entry *ze;
3422
3423         scanobj->entries_flag = 1;
3424         scanobj->which = scanrs->entries->which;
3425         switch (scanobj->which)
3426         {
3427         case Z_ListEntries_entries:
3428             scanobj->num_entries = scanrs->entries->u.entries->num_entries;
3429             scanobj->entries = ir_tcl_malloc (scanobj->num_entries *
3430                                        sizeof(*scanobj->entries));
3431             for (i=0; i<scanobj->num_entries; i++)
3432             {
3433                 ze = scanrs->entries->u.entries->entries[i];
3434                 scanobj->entries[i].which = ze->which;
3435                 switch (ze->which)
3436                 {
3437                 case Z_Entry_termInfo:
3438                     if (ze->u.termInfo->term->which == Z_Term_general)
3439                     {
3440                         int l = ze->u.termInfo->term->u.general->len;
3441                         scanobj->entries[i].u.term.buf = ir_tcl_malloc (1+l);
3442                         memcpy (scanobj->entries[i].u.term.buf,
3443                                 ze->u.termInfo->term->u.general->buf,
3444                                 l);
3445                         scanobj->entries[i].u.term.buf[l] = '\0';
3446                     }
3447                     else
3448                         scanobj->entries[i].u.term.buf = NULL;
3449                     if (ze->u.termInfo->globalOccurrences)
3450                         scanobj->entries[i].u.term.globalOccurrences =
3451                             *ze->u.termInfo->globalOccurrences;
3452                     else
3453                         scanobj->entries[i].u.term.globalOccurrences = 0;
3454                     break;
3455                 case Z_Entry_surrogateDiagnostic:
3456                     ir_handleDiags (&scanobj->entries[i].u.diag.list,
3457                                     &scanobj->entries[i].u.diag.num,
3458                                     &ze->u.surrogateDiagnostic,
3459                                     1);
3460                     break;
3461                 }
3462             }
3463             break;
3464         case Z_ListEntries_nonSurrogateDiagnostics:
3465             ir_handleDiags (&scanobj->nonSurrogateDiagnosticList,
3466                             &scanobj->nonSurrogateDiagnosticNum,
3467                             scanrs->entries->u.nonSurrogateDiagnostics->
3468                             diagRecs,
3469                             scanrs->entries->u.nonSurrogateDiagnostics->
3470                             num_diagRecs);
3471             break;
3472         }
3473     }
3474     else
3475         scanobj->entries_flag = 0;
3476 }
3477
3478 /*
3479  * ir_select_read: handle incoming packages
3480  */
3481 static void ir_select_read (ClientData clientData)
3482 {
3483     IrTcl_Obj *p = clientData;
3484     Z_APDU *apdu;
3485     int r;
3486     IrTcl_Request *rq;
3487     char *object_name;
3488     Tcl_CmdInfo cmd_info;
3489     const char *apdu_call;
3490
3491     logf(LOG_DEBUG, "Read handler fd=%d", cs_fileno(p->cs_link));
3492     if (p->state == IR_TCL_R_Connecting)
3493     {
3494         logf(LOG_DEBUG, "read: connect");
3495         r = cs_rcvconnect (p->cs_link);
3496         if (r == 1)
3497         {
3498             logf (LOG_WARN, "cs_rcvconnect returned 1");
3499             return;
3500         }
3501         p->state = IR_TCL_R_Idle;
3502         p->ref_count = 2;
3503         ir_select_remove_write (cs_fileno (p->cs_link), p);
3504         if (r < 0)
3505         {
3506             logf (LOG_DEBUG, "cs_rcvconnect error");
3507             ir_tcl_disconnect (p);
3508             if (p->failback)
3509             {
3510                 p->failInfo = IR_TCL_FAIL_CONNECT;
3511                 ir_tcl_eval (p->interp, p->failback);
3512             }
3513             ir_obj_delete (p);
3514             return;
3515         }
3516         if (p->callback)
3517             ir_tcl_eval (p->interp, p->callback);
3518         if (p->ref_count == 2 && p->cs_link && p->request_queue
3519             && p->state == IR_TCL_R_Idle)
3520             ir_tcl_send_q (p, p->request_queue, "x");
3521         ir_obj_delete (p);
3522         return;
3523     }
3524     do
3525     {
3526         p->state = IR_TCL_R_Reading;
3527
3528         /* read incoming APDU */
3529         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) == 1)
3530         {
3531             logf(LOG_DEBUG, "PDU Fraction read");
3532             return ;
3533         }
3534         /* signal one more use of ir object - callbacks must not
3535            release the ir memory (p pointer) */
3536         p->ref_count = 2;
3537         if (r <= 0)
3538         {
3539             logf (LOG_DEBUG, "cs_get failed, code %d", r);
3540             ir_select_remove (cs_fileno (p->cs_link), p);
3541             ir_tcl_disconnect (p);
3542             if (p->failback)
3543             {
3544                 p->failInfo = IR_TCL_FAIL_READ;
3545                 ir_tcl_eval (p->interp, p->failback);
3546             }
3547             /* release ir object now if callback deleted it */
3548             ir_obj_delete (p);
3549             return;
3550         }
3551         /* got complete APDU. Now decode */
3552         p->apduLen = r;
3553         p->apduOffset = -1;
3554         odr_setbuf (p->odr_in, p->buf_in, r, 0);
3555         logf (LOG_DEBUG, "cs_get ok, total size %d", r);
3556         if (!z_APDU (p->odr_in, &apdu, 0))
3557         {
3558             logf (LOG_DEBUG, "cs_get failed: %s",
3559                 odr_errmsg (odr_geterror (p->odr_in)));
3560             ir_tcl_disconnect (p);
3561             if (p->failback)
3562             {
3563                 p->failInfo = IR_TCL_FAIL_IN_APDU;
3564                 p->apduOffset = odr_offset (p->odr_in);
3565                 ir_tcl_eval (p->interp, p->failback);
3566             }
3567             /* release ir object now if failback deleted it */
3568             ir_obj_delete (p);
3569             return;
3570         }
3571         /* handle APDU and invoke callback */
3572         rq = p->request_queue;
3573         if (!rq)
3574         {
3575             logf (LOG_FATAL, "Internal error. No queue entry");
3576             exit (1);
3577         }
3578         object_name = rq->object_name;
3579         logf (LOG_DEBUG, "Object %s", object_name);
3580         apdu_call = NULL;
3581         if (Tcl_GetCommandInfo (p->interp, object_name, &cmd_info))
3582         {
3583             switch(apdu->which)
3584             {
3585             case Z_APDU_initResponse:
3586                 p->eventType = "init";
3587                 ir_initResponse (p, apdu->u.initResponse);
3588                 apdu_call = p->initResponse;
3589                 break;
3590             case Z_APDU_searchResponse:
3591                 p->eventType = "search";
3592                 ir_searchResponse (p, apdu->u.searchResponse,
3593                                    (IrTcl_SetObj *) cmd_info.clientData);
3594                 apdu_call = ((IrTcl_SetObj *)
3595                              cmd_info.clientData)->searchResponse;
3596                 break;
3597             case Z_APDU_presentResponse:
3598                 p->eventType = "present";
3599                 ir_presentResponse (p, apdu->u.presentResponse,
3600                                     (IrTcl_SetObj *) cmd_info.clientData);
3601                 apdu_call = ((IrTcl_SetObj *)
3602                              cmd_info.clientData)->presentResponse;
3603                 break;
3604             case Z_APDU_scanResponse:
3605                 p->eventType = "scan";
3606                 ir_scanResponse (p, apdu->u.scanResponse,
3607                                  (IrTcl_ScanObj *) cmd_info.clientData);
3608                 apdu_call = ((IrTcl_ScanObj *)
3609                              cmd_info.clientData)->scanResponse;
3610                 break;
3611             default:
3612                 logf (LOG_WARN, "Received unknown APDU type (%d)",
3613                       apdu->which);
3614                 ir_tcl_disconnect (p);
3615                 if (p->failback)
3616                 {
3617                     p->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;
3618                     ir_tcl_eval (p->interp, p->failback);
3619                 }
3620                 return;
3621             }
3622         }
3623         p->request_queue = rq->next;
3624         p->state = IR_TCL_R_Idle;
3625
3626         if (apdu_call)
3627             ir_tcl_eval (p->interp, apdu_call);
3628         else if (rq->callback)
3629             ir_tcl_eval (p->interp, rq->callback);
3630         free (rq->buf_out);
3631         free (rq->callback);
3632         free (rq->object_name);
3633         free (rq);
3634         odr_reset (p->odr_in);
3635         if (p->ref_count == 1)
3636         {
3637             ir_obj_delete (p);
3638             return;
3639         }
3640         ir_obj_delete (p);
3641     } while (p->cs_link && cs_more (p->cs_link));
3642     if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle)
3643         ir_tcl_send_q (p, p->request_queue, "x");
3644 }
3645
3646 /*
3647  * ir_select_write: handle outgoing packages - not yet written.
3648  */
3649 static int ir_select_write (ClientData clientData)
3650 {
3651     IrTcl_Obj *p = clientData;
3652     int r;
3653     IrTcl_Request *rq;
3654
3655     logf (LOG_DEBUG, "Write handler fd=%d", cs_fileno(p->cs_link));
3656     if (p->state == IR_TCL_R_Connecting)
3657     {
3658         logf(LOG_DEBUG, "write: connect");
3659         r = cs_rcvconnect (p->cs_link);
3660         if (r == 1)
3661         {
3662             logf (LOG_DEBUG, "cs_rcvconnect returned 1");
3663             return 2;
3664         }
3665         p->state = IR_TCL_R_Idle;
3666         p->ref_count = 2;
3667         ir_select_remove_write (cs_fileno (p->cs_link), p);
3668         if (r < 0)
3669         {
3670             logf (LOG_DEBUG, "cs_rcvconnect error");
3671             ir_tcl_disconnect (p);
3672             if (p->failback)
3673             {
3674                 p->failInfo = IR_TCL_FAIL_CONNECT;
3675                 ir_tcl_eval (p->interp, p->failback);
3676             }
3677             ir_obj_delete (p);
3678             return 2;
3679         }
3680         if (p->callback)
3681             ir_tcl_eval (p->interp, p->callback);
3682         ir_obj_delete (p);
3683         return 2;
3684     }
3685     rq = p->request_queue;
3686     if (!rq || !rq->buf_out)
3687         return 0;
3688     assert (rq);
3689     if ((r=cs_put (p->cs_link, rq->buf_out, rq->len_out)) < 0)
3690     {
3691         logf (LOG_DEBUG, "cs_put write fail");
3692         p->ref_count = 2;
3693         free (rq->buf_out);
3694         rq->buf_out = NULL;
3695         ir_tcl_disconnect (p);
3696         if (p->failback)
3697         {
3698             p->failInfo = IR_TCL_FAIL_WRITE;
3699             ir_tcl_eval (p->interp, p->failback);
3700         }
3701         ir_obj_delete (p);
3702     }
3703     else if (r == 0)            /* remove select bit */
3704     {
3705         logf (LOG_DEBUG, "Write completed");
3706         p->state = IR_TCL_R_Waiting;
3707         ir_select_remove_write (cs_fileno (p->cs_link), p);
3708         free (rq->buf_out);
3709         rq->buf_out = NULL;
3710     }
3711     return 1;
3712 }
3713
3714 static void ir_select_notify (ClientData clientData, int r, int w, int e)
3715 {
3716     if (w)
3717     {
3718         if (!ir_select_write (clientData) && r)
3719             ir_select_read (clientData);
3720     }
3721     else if (r)
3722     {
3723         ir_select_read (clientData);
3724     }
3725 }
3726
3727 /* ------------------------------------------------------- */
3728
3729 /*
3730  * Irtcl_init: Registration of TCL commands.
3731  */
3732 int Irtcl_Init (Tcl_Interp *interp)
3733 {
3734     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
3735                        (Tcl_CmdDeleteProc *) NULL);
3736     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
3737                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
3738     Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,
3739                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
3740     return TCL_OK;
3741 }
3742