ir-tcl.c

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