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