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