ir-tcl.c

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