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