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