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