ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  * Sebastian Hammer, Adam Dickmeiss
   5  *
   6  * $Log: ir-tcl.c,v $
   7  * Revision 1.28  1995-05-23 15:34:48  adam
   8  * Many new settings, userInformationField, smallSetUpperBound, etc.
   9  * A number of settings are inherited when ir-set is executed.
  10  * This version is incompatible with the graphical test client (client.tcl).
  11  *
  12  * Revision 1.27  1995/05/11  15:34:47  adam
  13  * Scan request changed a bit. This version works with RLG.
  14  *
  15  * Revision 1.26  1995/04/18  16:11:51  adam
  16  * First version of graphical Scan. Some work on query-by-form.
  17  *
  18  * Revision 1.25  1995/04/17  09:37:17  adam
  19  * Further development of scan.
  20  *
  21  * Revision 1.24  1995/04/11  14:16:42  adam
  22  * Further work on scan. Response works. Entries aren't saved yet.
  23  *
  24  * Revision 1.23  1995/04/10  10:50:27  adam
  25  * Result-set name defaults to suffix of ir-set name.
  26  * Started working on scan. Not finished at this point.
  27  *
  28  * Revision 1.22  1995/03/31  10:43:03  adam
  29  * More robust when getting bad MARC records.
  30  *
  31  * Revision 1.21  1995/03/31  08:56:37  adam
  32  * New button "Search".
  33  *
  34  * Revision 1.20  1995/03/29  16:07:09  adam
  35  * Bug fix: Didn't use setName in present request.
  36  *
  37  * Revision 1.19  1995/03/28  12:45:23  adam
  38  * New ir method failback: called on disconnect/protocol error.
  39  * New ir set/get method: protocol: SR / Z3950.
  40  * Simple popup and disconnect when failback is invoked.
  41  *
  42  * Revision 1.18  1995/03/21  15:50:12  adam
  43  * Minor changes.
  44  *
  45  * Revision 1.17  1995/03/21  13:41:03  adam
  46  * Comstack cs_create not used too often. Non-blocking connect.
  47  *
  48  * Revision 1.16  1995/03/21  08:26:06  adam
  49  * New method, setName, to specify the result set name (other than Default).
  50  * New method, responseStatus, which returns diagnostic info, if any, after
  51  * present response / search response.
  52  *
  53  * Revision 1.15  1995/03/20  15:24:07  adam
  54  * Diagnostic records saved on searchResponse.
  55  *
  56  * Revision 1.14  1995/03/20  08:53:22  adam
  57  * Event loop in tclmain.c rewritten. New method searchStatus.
  58  *
  59  * Revision 1.13  1995/03/17  18:26:17  adam
  60  * Non-blocking i/o used now. Database names popup as cascade items.
  61  *
  62  * Revision 1.12  1995/03/17  15:45:00  adam
  63  * Improved target/database setup.
  64  *
  65  * Revision 1.11  1995/03/16  17:54:03  adam
  66  * Minor changes really.
  67  *
  68  * Revision 1.10  1995/03/15  16:14:50  adam
  69  * Blocking arg in cs_create changed.
  70  *
  71  * Revision 1.9  1995/03/15  13:59:24  adam
  72  * Minor changes.
  73  *
  74  * Revision 1.8  1995/03/15  08:25:16  adam
  75  * New method presentStatus to check for error on present. Misc. cleanup
  76  * of IRRecordList manipulations. Full MARC record presentation in
  77  * search.tcl.
  78  *
  79  * Revision 1.7  1995/03/14  17:32:29  adam
  80  * Presentation of full Marc record in popup window.
  81  *
  82  * Revision 1.6  1995/03/12  19:31:55  adam
  83  * Pattern matching implemented when retrieving MARC records. More
  84  * diagnostic functions.
  85  *
  86  * Revision 1.5  1995/03/10  18:00:15  adam
  87  * Actual presentation in line-by-line format. RPN query support.
  88  *
  89  * Revision 1.4  1995/03/09  16:15:08  adam
  90  * First presentRequest attempts. Hot-target list.
  91  *
  92  */
  93
  94 #include <stdlib.h>
  95 #include <stdio.h>
  96 #include <sys/time.h>
  97 #include <assert.h>
  98
  99 #define CS_BLOCK 0
 100
 101 #include "ir-tclp.h"
 102
 103 typedef struct {
 104     int type;
 105     char *name;
 106     int (*method) (void *obj, Tcl_Interp *interp, int argc, char **argv);
 107 } IRMethod;
 108
 109
 110 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
 111
 112 static IRRecordList *new_IR_record (IRSetObj *setobj, int no, int which)
 113 {
 114     IRRecordList *rl;
 115
 116     for (rl = setobj->record_list; rl; rl = rl->next)
 117     {
 118         if (no == rl->no)
 119         {
 120             switch (rl->which)
 121             {
 122             case Z_NamePlusRecord_databaseRecord:
 123                 iso2709_rm (rl->u.marc.rec);
 124                 break;
 125             case Z_NamePlusRecord_surrogateDiagnostic:
 126                 free (rl->u.diag.addinfo);
 127                 rl->u.diag.addinfo = NULL;
 128                 break;
 129             }
 130             break;
 131         }
 132     }
 133     if (!rl)
 134     {
 135         rl = malloc (sizeof(*rl));
 136         assert (rl);
 137         rl->next = setobj->record_list;
 138         rl->no = no;
 139         setobj->record_list = rl;
 140     }
 141     rl->which = which;
 142     return rl;
 143 }
 144
 145 static IRRecordList *find_IR_record (IRSetObj *setobj, int no)
 146 {
 147     IRRecordList *rl;
 148
 149     for (rl = setobj->record_list; rl; rl = rl->next)
 150         if (no == rl->no)
 151             return rl;
 152     return NULL;
 153 }
 154
 155 /*
 156  * getsetint: Set/get integer value
 157  */
 158 static int get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)
 159 {
 160     char buf[20];
 161
 162     if (argc == 3)
 163     {
 164         if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)
 165             return TCL_ERROR;
 166     }
 167     sprintf (buf, "%d", *val);
 168     Tcl_AppendResult (interp, buf, NULL);
 169     return TCL_OK;
 170 }
 171
 172 /*
 173  * mk_nonSurrogateDiagnostics: Make Tcl result with diagnostic info
 174  */
 175 static int mk_nonSurrogateDiagnostics (Tcl_Interp *interp,
 176                                        int condition,
 177                                        const char *addinfo)
 178 {
 179     char buf[20];
 180     const char *cp;
 181
 182     Tcl_AppendElement (interp, "NSD");
 183     sprintf (buf, "%d", condition);
 184     Tcl_AppendElement (interp, buf);
 185     cp = diagbib1_str (condition);
 186     if (cp)
 187         Tcl_AppendElement (interp, (char*) cp);
 188     else
 189         Tcl_AppendElement (interp, "");
 190     if (addinfo)
 191         Tcl_AppendElement (interp, (char*) addinfo);
 192     else
 193         Tcl_AppendElement (interp, "");
 194     return TCL_OK;
 195 }
 196
 197 /*
 198  * get_parent_info: Returns information about parent object.
 199  */
 200 static int get_parent_info (Tcl_Interp *interp, const char *name,
 201                             Tcl_CmdInfo *parent_info,
 202                             const char **suffix)
 203 {
 204     char parent_name[128];
 205     const char *csep = strrchr (name, '.');
 206     int pos;
 207
 208     if (!csep)
 209     {
 210         interp->result = "missing .";
 211         return TCL_ERROR;
 212     }
 213     if (suffix)
 214         *suffix = csep+1;
 215     pos = csep-name;
 216     if (pos > 127)
 217         pos = 127;
 218     memcpy (parent_name, name, pos);
 219     parent_name[pos] = '\0';
 220     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
 221     {
 222         interp->result = "No parent";
 223         return TCL_ERROR;
 224     }
 225     return TCL_OK;
 226 }
 227
 228 /*
 229  * ir_method: Search for method in table and invoke method handler
 230  */
 231 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 232                IRMethod *tab, int sigerr)
 233 {
 234     IRMethod *t;
 235     for (t = tab; t->name; t++)
 236         if (!strcmp (t->name, argv[1]))
 237             return (*t->method)(obj, interp, argc, argv);
 238     if (sigerr)
 239         return TCL_ERROR;
 240     Tcl_AppendResult (interp, "Bad method. Possible values:", NULL);
 241     for (t = tab; t->name; t++)
 242         Tcl_AppendResult (interp, " ", t->name, NULL);
 243     return TCL_ERROR;
 244 }
 245
 246 /*
 247  * ir_method_r: Get status for all readable elements
 248  */
 249 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,
 250                  IRMethod *tab)
 251 {
 252     char *argv_n[3];
 253     int argc_n;
 254
 255     argv_n[0] = argv[0];
 256     argc_n = 2;
 257     for (; tab->name; tab++)
 258         if (tab->type)
 259         {
 260             argv_n[1] = tab->name;
 261             Tcl_AppendResult (interp, "{", NULL);
 262             (*tab->method)(obj, interp, argc_n, argv_n);
 263             Tcl_AppendResult (interp, "} ", NULL);
 264         }
 265     return TCL_OK;
 266 }
 267
 268 /*
 269  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 270  */
 271 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 272 {
 273     const char *cp = asc + strlen(asc);
 274     int bitno = 0;
 275
 276     ODR_MASK_ZERO (ob);
 277     do
 278     {
 279         if (*--cp == '1')
 280             ODR_MASK_SET (ob, bitno);
 281         bitno++;
 282     } while (cp != asc);
 283     return bitno;
 284 }
 285
 286 /*
 287  * ir_strdup: Duplicate string
 288  */
 289 int ir_strdup (Tcl_Interp *interp, char** p, const char *s)
 290 {
 291     *p = malloc (strlen(s)+1);
 292     if (!*p)
 293     {
 294         interp->result = "strdup fail";
 295         return TCL_ERROR;
 296     }
 297     strcpy (*p, s);
 298     return TCL_OK;
 299 }
 300
 301 /*
 302  * ir_malloc: Malloc function
 303  */
 304 void *ir_malloc (Tcl_Interp *interp, size_t size)
 305 {
 306     static char buf[128];
 307     void *p = malloc (size);
 308
 309     if (!p)
 310     {
 311         sprintf (buf, "Malloc fail. %ld bytes requested", (long) size);
 312         interp->result = buf;
 313         return NULL;
 314     }
 315     return p;
 316 }
 317
 318 /* ------------------------------------------------------- */
 319
 320 /*
 321  * do_init_request: init method on IR object
 322  */
 323 static int do_init_request (void *obj, Tcl_Interp *interp,
 324                        int argc, char **argv)
 325 {
 326     Z_APDU apdu, *apdup = &apdu;
 327     IRObj *p = obj;
 328     Z_InitRequest req;
 329     int r;
 330
 331     if (!p->cs_link)
 332     {
 333         interp->result = "not connected";
 334         return TCL_ERROR;
 335     }
 336     req.referenceId = 0;
 337     req.options = &p->options;
 338     req.protocolVersion = &p->protocolVersion;
 339     req.preferredMessageSize = &p->preferredMessageSize;
 340     req.maximumRecordSize = &p->maximumRecordSize;
 341
 342     req.idAuthentication = p->idAuthentication;
 343     req.implementationId = p->implementationId;
 344     req.implementationName = p->implementationName;
 345     req.implementationVersion = "0.1";
 346     req.userInformationField = 0;
 347
 348     apdu.u.initRequest = &req;
 349     apdu.which = Z_APDU_initRequest;
 350
 351     if (!z_APDU (p->odr_out, &apdup, 0))
 352     {
 353         Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
 354                           NULL);
 355         odr_reset (p->odr_out);
 356         return TCL_ERROR;
 357     }
 358     p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
 359     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 360     {
 361         interp->result = "cs_put failed in init";
 362         do_disconnect (p, NULL, 0, NULL);
 363         return TCL_ERROR;
 364     }
 365     else if (r == 1)
 366     {
 367         ir_select_add_write (cs_fileno(p->cs_link), p);
 368         printf("Sent part of initializeRequest (%d bytes).\n", p->slen);
 369     }
 370     else
 371         printf("Sent whole initializeRequest (%d bytes).\n", p->slen);
 372     return TCL_OK;
 373 }
 374
 375 /*
 376  * do_protocolVersion: Set protocol Version
 377  */
 378 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 379                                int argc, char **argv)
 380 {
 381     if (argc == 3)
 382         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 383     return TCL_OK;
 384 }
 385
 386 /*
 387  * do_options: Set options
 388  */
 389 static int do_options (void *obj, Tcl_Interp *interp,
 390                        int argc, char **argv)
 391 {
 392     if (argc == 3)
 393         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 394     return TCL_OK;
 395 }
 396
 397 /*
 398  * do_preferredMessageSize: Set/get preferred message size
 399  */
 400 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 401                                     int argc, char **argv)
 402 {
 403     IRObj *p = obj;
 404     return get_set_int (&p->preferredMessageSize, interp, argc, argv);
 405 }
 406
 407 /*
 408  * do_maximumRecordSize: Set/get maximum record size
 409  */
 410 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 411                                     int argc, char **argv)
 412 {
 413     IRObj *p = obj;
 414     return get_set_int (&p->maximumRecordSize, interp, argc, argv);
 415 }
 416
 417 /*
 418  * do_initResult: Get init result
 419  */
 420 static int do_initResult (void *o, Tcl_Interp *interp,
 421                           int argc, char **argv)
 422 {
 423     IRObj *obj = o;
 424
 425     return get_set_int (&obj->initResult, interp, argc, argv);
 426 }
 427
 428
 429 /*
 430  * do_implementationName: Set/get Implementation Name.
 431  */
 432 static int do_implementationName (void *obj, Tcl_Interp *interp,
 433                                     int argc, char **argv)
 434 {
 435     IRObj *p = obj;
 436
 437     if (argc == 3)
 438     {
 439         free (((IRObj*)obj)->implementationName);
 440         if (ir_strdup (interp, &p->implementationName, argv[2])
 441             == TCL_ERROR)
 442             return TCL_ERROR;
 443     }
 444     Tcl_AppendResult (interp, p->implementationName,
 445                       (char*) NULL);
 446     return TCL_OK;
 447 }
 448
 449 /*
 450  * do_implementationId: Set/get Implementation Id.
 451  */
 452 static int do_implementationId (void *obj, Tcl_Interp *interp,
 453                                 int argc, char **argv)
 454 {
 455     if (argc == 3)
 456     {
 457         free (((IRObj*)obj)->implementationId);
 458         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 459             == TCL_ERROR)
 460             return TCL_ERROR;
 461     }
 462     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 463                       (char*) NULL);
 464     return TCL_OK;
 465 }
 466
 467 /*
 468  * do_targetImplementationName: Get Implementation Name of target.
 469  */
 470 static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
 471                                     int argc, char **argv)
 472 {
 473     IRObj *p = obj;
 474
 475     Tcl_AppendResult (interp, p->targetImplementationName,
 476                       (char*) NULL);
 477     return TCL_OK;
 478 }
 479
 480 /*
 481  * do_targetImplementationId: Get Implementation Id of target
 482  */
 483 static int do_targetImplementationId (void *obj, Tcl_Interp *interp,
 484                                       int argc, char **argv)
 485 {
 486     Tcl_AppendResult (interp, ((IRObj*)obj)->targetImplementationId,
 487                       (char*) NULL);
 488     return TCL_OK;
 489 }
 490
 491 /*
 492  * do_targetImplementationVersion: Get Implementation Version of target
 493  */
 494 static int do_targetImplementationVersion (void *obj, Tcl_Interp *interp,
 495                                            int argc, char **argv)
 496 {
 497     Tcl_AppendResult (interp, ((IRObj*)obj)->targetImplementationVersion,
 498                       (char*) NULL);
 499     return TCL_OK;
 500 }
 501
 502 /*
 503  * do_idAuthentication: Set/get id Authentication
 504  */
 505 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 506                                 int argc, char **argv)
 507 {
 508     if (argc == 3)
 509     {
 510         free (((IRObj*)obj)->idAuthentication);
 511         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 512             == TCL_ERROR)
 513             return TCL_ERROR;
 514     }
 515     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 516                       (char*) NULL);
 517     return TCL_OK;
 518 }
 519
 520 /*
 521  * do_connect: connect method on IR object
 522  */
 523 static int do_connect (void *obj, Tcl_Interp *interp,
 524                        int argc, char **argv)
 525 {
 526     void *addr;
 527     IRObj *p = obj;
 528     int r;
 529     int protocol_type = CS_Z3950;
 530
 531     if (argc == 3)
 532     {
 533         if (p->hostname)
 534         {
 535             interp->result = "already connected";
 536             return TCL_ERROR;
 537         }
 538         if (!strcmp (p->protocol_type, "Z3950"))
 539             protocol_type = CS_Z3950;
 540         else if (!strcmp (p->protocol_type, "SR"))
 541             protocol_type = CS_SR;
 542         else
 543         {
 544             interp->result = "bad protocol type";
 545             return TCL_ERROR;
 546         }
 547         if (!strcmp (p->cs_type, "tcpip"))
 548         {
 549             p->cs_link = cs_create (tcpip_type, CS_BLOCK, protocol_type);
 550             addr = tcpip_strtoaddr (argv[2]);
 551             if (!addr)
 552             {
 553                 interp->result = "tcpip_strtoaddr fail";
 554                 return TCL_ERROR;
 555             }
 556             printf ("tcp/ip connect %s\n", argv[2]);
 557         }
 558 #if MOSI
 559         else if (!strcmp (p->cs_type, "mosi"))
 560         {
 561             p->cs_link = cs_create (mosi_type, CS_BLOCK, protocol_type);
 562             addr = mosi_strtoaddr (argv[2]);
 563             if (!addr)
 564             {
 565                 interp->result = "mosi_strtoaddr fail";
 566                 return TCL_ERROR;
 567             }
 568             printf ("mosi connect %s\n", argv[2]);
 569         }
 570 #endif
 571         else
 572         {
 573             interp->result = "unknown comstack type";
 574             return TCL_ERROR;
 575         }
 576         if (ir_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 577             return TCL_ERROR;
 578         if ((r=cs_connect (p->cs_link, addr)) < 0)
 579         {
 580             interp->result = "cs_connect fail";
 581             do_disconnect (p, NULL, 0, NULL);
 582             return TCL_ERROR;
 583         }
 584         ir_select_add (cs_fileno (p->cs_link), p);
 585         if (r == 1)
 586         {
 587             ir_select_add_write (cs_fileno (p->cs_link), p);
 588             p->connectFlag = 1;
 589         }
 590         else
 591         {
 592             p->connectFlag = 0;
 593             if (p->callback)
 594                 Tcl_Eval (p->interp, p->callback);
 595         }
 596     }
 597     if (p->hostname)
 598         Tcl_AppendElement (interp, p->hostname);
 599     return TCL_OK;
 600 }
 601
 602 /*
 603  * do_disconnect: disconnect method on IR object
 604  */
 605 static int do_disconnect (void *obj, Tcl_Interp *interp,
 606                           int argc, char **argv)
 607 {
 608     IRObj *p = obj;
 609
 610     if (p->hostname)
 611     {
 612         free (p->hostname);
 613         p->hostname = NULL;
 614         ir_select_remove_write (cs_fileno (p->cs_link), p);
 615         ir_select_remove (cs_fileno (p->cs_link), p);
 616
 617         assert (p->cs_link);
 618         cs_close (p->cs_link);
 619         p->cs_link = NULL;
 620     }
 621     assert (!p->cs_link);
 622     return TCL_OK;
 623 }
 624
 625 /*
 626  * do_comstack: Set/get comstack method on IR object
 627  */
 628 static int do_comstack (void *o, Tcl_Interp *interp,
 629                         int argc, char **argv)
 630 {
 631     IRObj *obj = o;
 632
 633     if (argc == 3)
 634     {
 635         free (obj->cs_type);
 636         if (ir_strdup (interp, &obj->cs_type, argv[2]) == TCL_ERROR)
 637             return TCL_ERROR;
 638     }
 639     Tcl_AppendElement (interp, obj->cs_type);
 640     return TCL_OK;
 641 }
 642
 643 /*
 644  * do_protocol: Set/get protocol method on IR object
 645  */
 646 static int do_protocol (void *o, Tcl_Interp *interp,
 647                         int argc, char **argv)
 648 {
 649     IRObj *obj = o;
 650
 651     if (argc == 3)
 652     {
 653         free (obj->protocol_type);
 654         if (ir_strdup (interp, &obj->protocol_type, argv[2]) == TCL_ERROR)
 655             return TCL_ERROR;
 656     }
 657     Tcl_AppendElement (interp, obj->protocol_type);
 658     return TCL_OK;
 659 }
 660
 661 /*
 662  * do_callback: add callback
 663  */
 664 static int do_callback (void *obj, Tcl_Interp *interp,
 665                           int argc, char **argv)
 666 {
 667     IRObj *p = obj;
 668
 669     if (argc == 3)
 670     {
 671         free (p->callback);
 672         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 673             return TCL_ERROR;
 674         p->interp = interp;
 675     }
 676     return TCL_OK;
 677 }
 678
 679 /*
 680  * do_failback: add error handle callback
 681  */
 682 static int do_failback (void *obj, Tcl_Interp *interp,
 683                           int argc, char **argv)
 684 {
 685     IRObj *p = obj;
 686
 687     if (argc == 3)
 688     {
 689         free (p->failback);
 690         if (ir_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
 691             return TCL_ERROR;
 692         p->interp = interp;
 693     }
 694     return TCL_OK;
 695 }
 696
 697 /*
 698  * do_databaseNames: specify database names
 699  */
 700 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 701                           int argc, char **argv)
 702 {
 703     int i;
 704     IRSetCObj *p = obj;
 705
 706     if (argc < 3)
 707     {
 708         for (i=0; i<p->num_databaseNames; i++)
 709             Tcl_AppendElement (interp, p->databaseNames[i]);
 710         return TCL_OK;
 711     }
 712     if (p->databaseNames)
 713     {
 714         for (i=0; i<p->num_databaseNames; i++)
 715             free (p->databaseNames[i]);
 716         free (p->databaseNames);
 717     }
 718     p->num_databaseNames = argc - 2;
 719     if (!(p->databaseNames = ir_malloc (interp,
 720           sizeof(*p->databaseNames) * p->num_databaseNames)))
 721         return TCL_ERROR;
 722     for (i=0; i<p->num_databaseNames; i++)
 723     {
 724         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 725             == TCL_ERROR)
 726             return TCL_ERROR;
 727     }
 728     return TCL_OK;
 729 }
 730
 731 /*
 732  * do_replaceIndicator: Set/get replace Set indicator
 733  */
 734 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
 735                                 int argc, char **argv)
 736 {
 737     IRSetCObj *p = obj;
 738
 739     return get_set_int (&p->replaceIndicator, interp, argc, argv);
 740 }
 741
 742 /*
 743  * do_queryType: Set/Get query method
 744  */
 745 static int do_queryType (void *obj, Tcl_Interp *interp,
 746                        int argc, char **argv)
 747 {
 748     IRSetCObj *p = obj;
 749
 750     if (argc == 3)
 751     {
 752         free (p->queryType);
 753         if (ir_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR)
 754             return TCL_ERROR;
 755     }
 756     Tcl_AppendResult (interp, p->queryType, NULL);
 757     return TCL_OK;
 758 }
 759
 760 /*
 761  * do_userInformationField: Get User information field
 762  */
 763 static int do_userInformationField (void *obj, Tcl_Interp *interp,
 764                                     int argc, char **argv)
 765 {
 766     IRObj *p = obj;
 767
 768     Tcl_AppendResult (interp, p->userInformationField, NULL);
 769     return TCL_OK;
 770 }
 771
 772 /*
 773  * do_smallSetUpperBound: Set/get small set upper bound
 774  */
 775 static int do_smallSetUpperBound (void *o, Tcl_Interp *interp,
 776                        int argc, char **argv)
 777 {
 778     IRSetCObj *obj = o;
 779
 780     return get_set_int (&obj->smallSetUpperBound, interp, argc, argv);
 781 }
 782
 783 /*
 784  * do_largeSetLowerBound: Set/get large set lower bound
 785  */
 786 static int do_largeSetLowerBound (void *o, Tcl_Interp *interp,
 787                                   int argc, char **argv)
 788 {
 789     IRSetCObj *obj = o;
 790
 791     return get_set_int (&obj->largeSetLowerBound, interp, argc, argv);
 792 }
 793
 794 /*
 795  * do_mediumSetPresentNumber: Set/get large set lower bound
 796  */
 797 static int do_mediumSetPresentNumber (void *o, Tcl_Interp *interp,
 798                                       int argc, char **argv)
 799 {
 800     IRSetCObj *obj = o;
 801
 802     return get_set_int (&obj->mediumSetPresentNumber, interp, argc, argv);
 803 }
 804
 805
 806 static IRMethod ir_method_tab[] = {
 807 { 1, "comstack",                    do_comstack },
 808 { 1, "protocol",                    do_protocol },
 809 { 0, "failback",                    do_failback },
 810
 811 { 1, "connect",                     do_connect },
 812 { 0, "protocolVersion",             do_protocolVersion },
 813 { 1, "preferredMessageSize",        do_preferredMessageSize },
 814 { 1, "maximumRecordSize",           do_maximumRecordSize },
 815 { 1, "implementationName",          do_implementationName },
 816 { 1, "implementationId",            do_implementationId },
 817 { 0, "targetImplementationName",    do_targetImplementationName },
 818 { 0, "targetImplementationId",      do_targetImplementationId },
 819 { 0, "targetImplementationVersion", do_targetImplementationVersion },
 820 { 0, "userInformationField",        do_userInformationField },
 821 { 1, "idAuthentication",            do_idAuthentication },
 822 { 0, "options",                     do_options },
 823 { 0, "init",                        do_init_request },
 824 { 0, "initResult",                  do_initResult },
 825 { 0, "disconnect",                  do_disconnect },
 826 { 0, "callback",                    do_callback },
 827 { 0, NULL, NULL}
 828 };
 829
 830 static IRMethod ir_set_c_method_tab[] = {
 831 { 0, "databaseNames",           do_databaseNames},
 832 { 0, "replaceIndicator",        do_replaceIndicator},
 833 { 0, "queryType",               do_queryType },
 834 { 0, "smallSetUpperBound",      do_smallSetUpperBound},
 835 { 0, "largeSetLowerBound",      do_largeSetLowerBound},
 836 { 0, "mediumSetPresentNumber",  do_mediumSetPresentNumber},
 837 { 0, NULL, NULL}
 838 };
 839
 840 /*
 841  * ir_obj_method: IR Object methods
 842  */
 843 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 844 int argc, char **argv)
 845 {
 846     if (argc < 2)
 847         return ir_method_r (clientData, interp, argc, argv, ir_method_tab);
 848     if (ir_method (clientData, interp, argc, argv,
 849                    ir_method_tab, 1) == TCL_OK)
 850         return TCL_OK;
 851     return ir_method (&((IRObj*) clientData)->set_inher, interp,
 852                       argc, argv, ir_set_c_method_tab, 0);
 853 }
 854
 855 /*
 856  * ir_obj_delete: IR Object disposal
 857  */
 858 static void ir_obj_delete (ClientData clientData)
 859 {
 860     free ( (void*) clientData);
 861 }
 862
 863 static int ir_reset_inher (Tcl_Interp *interp, IRSetCObj *o)
 864 {
 865     o->smallSetUpperBound = 0;
 866     o->largeSetLowerBound = 2;
 867     o->mediumSetPresentNumber = 0;
 868     o->replaceIndicator = 1;
 869 #if 0
 870     obj->databaseNames = NULL;
 871     obj->num_databaseNames = 0;
 872 #else
 873     o->num_databaseNames = 1;
 874     if (!(o->databaseNames =
 875           ir_malloc (interp, sizeof(*o->databaseNames))))
 876         return TCL_ERROR;
 877     if (ir_strdup (interp, &o->databaseNames[0], "Default")
 878         == TCL_ERROR)
 879         return TCL_ERROR;
 880 #endif
 881     if (ir_strdup (interp, &o->queryType, "rpn") == TCL_ERROR)
 882         return TCL_ERROR;
 883     return TCL_OK;
 884 }
 885
 886 /*
 887  * ir_obj_mk: IR Object creation
 888  */
 889 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 890               int argc, char **argv)
 891 {
 892     IRObj *obj;
 893     FILE *inf;
 894
 895     if (argc != 2)
 896     {
 897         interp->result = "wrong # args";
 898         return TCL_ERROR;
 899     }
 900     if (!(obj = ir_malloc (interp, sizeof(*obj))))
 901         return TCL_ERROR;
 902     if (ir_strdup (interp, &obj->cs_type, "tcpip") == TCL_ERROR)
 903         return TCL_ERROR;
 904     if (ir_strdup (interp, &obj->protocol_type, "Z3950") == TCL_ERROR)
 905         return TCL_ERROR;
 906     obj->cs_link = NULL;
 907     obj->bib1.proto = PROTO_Z3950;
 908     obj->bib1.class = CLASS_ATTSET;
 909     obj->bib1.value = VAL_BIB1;
 910
 911     obj->maximumRecordSize = 32768;
 912     obj->preferredMessageSize = 4096;
 913     obj->connectFlag = 0;
 914
 915     obj->idAuthentication = NULL;
 916
 917     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 918         == TCL_ERROR)
 919         return TCL_ERROR;
 920
 921     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 922         == TCL_ERROR)
 923         return TCL_ERROR;
 924
 925     obj->targetImplementationName = NULL;
 926     obj->targetImplementationId = NULL;
 927     obj->targetImplementationVersion = NULL;
 928     obj->userInformationField = NULL;
 929
 930     obj->hostname = NULL;
 931
 932     obj->bibset = ccl_qual_mk ();
 933     if ((inf = fopen ("default.bib", "r")))
 934     {
 935         ccl_qual_file (obj->bibset, inf);
 936         fclose (inf);
 937     }
 938     ODR_MASK_ZERO (&obj->protocolVersion);
 939     ODR_MASK_SET (&obj->protocolVersion, 0);
 940     ODR_MASK_SET (&obj->protocolVersion, 1);
 941
 942     ODR_MASK_ZERO (&obj->options);
 943     ODR_MASK_SET (&obj->options, 0);
 944
 945     obj->odr_in = odr_createmem (ODR_DECODE);
 946     obj->odr_out = odr_createmem (ODR_ENCODE);
 947     obj->odr_pr = odr_createmem (ODR_PRINT);
 948
 949     obj->len_out = 10000;
 950     if (!(obj->buf_out = ir_malloc (interp, obj->len_out)))
 951         return TCL_ERROR;
 952     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out, 0);
 953
 954     obj->len_in = 0;
 955     obj->buf_in = NULL;
 956
 957     obj->callback = NULL;
 958     obj->failback = NULL;
 959
 960     if (ir_reset_inher (interp, &obj->set_inher) == TCL_ERROR)
 961         return TCL_ERROR;
 962     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 963                        (ClientData) obj, ir_obj_delete);
 964     return TCL_OK;
 965 }
 966
 967 /* ------------------------------------------------------- */
 968 /*
 969  * do_search: Do search request
 970  */
 971 static int do_search (void *o, Tcl_Interp *interp,
 972                        int argc, char **argv)
 973 {
 974     Z_SearchRequest req;
 975     Z_Query query;
 976     Z_APDU apdu, *apdup = &apdu;
 977     Odr_oct ccl_query;
 978     IRSetObj *obj = o;
 979     IRObj *p = obj->parent;
 980     int r;
 981
 982     p->set_child = o;
 983     if (argc != 3)
 984     {
 985         interp->result = "wrong # args";
 986         return TCL_ERROR;
 987     }
 988     if (!p->set_inher.num_databaseNames)
 989     {
 990         interp->result = "no databaseNames";
 991         return TCL_ERROR;
 992     }
 993     if (!p->cs_link)
 994     {
 995         interp->result = "not connected";
 996         return TCL_ERROR;
 997     }
 998     apdu.which = Z_APDU_searchRequest;
 999     apdu.u.searchRequest = &req;
1000
1001     req.referenceId = 0;
1002     req.smallSetUpperBound = &p->set_inher.smallSetUpperBound;
1003     req.largeSetLowerBound = &p->set_inher.largeSetLowerBound;
1004     req.mediumSetPresentNumber = &p->set_inher.mediumSetPresentNumber;
1005     req.replaceIndicator = &p->set_inher.replaceIndicator;
1006     req.resultSetName = obj->setName ? obj->setName : "Default";
1007     req.num_databaseNames = p->set_inher.num_databaseNames;
1008     req.databaseNames = p->set_inher.databaseNames;
1009     printf ("Search:");
1010     for (r=0; r < p->set_inher.num_databaseNames; r++)
1011     {
1012         printf (" %s", p->set_inher.databaseNames[r]);
1013     }
1014     req.smallSetElementSetNames = 0;
1015     req.mediumSetElementSetNames = 0;
1016     req.preferredRecordSyntax = 0;
1017     req.query = &query;
1018
1019     if (!strcmp (p->set_inher.queryType, "rpn"))
1020     {
1021         int error;
1022         int pos;
1023         struct ccl_rpn_node *rpn;
1024         Z_RPNQuery *RPNquery;
1025
1026         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
1027         if (error)
1028         {
1029             Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg(error),NULL);
1030             return TCL_ERROR;
1031         }
1032         ccl_pr_tree (rpn, stderr);
1033         fprintf (stderr, "\n");
1034         query.which = Z_Query_type_1;
1035         assert((RPNquery = ccl_rpn_query(rpn)));
1036         RPNquery->attributeSetId = oid_getoidbyent (&p->bib1);
1037         query.u.type_1 = RPNquery;
1038         printf ("- RPN\n");
1039     }
1040     else if (!strcmp (p->set_inher.queryType, "ccl"))
1041     {
1042         query.which = Z_Query_type_2;
1043         query.u.type_2 = &ccl_query;
1044         ccl_query.buf = (unsigned char *) argv[2];
1045         ccl_query.len = strlen (argv[2]);
1046         printf ("- CCL\n");
1047     }
1048     else
1049     {
1050         interp->result = "unknown query method";
1051         return TCL_ERROR;
1052     }
1053     if (!z_APDU (p->odr_out, &apdup, 0))
1054     {
1055         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1056         odr_reset (p->odr_out);
1057         return TCL_ERROR;
1058     }
1059     p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
1060     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1061     {
1062         interp->result = "cs_put failed in search";
1063         return TCL_ERROR;
1064     }
1065     else if (r == 1)
1066     {
1067         ir_select_add_write (cs_fileno(p->cs_link), p);
1068         printf("Sent part of searchRequest (%d bytes).\n", p->slen);
1069     }
1070     else
1071     {
1072         printf ("Whole search request\n");
1073     }
1074     return TCL_OK;
1075 }
1076
1077 /*
1078  * do_resultCount: Get number of hits
1079  */
1080 static int do_resultCount (void *o, Tcl_Interp *interp,
1081                        int argc, char **argv)
1082 {
1083     IRSetObj *obj = o;
1084
1085     return get_set_int (&obj->resultCount, interp, argc, argv);
1086 }
1087
1088 /*
1089  * do_searchStatus: Get search status (after search response)
1090  */
1091 static int do_searchStatus (void *o, Tcl_Interp *interp,
1092                             int argc, char **argv)
1093 {
1094     IRSetObj *obj = o;
1095
1096     return get_set_int (&obj->searchStatus, interp, argc, argv);
1097 }
1098
1099 /*
1100  * do_setName: Set result Set name
1101  */
1102 static int do_setName (void *o, Tcl_Interp *interp,
1103                        int argc, char **argv)
1104 {
1105     IRSetObj *obj = o;
1106
1107     if (argc == 3)
1108     {
1109         free (obj->setName);
1110         if (ir_strdup (interp, &obj->setName, argv[2])
1111             == TCL_ERROR)
1112             return TCL_ERROR;
1113     }
1114     Tcl_AppendElement (interp, obj->setName);
1115     return TCL_OK;
1116 }
1117
1118 /*
1119  * do_numberOfRecordsReturned: Get number of records returned
1120  */
1121 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
1122                        int argc, char **argv)
1123 {
1124     IRSetObj *obj = o;
1125
1126     return get_set_int (&obj->numberOfRecordsReturned, interp, argc, argv);
1127 }
1128
1129 static int get_marc_fields(Tcl_Interp *interp, Iso2709Rec rec,
1130                            int argc, char **argv)
1131 {
1132     Iso2709Anchor a;
1133     char *data;
1134
1135     if (!rec)
1136         return TCL_OK;
1137     a = iso2709_a_mk (rec);
1138     while (iso2709_a_search (a, argv[4], argv[5], argv[6]))
1139     {
1140         if (!(iso2709_a_info_field (a, NULL, NULL, NULL, &data)))
1141             break;
1142         Tcl_AppendElement (interp, data);
1143         iso2709_a_next (a);
1144     }
1145
1146     iso2709_a_rm (a);
1147     return TCL_OK;
1148 }
1149
1150 static int get_marc_lines(Tcl_Interp *interp, Iso2709Rec rec,
1151                          int argc, char **argv)
1152 {
1153     Iso2709Anchor a;
1154     char *tag;
1155     char *indicator;
1156     char *identifier;
1157     char *data;
1158     char *ptag = "";
1159
1160     if (!rec)
1161         return TCL_OK;
1162     a = iso2709_a_mk (rec);
1163     while (iso2709_a_search (a, argv[4], argv[5], argv[6]))
1164     {
1165         if (!(iso2709_a_info_field (a, &tag, &indicator, &identifier, &data)))
1166             break;
1167         if (strcmp (tag, ptag))
1168         {
1169             if (*ptag)
1170                 Tcl_AppendResult (interp, "}} ", NULL);
1171             if (!indicator)
1172                 Tcl_AppendResult (interp, "{", tag, " {} {", NULL);
1173             else
1174                 Tcl_AppendResult (interp, "{", tag, " {", indicator,
1175                                   "} {", NULL);
1176             ptag = tag;
1177         }
1178         if (!identifier)
1179             Tcl_AppendResult (interp, "{{}", NULL);
1180         else
1181             Tcl_AppendResult (interp, "{", identifier, NULL);
1182         Tcl_AppendElement (interp, data);
1183         Tcl_AppendResult (interp, "} ", NULL);
1184         iso2709_a_next (a);
1185     }
1186     if (*ptag)
1187         Tcl_AppendResult (interp, "}} ", NULL);
1188     iso2709_a_rm (a);
1189     return TCL_OK;
1190 }
1191
1192 /*
1193  * do_recordType: Return record type (if any) at position.
1194  */
1195 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
1196 {
1197     IRSetObj *obj = o;
1198     int offset;
1199     IRRecordList *rl;
1200
1201     if (argc < 3)
1202     {
1203         sprintf (interp->result, "wrong # args");
1204         return TCL_ERROR;
1205     }
1206     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1207         return TCL_ERROR;
1208     rl = find_IR_record (obj, offset);
1209     if (!rl)
1210         return TCL_OK;
1211     switch (rl->which)
1212     {
1213     case Z_NamePlusRecord_databaseRecord:
1214         interp->result = "databaseRecord";
1215         break;
1216     case Z_NamePlusRecord_surrogateDiagnostic:
1217         interp->result = "surrogateDiagnostic";
1218         break;
1219     }
1220     return TCL_OK;
1221 }
1222
1223 /*
1224  * do_recordDiag: Return diagnostic record info
1225  */
1226 static int do_recordDiag (void *o, Tcl_Interp *interp, int argc, char **argv)
1227 {
1228     IRSetObj *obj = o;
1229     int offset;
1230     IRRecordList *rl;
1231     char buf[20];
1232
1233     if (argc < 3)
1234     {
1235         sprintf (interp->result, "wrong # args");
1236         return TCL_ERROR;
1237     }
1238     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1239         return TCL_ERROR;
1240     rl = find_IR_record (obj, offset);
1241     if (!rl)
1242     {
1243         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1244         return TCL_ERROR;
1245     }
1246     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
1247     {
1248         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
1249         return TCL_ERROR;
1250     }
1251     sprintf (buf, "%d", rl->u.diag.condition);
1252     Tcl_AppendResult (interp, buf, " {",
1253                       (rl->u.diag.addinfo ? rl->u.diag.addinfo : ""),
1254                       "}", NULL);
1255     return TCL_OK;
1256 }
1257
1258 /*
1259  * do_recordMarc: Get ISO2709 Record lines/fields
1260  */
1261 static int do_recordMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
1262 {
1263     IRSetObj *obj = o;
1264     int offset;
1265     IRRecordList *rl;
1266
1267     if (argc < 4)
1268     {
1269         sprintf (interp->result, "wrong # args");
1270         return TCL_ERROR;
1271     }
1272     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1273         return TCL_ERROR;
1274     rl = find_IR_record (obj, offset);
1275     if (!rl)
1276     {
1277         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1278         return TCL_ERROR;
1279     }
1280     if (rl->which != Z_NamePlusRecord_databaseRecord)
1281     {
1282         Tcl_AppendResult (interp, "No MARC record at #", argv[2], NULL);
1283         return TCL_ERROR;
1284     }
1285     if (!strcmp (argv[3], "field"))
1286         return get_marc_fields (interp, rl->u.marc.rec, argc, argv);
1287     else if (!strcmp (argv[3], "line"))
1288         return get_marc_lines (interp, rl->u.marc.rec, argc, argv);
1289     else
1290     {
1291         Tcl_AppendResult (interp, "field/line expected", NULL);
1292         return TCL_ERROR;
1293     }
1294 }
1295
1296
1297 /*
1298  * do_responseStatus: Return response status (present or search)
1299  */
1300 static int do_responseStatus (void *o, Tcl_Interp *interp,
1301                              int argc, char **argv)
1302 {
1303     IRSetObj *obj = o;
1304
1305     if (!obj->recordFlag)
1306     {
1307         Tcl_AppendElement (interp, "OK");
1308         return TCL_OK;
1309     }
1310     switch (obj->which)
1311     {
1312     case Z_Records_DBOSD:
1313         Tcl_AppendElement (interp, "DBOSD");
1314         break;
1315     case Z_Records_NSD:
1316         return mk_nonSurrogateDiagnostics (interp, obj->condition,
1317                                            obj->addinfo);
1318     }
1319     return TCL_OK;
1320 }
1321
1322 /*
1323  * do_present: Perform Present Request
1324  */
1325
1326 static int do_present (void *o, Tcl_Interp *interp,
1327                        int argc, char **argv)
1328 {
1329     IRSetObj *obj = o;
1330     IRObj *p = obj->parent;
1331     Z_APDU apdu, *apdup = &apdu;
1332     Z_PresentRequest req;
1333     int start;
1334     int number;
1335     int r;
1336
1337     if (argc >= 3)
1338     {
1339         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
1340             return TCL_ERROR;
1341     }
1342     else
1343         start = 1;
1344     if (argc >= 4)
1345     {
1346         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
1347             return TCL_ERROR;
1348     }
1349     else
1350         number = 10;
1351     if (!p->cs_link)
1352     {
1353         interp->result = "not connected";
1354         return TCL_ERROR;
1355     }
1356     obj->start = start;
1357     obj->number = number;
1358
1359     apdu.which = Z_APDU_presentRequest;
1360     apdu.u.presentRequest = &req;
1361     req.referenceId = 0;
1362     /* sprintf(setstring, "%d", setnumber); */
1363
1364     req.resultSetId = obj->setName ? obj->setName : "Default";
1365
1366     req.resultSetStartPoint = &start;
1367     req.numberOfRecordsRequested = &number;
1368     req.elementSetNames = 0;
1369     req.preferredRecordSyntax = 0;
1370
1371     if (!z_APDU (p->odr_out, &apdup, 0))
1372     {
1373         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1374         odr_reset (p->odr_out);
1375         return TCL_ERROR;
1376     }
1377     p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
1378     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1379     {
1380         interp->result = "cs_put failed in present";
1381         return TCL_ERROR;
1382     }
1383     else if (r == 1)
1384     {
1385         ir_select_add_write (cs_fileno(p->cs_link), p);
1386         printf ("Part of present request, start=%d, num=%d (%d bytes)\n",
1387                 start, number, p->slen);
1388     }
1389     else
1390     {
1391         printf ("Whole present request, start=%d, num=%d (%d bytes)\n",
1392                 start, number, p->slen);
1393     }
1394     return TCL_OK;
1395 }
1396
1397 /*
1398  * do_loadFile: Load result set from file
1399  */
1400
1401 static int do_loadFile (void *o, Tcl_Interp *interp,
1402                         int argc, char **argv)
1403 {
1404     IRSetObj *setobj = o;
1405     FILE *inf;
1406     int  no = 1;
1407     const char *buf;
1408
1409     if (argc < 3)
1410     {
1411         interp->result = "wrong # args";
1412         return TCL_ERROR;
1413     }
1414     inf = fopen (argv[2], "r");
1415     if (!inf)
1416     {
1417         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
1418         return TCL_ERROR;
1419     }
1420     while ((buf = iso2709_read (inf)))
1421     {
1422         IRRecordList *rl;
1423         Iso2709Rec rec;
1424
1425         rec = iso2709_cvt (buf);
1426         if (!rec)
1427             break;
1428         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
1429         rl->u.marc.rec = rec;
1430         no++;
1431     }
1432     setobj->numberOfRecordsReturned = no-1;
1433     fclose (inf);
1434     return TCL_OK;
1435 }
1436
1437 /*
1438  * ir_set_obj_method: IR Set Object methods
1439  */
1440 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1441                           int argc, char **argv)
1442 {
1443     static IRMethod tab[] = {
1444     { 0, "search",                  do_search },
1445     { 0, "searchStatus",            do_searchStatus },
1446     { 0, "setName",                 do_setName },
1447     { 0, "resultCount",             do_resultCount },
1448     { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },
1449     { 0, "present",                 do_present },
1450     { 0, "recordType",              do_recordType },
1451     { 0, "recordMarc",              do_recordMarc },
1452     { 0, "recordDiag",              do_recordDiag },
1453     { 0, "responseStatus",          do_responseStatus },
1454     { 0, "loadFile",                do_loadFile },
1455     { 0, NULL, NULL}
1456     };
1457
1458     if (argc < 2)
1459     {
1460         interp->result = "wrong # args";
1461         return TCL_ERROR;
1462     }
1463     if (ir_method (clientData, interp, argc, argv, tab, 1) == TCL_OK)
1464         return TCL_OK;
1465     return ir_method (&((IRSetObj *)clientData)->set_inher, interp, argc,
1466                       argv, ir_set_c_method_tab, 0);
1467 }
1468
1469 /*
1470  * ir_set_obj_delete: IR Set Object disposal
1471  */
1472 static void ir_set_obj_delete (ClientData clientData)
1473 {
1474     free ( (void*) clientData);
1475 }
1476
1477 /*
1478  * ir_set_obj_mk: IR Set Object creation
1479  */
1480 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1481                              int argc, char **argv)
1482 {
1483     IRSetObj *obj;
1484
1485     if (argc < 2 || argc > 3)
1486     {
1487         interp->result = "wrong # args";
1488         return TCL_ERROR;
1489     }
1490     else if (argc == 3)
1491     {
1492         Tcl_CmdInfo parent_info;
1493         int i;
1494         IRSetCObj *dst;
1495         IRSetCObj *src;
1496
1497         if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
1498         {
1499             interp->result = "No parent";
1500             return TCL_ERROR;
1501         }
1502         if (!(obj = ir_malloc (interp, sizeof(*obj))))
1503             return TCL_ERROR;
1504         obj->parent = (IRObj *) parent_info.clientData;
1505
1506         dst = &obj->set_inher;
1507         src = &obj->parent->set_inher;
1508
1509         dst->num_databaseNames = src->num_databaseNames;
1510         if (!(dst->databaseNames =
1511               ir_malloc (interp, sizeof (*dst->databaseNames)
1512                          * dst->num_databaseNames)))
1513             return TCL_ERROR;
1514         for (i = 0; i < dst->num_databaseNames; i++)
1515         {
1516             printf ("database %i %s\n", i, src->databaseNames[i]);
1517             if (ir_strdup (interp, &dst->databaseNames[i],
1518                            src->databaseNames[i]) == TCL_ERROR)
1519                 return TCL_ERROR;
1520         }
1521         if (ir_strdup (interp, &dst->queryType, src->queryType)
1522             == TCL_ERROR)
1523             return TCL_ERROR;
1524
1525         dst->smallSetUpperBound = src->smallSetUpperBound;
1526         dst->largeSetLowerBound = src->largeSetLowerBound;
1527         dst->mediumSetPresentNumber = src->mediumSetPresentNumber;
1528         printf ("ssu lsl msp %d %d %d\n", dst->smallSetUpperBound,
1529                 dst->largeSetLowerBound, dst->mediumSetPresentNumber);
1530     }
1531     else
1532         obj->parent = NULL;
1533     if (ir_strdup (interp, &obj->setName, argv[2]) == TCL_ERROR)
1534         return TCL_ERROR;
1535     obj->record_list = NULL;
1536     obj->addinfo = NULL;
1537     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
1538                        (ClientData) obj, ir_set_obj_delete);
1539     return TCL_OK;
1540 }
1541
1542 /* ------------------------------------------------------- */
1543
1544 /*
1545  * do_scan: Perform scan
1546  */
1547 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
1548 {
1549     Z_ScanRequest req;
1550     Z_APDU apdu, *apdup = &apdu;
1551     IRScanObj *obj = o;
1552     IRObj *p = obj->parent;
1553     int r, pos;
1554     struct ccl_rpn_node *rpn;
1555
1556     p->scan_child = o;
1557     if (argc != 3)
1558     {
1559         interp->result = "wrong # args";
1560         return TCL_ERROR;
1561     }
1562     if (!p->set_inher.num_databaseNames)
1563     {
1564         interp->result = "no databaseNames";
1565         return TCL_ERROR;
1566     }
1567     if (!p->cs_link)
1568     {
1569         interp->result = "not connected";
1570         return TCL_ERROR;
1571     }
1572     apdu.which = Z_APDU_scanRequest;
1573     apdu.u.scanRequest = &req;
1574     req.referenceId = NULL;
1575     req.num_databaseNames = p->set_inher.num_databaseNames;
1576     req.databaseNames = p->set_inher.databaseNames;
1577     req.attributeSet = oid_getoidbyent (&p->bib1);
1578
1579 #if 0
1580     if (!(req.termListAndStartPoint =
1581           ir_malloc (interp, sizeof(*req.termListAndStartPoint))))
1582         return TCL_ERROR;
1583     req.termListAndStartPoint->num_attributes = 0;
1584     req.termListAndStartPoint->attributeList = NULL;
1585     if (!(req.termListAndStartPoint->term = ir_malloc (interp,
1586                                                        sizeof(Z_Term))))
1587         return TCL_ERROR;
1588     req.termListAndStartPoint->term->which = Z_Term_general;
1589     if (!(req.termListAndStartPoint->term->u.general =
1590         ir_malloc (interp, sizeof(*req.termListAndStartPoint->
1591                                   term->u.general))))
1592         return TCL_ERROR;
1593     if (ir_strdup (interp, &req.termListAndStartPoint->term->u.general->buf,
1594                    argv[2]) == TCL_ERROR)
1595         return TCL_ERROR;
1596     req.termListAndStartPoint->term->u.general->len =
1597         req.termListAndStartPoint->term->u.general->size = strlen(argv[2]);
1598 #else
1599     rpn = ccl_find_str(p->bibset, argv[2], &r, &pos);
1600     if (r)
1601     {
1602         Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL);
1603         return TCL_ERROR;
1604     }
1605     ccl_pr_tree (rpn, stderr);
1606     fprintf (stderr, "\n");
1607     if (!(req.termListAndStartPoint = ccl_scan_query (rpn)))
1608         return TCL_ERROR;
1609 #endif
1610     req.stepSize = &obj->stepSize;
1611     req.numberOfTermsRequested = &obj->numberOfTermsRequested;
1612     req.preferredPositionInResponse = &obj->preferredPositionInResponse;
1613     printf ("stepSize=%d\n", *req.stepSize);
1614     printf ("numberOfTermsRequested=%d\n", *req.numberOfTermsRequested);
1615     printf ("preferredPositionInResponse=%d\n",
1616             *req.preferredPositionInResponse);
1617
1618     if (!z_APDU (p->odr_out, &apdup, 0))
1619     {
1620         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1621         odr_reset (p->odr_out);
1622         return TCL_ERROR;
1623     }
1624     p->sbuf = odr_getbuf (p->odr_out, &p->slen, NULL);
1625     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1626     {
1627         interp->result = "cs_put failed in scan";
1628         return TCL_ERROR;
1629     }
1630     else if (r == 1)
1631     {
1632         ir_select_add_write (cs_fileno(p->cs_link), p);
1633         printf("Sent part of scanRequest (%d bytes).\n", p->slen);
1634     }
1635     else
1636     {
1637         printf ("Whole scan request\n");
1638     }
1639     return TCL_OK;
1640 }
1641
1642 /*
1643  * do_stepSize: Set/get replace Step Size
1644  */
1645 static int do_stepSize (void *obj, Tcl_Interp *interp,
1646                         int argc, char **argv)
1647 {
1648     IRScanObj *p = obj;
1649     return get_set_int (&p->stepSize, interp, argc, argv);
1650 }
1651
1652 /*
1653  * do_numberOfTermsRequested: Set/get Number of Terms requested
1654  */
1655 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,
1656                                       int argc, char **argv)
1657 {
1658     IRScanObj *p = obj;
1659     return get_set_int (&p->numberOfTermsRequested, interp, argc, argv);
1660 }
1661
1662
1663 /*
1664  * do_preferredPositionInResponse: Set/get preferred Position
1665  */
1666 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,
1667                                            int argc, char **argv)
1668 {
1669     IRScanObj *p = obj;
1670     return get_set_int (&p->preferredPositionInResponse, interp, argc, argv);
1671 }
1672
1673 /*
1674  * do_scanStatus: Get scan status
1675  */
1676 static int do_scanStatus (void *obj, Tcl_Interp *interp,
1677                           int argc, char **argv)
1678 {
1679     IRScanObj *p = obj;
1680     return get_set_int (&p->scanStatus, interp, argc, argv);
1681 }
1682
1683 /*
1684  * do_numberOfEntriesReturned: Get number of Entries returned
1685  */
1686 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,
1687                                        int argc, char **argv)
1688 {
1689     IRScanObj *p = obj;
1690     return get_set_int (&p->numberOfEntriesReturned, interp, argc, argv);
1691 }
1692
1693 /*
1694  * do_positionOfTerm: Get position of Term
1695  */
1696 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,
1697                               int argc, char **argv)
1698 {
1699     IRScanObj *p = obj;
1700     return get_set_int (&p->positionOfTerm, interp, argc, argv);
1701 }
1702
1703 /*
1704  * do_scanLine: get Scan Line (surrogate or normal) after response
1705  */
1706 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)
1707 {
1708     IRScanObj *p = obj;
1709     int i;
1710     char numstr[20];
1711
1712     if (argc != 3)
1713     {
1714         interp->result = "wrong # args";
1715         return TCL_ERROR;
1716     }
1717     if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)
1718         return TCL_ERROR;
1719     if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries
1720         || i >= p->num_entries || i < 0)
1721         return TCL_OK;
1722     switch (p->entries[i].which)
1723     {
1724     case Z_Entry_termInfo:
1725         Tcl_AppendElement (interp, "T");
1726         if (p->entries[i].u.term.buf)
1727             Tcl_AppendElement (interp, p->entries[i].u.term.buf);
1728         else
1729             Tcl_AppendElement (interp, "");
1730         sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);
1731         Tcl_AppendElement (interp, numstr);
1732         break;
1733     case Z_Entry_surrogateDiagnostic:
1734         return
1735             mk_nonSurrogateDiagnostics (interp, p->entries[i].u.diag.condition,
1736                                         p->entries[i].u.diag.addinfo);
1737         break;
1738     }
1739     return TCL_OK;
1740 }
1741
1742 /*
1743  * ir_scan_obj_method: IR Scan Object methods
1744  */
1745 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,
1746                                int argc, char **argv)
1747 {
1748     static IRMethod tab[] = {
1749     { 0, "scan",                    do_scan },
1750     { 0, "stepSize",                do_stepSize },
1751     { 0, "numberOfTermsRequested",  do_numberOfTermsRequested },
1752     { 0, "preferredPositionInResponse", do_preferredPositionInResponse },
1753     { 0, "scanStatus",              do_scanStatus },
1754     { 0, "numberOfEntriesReturned", do_numberOfEntriesReturned },
1755     { 0, "positionOfTerm",          do_positionOfTerm },
1756     { 0, "scanLine",                do_scanLine },
1757     { 0, NULL, NULL}
1758     };
1759
1760     if (argc < 2)
1761     {
1762         interp->result = "wrong # args";
1763         return TCL_ERROR;
1764     }
1765     return ir_method (clientData, interp, argc, argv, tab, 0);
1766 }
1767
1768 /*
1769  * ir_scan_obj_delete: IR Scan Object disposal
1770  */
1771 static void ir_scan_obj_delete (ClientData clientData)
1772 {
1773     free ( (void*) clientData);
1774 }
1775
1776 /*
1777  * ir_scan_obj_mk: IR Scan Object creation
1778  */
1779 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,
1780                            int argc, char **argv)
1781 {
1782     Tcl_CmdInfo parent_info;
1783     IRScanObj *obj;
1784
1785     if (argc != 2)
1786     {
1787         interp->result = "wrong # args";
1788         return TCL_ERROR;
1789     }
1790     if (get_parent_info (interp, argv[1], &parent_info, NULL) == TCL_ERROR)
1791         return TCL_ERROR;
1792     if (!(obj = ir_malloc (interp, sizeof(*obj))))
1793         return TCL_ERROR;
1794
1795     obj->stepSize = 0;
1796     obj->numberOfTermsRequested = 20;
1797     obj->preferredPositionInResponse = 1;
1798
1799     obj->entries = NULL;
1800     obj->nonSurrogateDiagnostics = NULL;
1801
1802     obj->parent = (IRObj *) parent_info.clientData;
1803     Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,
1804                        (ClientData) obj, ir_scan_obj_delete);
1805     return TCL_OK;
1806 }
1807
1808 /* ------------------------------------------------------- */
1809
1810 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
1811 {
1812     IRObj *p = obj;
1813
1814     p->initResult = *initrs->result ? 1 : 0;
1815     if (!*initrs->result)
1816         printf("Connection rejected by target.\n");
1817     else
1818         printf("Connection accepted by target.\n");
1819
1820     free (p->targetImplementationId);
1821     ir_strdup (p->interp, &p->targetImplementationId,
1822                initrs->implementationId);
1823     free (p->targetImplementationName);
1824     ir_strdup (p->interp, &p->targetImplementationName,
1825                initrs->implementationName);
1826     free (p->targetImplementationVersion);
1827     ir_strdup (p->interp, &p->targetImplementationVersion,
1828                initrs->implementationVersion);
1829
1830     p->maximumRecordSize = *initrs->maximumRecordSize;
1831     p->preferredMessageSize = *initrs->preferredMessageSize;
1832
1833     free (p->userInformationField);
1834     p->userInformationField = NULL;
1835     if (initrs->userInformationField)
1836     {
1837         int len;
1838
1839         if (initrs->userInformationField->which == ODR_EXTERNAL_octet &&
1840             (p->userInformationField =
1841              malloc ((len =
1842                       initrs->userInformationField->u.octet_aligned->len)
1843                      +1)))
1844         {
1845             memcpy (p->userInformationField,
1846                     initrs->userInformationField->u.octet_aligned->buf,
1847                         len);
1848             (p->userInformationField)[len] = '\0';
1849         }
1850     }
1851 }
1852
1853 static void ir_handleRecords (void *o, Z_Records *zrs)
1854 {
1855     IRObj *p = o;
1856     IRSetObj *setobj = p->set_child;
1857
1858     setobj->which = zrs->which;
1859     setobj->recordFlag = 1;
1860     if (zrs->which == Z_Records_NSD)
1861     {
1862         const char *addinfo;
1863
1864         setobj->numberOfRecordsReturned = 0;
1865         setobj->condition = *zrs->u.nonSurrogateDiagnostic->condition;
1866         free (setobj->addinfo);
1867         setobj->addinfo = NULL;
1868         addinfo = zrs->u.nonSurrogateDiagnostic->addinfo;
1869         if (addinfo && (setobj->addinfo = malloc (strlen(addinfo) + 1)))
1870             strcpy (setobj->addinfo, addinfo);
1871         printf ("Diagnostic response. %s (%d): %s\n",
1872                 diagbib1_str (setobj->condition),
1873                 setobj->condition,
1874                 setobj->addinfo ? setobj->addinfo : "");
1875     }
1876     else
1877     {
1878         int offset;
1879         IRRecordList *rl;
1880
1881         setobj->numberOfRecordsReturned =
1882             zrs->u.databaseOrSurDiagnostics->num_records;
1883         printf ("Got %d records\n", setobj->numberOfRecordsReturned);
1884         for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
1885         {
1886             rl = new_IR_record (setobj, setobj->start + offset,
1887                                 zrs->u.databaseOrSurDiagnostics->
1888                                 records[offset]->which);
1889             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
1890             {
1891                 Z_DiagRec *diagrec;
1892
1893                 diagrec = zrs->u.databaseOrSurDiagnostics->
1894                     records[offset]->u.surrogateDiagnostic;
1895
1896                 rl->u.diag.condition = *diagrec->condition;
1897                 if (diagrec->addinfo && (rl->u.diag.addinfo =
1898                                          malloc (strlen (diagrec->addinfo)+1)))
1899                     strcpy (rl->u.diag.addinfo, diagrec->addinfo);
1900             }
1901             else
1902             {
1903                 Z_DatabaseRecord *zr;
1904                 Odr_external *oe;
1905
1906                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
1907                     ->u.databaseRecord;
1908                 oe = (Odr_external*) zr;
1909                 if (oe->which == ODR_EXTERNAL_octet
1910                     && zr->u.octet_aligned->len)
1911                 {
1912                     const char *buf = (char*) zr->u.octet_aligned->buf;
1913                     rl->u.marc.rec = iso2709_cvt (buf);
1914                 }
1915                 else
1916                     rl->u.marc.rec = NULL;
1917             }
1918         }
1919     }
1920 }
1921
1922 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
1923 {
1924     IRObj *p = o;
1925     IRSetObj *setobj = p->set_child;
1926     Z_Records *zrs = searchrs->records;
1927
1928     if (setobj)
1929     {
1930         setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
1931         setobj->resultCount = *searchrs->resultCount;
1932         printf ("Search response %d, %d hits\n",
1933                  setobj->searchStatus, setobj->resultCount);
1934         if (zrs)
1935             ir_handleRecords (o, zrs);
1936         else
1937             setobj->recordFlag = 0;
1938     }
1939     else
1940         printf ("Search response, no object!\n");
1941 }
1942
1943
1944 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
1945 {
1946     IRObj *p = o;
1947     IRSetObj *setobj = p->set_child;
1948     Z_Records *zrs = presrs->records;
1949
1950     printf ("Received presentResponse\n");
1951     if (zrs)
1952         ir_handleRecords (o, zrs);
1953     else
1954     {
1955         setobj->recordFlag = 0;
1956         printf ("No records!\n");
1957     }
1958 }
1959
1960 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs)
1961 {
1962     IRObj *p = o;
1963     IRScanObj *scanobj = p->scan_child;
1964
1965     printf ("Received scanResponse\n");
1966
1967     scanobj->scanStatus = *scanrs->scanStatus;
1968     printf ("scanStatus=%d\n", scanobj->scanStatus);
1969
1970     if (scanrs->stepSize)
1971         scanobj->stepSize = *scanrs->stepSize;
1972     printf ("stepSize=%d\n", scanobj->stepSize);
1973
1974     scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;
1975     printf ("numberOfEntriesReturned=%d\n", scanobj->numberOfEntriesReturned);
1976
1977     if (scanrs->positionOfTerm)
1978         scanobj->positionOfTerm = *scanrs->positionOfTerm;
1979     else
1980         scanobj->positionOfTerm = -1;
1981     printf ("positionOfTerm=%d\n", scanobj->positionOfTerm);
1982
1983     free (scanobj->entries);
1984     scanobj->entries = NULL;
1985     free (scanobj->nonSurrogateDiagnostics);
1986     scanobj->nonSurrogateDiagnostics = NULL;
1987
1988     if (scanrs->entries)
1989     {
1990         int i;
1991         Z_Entry *ze;
1992
1993         scanobj->entries_flag = 1;
1994         scanobj->which = scanrs->entries->which;
1995         switch (scanobj->which)
1996         {
1997         case Z_ListEntries_entries:
1998             scanobj->num_entries = scanrs->entries->u.entries->num_entries;
1999             scanobj->entries = malloc (scanobj->num_entries *
2000                                        sizeof(*scanobj->entries));
2001             for (i=0; i<scanobj->num_entries; i++)
2002             {
2003                 ze = scanrs->entries->u.entries->entries[i];
2004                 scanobj->entries[i].which = ze->which;
2005                 switch (ze->which)
2006                 {
2007                 case Z_Entry_termInfo:
2008                     if (ze->u.termInfo->term->which == Z_Term_general)
2009                     {
2010                         int l = ze->u.termInfo->term->u.general->len;
2011                         scanobj->entries[i].u.term.buf = malloc (1+l);
2012                         memcpy (scanobj->entries[i].u.term.buf,
2013                                 ze->u.termInfo->term->u.general->buf,
2014                                 l);
2015                         scanobj->entries[i].u.term.buf[l] = '\0';
2016                     }
2017                     else
2018                         scanobj->entries[i].u.term.buf = NULL;
2019                     if (ze->u.termInfo->globalOccurrences)
2020                         scanobj->entries[i].u.term.globalOccurrences =
2021                             *ze->u.termInfo->globalOccurrences;
2022                     else
2023                         scanobj->entries[i].u.term.globalOccurrences = 0;
2024                     break;
2025                 case Z_Entry_surrogateDiagnostic:
2026                     scanobj->entries[i].u.diag.addinfo =
2027                             malloc (1+strlen(ze->u.surrogateDiagnostic->
2028                                              addinfo));
2029                     strcpy (scanobj->entries[i].u.diag.addinfo,
2030                             ze->u.surrogateDiagnostic->addinfo);
2031                     scanobj->entries[i].u.diag.condition =
2032                         *ze->u.surrogateDiagnostic->condition;
2033                     break;
2034                 }
2035             }
2036             break;
2037         case Z_ListEntries_nonSurrogateDiagnostics:
2038             scanobj->num_diagRecs = scanrs->entries->
2039                                   u.nonSurrogateDiagnostics->num_diagRecs;
2040             scanobj->nonSurrogateDiagnostics = malloc (scanobj->num_diagRecs *
2041                                   sizeof(*scanobj->nonSurrogateDiagnostics));
2042             break;
2043         }
2044     }
2045     else
2046         scanobj->entries_flag = 0;
2047 }
2048
2049 /*
2050  * ir_select_read: handle incoming packages
2051  */
2052 void ir_select_read (ClientData clientData)
2053 {
2054     IRObj *p = clientData;
2055     Z_APDU *apdu;
2056     int r;
2057
2058     if (p->connectFlag)
2059     {
2060         r = cs_rcvconnect (p->cs_link);
2061         if (r == 1)
2062             return;
2063         p->connectFlag = 0;
2064         ir_select_remove_write (cs_fileno (p->cs_link), p);
2065         if (r < 0)
2066         {
2067             printf ("cs_rcvconnect error\n");
2068             if (p->failback)
2069                 Tcl_Eval (p->interp, p->failback);
2070             do_disconnect (p, NULL, 0, NULL);
2071             return;
2072         }
2073         if (p->callback)
2074             Tcl_Eval (p->interp, p->callback);
2075         return;
2076     }
2077     do
2078     {
2079         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  <= 0)
2080         {
2081             printf ("cs_get failed\n");
2082             ir_select_remove (cs_fileno (p->cs_link), p);
2083             if (p->failback)
2084                 Tcl_Eval (p->interp, p->failback);
2085             do_disconnect (p, NULL, 0, NULL);
2086             return;
2087         }
2088         if (r == 1)
2089             return ;
2090         odr_setbuf (p->odr_in, p->buf_in, r, 0);
2091         printf ("cs_get ok, got %d\n", r);
2092         if (!z_APDU (p->odr_in, &apdu, 0))
2093         {
2094             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
2095             if (p->failback)
2096                 Tcl_Eval (p->interp, p->failback);
2097             do_disconnect (p, NULL, 0, NULL);
2098             return;
2099         }
2100         switch(apdu->which)
2101         {
2102         case Z_APDU_initResponse:
2103             ir_initResponse (p, apdu->u.initResponse);
2104             break;
2105         case Z_APDU_searchResponse:
2106             ir_searchResponse (p, apdu->u.searchResponse);
2107             break;
2108         case Z_APDU_presentResponse:
2109             ir_presentResponse (p, apdu->u.presentResponse);
2110             break;
2111         case Z_APDU_scanResponse:
2112             ir_scanResponse (p, apdu->u.scanResponse);
2113             break;
2114         default:
2115             printf("Received unknown APDU type (%d).\n",
2116                    apdu->which);
2117             if (p->failback)
2118                 Tcl_Eval (p->interp, p->failback);
2119             do_disconnect (p, NULL, 0, NULL);
2120         }
2121         if (p->callback)
2122             Tcl_Eval (p->interp, p->callback);
2123     } while (cs_more (p->cs_link));
2124 }
2125
2126 /*
2127  * ir_select_write: handle outgoing packages - not yet written.
2128  */
2129 void ir_select_write (ClientData clientData)
2130 {
2131     IRObj *p = clientData;
2132     int r;
2133
2134     printf ("In write handler.....\n");
2135     if (p->connectFlag)
2136     {
2137         r = cs_rcvconnect (p->cs_link);
2138         if (r == 1)
2139             return;
2140         p->connectFlag = 0;
2141         if (r < 0)
2142         {
2143             printf ("cs_rcvconnect error\n");
2144             ir_select_remove_write (cs_fileno (p->cs_link), p);
2145             if (p->failback)
2146                 Tcl_Eval (p->interp, p->failback);
2147             do_disconnect (p, NULL, 0, NULL);
2148             return;
2149         }
2150         ir_select_remove_write (cs_fileno (p->cs_link), p);
2151         if (p->callback)
2152             Tcl_Eval (p->interp, p->callback);
2153         return;
2154     }
2155     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
2156     {
2157         printf ("select write fail\n");
2158         if (p->failback)
2159             Tcl_Eval (p->interp, p->failback);
2160         do_disconnect (p, NULL, 0, NULL);
2161     }
2162     else if (r == 0)            /* remove select bit */
2163     {
2164         ir_select_remove_write (cs_fileno (p->cs_link), p);
2165     }
2166 }
2167
2168 /* ------------------------------------------------------- */
2169
2170 /*
2171  * ir_tcl_init: Registration of TCL commands.
2172  */
2173 int ir_tcl_init (Tcl_Interp *interp)
2174 {
2175     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
2176                        (Tcl_CmdDeleteProc *) NULL);
2177     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
2178                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2179     Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,
2180                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2181     return TCL_OK;
2182 }
2183
2184