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