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