ir-tcl.c

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