ir-tcl.c

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