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