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