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