ir-tcl.c

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