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