ir-tcl.c

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