ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995-1996
   4  * See the file LICENSE for details.
   5  * Sebastian Hammer, Adam Dickmeiss
   6  *
   7  * $Log: ir-tcl.c,v $
   8  * Revision 1.93  1996-08-16 15:07:45  adam
   9  * First work on Explain.
  10  *
  11  * Revision 1.92  1996/08/09  15:33:07  adam
  12  * Modified the code to use tk4.1/tcl7.5 patch level 1. The time-driven
  13  * polling is no longer activated on Windows since asynchrounous I/O works
  14  * better.
  15  *
  16  * Revision 1.91  1996/07/03  13:31:11  adam
  17  * The xmalloc/xfree functions from YAZ are used to manage memory.
  18  *
  19  * Revision 1.90  1996/06/27  14:21:00  adam
  20  * Yet another Windows port.
  21  *
  22  * Revision 1.89  1996/06/11  15:27:15  adam
  23  * Event type set to connect a little earlier in the do_connect function.
  24  *
  25  * Revision 1.88  1996/06/03  09:04:22  adam
  26  * Changed a few logf calls.
  27  *
  28  * Revision 1.87  1996/05/29  06:37:51  adam
  29  * Function ir_tcl_get_grs_r enhanced so that specific elements can be
  30  * extracted.
  31  *
  32  * Revision 1.86  1996/03/20 13:54:04  adam
  33  * The Tcl_File structure is only manipulated in the Tk-event interface
  34  * in tkinit.c.
  35  *
  36  * Revision 1.85  1996/03/15  11:15:48  adam
  37  * Modified to use new prototypes for p_query_rpn and p_query_scan.
  38  *
  39  * Revision 1.84  1996/03/07  12:42:49  adam
  40  * Better logging when callback is invoked.
  41  *
  42  * Revision 1.83  1996/03/05  09:21:09  adam
  43  * Bug fix: memory used by GRS records wasn't freed.
  44  * Rewrote some of the error handling code - the connection is always
  45  * closed before failback is called.
  46  * If failback is defined the send APDU methods (init, search, ...) will
  47  * return OK but invoke failback (as is the case if the write operation
  48  * fails).
  49  * Bug fix: ref_count in assoc object could grow if fraction of PDU was
  50  * read.
  51  *
  52  * Revision 1.82  1996/02/29  15:30:21  adam
  53  * Export of IrTcl functionality to extensions.
  54  *
  55  * Revision 1.81  1996/02/26  18:38:32  adam
  56  * Work on export of set methods.
  57  *
  58  * Revision 1.80  1996/02/23  17:31:39  adam
  59  * More functions made available to the wais tcl extension.
  60  *
  61  * Revision 1.79  1996/02/23  13:41:38  adam
  62  * Work on public access to simple ir class system.
  63  *
  64  * Revision 1.78  1996/02/21  10:16:08  adam
  65  * Simplified select handling. Only one function ir_tcl_select_set has
  66  * to be externally defined.
  67  *
  68  * Revision 1.77  1996/02/20  17:52:58  adam
  69  * Uses the YAZ oid system to name record syntax object identifiers.
  70  *
  71  * Revision 1.76  1996/02/20  16:09:51  adam
  72  * Bug fix: didn't set element set names stamp correctly on result
  73  * set records when element set names were set to the empty string.
  74  *
  75  * Revision 1.75  1996/02/19  15:41:53  adam
  76  * Better log messages.
  77  * Minor improvement of connect method.
  78  *
  79  * Revision 1.74  1996/02/05  17:58:03  adam
  80  * Ported ir-tcl to use the beta releases of tcl7.5/tk4.1.
  81  *
  82  * Revision 1.73  1996/01/29  11:35:19  adam
  83  * Bug fix: cs_type member renamed to comstackType to avoid conflict with
  84  * cs_type macro defined by YAZ.
  85  *
  86  * Revision 1.72  1996/01/19  17:45:34  quinn
  87  * Added debugging output
  88  *
  89  * Revision 1.71  1996/01/19  16:22:38  adam
  90  * New method: apduDump - returns information about last incoming APDU.
  91  *
  92  * Revision 1.70  1996/01/10  09:18:34  adam
  93  * PDU specific callbacks implemented: initRespnse, searchResponse,
  94  *  presentResponse and scanResponse.
  95  * Bug fix in the command line shell (tclmain.c) - discovered on OSF/1.
  96  *
  97  * Revision 1.69  1996/01/04  16:12:12  adam
  98  * Setting PDUType renamed to eventType.
  99  *
 100  * Revision 1.68  1996/01/04  11:05:22  adam
 101  * New setting: PDUType - returns type of last PDU returned from the target.
 102  * Fixed a bug in configure/Makefile.
 103  *
 104  * Revision 1.67  1996/01/03  09:00:51  adam
 105  * Updated to use new version of Yaz (names changed to avoid C++ conflict).
 106  *
 107  * Revision 1.66  1995/11/28  17:26:39  adam
 108  * Removed Carriage return from ir-tcl.c!
 109  * Removed misc. debug logs.
 110  *
 111  * Revision 1.65  1995/11/28  13:53:00  quinn
 112  * Windows port.
 113  *
 114  * Revision 1.64  1995/11/13  15:39:18  adam
 115  * Bug fix: {small,medium}SetElementSetNames weren't set correctly.
 116  * Bug fix: idAuthentication weren't set correctly.
 117  *
 118  * Revision 1.63  1995/11/13  09:55:39  adam
 119  * Multiple records at a position in a result-set with differnt
 120  * element specs.
 121  *
 122  * Revision 1.62  1995/10/18  17:20:33  adam
 123  * Work on target setup in client.tcl.
 124  *
 125  * Revision 1.61  1995/10/18  16:42:42  adam
 126  * New settings: smallSetElementSetNames and mediumSetElementSetNames.
 127  *
 128  * Revision 1.60  1995/10/18  15:43:31  adam
 129  * In search: mediumSetElementSetNames and smallSetElementSetNames are
 130  * set to elementSetNames.
 131  *
 132  * Revision 1.59  1995/10/17  12:18:58  adam
 133  * Bug fix: when target connection closed, the connection was not
 134  * properly reestablished.
 135  *
 136  * Revision 1.58  1995/10/16  17:00:55  adam
 137  * New setting: elementSetNames.
 138  * Various client improvements. Medium presentation format looks better.
 139  *
 140  * Revision 1.57  1995/09/21  13:11:51  adam
 141  * Support of dynamic loading.
 142  * Test script uses load command if necessary.
 143  *
 144  * Revision 1.56  1995/08/29  15:30:14  adam
 145  * Work on GRS records.
 146  *
 147  * Revision 1.55  1995/08/28  09:43:25  adam
 148  * Minor changes. configure only searches for yaz beta 3 and versions after
 149  * that.
 150  *
 151  * Revision 1.54  1995/08/24  12:25:16  adam
 152  * Modified to work with yaz 1.0b3.
 153  *
 154  * Revision 1.53  1995/08/04  12:49:26  adam
 155  * Bug fix: reading uninitialized variable p.
 156  *
 157  * Revision 1.52  1995/08/04  11:32:38  adam
 158  * More work on output queue. Memory related routines moved
 159  * to mem.c
 160  *
 161  * Revision 1.51  1995/08/03  13:22:54  adam
 162  * Request queue.
 163  *
 164  * Revision 1.50  1995/07/20  08:09:49  adam
 165  * client.tcl: Targets removed from hotTargets list when targets
 166  *  are removed/modified.
 167  * ir-tcl.c: More work on triggerResourceControl.
 168  *
 169  * Revision 1.49  1995/06/30  12:39:21  adam
 170  * Bug fix: loadFile didn't set record type.
 171  * The MARC routines are a little less strict in the interpretation.
 172  * Script display.tcl replaces the old marc.tcl.
 173  * New interactive script: shell.tcl.
 174  *
 175  * Revision 1.48  1995/06/27  19:03:50  adam
 176  * Bug fix in do_present in ir-tcl.c: p->set_child member weren't set.
 177  * nextResultSetPosition used instead of setOffset.
 178  *
 179  * Revision 1.47  1995/06/25  10:25:04  adam
 180  * Working on triggerResourceControl. Description of compile/install
 181  * procedure moved to ir-tcl.sgml.
 182  *
 183  * Revision 1.46  1995/06/22  13:15:06  adam
 184  * Feature: SUTRS. Setting getSutrs implemented.
 185  * Work on display formats.
 186  * Preferred record syntax can be set by the user.
 187  *
 188  * Revision 1.45  1995/06/20  08:07:30  adam
 189  * New setting: failInfo.
 190  * Working on better cancel mechanism.
 191  *
 192  * Revision 1.44  1995/06/19  17:01:20  adam
 193  * Minor changes.
 194  *
 195  * Revision 1.43  1995/06/19  13:06:08  adam
 196  * New define: IR_TCL_VERSION.
 197  *
 198  * Revision 1.42  1995/06/19  08:08:52  adam
 199  * client.tcl: hotTargets now contain both database and target name.
 200  * ir-tcl.c: setting protocol edited. Errors in callbacks are logged
 201  * by logf(LOG_WARN, ...) calls.
 202  *
 203  * Revision 1.41  1995/06/16  12:28:16  adam
 204  * Implemented preferredRecordSyntax.
 205  * Minor changes in diagnostic handling.
 206  * Record list deleted when connection closes.
 207  *
 208  * Revision 1.40  1995/06/14  13:37:18  adam
 209  * Setting recordType implemented.
 210  * Setting implementationVersion implemented.
 211  * Settings implementationId / implementationName edited.
 212  *
 213  * Revision 1.39  1995/06/08  10:26:32  adam
 214  * Bug fix in ir_strdup.
 215  *
 216  * Revision 1.38  1995/06/01  16:36:47  adam
 217  * About buttons. Minor bug fixes.
 218  *
 219  * Revision 1.37  1995/06/01  07:31:20  adam
 220  * Rename of many typedefs -> IrTcl_...
 221  *
 222  * Revision 1.36  1995/05/31  13:09:59  adam
 223  * Client searches/presents may be interrupted.
 224  * New moving book-logo.
 225  *
 226  * Revision 1.35  1995/05/31  08:36:33  adam
 227  * Bug fix in client.tcl: didn't save options on clientrc.tcl.
 228  * New method: referenceId. More work on scan.
 229  *
 230  * Revision 1.34  1995/05/29  10:33:42  adam
 231  * README and rename of startup script.
 232  *
 233  * Revision 1.33  1995/05/29  09:15:11  quinn
 234  * Changed CS_SR to PROTO_SR, etc.
 235  *
 236  * Revision 1.32  1995/05/29  08:44:16  adam
 237  * Work on delete of objects.
 238  *
 239  * Revision 1.31  1995/05/26  11:44:10  adam
 240  * Bugs fixed. More work on MARC utilities and queries. Test
 241  * client is up-to-date again.
 242  *
 243  * Revision 1.30  1995/05/26  08:54:11  adam
 244  * New MARC utilities. Uses prefix query.
 245  *
 246  * Revision 1.29  1995/05/24  14:10:22  adam
 247  * Work on idAuthentication, protocolVersion and options.
 248  *
 249  * Revision 1.28  1995/05/23  15:34:48  adam
 250  * Many new settings, userInformationField, smallSetUpperBound, etc.
 251  * A number of settings are inherited when ir-set is executed.
 252  * This version is incompatible with the graphical test client (client.tcl).
 253  *
 254  * Revision 1.27  1995/05/11  15:34:47  adam
 255  * Scan request changed a bit. This version works with RLG.
 256  *
 257  * Revision 1.26  1995/04/18  16:11:51  adam
 258  * First version of graphical Scan. Some work on query-by-form.
 259  *
 260  * Revision 1.25  1995/04/17  09:37:17  adam
 261  * Further development of scan.
 262  *
 263  * Revision 1.24  1995/04/11  14:16:42  adam
 264  * Further work on scan. Response works. Entries aren't saved yet.
 265  *
 266  * Revision 1.23  1995/04/10  10:50:27  adam
 267  * Result-set name defaults to suffix of ir-set name.
 268  * Started working on scan. Not finished at this point.
 269  *
 270  * Revision 1.22  1995/03/31  10:43:03  adam
 271  * More robust when getting bad MARC records.
 272  *
 273  * Revision 1.21  1995/03/31  08:56:37  adam
 274  * New button "Search".
 275  *
 276  * Revision 1.20  1995/03/29  16:07:09  adam
 277  * Bug fix: Didn't use setName in present request.
 278  *
 279  * Revision 1.19  1995/03/28  12:45:23  adam
 280  * New ir method failback: called on disconnect/protocol error.
 281  * New ir set/get method: protocol: SR / Z3950.
 282  * Simple popup and disconnect when failback is invoked.
 283  *
 284  * Revision 1.18  1995/03/21  15:50:12  adam
 285  * Minor changes.
 286  *
 287  * Revision 1.17  1995/03/21  13:41:03  adam
 288  * Comstack cs_create not used too often. Non-blocking connect.
 289  *
 290  * Revision 1.16  1995/03/21  08:26:06  adam
 291  * New method, setName, to specify the result set name (other than Default).
 292  * New method, responseStatus, which returns diagnostic info, if any, after
 293  * present response / search response.
 294  *
 295  * Revision 1.15  1995/03/20  15:24:07  adam
 296  * Diagnostic records saved on searchResponse.
 297  *
 298  * Revision 1.14  1995/03/20  08:53:22  adam
 299  * Event loop in tclmain.c rewritten. New method searchStatus.
 300  *
 301  * Revision 1.13  1995/03/17  18:26:17  adam
 302  * Non-blocking i/o used now. Database names popup as cascade items.
 303  *
 304  * Revision 1.12  1995/03/17  15:45:00  adam
 305  * Improved target/database setup.
 306  *
 307  * Revision 1.11  1995/03/16  17:54:03  adam
 308  * Minor changes really.
 309  *
 310  * Revision 1.10  1995/03/15  16:14:50  adam
 311  * Blocking arg in cs_create changed.
 312  *
 313  * Revision 1.9  1995/03/15  13:59:24  adam
 314  * Minor changes.
 315  *
 316  * Revision 1.8  1995/03/15  08:25:16  adam
 317  * New method presentStatus to check for error on present. Misc. cleanup
 318  * of IrTcl_RecordList manipulations. Full MARC record presentation in
 319  * search.tcl.
 320  *
 321  * Revision 1.7  1995/03/14  17:32:29  adam
 322  * Presentation of full Marc record in popup window.
 323  *
 324  * Revision 1.6  1995/03/12  19:31:55  adam
 325  * Pattern matching implemented when retrieving MARC records. More
 326  * diagnostic functions.
 327  *
 328  * Revision 1.5  1995/03/10  18:00:15  adam
 329  * Actual presentation in line-by-line format. RPN query support.
 330  *
 331  * Revision 1.4  1995/03/09  16:15:08  adam
 332  * First presentRequest attempts. Hot-target list.
 333  *
 334  */
 335
 336 #include <stdlib.h>
 337 #include <stdio.h>
 338 #ifdef WINDOWS
 339
 340 #else
 341 #include <unistd.h>
 342 #endif
 343 #include <time.h>
 344 #include <assert.h>
 345
 346 #define CS_BLOCK 0
 347
 348 #include "ir-tclp.h"
 349
 350 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num);
 351
 352 static void ir_select_notify (ClientData clientData, int r, int w, int e);
 353
 354 void ir_select_add (int fd, void *obj)
 355 {
 356     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 0, 0);
 357 }
 358
 359 void ir_select_add_write (int fd, void *obj)
 360 {
 361     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 1, 0);
 362 }
 363
 364 void ir_select_remove (int fd, void *obj)
 365 {
 366     ir_tcl_select_set (NULL, fd, obj, 0, 0, 0);
 367 }
 368
 369 void ir_select_remove_write (int fd, void *obj)
 370 {
 371     ir_tcl_select_set (ir_select_notify, fd, obj, 1, 0, 0);
 372 }
 373
 374 static void delete_IR_record (IrTcl_RecordList *rl)
 375 {
 376     switch (rl->which)
 377     {
 378     case Z_NamePlusRecord_databaseRecord:
 379         switch (rl->u.dbrec.type)
 380         {
 381         case VAL_GRS1:
 382             ir_tcl_grs_del (&rl->u.dbrec.u.grs1);
 383             break;
 384         default:
 385             break;
 386         }
 387         xfree (rl->u.dbrec.buf);
 388         rl->u.dbrec.buf = NULL;
 389         break;
 390     case Z_NamePlusRecord_surrogateDiagnostic:
 391         ir_deleteDiags (&rl->u.surrogateDiagnostics.list,
 392                         &rl->u.surrogateDiagnostics.num);
 393         break;
 394     }
 395     xfree (rl->elements);
 396 }
 397
 398 static IrTcl_RecordList *new_IR_record (IrTcl_SetObj *setobj,
 399                                         int no, int which,
 400                                         const char *elements)
 401 {
 402     IrTcl_RecordList *rl;
 403
 404     if (elements && !*elements)
 405         elements = NULL;
 406     for (rl = setobj->record_list; rl; rl = rl->next)
 407     {
 408         if (no == rl->no && (!rl->elements || !elements ||
 409                              !strcmp(elements, rl->elements)))
 410         {
 411             delete_IR_record (rl);
 412             break;
 413         }
 414     }
 415     if (!rl)
 416     {
 417         rl = ir_tcl_malloc (sizeof(*rl));
 418         rl->next = setobj->record_list;
 419         rl->no = no;
 420         setobj->record_list = rl;
 421     }
 422     rl->which = which;
 423     ir_tcl_strdup (NULL, &rl->elements, elements);
 424     return rl;
 425 }
 426
 427 /*
 428  * ir_tcl_eval
 429  */
 430 int ir_tcl_eval (Tcl_Interp *interp, const char *command)
 431 {
 432     char *tmp = ir_tcl_malloc (strlen(command)+1);
 433     int r;
 434
 435     logf (LOG_DEBUG, "Invoking %.23s ...", command);
 436     strcpy (tmp, command);
 437     r = Tcl_Eval (interp, tmp);
 438     if (r == TCL_ERROR)
 439     {
 440         logf (LOG_WARN, "Tcl error in line %d: %s", interp->errorLine,
 441               interp->result);
 442     }
 443     Tcl_FreeResult (interp);
 444     xfree (tmp);
 445     return r;
 446 }
 447
 448 /*
 449  * IrTcl_getRecordSyntaxStr: Return record syntax name of object id
 450  */
 451 static char *IrTcl_getRecordSyntaxStr (enum oid_value value)
 452 {
 453     int *o;
 454     struct oident ent, *entp;
 455
 456     ent.proto = PROTO_Z3950;
 457     ent.oclass = CLASS_RECSYN;
 458     ent.value = value;
 459
 460     o = oid_getoidbyent (&ent);
 461     entp = oid_getentbyoid (o);
 462
 463     if (!entp)
 464         return "";
 465     return entp->desc;
 466 }
 467
 468 /*
 469  * IrTcl_getRecordSyntaxVal: Return record syntax value of string
 470  */
 471 static enum oid_value IrTcl_getRecordSyntaxVal (const char *name)
 472 {
 473     return oid_getvalbyname (name);
 474 }
 475
 476 static IrTcl_RecordList *find_IR_record (IrTcl_SetObj *setobj, int no)
 477 {
 478     IrTcl_RecordList *rl;
 479
 480     for (rl = setobj->record_list; rl; rl = rl->next)
 481         if (no == rl->no &&
 482             (!setobj->recordElements || !rl->elements ||
 483              !strcmp (setobj->recordElements, rl->elements)))
 484             return rl;
 485     return NULL;
 486 }
 487
 488 static void delete_IR_records (IrTcl_SetObj *setobj)
 489 {
 490     IrTcl_RecordList *rl, *rl1;
 491
 492     for (rl = setobj->record_list; rl; rl = rl1)
 493     {
 494         delete_IR_record (rl);
 495         rl1 = rl->next;
 496         xfree (rl);
 497     }
 498     setobj->record_list = NULL;
 499 }
 500
 501 /*
 502  * ir_tcl_get_set_int: Set/get integer value
 503  */
 504 int ir_tcl_get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)
 505 {
 506     char buf[20];
 507
 508     if (argc == 3)
 509     {
 510         if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)
 511             return TCL_ERROR;
 512     }
 513     sprintf (buf, "%d", *val);
 514     Tcl_AppendResult (interp, buf, NULL);
 515     return TCL_OK;
 516 }
 517
 518 /*
 519  * ir_tcl_method: Search for method in table and invoke method handler
 520  */
 521 int ir_tcl_method (Tcl_Interp *interp, int argc, char **argv,
 522                    IrTcl_Methods *tab, int *ret)
 523 {
 524     IrTcl_Methods *tab_i = tab;
 525     IrTcl_Method *t;
 526
 527     for (tab_i = tab; tab_i->tab; tab_i++)
 528         for (t = tab_i->tab; t->name; t++)
 529             if (argc <= 0)
 530             {
 531                 if ((*t->method)(tab_i->obj, interp, argc, argv) == TCL_ERROR)
 532                     return TCL_ERROR;
 533             }
 534             else
 535                 if (!strcmp (t->name, argv[1]))
 536                 {
 537                     *ret = (*t->method)(tab_i->obj, interp, argc, argv);
 538                     return TCL_OK;
 539                 }
 540
 541     if (argc <= 0)
 542         return TCL_OK;
 543 #if 0
 544     Tcl_AppendResult (interp, "Bad method: ", argv[1],
 545                       ". Possible methods:", NULL);
 546     for (tab_i = tab; tab_i->tab; tab_i++)
 547         for (t = tab_i->tab; t->name; t++)
 548             Tcl_AppendResult (interp, " ", t->name, NULL);
 549 #endif
 550     *ret = TCL_ERROR;
 551     return TCL_ERROR;
 552 }
 553
 554 /*
 555  *  ir_tcl_named_bits: get/set named bits
 556  */
 557 int ir_tcl_named_bits (struct ir_named_entry *tab, Odr_bitmask *ob,
 558                        Tcl_Interp *interp, int argc, char **argv)
 559 {
 560     struct ir_named_entry *ti;
 561     if (argc > 0)
 562     {
 563         int no;
 564         ODR_MASK_ZERO (ob);
 565         for (no = 0; no < argc; no++)
 566         {
 567             for (ti = tab; ti->name; ti++)
 568                 if (!strcmp (argv[no], ti->name))
 569                 {
 570                     ODR_MASK_SET (ob, ti->pos);
 571                     break;
 572                 }
 573             if (!ti->name)
 574             {
 575                 Tcl_AppendResult (interp, "Bad bit mask: ", argv[no], NULL);
 576                 return TCL_ERROR;
 577             }
 578         }
 579         return TCL_OK;
 580     }
 581     for (ti = tab; ti->name; ti++)
 582         if (ODR_MASK_GET (ob, ti->pos))
 583             Tcl_AppendElement (interp, ti->name);
 584     return TCL_OK;
 585 }
 586
 587 static void set_referenceId (ODR o, Z_ReferenceId **dst, const char *src)
 588 {
 589     if (!src || !*src)
 590         *dst = NULL;
 591     else
 592     {
 593         *dst = odr_malloc (o, sizeof(**dst));
 594         (*dst)->size = (*dst)->len = strlen(src);
 595         (*dst)->buf = odr_malloc (o, (*dst)->len);
 596         memcpy ((*dst)->buf, src, (*dst)->len);
 597     }
 598 }
 599
 600 static void get_referenceId (char **dst, Z_ReferenceId *src)
 601 {
 602     xfree (*dst);
 603     if (!src)
 604     {
 605         *dst = NULL;
 606         return;
 607     }
 608     *dst = ir_tcl_malloc (src->len+1);
 609     memcpy (*dst, src->buf, src->len);
 610     (*dst)[src->len] = '\0';
 611 }
 612
 613 /* ------------------------------------------------------- */
 614
 615 /*
 616  * do_init_request: init method on IR object
 617  */
 618 static int do_init_request (void *obj, Tcl_Interp *interp,
 619                             int argc, char **argv)
 620 {
 621     Z_APDU *apdu;
 622     IrTcl_Obj *p = obj;
 623     Z_InitRequest *req;
 624
 625     if (argc <= 0)
 626         return TCL_OK;
 627     logf (LOG_DEBUG, "init %s", *argv);
 628     if (!p->cs_link)
 629     {
 630         interp->result = "init: not connected";
 631         return TCL_ERROR;
 632     }
 633     apdu = zget_APDU (p->odr_out, Z_APDU_initRequest);
 634     req = apdu->u.initRequest;
 635
 636     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
 637     req->options = &p->options;
 638     req->protocolVersion = &p->protocolVersion;
 639     req->preferredMessageSize = &p->preferredMessageSize;
 640     req->maximumRecordSize = &p->maximumRecordSize;
 641
 642     if (p->idAuthenticationGroupId)
 643     {
 644         Z_IdPass *pass = odr_malloc (p->odr_out, sizeof(*pass));
 645         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
 646
 647         logf (LOG_DEBUG, "using pass authentication");
 648
 649         auth->which = Z_IdAuthentication_idPass;
 650         auth->u.idPass = pass;
 651         if (p->idAuthenticationGroupId && *p->idAuthenticationGroupId)
 652             pass->groupId = p->idAuthenticationGroupId;
 653         else
 654             pass->groupId = NULL;
 655         if (p->idAuthenticationUserId && *p->idAuthenticationUserId)
 656             pass->userId = p->idAuthenticationUserId;
 657         else
 658             pass->userId = NULL;
 659         if (p->idAuthenticationPassword && *p->idAuthenticationPassword)
 660             pass->password = p->idAuthenticationPassword;
 661         else
 662             pass->password = NULL;
 663         req->idAuthentication = auth;
 664     }
 665     else if (!p->idAuthenticationOpen || !*p->idAuthenticationOpen)
 666         req->idAuthentication = NULL;
 667     else
 668     {
 669         Z_IdAuthentication *auth = odr_malloc (p->odr_out, sizeof(*auth));
 670
 671         logf (LOG_DEBUG, "using open authentication");
 672         auth->which = Z_IdAuthentication_open;
 673         auth->u.open = p->idAuthenticationOpen;
 674         req->idAuthentication = auth;
 675     }
 676     req->implementationId = p->implementationId;
 677     req->implementationName = p->implementationName;
 678     req->implementationVersion = p->implementationVersion;
 679     req->userInformationField = 0;
 680
 681     return ir_tcl_send_APDU (interp, p, apdu, "init", *argv);
 682 }
 683
 684 /*
 685  * do_protocolVersion: Set protocol Version
 686  */
 687 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 688                                int argc, char **argv)
 689 {
 690     int version, i;
 691     char buf[10];
 692     IrTcl_Obj *p = obj;
 693
 694     if (argc <= 0)
 695     {
 696         ODR_MASK_ZERO (&p->protocolVersion);
 697         ODR_MASK_SET (&p->protocolVersion, 0);
 698         ODR_MASK_SET (&p->protocolVersion, 1);
 699         return TCL_OK;
 700     }
 701     if (argc == 3)
 702     {
 703         if (Tcl_GetInt (interp, argv[2], &version)==TCL_ERROR)
 704             return TCL_ERROR;
 705         ODR_MASK_ZERO (&p->protocolVersion);
 706         for (i = 0; i<version; i++)
 707             ODR_MASK_SET (&p->protocolVersion, i);
 708     }
 709     for (i = 4; --i >= 0; )
 710         if (ODR_MASK_GET (&p->protocolVersion, i))
 711             break;
 712     sprintf (buf, "%d", i+1);
 713     interp->result = buf;
 714     return TCL_OK;
 715 }
 716
 717 /*
 718  * do_options: Set options
 719  */
 720 static int do_options (void *obj, Tcl_Interp *interp,
 721                        int argc, char **argv)
 722 {
 723     static struct ir_named_entry options_tab[] = {
 724     { "search", 0 },
 725     { "present", 1 },
 726     { "delSet", 2 },
 727     { "resourceReport", 3 },
 728     { "triggerResourceCtrl", 4},
 729     { "resourceCtrl", 5},
 730     { "accessCtrl", 6},
 731     { "scan", 7},
 732     { "sort", 8},
 733     { "extendedServices", 10},
 734     { "level-1Segmentation", 11},
 735     { "level-2Segmentation", 12},
 736     { "concurrentOperations", 13},
 737     { "namedResultSets", 14},
 738     { NULL, 0}
 739     };
 740     IrTcl_Obj *p = obj;
 741
 742     if (argc <= 0)
 743     {
 744         ODR_MASK_ZERO (&p->options);
 745         ODR_MASK_SET (&p->options, 0);
 746         ODR_MASK_SET (&p->options, 1);
 747         ODR_MASK_SET (&p->options, 4);
 748         ODR_MASK_SET (&p->options, 7);
 749         ODR_MASK_SET (&p->options, 14);
 750         return TCL_OK;
 751     }
 752     return ir_tcl_named_bits (options_tab, &p->options, interp, argc-2, argv+2);
 753 }
 754
 755 /*
 756  * do_apduInfo: Get APDU information
 757  */
 758 static int do_apduInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)
 759 {
 760     char buf[16];
 761     FILE *apduf;
 762     IrTcl_Obj *p = obj;
 763
 764     if (argc <= 0)
 765         return TCL_OK;
 766     sprintf (buf, "%d", p->apduLen);
 767     Tcl_AppendElement (interp, buf);
 768     sprintf (buf, "%d", p->apduOffset);
 769     Tcl_AppendElement (interp, buf);
 770     if (!p->buf_in)
 771     {
 772         Tcl_AppendElement (interp, "");
 773         return TCL_OK;
 774     }
 775     apduf = fopen ("apdu.tmp", "w");
 776     if (!apduf)
 777     {
 778         Tcl_AppendElement (interp, "");
 779         return TCL_OK;
 780     }
 781     odr_dumpBER (apduf, p->buf_in, p->apduLen);
 782     fclose (apduf);
 783     if (!(apduf = fopen ("apdu.tmp", "r")))
 784         Tcl_AppendElement (interp, "");
 785     else
 786     {
 787         int c;
 788
 789         Tcl_AppendResult (interp, " {", NULL);
 790         while ((c = getc (apduf)) != EOF)
 791         {
 792             buf[0] = c;
 793             buf[1] = '\0';
 794             Tcl_AppendResult (interp, buf, NULL);
 795         }
 796         fclose (apduf);
 797         Tcl_AppendResult (interp, "}", NULL);
 798     }
 799     unlink ("apdu.tmp");
 800     return TCL_OK;
 801 }
 802
 803 /*
 804  * do_failInfo: Get fail information
 805  */
 806 static int do_failInfo (void *obj, Tcl_Interp *interp, int argc, char **argv)
 807 {
 808     char buf[16], *cp;
 809     IrTcl_Obj *p = obj;
 810
 811     if (argc <= 0)
 812     {
 813         p->failInfo = 0;
 814         return TCL_OK;
 815     }
 816     sprintf (buf, "%d", p->failInfo);
 817     switch (p->failInfo)
 818     {
 819     case 0:
 820         cp = "ok";
 821         break;
 822     case IR_TCL_FAIL_CONNECT:
 823         cp = "connect failed";
 824         break;
 825     case IR_TCL_FAIL_READ:
 826         cp = "connection closed";
 827         break;
 828     case IR_TCL_FAIL_WRITE:
 829         cp = "connection closed";
 830         break;
 831     case IR_TCL_FAIL_IN_APDU:
 832         cp = "failed to decode incoming APDU";
 833         break;
 834     case IR_TCL_FAIL_UNKNOWN_APDU:
 835         cp = "unknown APDU";
 836         break;
 837     default:
 838         cp = "";
 839     }
 840     Tcl_AppendElement (interp, buf);
 841     Tcl_AppendElement (interp, cp);
 842     return TCL_OK;
 843 }
 844
 845 /*
 846  * do_preferredMessageSize: Set/get preferred message size
 847  */
 848 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 849                                     int argc, char **argv)
 850 {
 851     IrTcl_Obj *p = obj;
 852
 853     if (argc <= 0)
 854     {
 855         p->preferredMessageSize = 30000;
 856         return TCL_OK;
 857     }
 858     return ir_tcl_get_set_int (&p->preferredMessageSize, interp, argc, argv);
 859 }
 860
 861 /*
 862  * do_maximumRecordSize: Set/get maximum record size
 863  */
 864 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 865                                  int argc, char **argv)
 866 {
 867     IrTcl_Obj *p = obj;
 868
 869     if (argc <= 0)
 870     {
 871         p->maximumRecordSize = 30000;
 872         return TCL_OK;
 873     }
 874     return ir_tcl_get_set_int (&p->maximumRecordSize, interp, argc, argv);
 875 }
 876
 877 /*
 878  * do_initResult: Get init result
 879  */
 880 static int do_initResult (void *obj, Tcl_Interp *interp,
 881                           int argc, char **argv)
 882 {
 883     IrTcl_Obj *p = obj;
 884
 885     if (argc <= 0)
 886         return TCL_OK;
 887     return ir_tcl_get_set_int (&p->initResult, interp, argc, argv);
 888 }
 889
 890
 891 /*
 892  * do_implementationName: Set/get Implementation Name.
 893  */
 894 static int do_implementationName (void *obj, Tcl_Interp *interp,
 895                                     int argc, char **argv)
 896 {
 897     IrTcl_Obj *p = obj;
 898
 899     if (argc == 0)
 900         return ir_tcl_strdup (interp, &p->implementationName,
 901                           "Index Data/IrTcl on YAZ");
 902     else if (argc == -1)
 903         return ir_tcl_strdel (interp, &p->implementationName);
 904     if (argc == 3)
 905     {
 906         xfree (p->implementationName);
 907         if (ir_tcl_strdup (interp, &p->implementationName, argv[2])
 908             == TCL_ERROR)
 909             return TCL_ERROR;
 910     }
 911     Tcl_AppendResult (interp, p->implementationName, (char*) NULL);
 912     return TCL_OK;
 913 }
 914
 915 /*
 916  * do_implementationId: Get Implementation Id.
 917  */
 918 static int do_implementationId (void *obj, Tcl_Interp *interp,
 919                                 int argc, char **argv)
 920 {
 921     IrTcl_Obj *p = obj;
 922
 923     if (argc == 0)
 924         return ir_tcl_strdup (interp, &p->implementationId, "YAZ (id=81)");
 925     else if (argc == -1)
 926         return ir_tcl_strdel (interp, &p->implementationId);
 927     Tcl_AppendResult (interp, p->implementationId, (char*) NULL);
 928     return TCL_OK;
 929 }
 930
 931 /*
 932  * do_implementationVersion: get Implementation Version.
 933  */
 934 static int do_implementationVersion (void *obj, Tcl_Interp *interp,
 935                                      int argc, char **argv)
 936 {
 937     IrTcl_Obj *p = obj;
 938
 939     if (argc == 0)
 940         return ir_tcl_strdup (interp, &p->implementationVersion,
 941                           "YAZ: " YAZ_VERSION
 942 #ifdef IR_TCL_VERSION
 943                           " / Irtcl: " IR_TCL_VERSION
 944 #endif
 945                           );
 946     else if (argc == -1)
 947         return ir_tcl_strdel (interp, &p->implementationVersion);
 948     Tcl_AppendResult (interp, p->implementationVersion, (char*) NULL);
 949     return TCL_OK;
 950 }
 951
 952 /*
 953  * do_targetImplementationName: Get Implementation Name of target.
 954  */
 955 static int do_targetImplementationName (void *obj, Tcl_Interp *interp,
 956                                         int argc, char **argv)
 957 {
 958     IrTcl_Obj *p = obj;
 959
 960     if (argc == 0)
 961     {
 962         p->targetImplementationName = NULL;
 963         return TCL_OK;
 964     }
 965     else if (argc == -1)
 966         return ir_tcl_strdel (interp, &p->targetImplementationName);
 967     Tcl_AppendResult (interp, p->targetImplementationName, (char*) NULL);
 968     return TCL_OK;
 969 }
 970
 971 /*
 972  * do_targetImplementationId: Get Implementation Id of target
 973  */
 974 static int do_targetImplementationId (void *obj, Tcl_Interp *interp,
 975                                       int argc, char **argv)
 976 {
 977     IrTcl_Obj *p = obj;
 978
 979     if (argc == 0)
 980     {
 981         p->targetImplementationId = NULL;
 982         return TCL_OK;
 983     }
 984     else if (argc == -1)
 985         return ir_tcl_strdel (interp, &p->targetImplementationId);
 986     Tcl_AppendResult (interp, p->targetImplementationId, (char*) NULL);
 987     return TCL_OK;
 988 }
 989
 990 /*
 991  * do_targetImplementationVersion: Get Implementation Version of target
 992  */
 993 static int do_targetImplementationVersion (void *obj, Tcl_Interp *interp,
 994                                            int argc, char **argv)
 995 {
 996     IrTcl_Obj *p = obj;
 997
 998     if (argc == 0)
 999     {
1000         p->targetImplementationVersion = NULL;
1001         return TCL_OK;
1002     }
1003     else if (argc == -1)
1004         return ir_tcl_strdel (interp, &p->targetImplementationVersion);
1005     Tcl_AppendResult (interp, p->targetImplementationVersion, (char*) NULL);
1006     return TCL_OK;
1007 }
1008
1009 /*
1010  * do_idAuthentication: Set/get id Authentication
1011  */
1012 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
1013                                 int argc, char **argv)
1014 {
1015     IrTcl_Obj *p = obj;
1016
1017     if (argc >= 3 || argc == -1)
1018     {
1019         xfree (p->idAuthenticationOpen);
1020         xfree (p->idAuthenticationGroupId);
1021         xfree (p->idAuthenticationUserId);
1022         xfree (p->idAuthenticationPassword);
1023     }
1024     if (argc >= 3 || argc <= 0)
1025     {
1026         p->idAuthenticationOpen = NULL;
1027         p->idAuthenticationGroupId = NULL;
1028         p->idAuthenticationUserId = NULL;
1029         p->idAuthenticationPassword = NULL;
1030     }
1031     if (argc <= 0)
1032         return TCL_OK;
1033     if (argc >= 3)
1034     {
1035         if (argc == 3)
1036         {
1037             if (argv[2][0] &&
1038                 ir_tcl_strdup (interp, &p->idAuthenticationOpen, argv[2])
1039                 == TCL_ERROR)
1040                 return TCL_ERROR;
1041         }
1042         else if (argc == 5)
1043         {
1044             if (argv[2][0] &&
1045                 ir_tcl_strdup (interp, &p->idAuthenticationGroupId, argv[2])
1046                 == TCL_ERROR)
1047                 return TCL_ERROR;
1048             if (argv[3][0] &&
1049                 ir_tcl_strdup (interp, &p->idAuthenticationUserId, argv[3])
1050                 == TCL_ERROR)
1051                 return TCL_ERROR;
1052             if (argv[4][0] &&
1053                 ir_tcl_strdup (interp, &p->idAuthenticationPassword, argv[4])
1054                 == TCL_ERROR)
1055                 return TCL_ERROR;
1056         }
1057     }
1058     if (p->idAuthenticationOpen)
1059         Tcl_AppendElement (interp, p->idAuthenticationOpen);
1060     else if (p->idAuthenticationGroupId)
1061     {
1062         Tcl_AppendElement (interp, p->idAuthenticationGroupId);
1063         Tcl_AppendElement (interp, p->idAuthenticationUserId);
1064         Tcl_AppendElement (interp, p->idAuthenticationPassword);
1065     }
1066     return TCL_OK;
1067 }
1068
1069 /*
1070  * do_connect: connect method on IR object
1071  */
1072 static int do_connect (void *obj, Tcl_Interp *interp,
1073                        int argc, char **argv)
1074 {
1075     void *addr;
1076     IrTcl_Obj *p = obj;
1077     int r;
1078
1079     if (argc <= 0)
1080         return TCL_OK;
1081     if (argc == 3)
1082     {
1083         logf (LOG_DEBUG, "connect %s %s", *argv, argv[2]);
1084         if (p->hostname)
1085         {
1086             interp->result = "already connected";
1087             return TCL_ERROR;
1088         }
1089         if (!strcmp (p->comstackType, "tcpip"))
1090         {
1091             p->cs_link = cs_create (tcpip_type, CS_BLOCK, p->protocol_type);
1092             addr = tcpip_strtoaddr (argv[2]);
1093             if (!addr)
1094             {
1095                 interp->result = "tcpip_strtoaddr fail";
1096                 return TCL_ERROR;
1097             }
1098             logf (LOG_DEBUG, "tcp/ip connect %s", argv[2]);
1099         }
1100         else if (!strcmp (p->comstackType, "mosi"))
1101         {
1102 #if MOSI
1103             p->cs_link = cs_create (mosi_type, CS_BLOCK, p->protocol_type);
1104             addr = mosi_strtoaddr (argv[2]);
1105             if (!addr)
1106             {
1107                 interp->result = "mosi_strtoaddr fail";
1108                 return TCL_ERROR;
1109             }
1110             logf (LOG_DEBUG, "mosi connect %s", argv[2]);
1111 #else
1112             interp->result = "MOSI support not there";
1113             return TCL_ERROR;
1114 #endif
1115         }
1116         else
1117         {
1118             Tcl_AppendResult (interp, "Bad comstack type: ",
1119                               p->comstackType, NULL);
1120             return TCL_ERROR;
1121         }
1122         if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
1123             return TCL_ERROR;
1124         p->eventType = "connect";
1125         if ((r=cs_connect (p->cs_link, addr)) < 0)
1126         {
1127             interp->result = "connect fail";
1128             ir_tcl_disconnect (p);
1129             return TCL_ERROR;
1130         }
1131         ir_select_add (cs_fileno (p->cs_link), p);
1132         if (r == 1)
1133         {
1134             logf (LOG_DEBUG, "connect pending fd=%d", cs_fileno(p->cs_link));
1135             ir_select_add_write (cs_fileno (p->cs_link), p);
1136             p->state = IR_TCL_R_Connecting;
1137         }
1138         else
1139         {
1140             logf (LOG_DEBUG, "connect ok fd=%d", cs_fileno(p->cs_link));
1141             p->state = IR_TCL_R_Idle;
1142             if (p->callback)
1143                 ir_tcl_eval (p->interp, p->callback);
1144         }
1145     }
1146     else
1147         Tcl_AppendResult (interp, p->hostname, NULL);
1148     return TCL_OK;
1149 }
1150
1151 /*
1152  * ir_tcl_disconnect: close connection
1153  */
1154 void ir_tcl_disconnect (IrTcl_Obj *p)
1155 {
1156     if (p->hostname)
1157     {
1158         logf(LOG_DEBUG, "Closing connection to %s", p->hostname);
1159         xfree (p->hostname);
1160         p->hostname = NULL;
1161         ir_select_remove_write (cs_fileno (p->cs_link), p);
1162         ir_select_remove (cs_fileno (p->cs_link), p);
1163
1164         odr_reset (p->odr_in);
1165
1166         assert (p->cs_link);
1167         cs_close (p->cs_link);
1168         p->cs_link = NULL;
1169
1170         ODR_MASK_ZERO (&p->options);
1171         ODR_MASK_SET (&p->options, 0);
1172         ODR_MASK_SET (&p->options, 1);
1173         ODR_MASK_SET (&p->options, 4);
1174         ODR_MASK_SET (&p->options, 7);
1175         ODR_MASK_SET (&p->options, 14);
1176
1177         ODR_MASK_ZERO (&p->protocolVersion);
1178         ODR_MASK_SET (&p->protocolVersion, 0);
1179         ODR_MASK_SET (&p->protocolVersion, 1);
1180         ir_tcl_del_q (p);
1181     }
1182     assert (!p->cs_link);
1183 }
1184
1185 /*
1186  * do_disconnect: disconnect method on IR object
1187  */
1188 static int do_disconnect (void *obj, Tcl_Interp *interp,
1189                           int argc, char **argv)
1190 {
1191     IrTcl_Obj *p = obj;
1192
1193     if (argc == 0)
1194     {
1195         p->state = IR_TCL_R_Idle;
1196         p->eventType = NULL;
1197         p->hostname = NULL;
1198         p->cs_link = NULL;
1199         return TCL_OK;
1200     }
1201     ir_tcl_disconnect (p);
1202     return TCL_OK;
1203 }
1204
1205 /*
1206  * do_comstack: Set/get comstack method on IR object
1207  */
1208 static int do_comstack (void *o, Tcl_Interp *interp,
1209                         int argc, char **argv)
1210 {
1211     IrTcl_Obj *obj = o;
1212
1213     if (argc == 0)
1214         return ir_tcl_strdup (interp, &obj->comstackType, "tcpip");
1215     else if (argc == -1)
1216         return ir_tcl_strdel (interp, &obj->comstackType);
1217     else if (argc == 3)
1218     {
1219         xfree (obj->comstackType);
1220         if (ir_tcl_strdup (interp, &obj->comstackType, argv[2]) == TCL_ERROR)
1221             return TCL_ERROR;
1222     }
1223     Tcl_AppendElement (interp, obj->comstackType);
1224     return TCL_OK;
1225 }
1226
1227 /*
1228  * do_logLevel: Set log level
1229  */
1230 static int do_logLevel (void *o, Tcl_Interp *interp,
1231                         int argc, char **argv)
1232 {
1233     if (argc <= 2)
1234         return TCL_OK;
1235     if (argc == 3)
1236         log_init (log_mask_str (argv[2]), "", NULL);
1237     else if (argc == 4)
1238         log_init (log_mask_str (argv[2]), argv[3], NULL);
1239     else if (argc == 5)
1240         log_init (log_mask_str (argv[2]), argv[3], argv[4]);
1241     return TCL_OK;
1242 }
1243
1244
1245 /*
1246  * do_eventType: Return type of last event
1247  */
1248 static int do_eventType (void *obj, Tcl_Interp *interp,
1249                          int argc, char **argv)
1250 {
1251     IrTcl_Obj *p = obj;
1252
1253     if (argc <= 0)
1254     {
1255         p->eventType = NULL;
1256         return TCL_OK;
1257     }
1258     Tcl_AppendElement (interp, p->eventType ? p->eventType : "");
1259     return TCL_OK;
1260 }
1261
1262
1263 /*
1264  * do_callback: add callback
1265  */
1266 static int do_callback (void *obj, Tcl_Interp *interp,
1267                         int argc, char **argv)
1268 {
1269     IrTcl_Obj *p = obj;
1270
1271     if (argc == 0)
1272     {
1273         p->callback = NULL;
1274         return TCL_OK;
1275     }
1276     else if (argc == -1)
1277         return ir_tcl_strdel (interp, &p->callback);
1278     if (argc == 3)
1279     {
1280         xfree (p->callback);
1281         if (argv[2][0])
1282         {
1283             if (ir_tcl_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
1284                 return TCL_ERROR;
1285         }
1286         else
1287             p->callback = NULL;
1288     }
1289     return TCL_OK;
1290 }
1291
1292 /*
1293  * do_failback: add error handle callback
1294  */
1295 static int do_failback (void *obj, Tcl_Interp *interp,
1296                           int argc, char **argv)
1297 {
1298     IrTcl_Obj *p = obj;
1299
1300     if (argc == 0)
1301     {
1302         p->failback = NULL;
1303         return TCL_OK;
1304     }
1305     else if (argc == -1)
1306         return ir_tcl_strdel (interp, &p->failback);
1307     else if (argc == 3)
1308     {
1309         xfree (p->failback);
1310         if (argv[2][0])
1311         {
1312             if (ir_tcl_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
1313                 return TCL_ERROR;
1314         }
1315         else
1316             p->failback = NULL;
1317     }
1318     return TCL_OK;
1319 }
1320
1321 /*
1322  * do_initResponse: add init response handler
1323  */
1324 static int do_initResponse (void *obj, Tcl_Interp *interp,
1325                             int argc, char **argv)
1326 {
1327     IrTcl_Obj *p = obj;
1328
1329     if (argc == 0)
1330     {
1331         p->initResponse = NULL;
1332         return TCL_OK;
1333     }
1334     else if (argc == -1)
1335         return ir_tcl_strdel (interp, &p->initResponse);
1336     if (argc == 3)
1337     {
1338         xfree (p->initResponse);
1339         if (argv[2][0])
1340         {
1341             if (ir_tcl_strdup (interp, &p->initResponse, argv[2]) == TCL_ERROR)
1342                 return TCL_ERROR;
1343         }
1344         else
1345             p->initResponse = NULL;
1346     }
1347     return TCL_OK;
1348 }
1349 /*
1350  * do_protocol: Set/get protocol method on IR object
1351  */
1352 static int do_protocol (void *o, Tcl_Interp *interp, int argc, char **argv)
1353 {
1354     IrTcl_Obj *p = o;
1355
1356     if (argc <= 0)
1357     {
1358         p->protocol_type = PROTO_Z3950;
1359         return TCL_OK;
1360     }
1361     else if (argc == 3)
1362     {
1363         if (!strcmp (argv[2], "Z39"))
1364             p->protocol_type = PROTO_Z3950;
1365         else if (!strcmp (argv[2], "SR"))
1366             p->protocol_type = PROTO_SR;
1367         else
1368         {
1369             Tcl_AppendResult (interp, "Bad protocol: ", argv[2], NULL);
1370             return TCL_ERROR;
1371         }
1372         return TCL_OK;
1373     }
1374     switch (p->protocol_type)
1375     {
1376     case PROTO_Z3950:
1377         Tcl_AppendElement (interp, "Z39");
1378         break;
1379     case PROTO_SR:
1380         Tcl_AppendElement (interp, "SR");
1381         break;
1382     }
1383     return TCL_OK;
1384 }
1385
1386 /*
1387  * do_triggerResourceControl:
1388  */
1389 static int do_triggerResourceControl (void *obj, Tcl_Interp *interp,
1390                                       int argc, char **argv)
1391 {
1392     IrTcl_Obj *p = obj;
1393     Z_APDU *apdu;
1394     Z_TriggerResourceControlRequest *req;
1395     bool_t is_false = 0;
1396
1397     if (argc <= 0)
1398         return TCL_OK;
1399     if (!p->cs_link)
1400     {
1401         interp->result = "triggerResourceControl: not connected";
1402         return TCL_ERROR;
1403     }
1404     apdu = zget_APDU (p->odr_out, Z_APDU_triggerResourceControlRequest);
1405     req = apdu->u.triggerResourceControlRequest;
1406     *req->requestedAction = Z_TriggerResourceCtrl_cancel;
1407     req->resultSetWanted = &is_false;
1408
1409     return ir_tcl_send_APDU (interp, p, apdu, "triggerResourceControl",
1410                              argv[0]);
1411 }
1412
1413 /*
1414  * do_databaseNames: specify database names
1415  */
1416 static int do_databaseNames (void *obj, Tcl_Interp *interp,
1417                              int argc, char **argv)
1418 {
1419     int i;
1420     IrTcl_SetCObj *p = obj;
1421
1422     if (argc == -1)
1423     {
1424         for (i=0; i<p->num_databaseNames; i++)
1425             xfree (p->databaseNames[i]);
1426         xfree (p->databaseNames);
1427     }
1428     if (argc <= 0)
1429     {
1430         p->num_databaseNames = 0;
1431         p->databaseNames = NULL;
1432         return TCL_OK;
1433     }
1434     if (argc < 3)
1435     {
1436         for (i=0; i<p->num_databaseNames; i++)
1437             Tcl_AppendElement (interp, p->databaseNames[i]);
1438         return TCL_OK;
1439     }
1440     if (p->databaseNames)
1441     {
1442         for (i=0; i<p->num_databaseNames; i++)
1443             xfree (p->databaseNames[i]);
1444         xfree (p->databaseNames);
1445     }
1446     p->num_databaseNames = argc - 2;
1447     p->databaseNames =
1448         ir_tcl_malloc (sizeof(*p->databaseNames) * (1+p->num_databaseNames));
1449     for (i=0; i<p->num_databaseNames; i++)
1450     {
1451         if (ir_tcl_strdup (interp, &p->databaseNames[i], argv[2+i])
1452             == TCL_ERROR)
1453             return TCL_ERROR;
1454     }
1455     p->databaseNames[i] = NULL;
1456     return TCL_OK;
1457 }
1458
1459 /*
1460  * do_replaceIndicator: Set/get replace Set indicator
1461  */
1462 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
1463                                 int argc, char **argv)
1464 {
1465     IrTcl_SetCObj *p = obj;
1466
1467     if (argc <= 0)
1468     {
1469         p->replaceIndicator = 1;
1470         return TCL_OK;
1471     }
1472     return ir_tcl_get_set_int (&p->replaceIndicator, interp, argc, argv);
1473 }
1474
1475 /*
1476  * do_queryType: Set/Get query method
1477  */
1478 static int do_queryType (void *obj, Tcl_Interp *interp,
1479                        int argc, char **argv)
1480 {
1481     IrTcl_SetCObj *p = obj;
1482
1483     if (argc == 0)
1484         return ir_tcl_strdup (interp, &p->queryType, "rpn");
1485     else if (argc == -1)
1486         return ir_tcl_strdel (interp, &p->queryType);
1487     if (argc == 3)
1488     {
1489         xfree (p->queryType);
1490         if (ir_tcl_strdup (interp, &p->queryType, argv[2]) == TCL_ERROR)
1491             return TCL_ERROR;
1492     }
1493     Tcl_AppendResult (interp, p->queryType, NULL);
1494     return TCL_OK;
1495 }
1496
1497 /*
1498  * do_userInformationField: Get User information field
1499  */
1500 static int do_userInformationField (void *obj, Tcl_Interp *interp,
1501                                     int argc, char **argv)
1502 {
1503     IrTcl_Obj *p = obj;
1504
1505     if (argc == 0)
1506     {
1507         p->userInformationField = NULL;
1508         return TCL_OK;
1509     }
1510     else if (argc == -1)
1511         return ir_tcl_strdel (interp, &p->userInformationField);
1512     Tcl_AppendResult (interp, p->userInformationField, NULL);
1513     return TCL_OK;
1514 }
1515
1516 /*
1517  * do_smallSetUpperBound: Set/get small set upper bound
1518  */
1519 static int do_smallSetUpperBound (void *o, Tcl_Interp *interp,
1520                        int argc, char **argv)
1521 {
1522     IrTcl_SetCObj *p = o;
1523
1524     if (argc <= 0)
1525     {
1526         p->smallSetUpperBound = 0;
1527         return TCL_OK;
1528     }
1529     return ir_tcl_get_set_int (&p->smallSetUpperBound, interp, argc, argv);
1530 }
1531
1532 /*
1533  * do_largeSetLowerBound: Set/get large set lower bound
1534  */
1535 static int do_largeSetLowerBound (void *o, Tcl_Interp *interp,
1536                                   int argc, char **argv)
1537 {
1538     IrTcl_SetCObj *p = o;
1539
1540     if (argc <= 0)
1541     {
1542         p->largeSetLowerBound = 2;
1543         return TCL_OK;
1544     }
1545     return ir_tcl_get_set_int (&p->largeSetLowerBound, interp, argc, argv);
1546 }
1547
1548 /*
1549  * do_mediumSetPresentNumber: Set/get large set lower bound
1550  */
1551 static int do_mediumSetPresentNumber (void *o, Tcl_Interp *interp,
1552                                       int argc, char **argv)
1553 {
1554     IrTcl_SetCObj *p = o;
1555
1556     if (argc <= 0)
1557     {
1558         p->mediumSetPresentNumber = 0;
1559         return TCL_OK;
1560     }
1561     return ir_tcl_get_set_int (&p->mediumSetPresentNumber, interp, argc, argv);
1562 }
1563
1564 /*
1565  * do_referenceId: Set/Get referenceId
1566  */
1567 static int do_referenceId (void *obj, Tcl_Interp *interp,
1568                            int argc, char **argv)
1569 {
1570     IrTcl_SetCObj *p = obj;
1571
1572     if (argc == 0)
1573     {
1574         p->referenceId = NULL;
1575         return TCL_OK;
1576     }
1577     else if (argc == -1)
1578         return ir_tcl_strdel (interp, &p->referenceId);
1579     if (argc == 3)
1580     {
1581         xfree (p->referenceId);
1582         if (ir_tcl_strdup (interp, &p->referenceId, argv[2]) == TCL_ERROR)
1583             return TCL_ERROR;
1584     }
1585     Tcl_AppendResult (interp, p->referenceId, NULL);
1586     return TCL_OK;
1587 }
1588
1589 /*
1590  * do_preferredRecordSyntax: Set/get preferred record syntax
1591  */
1592 static int do_preferredRecordSyntax (void *obj, Tcl_Interp *interp,
1593                                      int argc, char **argv)
1594 {
1595     IrTcl_SetCObj *p = obj;
1596
1597     if (argc == 0)
1598     {
1599         p->preferredRecordSyntax = NULL;
1600         return TCL_OK;
1601     }
1602     else if (argc == -1)
1603     {
1604         xfree (p->preferredRecordSyntax);
1605         p->preferredRecordSyntax = NULL;
1606         return TCL_OK;
1607     }
1608     if (argc == 3)
1609     {
1610         xfree (p->preferredRecordSyntax);
1611         p->preferredRecordSyntax = NULL;
1612         if (argv[2][0] && (p->preferredRecordSyntax =
1613                            ir_tcl_malloc (sizeof(*p->preferredRecordSyntax))))
1614             *p->preferredRecordSyntax = IrTcl_getRecordSyntaxVal (argv[2]);
1615     }
1616     else if (argc == 2)
1617     {
1618         Tcl_AppendElement
1619             (interp,!p->preferredRecordSyntax ? "" :
1620              IrTcl_getRecordSyntaxStr(*p->preferredRecordSyntax));
1621     }
1622     return TCL_OK;
1623
1624 }
1625
1626 /*
1627  * do_elementSetNames: Set/Get element Set Names
1628  */
1629 static int do_elementSetNames (void *obj, Tcl_Interp *interp,
1630                                int argc, char **argv)
1631 {
1632     IrTcl_SetCObj *p = obj;
1633
1634     if (argc == 0)
1635     {
1636         p->elementSetNames = NULL;
1637         return TCL_OK;
1638     }
1639     else if (argc == -1)
1640         return ir_tcl_strdel (interp, &p->elementSetNames);
1641     if (argc == 3)
1642     {
1643         xfree (p->elementSetNames);
1644         if (ir_tcl_strdup (interp, &p->elementSetNames, argv[2]) == TCL_ERROR)
1645             return TCL_ERROR;
1646     }
1647     Tcl_AppendResult (interp, p->elementSetNames, NULL);
1648     return TCL_OK;
1649 }
1650
1651 /*
1652  * do_smallSetElementSetNames: Set/Get small Set Element Set Names
1653  */
1654 static int do_smallSetElementSetNames (void *obj, Tcl_Interp *interp,
1655                                int argc, char **argv)
1656 {
1657     IrTcl_SetCObj *p = obj;
1658
1659     if (argc == 0)
1660     {
1661         p->smallSetElementSetNames = NULL;
1662         return TCL_OK;
1663     }
1664     else if (argc == -1)
1665         return ir_tcl_strdel (interp, &p->smallSetElementSetNames);
1666     if (argc == 3)
1667     {
1668         xfree (p->smallSetElementSetNames);
1669         if (ir_tcl_strdup (interp, &p->smallSetElementSetNames,
1670                            argv[2]) == TCL_ERROR)
1671             return TCL_ERROR;
1672     }
1673     Tcl_AppendResult (interp, p->smallSetElementSetNames, NULL);
1674     return TCL_OK;
1675 }
1676
1677 /*
1678  * do_mediumSetElementSetNames: Set/Get medium Set Element Set Names
1679  */
1680 static int do_mediumSetElementSetNames (void *obj, Tcl_Interp *interp,
1681                                int argc, char **argv)
1682 {
1683     IrTcl_SetCObj *p = obj;
1684
1685     if (argc == 0)
1686     {
1687         p->mediumSetElementSetNames = NULL;
1688         return TCL_OK;
1689     }
1690     else if (argc == -1)
1691         return ir_tcl_strdel (interp, &p->mediumSetElementSetNames);
1692     if (argc == 3)
1693     {
1694         xfree (p->mediumSetElementSetNames);
1695         if (ir_tcl_strdup (interp, &p->mediumSetElementSetNames,
1696                            argv[2]) == TCL_ERROR)
1697             return TCL_ERROR;
1698     }
1699     Tcl_AppendResult (interp, p->mediumSetElementSetNames, NULL);
1700     return TCL_OK;
1701 }
1702
1703 static IrTcl_Method ir_method_tab[] = {
1704 { "comstack",                    do_comstack, NULL },
1705 { "protocol",                    do_protocol, NULL },
1706 { "failback",                    do_failback, NULL },
1707 { "failInfo",                    do_failInfo, NULL },
1708 { "apduInfo",                    do_apduInfo, NULL },
1709 { "logLevel",                    do_logLevel, NULL },
1710
1711 { "eventType",                   do_eventType, NULL },
1712 { "connect",                     do_connect, NULL },
1713 { "protocolVersion",             do_protocolVersion, NULL },
1714 { "preferredMessageSize",        do_preferredMessageSize, NULL },
1715 { "maximumRecordSize",           do_maximumRecordSize, NULL },
1716 { "implementationName",          do_implementationName, NULL },
1717 { "implementationId",            do_implementationId, NULL },
1718 { "implementationVersion",       do_implementationVersion, NULL },
1719 { "targetImplementationName",    do_targetImplementationName, NULL },
1720 { "targetImplementationId",      do_targetImplementationId, NULL },
1721 { "targetImplementationVersion", do_targetImplementationVersion, NULL},
1722 { "userInformationField",        do_userInformationField, NULL},
1723 { "idAuthentication",            do_idAuthentication, NULL},
1724 { "options",                     do_options, NULL},
1725 { "init",                        do_init_request, NULL},
1726 { "initResult",                  do_initResult, NULL},
1727 { "disconnect",                  do_disconnect, NULL},
1728 { "callback",                    do_callback, NULL},
1729 { "initResponse",                do_initResponse, NULL},
1730 { "triggerResourceControl",      do_triggerResourceControl, NULL},
1731 { "initResponse",                do_initResponse, NULL},
1732 { NULL, NULL}
1733 };
1734
1735 static IrTcl_Method ir_set_c_method_tab[] = {
1736 { "databaseNames",               do_databaseNames, NULL},
1737 { "replaceIndicator",            do_replaceIndicator, NULL},
1738 { "queryType",                   do_queryType, NULL},
1739 { "preferredRecordSyntax",       do_preferredRecordSyntax, NULL},
1740 { "smallSetUpperBound",          do_smallSetUpperBound, NULL},
1741 { "largeSetLowerBound",          do_largeSetLowerBound, NULL},
1742 { "mediumSetPresentNumber",      do_mediumSetPresentNumber, NULL},
1743 { "referenceId",                 do_referenceId, NULL},
1744 { "elementSetNames",             do_elementSetNames, NULL},
1745 { "smallSetElementSetNames",     do_smallSetElementSetNames, NULL},
1746 { "mediumSetElementSetNames",    do_mediumSetElementSetNames, NULL},
1747 { NULL, NULL}
1748 };
1749
1750 /*
1751  * ir_obj_method: IR Object methods
1752  */
1753 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
1754                           int argc, char **argv)
1755 {
1756     IrTcl_Methods tab[3];
1757     IrTcl_Obj *p = clientData;
1758     int r;
1759
1760     if (argc < 2)
1761         return TCL_ERROR;
1762
1763     tab[0].tab = ir_method_tab;
1764     tab[0].obj = p;
1765     tab[1].tab = ir_set_c_method_tab;
1766     tab[1].obj = &p->set_inher;
1767     tab[2].tab = NULL;
1768
1769     ir_tcl_method (interp, argc, argv, tab, &r);
1770     return r;
1771 }
1772
1773 /*
1774  * ir_obj_delete: IR Object disposal
1775  */
1776 static void ir_obj_delete (ClientData clientData)
1777 {
1778     IrTcl_Obj *obj = clientData;
1779     IrTcl_Methods tab[3];
1780
1781     --(obj->ref_count);
1782     if (obj->ref_count > 0)
1783         return;
1784     assert (obj->ref_count == 0);
1785
1786     logf (LOG_DEBUG, "ir object delete");
1787     tab[0].tab = ir_method_tab;
1788     tab[0].obj = obj;
1789     tab[1].tab = ir_set_c_method_tab;
1790     tab[1].obj = &obj->set_inher;
1791     tab[2].tab = NULL;
1792
1793     ir_tcl_method (NULL, -1, NULL, tab, NULL);
1794
1795     ir_tcl_del_q (obj);
1796     odr_destroy (obj->odr_in);
1797     odr_destroy (obj->odr_out);
1798     odr_destroy (obj->odr_pr);
1799     xfree (obj);
1800 }
1801
1802 /*
1803  * ir_obj_init: IR Object initialization
1804  */
1805 int ir_obj_init (ClientData clientData, Tcl_Interp *interp,
1806                  int argc, char **argv, ClientData *subData,
1807                  ClientData parentData)
1808 {
1809     IrTcl_Methods tab[3];
1810     IrTcl_Obj *obj;
1811 #if CCL2RPN
1812     FILE *inf;
1813 #endif
1814
1815     if (argc != 2)
1816     {
1817         interp->result = "wrong # args";
1818         return TCL_ERROR;
1819     }
1820     obj = ir_tcl_malloc (sizeof(*obj));
1821     obj->ref_count = 1;
1822 #if CCL2RPN
1823     obj->bibset = ccl_qual_mk ();
1824     if ((inf = fopen ("default.bib", "r")))
1825     {
1826         ccl_qual_file (obj->bibset, inf);
1827         fclose (inf);
1828     }
1829 #endif
1830
1831     logf (LOG_DEBUG, "ir object create %s", argv[1]);
1832     obj->odr_in = odr_createmem (ODR_DECODE);
1833     obj->odr_out = odr_createmem (ODR_ENCODE);
1834     obj->odr_pr = odr_createmem (ODR_PRINT);
1835     obj->state = IR_TCL_R_Idle;
1836     obj->interp = interp;
1837
1838     obj->len_in = 0;
1839     obj->buf_in = NULL;
1840     obj->request_queue = NULL;
1841
1842     tab[0].tab = ir_method_tab;
1843     tab[0].obj = obj;
1844     tab[1].tab = ir_set_c_method_tab;
1845     tab[1].obj = &obj->set_inher;
1846     tab[2].tab = NULL;
1847
1848     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
1849     {
1850         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
1851         return TCL_ERROR;
1852     }
1853     *subData = obj;
1854     return TCL_OK;
1855 }
1856
1857
1858 /*
1859  * ir_obj_mk: IR Object creation
1860  */
1861 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
1862                       int argc, char **argv)
1863 {
1864     ClientData subData;
1865     int r = ir_obj_init (clientData, interp, argc, argv, &subData, 0);
1866
1867     if (r == TCL_ERROR)
1868         return TCL_ERROR;
1869     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
1870                        subData, ir_obj_delete);
1871     return TCL_OK;
1872 }
1873
1874 IrTcl_Class ir_obj_class = {
1875     "ir",
1876     ir_obj_init,
1877     ir_obj_method,
1878     ir_obj_delete
1879 };
1880
1881
1882 /* ------------------------------------------------------- */
1883 /*
1884  * do_search: Do search request
1885  */
1886 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
1887 {
1888     Z_SearchRequest *req;
1889     Z_Query query;
1890     Z_APDU *apdu;
1891     Odr_oct ccl_query;
1892     IrTcl_SetObj *obj = o;
1893     IrTcl_Obj *p;
1894     int r;
1895
1896     if (argc <= 0)
1897         return TCL_OK;
1898
1899     p = obj->parent;
1900     if (argc != 3)
1901     {
1902         logf (LOG_DEBUG, "search %s", *argv);
1903         interp->result = "wrong # args";
1904         return TCL_ERROR;
1905     }
1906     logf (LOG_DEBUG, "search %s %s", *argv, argv[2]);
1907     if (!obj->set_inher.num_databaseNames)
1908     {
1909         interp->result = "no databaseNames";
1910         return TCL_ERROR;
1911     }
1912     if (!p->cs_link)
1913     {
1914         interp->result = "search: not connected";
1915         return TCL_ERROR;
1916     }
1917     apdu = zget_APDU (p->odr_out, Z_APDU_searchRequest);
1918     req = apdu->u.searchRequest;
1919
1920     obj->start = 1;
1921
1922     set_referenceId (p->odr_out, &req->referenceId,
1923                      obj->set_inher.referenceId);
1924
1925     req->smallSetUpperBound = &obj->set_inher.smallSetUpperBound;
1926     req->largeSetLowerBound = &obj->set_inher.largeSetLowerBound;
1927     req->mediumSetPresentNumber = &obj->set_inher.mediumSetPresentNumber;
1928     req->replaceIndicator = &obj->set_inher.replaceIndicator;
1929     req->resultSetName = obj->setName ? obj->setName : "Default";
1930     logf (LOG_DEBUG, "Search, resultSetName %s", req->resultSetName);
1931     req->num_databaseNames = obj->set_inher.num_databaseNames;
1932     req->databaseNames = obj->set_inher.databaseNames;
1933     for (r=0; r < obj->set_inher.num_databaseNames; r++)
1934         logf (LOG_DEBUG, " Database %s", obj->set_inher.databaseNames[r]);
1935     if (obj->set_inher.preferredRecordSyntax)
1936     {
1937         struct oident ident;
1938
1939         ident.proto = p->protocol_type;
1940         ident.oclass = CLASS_RECSYN;
1941         ident.value = *obj->set_inher.preferredRecordSyntax;
1942         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
1943         req->preferredRecordSyntax = odr_oiddup (p->odr_out,
1944                                                  oid_getoidbyent (&ident));
1945     }
1946     else
1947         req->preferredRecordSyntax = 0;
1948
1949     if (obj->set_inher.smallSetElementSetNames &&
1950         *obj->set_inher.smallSetElementSetNames)
1951     {
1952         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
1953
1954         esn->which = Z_ElementSetNames_generic;
1955         esn->u.generic = obj->set_inher.smallSetElementSetNames;
1956         req->smallSetElementSetNames = esn;
1957     }
1958     else
1959         req->smallSetElementSetNames = NULL;
1960
1961     if (obj->set_inher.mediumSetElementSetNames &&
1962         *obj->set_inher.mediumSetElementSetNames)
1963     {
1964         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
1965
1966         esn->which = Z_ElementSetNames_generic;
1967         esn->u.generic = obj->set_inher.mediumSetElementSetNames;
1968         req->mediumSetElementSetNames = esn;
1969     }
1970     else
1971         req->mediumSetElementSetNames = NULL;
1972
1973     req->query = &query;
1974
1975     logf (LOG_DEBUG, "queryType %s", obj->set_inher.queryType);
1976     if (!strcmp (obj->set_inher.queryType, "rpn"))
1977     {
1978         Z_RPNQuery *RPNquery;
1979
1980         RPNquery = p_query_rpn (p->odr_out, p->protocol_type, argv[2]);
1981         if (!RPNquery)
1982         {
1983             Tcl_AppendResult (interp, "Syntax error in query", NULL);
1984             return TCL_ERROR;
1985         }
1986         query.which = Z_Query_type_1;
1987         query.u.type_1 = RPNquery;
1988     }
1989 #if CCL2RPN
1990     else if (!strcmp (obj->set_inher.queryType, "cclrpn"))
1991     {
1992         int error;
1993         int pos;
1994         struct ccl_rpn_node *rpn;
1995         Z_RPNQuery *RPNquery;
1996         oident bib1;
1997
1998         bib1.proto = p->protocol_type;
1999         bib1.oclass = CLASS_ATTSET;
2000         bib1.value = VAL_BIB1;
2001
2002         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
2003         if (error)
2004         {
2005             Tcl_AppendResult (interp, "CCL error: ",
2006                               ccl_err_msg(error), NULL);
2007             return TCL_ERROR;
2008         }
2009 #if 0
2010         ccl_pr_tree (rpn, stderr);
2011         fprintf (stderr, "\n");
2012 #endif
2013         assert((RPNquery = ccl_rpn_query(rpn)));
2014         RPNquery->attributeSetId = oid_getoidbyent (&bib1);
2015         query.which = Z_Query_type_1;
2016         query.u.type_1 = RPNquery;
2017     }
2018 #endif
2019     else if (!strcmp (obj->set_inher.queryType, "ccl"))
2020     {
2021         query.which = Z_Query_type_2;
2022         query.u.type_2 = &ccl_query;
2023         ccl_query.buf = (unsigned char *) argv[2];
2024         ccl_query.len = strlen (argv[2]);
2025     }
2026     else
2027     {
2028         interp->result = "unknown query method";
2029         return TCL_ERROR;
2030     }
2031     return ir_tcl_send_APDU (interp, p, apdu, "search", *argv);
2032 }
2033
2034 /*
2035  * do_searchResponse: add search response handler
2036  */
2037 static int do_searchResponse (void *o, Tcl_Interp *interp,
2038                               int argc, char **argv)
2039 {
2040     IrTcl_SetObj *obj = o;
2041
2042     if (argc == 0)
2043     {
2044         obj->searchResponse = NULL;
2045         return TCL_OK;
2046     }
2047     else if (argc == -1)
2048         return ir_tcl_strdel (interp, &obj->searchResponse);
2049     if (argc == 3)
2050     {
2051         xfree (obj->searchResponse);
2052         if (argv[2][0])
2053         {
2054             if (ir_tcl_strdup (interp, &obj->searchResponse, argv[2])
2055                 == TCL_ERROR)
2056                 return TCL_ERROR;
2057         }
2058         else
2059             obj->searchResponse = NULL;
2060     }
2061     return TCL_OK;
2062 }
2063
2064 /*
2065  * do_presentResponse: add present response handler
2066  */
2067 static int do_presentResponse (void *o, Tcl_Interp *interp,
2068                                int argc, char **argv)
2069 {
2070     IrTcl_SetObj *obj = o;
2071
2072     if (argc == 0)
2073     {
2074         obj->presentResponse = NULL;
2075         return TCL_OK;
2076     }
2077     else if (argc == -1)
2078         return ir_tcl_strdel (interp, &obj->presentResponse);
2079     if (argc == 3)
2080     {
2081         xfree (obj->presentResponse);
2082         if (argv[2][0])
2083         {
2084             if (ir_tcl_strdup (interp, &obj->presentResponse, argv[2])
2085                 == TCL_ERROR)
2086                 return TCL_ERROR;
2087         }
2088         else
2089             obj->presentResponse = NULL;
2090     }
2091     return TCL_OK;
2092 }
2093
2094 /*
2095  * do_resultCount: Get number of hits
2096  */
2097 static int do_resultCount (void *o, Tcl_Interp *interp,
2098                        int argc, char **argv)
2099 {
2100     IrTcl_SetObj *obj = o;
2101
2102     if (argc <= 0)
2103     {
2104         obj->resultCount = 0;
2105         return TCL_OK;
2106     }
2107     return ir_tcl_get_set_int (&obj->resultCount, interp, argc, argv);
2108 }
2109
2110 /*
2111  * do_searchStatus: Get search status (after search response)
2112  */
2113 static int do_searchStatus (void *o, Tcl_Interp *interp,
2114                             int argc, char **argv)
2115 {
2116     IrTcl_SetObj *obj = o;
2117
2118     if (argc <= 0)
2119         return TCL_OK;
2120     return ir_tcl_get_set_int (&obj->searchStatus, interp, argc, argv);
2121 }
2122
2123 /*
2124  * do_presentStatus: Get search status (after search/present response)
2125  */
2126 static int do_presentStatus (void *o, Tcl_Interp *interp,
2127                             int argc, char **argv)
2128 {
2129     IrTcl_SetObj *obj = o;
2130
2131     if (argc <= 0)
2132         return TCL_OK;
2133     return ir_tcl_get_set_int (&obj->presentStatus, interp, argc, argv);
2134 }
2135
2136 /*
2137  * do_nextResultSetPosition: Get next result set position
2138  *       (after search/present response)
2139  */
2140 static int do_nextResultSetPosition (void *o, Tcl_Interp *interp,
2141                                      int argc, char **argv)
2142 {
2143     IrTcl_SetObj *obj = o;
2144
2145     if (argc <= 0)
2146     {
2147         obj->nextResultSetPosition = 0;
2148         return TCL_OK;
2149     }
2150     return ir_tcl_get_set_int (&obj->nextResultSetPosition, interp,
2151                                argc, argv);
2152 }
2153
2154 /*
2155  * do_setName: Set result Set name
2156  */
2157 static int do_setName (void *o, Tcl_Interp *interp,
2158                        int argc, char **argv)
2159 {
2160     IrTcl_SetObj *obj = o;
2161
2162     if (argc == 0)
2163         return ir_tcl_strdup (interp, &obj->setName, "Default");
2164     else if (argc == -1)
2165         return ir_tcl_strdel (interp, &obj->setName);
2166     if (argc == 3)
2167     {
2168         xfree (obj->setName);
2169         if (ir_tcl_strdup (interp, &obj->setName, argv[2])
2170             == TCL_ERROR)
2171             return TCL_ERROR;
2172     }
2173     Tcl_AppendElement (interp, obj->setName);
2174     return TCL_OK;
2175 }
2176
2177 /*
2178  * do_numberOfRecordsReturned: Get number of records returned
2179  */
2180 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
2181                                        int argc, char **argv)
2182 {
2183     IrTcl_SetObj *obj = o;
2184
2185     if (argc <= 0)
2186     {
2187         obj->numberOfRecordsReturned = 0;
2188         return TCL_OK;
2189     }
2190     return ir_tcl_get_set_int (&obj->numberOfRecordsReturned, interp,
2191                                argc, argv);
2192 }
2193
2194 /*
2195  * do_type: Return type (if any) at position.
2196  */
2197 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)
2198 {
2199     IrTcl_SetObj *obj = o;
2200     int offset;
2201     IrTcl_RecordList *rl;
2202
2203     if (argc == 0)
2204     {
2205         obj->record_list = NULL;
2206         return TCL_OK;
2207     }
2208     else if (argc == -1)
2209     {
2210         delete_IR_records (obj);
2211         return TCL_OK;
2212     }
2213     if (argc != 3)
2214     {
2215         sprintf (interp->result, "wrong # args");
2216         return TCL_ERROR;
2217     }
2218     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2219         return TCL_ERROR;
2220     rl = find_IR_record (obj, offset);
2221     if (!rl)
2222     {
2223         logf (LOG_DEBUG, "No record at position %d", offset);
2224         return TCL_OK;
2225     }
2226     switch (rl->which)
2227     {
2228     case Z_NamePlusRecord_databaseRecord:
2229         interp->result = "DB";
2230         break;
2231     case Z_NamePlusRecord_surrogateDiagnostic:
2232         interp->result = "SD";
2233         break;
2234     }
2235     return TCL_OK;
2236 }
2237
2238
2239 /*
2240  * do_recordType: Return record type (if any) at position.
2241  */
2242 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
2243 {
2244     IrTcl_SetObj *obj = o;
2245     int offset;
2246     IrTcl_RecordList *rl;
2247
2248     if (argc == 0)
2249     {
2250         return TCL_OK;
2251     }
2252     else if (argc == -1)
2253     {
2254         return TCL_OK;
2255     }
2256     if (argc != 3)
2257     {
2258         sprintf (interp->result, "wrong # args");
2259         return TCL_ERROR;
2260     }
2261     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2262         return TCL_ERROR;
2263     rl = find_IR_record (obj, offset);
2264     if (!rl)
2265         return TCL_OK;
2266     if (rl->which != Z_NamePlusRecord_databaseRecord)
2267     {
2268         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2269         return TCL_ERROR;
2270     }
2271     Tcl_AppendElement (interp, (char*)
2272                        IrTcl_getRecordSyntaxStr (rl->u.dbrec.type));
2273     return TCL_OK;
2274 }
2275
2276 /*
2277  * set record elements (for record extraction)
2278  */
2279 static int do_recordElements (void *o, Tcl_Interp *interp,
2280                               int argc, char **argv)
2281 {
2282     IrTcl_SetObj *obj = o;
2283
2284     if (argc == 0)
2285     {
2286         obj->recordElements = NULL;
2287         return TCL_OK;
2288     }
2289     else if (argc == -1)
2290         return ir_tcl_strdel (NULL, &obj->recordElements);
2291     if (argc > 3)
2292     {
2293         sprintf (interp->result, "wrong # args");
2294         return TCL_ERROR;
2295     }
2296     if (argc == 3)
2297     {
2298         xfree (obj->recordElements);
2299         return ir_tcl_strdup (NULL, &obj->recordElements,
2300                               (*argv[2] ? argv[2] : NULL));
2301     }
2302     Tcl_AppendResult (interp, obj->recordElements, NULL);
2303     return TCL_OK;
2304 }
2305
2306 /*
2307  * ir_diagResult
2308  */
2309 static int ir_diagResult (Tcl_Interp *interp, IrTcl_Diagnostic *list, int num)
2310 {
2311     char buf[20];
2312     int i;
2313     const char *cp;
2314
2315     for (i = 0; i<num; i++)
2316     {
2317         sprintf (buf, "%d", list[i].condition);
2318         Tcl_AppendElement (interp, buf);
2319         cp = diagbib1_str (list[i].condition);
2320         if (cp)
2321             Tcl_AppendElement (interp, (char*) cp);
2322         else
2323             Tcl_AppendElement (interp, "");
2324         if (list[i].addinfo)
2325             Tcl_AppendElement (interp, (char*) list[i].addinfo);
2326         else
2327             Tcl_AppendElement (interp, "");
2328     }
2329     return TCL_OK;
2330 }
2331
2332 /*
2333  * do_diag: Return diagnostic record info
2334  */
2335 static int do_diag (void *o, Tcl_Interp *interp, int argc, char **argv)
2336 {
2337     IrTcl_SetObj *obj = o;
2338     int offset;
2339     IrTcl_RecordList *rl;
2340
2341     if (argc <= 0)
2342         return TCL_OK;
2343     if (argc != 3)
2344     {
2345         sprintf (interp->result, "wrong # args");
2346         return TCL_ERROR;
2347     }
2348     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2349         return TCL_ERROR;
2350     rl = find_IR_record (obj, offset);
2351     if (!rl)
2352     {
2353         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2354         return TCL_ERROR;
2355     }
2356     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
2357     {
2358         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
2359         return TCL_ERROR;
2360     }
2361     return ir_diagResult (interp, rl->u.surrogateDiagnostics.list,
2362                           rl->u.surrogateDiagnostics.num);
2363 }
2364
2365 /*
2366  * do_getMarc: Get ISO2709 Record lines/fields
2367  */
2368 static int do_getMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
2369 {
2370     IrTcl_SetObj *obj = o;
2371     int offset;
2372     IrTcl_RecordList *rl;
2373
2374     if (argc <= 0)
2375         return TCL_OK;
2376     if (argc < 7)
2377     {
2378         sprintf (interp->result, "wrong # args");
2379         return TCL_ERROR;
2380     }
2381     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2382         return TCL_ERROR;
2383     rl = find_IR_record (obj, offset);
2384     if (!rl)
2385     {
2386         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2387         return TCL_ERROR;
2388     }
2389     if (rl->which != Z_NamePlusRecord_databaseRecord)
2390     {
2391         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2392         return TCL_ERROR;
2393     }
2394     return ir_tcl_get_marc (interp, rl->u.dbrec.buf, argc, argv);
2395 }
2396
2397 /*
2398  * do_getSutrs: Get SUTRS Record
2399  */
2400 static int do_getSutrs (void *o, Tcl_Interp *interp, int argc, char **argv)
2401 {
2402     IrTcl_SetObj *obj = o;
2403     int offset;
2404     IrTcl_RecordList *rl;
2405
2406     if (argc <= 0)
2407         return TCL_OK;
2408     if (argc != 3)
2409     {
2410         sprintf (interp->result, "wrong # args");
2411         return TCL_ERROR;
2412     }
2413     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2414         return TCL_ERROR;
2415     rl = find_IR_record (obj, offset);
2416     if (!rl)
2417     {
2418         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2419         return TCL_ERROR;
2420     }
2421     if (rl->which != Z_NamePlusRecord_databaseRecord)
2422     {
2423         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2424         return TCL_ERROR;
2425     }
2426     if (rl->u.dbrec.type != VAL_SUTRS)
2427         return TCL_OK;
2428     Tcl_AppendElement (interp, rl->u.dbrec.buf);
2429     return TCL_OK;
2430 }
2431
2432
2433 /*
2434  * do_getGrs: Get a GRS-1 Record
2435  */
2436 static int do_getGrs (void *o, Tcl_Interp *interp, int argc, char **argv)
2437 {
2438     IrTcl_SetObj *obj = o;
2439     int offset;
2440     IrTcl_RecordList *rl;
2441
2442     if (argc <= 0)
2443         return TCL_OK;
2444     if (argc < 3)
2445     {
2446         sprintf (interp->result, "wrong # args");
2447         return TCL_ERROR;
2448     }
2449     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2450         return TCL_ERROR;
2451     rl = find_IR_record (obj, offset);
2452     if (!rl)
2453     {
2454         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2455         return TCL_ERROR;
2456     }
2457     if (rl->which != Z_NamePlusRecord_databaseRecord)
2458     {
2459         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2460         return TCL_ERROR;
2461     }
2462     if (rl->u.dbrec.type != VAL_GRS1)
2463         return TCL_OK;
2464     return ir_tcl_get_grs (interp, rl->u.dbrec.u.grs1, argc, argv);
2465 }
2466
2467
2468 /*
2469  * do_getExplain: Get an Explain Record
2470  */
2471 static int do_getExplain (void *o, Tcl_Interp *interp, int argc, char **argv)
2472 {
2473     IrTcl_SetObj *obj = o;
2474     IrTcl_Obj *p = obj->parent;
2475     void *rr;
2476     Z_ext_typeent *etype;
2477     int offset;
2478     IrTcl_RecordList *rl;
2479
2480     if (argc <= 0)
2481         return TCL_OK;
2482     if (argc < 3)
2483     {
2484         sprintf (interp->result, "wrong # args");
2485         return TCL_ERROR;
2486     }
2487     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
2488         return TCL_ERROR;
2489     rl = find_IR_record (obj, offset);
2490     if (!rl)
2491     {
2492         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
2493         return TCL_ERROR;
2494     }
2495     if (rl->which != Z_NamePlusRecord_databaseRecord)
2496     {
2497         Tcl_AppendResult (interp, "No DB record at #", argv[2], NULL);
2498         return TCL_ERROR;
2499     }
2500     if (rl->u.dbrec.type != VAL_EXPLAIN)
2501         return TCL_OK;
2502
2503     if (!(etype = z_ext_getentbyref (VAL_EXPLAIN)))
2504         return TCL_OK;
2505
2506     odr_setbuf (p->odr_in, rl->u.dbrec.buf, rl->u.dbrec.size, 0);
2507     if (!(*etype->fun)(p->odr_in, &rr, 0))
2508         return TCL_OK;
2509
2510     if (etype->what != Z_External_explainRecord)
2511         return TCL_OK;
2512
2513     return ir_tcl_get_explain (interp, rr, argc, argv);
2514 }
2515
2516 /*
2517  * do_responseStatus: Return response status (present or search)
2518  */
2519 static int do_responseStatus (void *o, Tcl_Interp *interp,
2520                              int argc, char **argv)
2521 {
2522     IrTcl_SetObj *obj = o;
2523
2524     if (argc == 0)
2525     {
2526         obj->recordFlag = 0;
2527         obj->nonSurrogateDiagnosticNum = 0;
2528         obj->nonSurrogateDiagnosticList = NULL;
2529         return TCL_OK;
2530     }
2531     else if (argc == -1)
2532     {
2533         ir_deleteDiags (&obj->nonSurrogateDiagnosticList,
2534                         &obj->nonSurrogateDiagnosticNum);
2535         return TCL_OK;
2536     }
2537     if (!obj->recordFlag)
2538     {
2539         Tcl_AppendElement (interp, "OK");
2540         return TCL_OK;
2541     }
2542     switch (obj->which)
2543     {
2544     case Z_Records_DBOSD:
2545         Tcl_AppendElement (interp, "DBOSD");
2546         break;
2547     case Z_Records_NSD:
2548         Tcl_AppendElement (interp, "NSD");
2549         return ir_diagResult (interp, obj->nonSurrogateDiagnosticList,
2550                               obj->nonSurrogateDiagnosticNum);
2551     }
2552     return TCL_OK;
2553 }
2554
2555 /*
2556  * do_present: Perform Present Request
2557  */
2558
2559 static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv)
2560 {
2561     IrTcl_SetObj *obj = o;
2562     IrTcl_Obj *p;
2563     Z_APDU *apdu;
2564     Z_PresentRequest *req;
2565     int start;
2566     int number;
2567
2568     if (argc <= 0)
2569         return TCL_OK;
2570     if (argc >= 3)
2571     {
2572         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
2573             return TCL_ERROR;
2574     }
2575     else
2576         start = 1;
2577     if (argc >= 4)
2578     {
2579         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
2580             return TCL_ERROR;
2581     }
2582     else
2583         number = 10;
2584     logf (LOG_DEBUG, "present %s %d %d", *argv, start, number);
2585     p = obj->parent;
2586     if (!p->cs_link)
2587     {
2588         interp->result = "present: not connected";
2589         return TCL_ERROR;
2590     }
2591
2592     obj->start = start;
2593     obj->number = number;
2594
2595     apdu = zget_APDU (p->odr_out, Z_APDU_presentRequest);
2596     req = apdu->u.presentRequest;
2597
2598     set_referenceId (p->odr_out, &req->referenceId,
2599                      obj->set_inher.referenceId);
2600
2601     req->resultSetId = obj->setName ? obj->setName : "Default";
2602
2603     req->resultSetStartPoint = &start;
2604     req->numberOfRecordsRequested = &number;
2605     if (obj->set_inher.preferredRecordSyntax)
2606     {
2607         struct oident ident;
2608
2609         ident.proto = p->protocol_type;
2610         ident.oclass = CLASS_RECSYN;
2611         ident.value = *obj->set_inher.preferredRecordSyntax;
2612         logf (LOG_DEBUG, "Preferred record syntax is %d", ident.value);
2613         req->preferredRecordSyntax = odr_oiddup (p->odr_out,
2614                                                  oid_getoidbyent (&ident));
2615     }
2616     else
2617         req->preferredRecordSyntax = 0;
2618
2619     if (obj->set_inher.elementSetNames && *obj->set_inher.elementSetNames)
2620     {
2621         Z_ElementSetNames *esn = odr_malloc (p->odr_out, sizeof(*esn));
2622         Z_RecordComposition *compo = odr_malloc (p->odr_out, sizeof(*compo));
2623
2624         esn->which = Z_ElementSetNames_generic;
2625         esn->u.generic = obj->set_inher.elementSetNames;
2626
2627         req->recordComposition = compo;
2628         compo->which = Z_RecordComp_simple;
2629         compo->u.simple = esn;
2630     }
2631     else
2632         req->recordComposition = NULL;
2633     return ir_tcl_send_APDU (interp, p, apdu, "present", *argv);
2634 }
2635
2636 /*
2637  * do_loadFile: Load result set from file
2638  */
2639
2640 static int do_loadFile (void *o, Tcl_Interp *interp,
2641                         int argc, char **argv)
2642 {
2643     IrTcl_SetObj *setobj = o;
2644     FILE *inf;
2645     size_t size;
2646     int  no = 1;
2647     char *buf;
2648
2649     if (argc <= 0)
2650         return TCL_OK;
2651     if (argc != 3)
2652     {
2653         interp->result = "wrong # args";
2654         return TCL_ERROR;
2655     }
2656     inf = fopen (argv[2], "r");
2657     if (!inf)
2658     {
2659         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
2660         return TCL_ERROR;
2661     }
2662     while ((buf = ir_tcl_fread_marc (inf, &size)))
2663     {
2664         IrTcl_RecordList *rl;
2665
2666         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord, "F");
2667         rl->u.dbrec.type = VAL_USMARC;
2668         rl->u.dbrec.buf = buf;
2669         rl->u.dbrec.size = size;
2670         no++;
2671     }
2672     setobj->numberOfRecordsReturned = no-1;
2673     fclose (inf);
2674     return TCL_OK;
2675 }
2676
2677 static IrTcl_Method ir_set_method_tab[] = {
2678     { "search",                  do_search, NULL},
2679     { "searchResponse",          do_searchResponse, NULL},
2680     { "presentResponse",         do_presentResponse, NULL},
2681     { "searchStatus",            do_searchStatus, NULL},
2682     { "presentStatus",           do_presentStatus, NULL},
2683     { "nextResultSetPosition",   do_nextResultSetPosition, NULL},
2684     { "setName",                 do_setName, NULL},
2685     { "resultCount",             do_resultCount, NULL},
2686     { "numberOfRecordsReturned", do_numberOfRecordsReturned, NULL},
2687     { "present",                 do_present, NULL},
2688     { "type",                    do_type, NULL},
2689     { "getMarc",                 do_getMarc, NULL},
2690     { "getSutrs",                do_getSutrs, NULL},
2691     { "getGrs",                  do_getGrs, NULL},
2692     { "getExplain",              do_getExplain, NULL},
2693     { "recordType",              do_recordType, NULL},
2694     { "recordElements",          do_recordElements, NULL},
2695     { "diag",                    do_diag, NULL},
2696     { "responseStatus",          do_responseStatus, NULL},
2697     { "loadFile",                do_loadFile, NULL},
2698     { NULL, NULL}
2699 };
2700
2701 /*
2702  * ir_set_obj_method: IR Set Object methods
2703  */
2704 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
2705                           int argc, char **argv)
2706 {
2707     IrTcl_Methods tabs[3];
2708     IrTcl_SetObj *p = clientData;
2709     int r;
2710
2711     if (argc < 2)
2712     {
2713         interp->result = "wrong # args";
2714         return TCL_ERROR;
2715     }
2716     tabs[0].tab = ir_set_method_tab;
2717     tabs[0].obj = p;
2718     tabs[1].tab = ir_set_c_method_tab;
2719     tabs[1].obj = &p->set_inher;
2720     tabs[2].tab = NULL;
2721
2722     ir_tcl_method (interp, argc, argv, tabs, &r);
2723     return r;
2724 }
2725
2726 /*
2727  * ir_set_obj_delete: IR Set Object disposal
2728  */
2729 static void ir_set_obj_delete (ClientData clientData)
2730 {
2731     IrTcl_Methods tabs[3];
2732     IrTcl_SetObj *p = clientData;
2733
2734     logf (LOG_DEBUG, "ir set delete");
2735
2736     tabs[0].tab = ir_set_method_tab;
2737     tabs[0].obj = p;
2738     tabs[1].tab = ir_set_c_method_tab;
2739     tabs[1].obj = &p->set_inher;
2740     tabs[2].tab = NULL;
2741
2742     ir_tcl_method (NULL, -1, NULL, tabs, NULL);
2743
2744     xfree (p);
2745 }
2746
2747 /*
2748  * ir_set_obj_init: IR Set Object initialization
2749  */
2750 static int ir_set_obj_init (ClientData clientData, Tcl_Interp *interp,
2751                             int argc, char **argv, ClientData *subData,
2752                             ClientData parentData)
2753 {
2754     IrTcl_Methods tabs[3];
2755     IrTcl_SetObj *obj;
2756
2757     if (argc < 2 || argc > 3)
2758     {
2759         interp->result = "wrong # args";
2760         return TCL_ERROR;
2761     }
2762     obj = ir_tcl_malloc (sizeof(*obj));
2763     logf (LOG_DEBUG, "ir set create %s", argv[1]);
2764     if (parentData)
2765     {
2766         int i;
2767         IrTcl_SetCObj *dst;
2768         IrTcl_SetCObj *src;
2769
2770         obj->parent = (IrTcl_Obj *) parentData;
2771
2772         dst = &obj->set_inher;
2773         src = &obj->parent->set_inher;
2774
2775         if ((dst->num_databaseNames = src->num_databaseNames))
2776         {
2777             dst->databaseNames =
2778                 ir_tcl_malloc (sizeof (*dst->databaseNames)
2779                                * (1+dst->num_databaseNames));
2780             for (i = 0; i < dst->num_databaseNames; i++)
2781                 if (ir_tcl_strdup (interp, &dst->databaseNames[i],
2782                                    src->databaseNames[i]) == TCL_ERROR)
2783                     return TCL_ERROR;
2784             dst->databaseNames[i] = NULL;
2785         }
2786         else
2787             dst->databaseNames = NULL;
2788         if (ir_tcl_strdup (interp, &dst->queryType, src->queryType)
2789             == TCL_ERROR)
2790             return TCL_ERROR;
2791
2792         if (ir_tcl_strdup (interp, &dst->referenceId, src->referenceId)
2793             == TCL_ERROR)
2794             return TCL_ERROR;
2795
2796         if (ir_tcl_strdup (interp, &dst->elementSetNames, src->elementSetNames)
2797             == TCL_ERROR)
2798             return TCL_ERROR;
2799
2800         if (ir_tcl_strdup (interp, &dst->smallSetElementSetNames,
2801                            src->smallSetElementSetNames)
2802             == TCL_ERROR)
2803             return TCL_ERROR;
2804
2805         if (ir_tcl_strdup (interp, &dst->mediumSetElementSetNames,
2806                            src->mediumSetElementSetNames)
2807             == TCL_ERROR)
2808             return TCL_ERROR;
2809
2810         if (src->preferredRecordSyntax &&
2811             (dst->preferredRecordSyntax
2812              = ir_tcl_malloc (sizeof(*dst->preferredRecordSyntax))))
2813             *dst->preferredRecordSyntax = *src->preferredRecordSyntax;
2814         else
2815             dst->preferredRecordSyntax = NULL;
2816         dst->replaceIndicator = src->replaceIndicator;
2817         dst->smallSetUpperBound = src->smallSetUpperBound;
2818         dst->largeSetLowerBound = src->largeSetLowerBound;
2819         dst->mediumSetPresentNumber = src->mediumSetPresentNumber;
2820     }
2821     else
2822         obj->parent = NULL;
2823
2824     tabs[0].tab = ir_set_method_tab;
2825     tabs[0].obj = obj;
2826     tabs[1].tab = NULL;
2827
2828     if (ir_tcl_method (interp, 0, NULL, tabs, NULL) == TCL_ERROR)
2829         return TCL_ERROR;
2830
2831     *subData = obj;
2832     return TCL_OK;
2833 }
2834
2835 /*
2836  * ir_set_obj_mk: IR Set Object creation
2837  */
2838 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
2839                           int argc, char **argv)
2840 {
2841     ClientData subData;
2842     ClientData parentData = 0;
2843     int r;
2844
2845     if (argc == 3)
2846     {
2847         Tcl_CmdInfo parent_info;
2848         if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
2849         {
2850             interp->result = "No parent";
2851             return TCL_ERROR;
2852         }
2853         parentData = parent_info.clientData;
2854     }
2855     r = ir_set_obj_init (clientData, interp, argc, argv, &subData, parentData);
2856     if (r == TCL_ERROR)
2857         return TCL_ERROR;
2858     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
2859                        subData, ir_set_obj_delete);
2860     return TCL_OK;
2861 }
2862
2863 IrTcl_Class ir_set_obj_class = {
2864     "ir-set",
2865     ir_set_obj_init,
2866     ir_set_obj_method,
2867     ir_set_obj_delete
2868 };
2869
2870 /* ------------------------------------------------------- */
2871
2872 /*
2873  * do_scan: Perform scan
2874  */
2875 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
2876 {
2877     Z_ScanRequest *req;
2878     Z_APDU *apdu;
2879     IrTcl_ScanObj *obj = o;
2880     IrTcl_Obj *p = obj->parent;
2881 #if CCL2RPN
2882     oident bib1;
2883     struct ccl_rpn_node *rpn;
2884     int pos;
2885 #endif
2886
2887     if (argc <= 0)
2888         return TCL_OK;
2889     if (argc != 3)
2890     {
2891         interp->result = "wrong # args";
2892         return TCL_ERROR;
2893     }
2894     logf (LOG_DEBUG, "scan %s %s", *argv, argv[2]);
2895     if (!p->set_inher.num_databaseNames)
2896     {
2897         interp->result = "no databaseNames";
2898         return TCL_ERROR;
2899     }
2900     if (!p->cs_link)
2901     {
2902         interp->result = "scan: not connected";
2903         return TCL_ERROR;
2904     }
2905
2906     apdu = zget_APDU (p->odr_out, Z_APDU_scanRequest);
2907     req = apdu->u.scanRequest;
2908
2909     set_referenceId (p->odr_out, &req->referenceId, p->set_inher.referenceId);
2910     req->num_databaseNames = p->set_inher.num_databaseNames;
2911     req->databaseNames = p->set_inher.databaseNames;
2912
2913 #if !CCL2RPN
2914     if (!(req->termListAndStartPoint =
2915           p_query_scan (p->odr_out, p->protocol_type,
2916                         &req->attributeSet, argv[2])))
2917     {
2918         Tcl_AppendResult (interp, "Syntax error in query", NULL);
2919         return TCL_ERROR;
2920     }
2921 #else
2922     rpn = ccl_find_str(p->bibset, argv[2], &r, &pos);
2923     if (r)
2924     {
2925         Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg (r), NULL);
2926         return TCL_ERROR;
2927     }
2928     bib1.proto = p->protocol_type;
2929     bib1.oclass = CLASS_ATTSET;
2930     bib1.value = VAL_BIB1;
2931
2932     req->attributeSet = oid_getoidbyent (&bib1);
2933     if (!(req->termListAndStartPoint = ccl_scan_query (rpn)))
2934         return TCL_ERROR;
2935 #endif
2936     req->stepSize = &obj->stepSize;
2937     req->numberOfTermsRequested = &obj->numberOfTermsRequested;
2938     req->preferredPositionInResponse = &obj->preferredPositionInResponse;
2939     logf (LOG_DEBUG, "stepSize=%d", *req->stepSize);
2940     logf (LOG_DEBUG, "numberOfTermsRequested=%d",
2941           *req->numberOfTermsRequested);
2942     logf (LOG_DEBUG, "preferredPositionInResponse=%d",
2943           *req->preferredPositionInResponse);
2944
2945     return ir_tcl_send_APDU (interp, p, apdu, "scan", *argv);
2946 }
2947
2948 /*
2949  * do_scanResponse: add scan response handler
2950  */
2951 static int do_scanResponse (void *o, Tcl_Interp *interp,
2952                             int argc, char **argv)
2953 {
2954     IrTcl_ScanObj *obj = o;
2955
2956     if (argc == 0)
2957     {
2958         obj->scanResponse = NULL;
2959         return TCL_OK;
2960     }
2961     else if (argc == -1)
2962         return ir_tcl_strdel (interp, &obj->scanResponse);
2963     if (argc == 3)
2964     {
2965         xfree (obj->scanResponse);
2966         if (argv[2][0])
2967         {
2968             if (ir_tcl_strdup (interp, &obj->scanResponse, argv[2])
2969                 == TCL_ERROR)
2970                 return TCL_ERROR;
2971         }
2972         else
2973             obj->scanResponse = NULL;
2974     }
2975     return TCL_OK;
2976 }
2977
2978 /*
2979  * do_stepSize: Set/get replace Step Size
2980  */
2981 static int do_stepSize (void *obj, Tcl_Interp *interp,
2982                         int argc, char **argv)
2983 {
2984     IrTcl_ScanObj *p = obj;
2985     if (argc <= 0)
2986     {
2987         p->stepSize = 0;
2988         return TCL_OK;
2989     }
2990     return ir_tcl_get_set_int (&p->stepSize, interp, argc, argv);
2991 }
2992
2993 /*
2994  * do_numberOfTermsRequested: Set/get Number of Terms requested
2995  */
2996 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,
2997                                       int argc, char **argv)
2998 {
2999     IrTcl_ScanObj *p = obj;
3000
3001     if (argc <= 0)
3002     {
3003         p->numberOfTermsRequested = 20;
3004         return TCL_OK;
3005     }
3006     return ir_tcl_get_set_int (&p->numberOfTermsRequested, interp, argc, argv);
3007 }
3008
3009
3010 /*
3011  * do_preferredPositionInResponse: Set/get preferred Position
3012  */
3013 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,
3014                                            int argc, char **argv)
3015 {
3016     IrTcl_ScanObj *p = obj;
3017
3018     if (argc <= 0)
3019     {
3020         p->preferredPositionInResponse = 1;
3021         return TCL_OK;
3022     }
3023     return ir_tcl_get_set_int (&p->preferredPositionInResponse, interp,
3024                                argc, argv);
3025 }
3026
3027 /*
3028  * do_scanStatus: Get scan status
3029  */
3030 static int do_scanStatus (void *obj, Tcl_Interp *interp,
3031                           int argc, char **argv)
3032 {
3033     IrTcl_ScanObj *p = obj;
3034
3035     if (argc <= 0)
3036         return TCL_OK;
3037     return ir_tcl_get_set_int (&p->scanStatus, interp, argc, argv);
3038 }
3039
3040 /*
3041  * do_numberOfEntriesReturned: Get number of Entries returned
3042  */
3043 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,
3044                                        int argc, char **argv)
3045 {
3046     IrTcl_ScanObj *p = obj;
3047
3048     if (argc <= 0)
3049         return TCL_OK;
3050     return ir_tcl_get_set_int (&p->numberOfEntriesReturned, interp,
3051                                argc, argv);
3052 }
3053
3054 /*
3055  * do_positionOfTerm: Get position of Term
3056  */
3057 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,
3058                               int argc, char **argv)
3059 {
3060     IrTcl_ScanObj *p = obj;
3061
3062     if (argc <= 0)
3063         return TCL_OK;
3064     return ir_tcl_get_set_int (&p->positionOfTerm, interp, argc, argv);
3065 }
3066
3067 /*
3068  * do_scanLine: get Scan Line (surrogate or normal) after response
3069  */
3070 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)
3071 {
3072     IrTcl_ScanObj *p = obj;
3073     int i;
3074     char numstr[20];
3075
3076     if (argc == 0)
3077     {
3078         p->entries_flag = 0;
3079         p->entries = NULL;
3080         p->nonSurrogateDiagnosticNum = 0;
3081         p->nonSurrogateDiagnosticList = 0;
3082         return TCL_OK;
3083     }
3084     else if (argc == -1)
3085     {
3086         p->entries_flag = 0;
3087         /* release entries */
3088         p->entries = NULL;
3089
3090         ir_deleteDiags (&p->nonSurrogateDiagnosticList,
3091                         &p->nonSurrogateDiagnosticNum);
3092         return TCL_OK;
3093     }
3094     if (argc != 3)
3095     {
3096         interp->result = "wrong # args";
3097         return TCL_ERROR;
3098     }
3099     if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)
3100         return TCL_ERROR;
3101     if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries
3102         || i >= p->num_entries || i < 0)
3103         return TCL_OK;
3104     switch (p->entries[i].which)
3105     {
3106     case Z_Entry_termInfo:
3107         Tcl_AppendElement (interp, "T");
3108         if (p->entries[i].u.term.buf)
3109             Tcl_AppendElement (interp, p->entries[i].u.term.buf);
3110         else
3111             Tcl_AppendElement (interp, "");
3112         sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);
3113         Tcl_AppendElement (interp, numstr);
3114         break;
3115     case Z_Entry_surrogateDiagnostic:
3116         Tcl_AppendElement (interp, "SD");
3117         return ir_diagResult (interp, p->entries[i].u.diag.list,
3118                               p->entries[i].u.diag.num);
3119         break;
3120     }
3121     return TCL_OK;
3122 }
3123
3124 static IrTcl_Method ir_scan_method_tab[] = {
3125     { "scan",                    do_scan, NULL},
3126     { "scanResponse",            do_scanResponse, NULL},
3127     { "stepSize",                do_stepSize, NULL},
3128     { "numberOfTermsRequested",  do_numberOfTermsRequested, NULL},
3129     { "preferredPositionInResponse", do_preferredPositionInResponse, NULL},
3130     { "scanStatus",              do_scanStatus, NULL},
3131     { "numberOfEntriesReturned", do_numberOfEntriesReturned, NULL},
3132     { "positionOfTerm",          do_positionOfTerm, NULL},
3133     { "scanLine",                do_scanLine, NULL},
3134     { NULL, NULL}
3135 };
3136
3137 /*
3138  * ir_scan_obj_method: IR Scan Object methods
3139  */
3140 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,
3141                                int argc, char **argv)
3142 {
3143     IrTcl_Methods tabs[2];
3144     int r;
3145
3146     if (argc < 2)
3147     {
3148         interp->result = "wrong # args";
3149         return TCL_ERROR;
3150     }
3151     tabs[0].tab = ir_scan_method_tab;
3152     tabs[0].obj = clientData;
3153     tabs[1].tab = NULL;
3154
3155     ir_tcl_method (interp, argc, argv, tabs, &r);
3156     return r;
3157 }
3158
3159 /*
3160  * ir_scan_obj_delete: IR Scan Object disposal
3161  */
3162 static void ir_scan_obj_delete (ClientData clientData)
3163 {
3164     IrTcl_Methods tabs[2];
3165     IrTcl_ScanObj *obj = clientData;
3166
3167     tabs[0].tab = ir_scan_method_tab;
3168     tabs[0].obj = obj;
3169     tabs[1].tab = NULL;
3170
3171     ir_tcl_method (NULL, -1, NULL, tabs, NULL);
3172     xfree (obj);
3173 }
3174
3175 /*
3176  * ir_scan_obj_mk: IR Scan Object creation
3177  */
3178 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,
3179                            int argc, char **argv)
3180 {
3181     Tcl_CmdInfo parent_info;
3182     IrTcl_ScanObj *obj;
3183     IrTcl_Methods tabs[2];
3184
3185     if (argc != 3)
3186     {
3187         interp->result = "wrong # args";
3188         return TCL_ERROR;
3189     }
3190     logf (LOG_DEBUG, "ir scan create %s", argv[1]);
3191     if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
3192     {
3193         interp->result = "No parent";
3194         return TCL_ERROR;
3195     }
3196     obj = ir_tcl_malloc (sizeof(*obj));
3197     obj->parent = (IrTcl_Obj *) parent_info.clientData;
3198
3199     tabs[0].tab = ir_scan_method_tab;
3200     tabs[0].obj = obj;
3201     tabs[1].tab = NULL;
3202
3203     if (ir_tcl_method (interp, 0, NULL, tabs, NULL) == TCL_ERROR)
3204         return TCL_ERROR;
3205     Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,
3206                        (ClientData) obj, ir_scan_obj_delete);
3207     return TCL_OK;
3208 }
3209
3210 /* ------------------------------------------------------- */
3211
3212 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
3213 {
3214     IrTcl_Obj *p = obj;
3215
3216     p->initResult = *initrs->result ? 1 : 0;
3217     if (!*initrs->result)
3218         logf (LOG_DEBUG, "Connection rejected by target");
3219     else
3220         logf (LOG_DEBUG, "Connection accepted by target");
3221
3222     get_referenceId (&p->set_inher.referenceId, initrs->referenceId);
3223
3224     xfree (p->targetImplementationId);
3225     ir_tcl_strdup (p->interp, &p->targetImplementationId,
3226                initrs->implementationId);
3227     xfree (p->targetImplementationName);
3228     ir_tcl_strdup (p->interp, &p->targetImplementationName,
3229                initrs->implementationName);
3230     xfree (p->targetImplementationVersion);
3231     ir_tcl_strdup (p->interp, &p->targetImplementationVersion,
3232                initrs->implementationVersion);
3233
3234     p->maximumRecordSize = *initrs->maximumRecordSize;
3235     p->preferredMessageSize = *initrs->preferredMessageSize;
3236
3237     memcpy (&p->options, initrs->options, sizeof(initrs->options));
3238     memcpy (&p->protocolVersion, initrs->protocolVersion,
3239             sizeof(initrs->protocolVersion));
3240     xfree (p->userInformationField);
3241     p->userInformationField = NULL;
3242     if (initrs->userInformationField)
3243     {
3244         int len;
3245
3246         if (initrs->userInformationField->which == ODR_EXTERNAL_octet &&
3247             (p->userInformationField =
3248              ir_tcl_malloc ((len =
3249                              initrs->userInformationField->
3250                              u.octet_aligned->len) +1)))
3251         {
3252             memcpy (p->userInformationField,
3253                     initrs->userInformationField->u.octet_aligned->buf,
3254                         len);
3255             (p->userInformationField)[len] = '\0';
3256         }
3257     }
3258 }
3259
3260 static void ir_deleteDiags (IrTcl_Diagnostic **dst_list, int *dst_num)
3261 {
3262     int i;
3263     for (i = 0; i<*dst_num; i++)
3264         xfree (dst_list[i]->addinfo);
3265     xfree (*dst_list);
3266     *dst_list = NULL;
3267     *dst_num = 0;
3268 }
3269
3270 static void ir_handleDiags (IrTcl_Diagnostic **dst_list, int *dst_num,
3271                             Z_DiagRec **list, int num)
3272 {
3273     int i;
3274     char *addinfo;
3275
3276     *dst_num = num;
3277     *dst_list = ir_tcl_malloc (sizeof(**dst_list) * num);
3278     for (i = 0; i<num; i++)
3279     {
3280         const char *cp;
3281         switch (list[i]->which)
3282         {
3283         case Z_DiagRec_defaultFormat:
3284             (*dst_list)[i].condition = *list[i]->u.defaultFormat->condition;
3285             addinfo = list[i]->u.defaultFormat->addinfo;
3286             if (addinfo &&
3287                 ((*dst_list)[i].addinfo = ir_tcl_malloc (strlen(addinfo)+1)))
3288                 strcpy ((*dst_list)[i].addinfo, addinfo);
3289             cp = diagbib1_str ((*dst_list)[i].condition);
3290             logf (LOG_DEBUG, "Diag %d %s %s", (*dst_list)[i].condition,
3291                   cp ? cp : "", addinfo ? addinfo : "");
3292             break;
3293         default:
3294             (*dst_list)[i].addinfo = NULL;
3295             (*dst_list)[i].condition = 0;
3296         }
3297     }
3298 }
3299
3300 static void ir_handleDBRecord (IrTcl_Obj *p, IrTcl_RecordList *rl,
3301                                Z_External *oe)
3302 {
3303     struct oident *ident;
3304     Z_ext_typeent *etype;
3305
3306     rl->u.dbrec.size = oe->u.octet_aligned->len;
3307     rl->u.dbrec.buf = NULL;
3308
3309     if ((ident = oid_getentbyoid (oe->direct_reference)))
3310         rl->u.dbrec.type = ident->value;
3311     else
3312         rl->u.dbrec.type = VAL_USMARC;
3313
3314     if (ident && (oe->which == Z_External_single ||
3315                   oe->which == Z_External_octet)
3316         && (etype = z_ext_getentbyref (ident->value)))
3317     {
3318         void *rr;
3319
3320         odr_setbuf (p->odr_in, (char*) oe->u.octet_aligned->buf,
3321                     oe->u.octet_aligned->len, 0);
3322         if (!(*etype->fun)(p->odr_in, &rr, 0))
3323             return;
3324         switch (etype->what)
3325         {
3326         case Z_External_sutrs:
3327             logf (LOG_LOG, "Z_External_sutrs");
3328             oe->u.sutrs = rr;
3329             if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1)))
3330             {
3331                 memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf,
3332                         oe->u.sutrs->len);
3333                 rl->u.dbrec.buf[oe->u.sutrs->len] = '\0';
3334             }
3335             rl->u.dbrec.size = oe->u.sutrs->len;
3336             break;
3337         case Z_External_grs1:
3338             logf (LOG_LOG, "Z_External_grs1");
3339             oe->u.grs1 = rr;
3340             ir_tcl_grs_mk (oe->u.grs1, &rl->u.dbrec.u.grs1);
3341             break;
3342         case Z_External_explainRecord:
3343             logf (LOG_LOG, "Z_External_explainRecord");
3344             if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size)))
3345             {
3346                 memcpy (rl->u.dbrec.buf, oe->u.octet_aligned->buf,
3347                         rl->u.dbrec.size);
3348             }
3349             break;
3350         }
3351     }
3352     else
3353     {
3354         if (oe->which == Z_External_octet && rl->u.dbrec.size > 0)
3355         {
3356             char *buf = (char*) oe->u.octet_aligned->buf;
3357             if ((rl->u.dbrec.buf = ir_tcl_malloc (rl->u.dbrec.size)))
3358                 memcpy (rl->u.dbrec.buf, buf, rl->u.dbrec.size);
3359         }
3360         else if (rl->u.dbrec.type == VAL_SUTRS &&
3361                  oe->which == Z_External_sutrs)
3362         {
3363             if ((rl->u.dbrec.buf = ir_tcl_malloc (oe->u.sutrs->len+1)))
3364             {
3365                 memcpy (rl->u.dbrec.buf, oe->u.sutrs->buf,
3366                         oe->u.sutrs->len);
3367                 rl->u.dbrec.buf[oe->u.sutrs->len] = '\0';
3368             }
3369             rl->u.dbrec.size = oe->u.sutrs->len;
3370         }
3371         else if (rl->u.dbrec.type == VAL_GRS1 &&
3372                  oe->which == Z_External_grs1)
3373         {
3374             ir_tcl_grs_mk (oe->u.grs1, &rl->u.dbrec.u.grs1);
3375         }
3376     }
3377 }
3378
3379 static void ir_handleZRecords (void *o, Z_Records *zrs, IrTcl_SetObj *setobj,
3380                               const char *elements)
3381 {
3382     IrTcl_Obj *p = o;
3383
3384     int offset;
3385     IrTcl_RecordList *rl;
3386
3387     setobj->which = zrs->which;
3388     setobj->recordFlag = 1;
3389
3390     ir_deleteDiags (&setobj->nonSurrogateDiagnosticList,
3391                     &setobj->nonSurrogateDiagnosticNum);
3392     if (zrs->which == Z_Records_DBOSD)
3393     {
3394         setobj->numberOfRecordsReturned =
3395             zrs->u.databaseOrSurDiagnostics->num_records;
3396         logf (LOG_DEBUG, "Got %d records", setobj->numberOfRecordsReturned);
3397         for (offset = 0; offset < setobj->numberOfRecordsReturned; offset++)
3398         {
3399             Z_NamePlusRecord *znpr = zrs->u.databaseOrSurDiagnostics->
3400                 records[offset];
3401
3402             rl = new_IR_record (setobj, setobj->start + offset, znpr->which,
3403                                 elements);
3404             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
3405                 ir_handleDiags (&rl->u.surrogateDiagnostics.list,
3406                                 &rl->u.surrogateDiagnostics.num,
3407                                 &znpr->u.surrogateDiagnostic,
3408                                 1);
3409             else
3410                 ir_handleDBRecord (p, rl,
3411                                    (Z_External*) (znpr->u.databaseRecord));
3412         }
3413     }
3414     else if (zrs->which == Z_Records_multipleNSD)
3415     {
3416         logf (LOG_DEBUG, "multipleNonSurrogateDiagnostic %d",
3417               zrs->u.multipleNonSurDiagnostics->num_diagRecs);
3418         setobj->numberOfRecordsReturned = 0;
3419         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
3420                         &setobj->nonSurrogateDiagnosticNum,
3421                         zrs->u.multipleNonSurDiagnostics->diagRecs,
3422                         zrs->u.multipleNonSurDiagnostics->num_diagRecs);
3423     }
3424     else
3425     {
3426         logf (LOG_DEBUG, "NonSurrogateDiagnostic");
3427         setobj->numberOfRecordsReturned = 0;
3428         ir_handleDiags (&setobj->nonSurrogateDiagnosticList,
3429                         &setobj->nonSurrogateDiagnosticNum,
3430                         &zrs->u.nonSurrogateDiagnostic,
3431                         1);
3432     }
3433 }
3434
3435 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs,
3436                                IrTcl_SetObj *setobj)
3437 {
3438     Z_Records *zrs = searchrs->records;
3439
3440     logf (LOG_DEBUG, "Received search response");
3441     if (!setobj)
3442     {
3443         logf (LOG_DEBUG, "Search response, no object!");
3444         return;
3445     }
3446     setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
3447     get_referenceId (&setobj->set_inher.referenceId, searchrs->referenceId);
3448     setobj->resultCount = *searchrs->resultCount;
3449     if (searchrs->presentStatus)
3450         setobj->presentStatus = *searchrs->presentStatus;
3451     if (searchrs->nextResultSetPosition)
3452         setobj->nextResultSetPosition = *searchrs->nextResultSetPosition;
3453
3454     logf (LOG_DEBUG, "status %d hits %d",
3455           setobj->searchStatus, setobj->resultCount);
3456     if (zrs)
3457     {
3458         const char *es;
3459         if (setobj->resultCount <= setobj->set_inher.smallSetUpperBound)
3460             es = setobj->set_inher.smallSetElementSetNames;
3461         else
3462             es = setobj->set_inher.mediumSetElementSetNames;
3463         ir_handleZRecords (o, zrs, setobj, es);
3464     }
3465     else
3466         setobj->recordFlag = 0;
3467 }
3468
3469
3470 static void ir_presentResponse (void *o, Z_PresentResponse *presrs,
3471                                 IrTcl_SetObj *setobj)
3472 {
3473     Z_Records *zrs = presrs->records;
3474
3475     logf (LOG_DEBUG, "Received present response");
3476     if (!setobj)
3477     {
3478         logf (LOG_DEBUG, "Present response, no object!");
3479         return;
3480     }
3481     setobj->presentStatus = *presrs->presentStatus;
3482     get_referenceId (&setobj->set_inher.referenceId, presrs->referenceId);
3483     setobj->nextResultSetPosition = *presrs->nextResultSetPosition;
3484     if (zrs)
3485         ir_handleZRecords (o, zrs, setobj, setobj->set_inher.elementSetNames);
3486     else
3487     {
3488         setobj->recordFlag = 0;
3489         logf (LOG_DEBUG, "No records!");
3490     }
3491 }
3492
3493 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs,
3494                              IrTcl_ScanObj *scanobj)
3495 {
3496     IrTcl_Obj *p = o;
3497
3498     logf (LOG_DEBUG, "Received scanResponse");
3499
3500     get_referenceId (&p->set_inher.referenceId, scanrs->referenceId);
3501     scanobj->scanStatus = *scanrs->scanStatus;
3502     logf (LOG_DEBUG, "scanStatus=%d", scanobj->scanStatus);
3503
3504     if (scanrs->stepSize)
3505         scanobj->stepSize = *scanrs->stepSize;
3506     logf (LOG_DEBUG, "stepSize=%d", scanobj->stepSize);
3507
3508     scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;
3509     logf (LOG_DEBUG, "numberOfEntriesReturned=%d",
3510           scanobj->numberOfEntriesReturned);
3511
3512     if (scanrs->positionOfTerm)
3513         scanobj->positionOfTerm = *scanrs->positionOfTerm;
3514     else
3515         scanobj->positionOfTerm = -1;
3516     logf (LOG_DEBUG, "positionOfTerm=%d", scanobj->positionOfTerm);
3517
3518     xfree (scanobj->entries);
3519     scanobj->entries = NULL;
3520
3521     ir_deleteDiags (&scanobj->nonSurrogateDiagnosticList,
3522                     &scanobj->nonSurrogateDiagnosticNum);
3523     if (scanrs->entries)
3524     {
3525         int i;
3526         Z_Entry *ze;
3527
3528         scanobj->entries_flag = 1;
3529         scanobj->which = scanrs->entries->which;
3530         switch (scanobj->which)
3531         {
3532         case Z_ListEntries_entries:
3533             scanobj->num_entries = scanrs->entries->u.entries->num_entries;
3534             scanobj->entries = ir_tcl_malloc (scanobj->num_entries *
3535                                        sizeof(*scanobj->entries));
3536             for (i=0; i<scanobj->num_entries; i++)
3537             {
3538                 ze = scanrs->entries->u.entries->entries[i];
3539                 scanobj->entries[i].which = ze->which;
3540                 switch (ze->which)
3541                 {
3542                 case Z_Entry_termInfo:
3543                     if (ze->u.termInfo->term->which == Z_Term_general)
3544                     {
3545                         int l = ze->u.termInfo->term->u.general->len;
3546                         scanobj->entries[i].u.term.buf = ir_tcl_malloc (1+l);
3547                         memcpy (scanobj->entries[i].u.term.buf,
3548                                 ze->u.termInfo->term->u.general->buf,
3549                                 l);
3550                         scanobj->entries[i].u.term.buf[l] = '\0';
3551                     }
3552                     else
3553                         scanobj->entries[i].u.term.buf = NULL;
3554                     if (ze->u.termInfo->globalOccurrences)
3555                         scanobj->entries[i].u.term.globalOccurrences =
3556                             *ze->u.termInfo->globalOccurrences;
3557                     else
3558                         scanobj->entries[i].u.term.globalOccurrences = 0;
3559                     break;
3560                 case Z_Entry_surrogateDiagnostic:
3561                     ir_handleDiags (&scanobj->entries[i].u.diag.list,
3562                                     &scanobj->entries[i].u.diag.num,
3563                                     &ze->u.surrogateDiagnostic,
3564                                     1);
3565                     break;
3566                 }
3567             }
3568             break;
3569         case Z_ListEntries_nonSurrogateDiagnostics:
3570             ir_handleDiags (&scanobj->nonSurrogateDiagnosticList,
3571                             &scanobj->nonSurrogateDiagnosticNum,
3572                             scanrs->entries->u.nonSurrogateDiagnostics->
3573                             diagRecs,
3574                             scanrs->entries->u.nonSurrogateDiagnostics->
3575                             num_diagRecs);
3576             break;
3577         }
3578     }
3579     else
3580         scanobj->entries_flag = 0;
3581 }
3582
3583 /*
3584  * ir_select_read: handle incoming packages
3585  */
3586 static void ir_select_read (ClientData clientData)
3587 {
3588     IrTcl_Obj *p = clientData;
3589     Z_APDU *apdu;
3590     int r;
3591     IrTcl_Request *rq;
3592     char *object_name;
3593     Tcl_CmdInfo cmd_info;
3594     const char *apdu_call;
3595
3596     logf(LOG_DEBUG, "Read handler fd=%d", cs_fileno(p->cs_link));
3597     if (p->state == IR_TCL_R_Connecting)
3598     {
3599         logf(LOG_DEBUG, "read: connect");
3600         r = cs_rcvconnect (p->cs_link);
3601         if (r == 1)
3602         {
3603             logf (LOG_WARN, "cs_rcvconnect returned 1");
3604             return;
3605         }
3606         p->state = IR_TCL_R_Idle;
3607         p->ref_count = 2;
3608         ir_select_remove_write (cs_fileno (p->cs_link), p);
3609         if (r < 0)
3610         {
3611             logf (LOG_DEBUG, "cs_rcvconnect error");
3612             ir_tcl_disconnect (p);
3613             if (p->failback)
3614             {
3615                 p->failInfo = IR_TCL_FAIL_CONNECT;
3616                 ir_tcl_eval (p->interp, p->failback);
3617             }
3618             ir_obj_delete (p);
3619             return;
3620         }
3621         if (p->callback)
3622             ir_tcl_eval (p->interp, p->callback);
3623         if (p->ref_count == 2 && p->cs_link && p->request_queue
3624             && p->state == IR_TCL_R_Idle)
3625             ir_tcl_send_q (p, p->request_queue, "x");
3626         ir_obj_delete (p);
3627         return;
3628     }
3629     do
3630     {
3631         p->state = IR_TCL_R_Reading;
3632
3633         /* read incoming APDU */
3634         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in)) == 1)
3635         {
3636             logf(LOG_DEBUG, "PDU Fraction read");
3637             return ;
3638         }
3639         /* signal one more use of ir object - callbacks must not
3640            release the ir memory (p pointer) */
3641         p->ref_count = 2;
3642         if (r <= 0)
3643         {
3644             logf (LOG_DEBUG, "cs_get failed, code %d", r);
3645             ir_select_remove (cs_fileno (p->cs_link), p);
3646             ir_tcl_disconnect (p);
3647             if (p->failback)
3648             {
3649                 p->failInfo = IR_TCL_FAIL_READ;
3650                 ir_tcl_eval (p->interp, p->failback);
3651             }
3652             /* release ir object now if callback deleted it */
3653             ir_obj_delete (p);
3654             return;
3655         }
3656         /* got complete APDU. Now decode */
3657         p->apduLen = r;
3658         p->apduOffset = -1;
3659         odr_setbuf (p->odr_in, p->buf_in, r, 0);
3660         logf (LOG_DEBUG, "cs_get ok, total size %d", r);
3661         if (!z_APDU (p->odr_in, &apdu, 0))
3662         {
3663             logf (LOG_DEBUG, "cs_get failed: %s",
3664                 odr_errmsg (odr_geterror (p->odr_in)));
3665             ir_tcl_disconnect (p);
3666             if (p->failback)
3667             {
3668                 p->failInfo = IR_TCL_FAIL_IN_APDU;
3669                 p->apduOffset = odr_offset (p->odr_in);
3670                 ir_tcl_eval (p->interp, p->failback);
3671             }
3672             /* release ir object now if failback deleted it */
3673             ir_obj_delete (p);
3674             return;
3675         }
3676         /* handle APDU and invoke callback */
3677         rq = p->request_queue;
3678         if (!rq)
3679         {
3680             logf (LOG_FATAL, "Internal error. No queue entry");
3681             exit (1);
3682         }
3683         object_name = rq->object_name;
3684         logf (LOG_DEBUG, "Object %s", object_name);
3685         apdu_call = NULL;
3686         if (Tcl_GetCommandInfo (p->interp, object_name, &cmd_info))
3687         {
3688             switch(apdu->which)
3689             {
3690             case Z_APDU_initResponse:
3691                 p->eventType = "init";
3692                 ir_initResponse (p, apdu->u.initResponse);
3693                 apdu_call = p->initResponse;
3694                 break;
3695             case Z_APDU_searchResponse:
3696                 p->eventType = "search";
3697                 ir_searchResponse (p, apdu->u.searchResponse,
3698                                    (IrTcl_SetObj *) cmd_info.clientData);
3699                 apdu_call = ((IrTcl_SetObj *)
3700                              cmd_info.clientData)->searchResponse;
3701                 break;
3702             case Z_APDU_presentResponse:
3703                 p->eventType = "present";
3704                 ir_presentResponse (p, apdu->u.presentResponse,
3705                                     (IrTcl_SetObj *) cmd_info.clientData);
3706                 apdu_call = ((IrTcl_SetObj *)
3707                              cmd_info.clientData)->presentResponse;
3708                 break;
3709             case Z_APDU_scanResponse:
3710                 p->eventType = "scan";
3711                 ir_scanResponse (p, apdu->u.scanResponse,
3712                                  (IrTcl_ScanObj *) cmd_info.clientData);
3713                 apdu_call = ((IrTcl_ScanObj *)
3714                              cmd_info.clientData)->scanResponse;
3715                 break;
3716             default:
3717                 logf (LOG_WARN, "Received unknown APDU type (%d)",
3718                       apdu->which);
3719                 ir_tcl_disconnect (p);
3720                 if (p->failback)
3721                 {
3722                     p->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;
3723                     ir_tcl_eval (p->interp, p->failback);
3724                 }
3725                 return;
3726             }
3727         }
3728         p->request_queue = rq->next;
3729         p->state = IR_TCL_R_Idle;
3730
3731         if (apdu_call)
3732             ir_tcl_eval (p->interp, apdu_call);
3733         else if (rq->callback)
3734             ir_tcl_eval (p->interp, rq->callback);
3735         xfree (rq->buf_out);
3736         xfree (rq->callback);
3737         xfree (rq->object_name);
3738         xfree (rq);
3739         odr_reset (p->odr_in);
3740         if (p->ref_count == 1)
3741         {
3742             ir_obj_delete (p);
3743             return;
3744         }
3745         ir_obj_delete (p);
3746     } while (p->cs_link && cs_more (p->cs_link));
3747     if (p->cs_link && p->request_queue && p->state == IR_TCL_R_Idle)
3748         ir_tcl_send_q (p, p->request_queue, "x");
3749 }
3750
3751 /*
3752  * ir_select_write: handle outgoing packages - not yet written.
3753  */
3754 static int ir_select_write (ClientData clientData)
3755 {
3756     IrTcl_Obj *p = clientData;
3757     int r;
3758     IrTcl_Request *rq;
3759
3760     logf (LOG_DEBUG, "Write handler fd=%d", cs_fileno(p->cs_link));
3761     if (p->state == IR_TCL_R_Connecting)
3762     {
3763         logf(LOG_DEBUG, "write: connect");
3764         r = cs_rcvconnect (p->cs_link);
3765         if (r == 1)
3766         {
3767             logf (LOG_DEBUG, "cs_rcvconnect returned 1");
3768             return 2;
3769         }
3770         p->state = IR_TCL_R_Idle;
3771         p->ref_count = 2;
3772         ir_select_remove_write (cs_fileno (p->cs_link), p);
3773         if (r < 0)
3774         {
3775             logf (LOG_DEBUG, "cs_rcvconnect error");
3776             ir_tcl_disconnect (p);
3777             if (p->failback)
3778             {
3779                 p->failInfo = IR_TCL_FAIL_CONNECT;
3780                 ir_tcl_eval (p->interp, p->failback);
3781             }
3782             ir_obj_delete (p);
3783             return 2;
3784         }
3785         if (p->callback)
3786             ir_tcl_eval (p->interp, p->callback);
3787         ir_obj_delete (p);
3788         return 2;
3789     }
3790     rq = p->request_queue;
3791     if (!rq || !rq->buf_out)
3792         return 0;
3793     assert (rq);
3794     if ((r=cs_put (p->cs_link, rq->buf_out, rq->len_out)) < 0)
3795     {
3796         logf (LOG_DEBUG, "cs_put write fail");
3797         p->ref_count = 2;
3798         xfree (rq->buf_out);
3799         rq->buf_out = NULL;
3800         ir_tcl_disconnect (p);
3801         if (p->failback)
3802         {
3803             p->failInfo = IR_TCL_FAIL_WRITE;
3804             ir_tcl_eval (p->interp, p->failback);
3805         }
3806         ir_obj_delete (p);
3807     }
3808     else if (r == 0)            /* remove select bit */
3809     {
3810         logf (LOG_DEBUG, "Write completed");
3811         p->state = IR_TCL_R_Waiting;
3812         ir_select_remove_write (cs_fileno (p->cs_link), p);
3813         xfree (rq->buf_out);
3814         rq->buf_out = NULL;
3815     }
3816     return 1;
3817 }
3818
3819 static void ir_select_notify (ClientData clientData, int r, int w, int e)
3820 {
3821     if (w)
3822     {
3823         if (!ir_select_write (clientData) && r)
3824             ir_select_read (clientData);
3825     }
3826     else if (r)
3827     {
3828         ir_select_read (clientData);
3829     }
3830 }
3831
3832 /* ------------------------------------------------------- */
3833
3834 /*
3835  * Irtcl_init: Registration of TCL commands.
3836  */
3837 int Irtcl_Init (Tcl_Interp *interp)
3838 {
3839     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
3840                        (Tcl_CmdDeleteProc *) NULL);
3841     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
3842                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
3843     Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,
3844                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
3845     return TCL_OK;
3846 }
3847