ir-tcl.c

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