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