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