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