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