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