ir-tcl.c

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