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