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