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