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