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