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