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