ir-tcl.c

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