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