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