ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  * Sebastian Hammer, Adam Dickmeiss
   5  *
   6  * $Log: ir-tcl.c,v $
   7  * Revision 1.14  1995-03-20 08:53:22  adam
   8  * Event loop in tclmain.c rewritten. New method searchStatus.
   9  *
  10  * Revision 1.13  1995/03/17  18:26:17  adam
  11  * Non-blocking i/o used now. Database names popup as cascade items.
  12  *
  13  * Revision 1.12  1995/03/17  15:45:00  adam
  14  * Improved target/database setup.
  15  *
  16  * Revision 1.11  1995/03/16  17:54:03  adam
  17  * Minor changes really.
  18  *
  19  * Revision 1.10  1995/03/15  16:14:50  adam
  20  * Blocking arg in cs_create changed.
  21  *
  22  * Revision 1.9  1995/03/15  13:59:24  adam
  23  * Minor changes.
  24  *
  25  * Revision 1.8  1995/03/15  08:25:16  adam
  26  * New method presentStatus to check for error on present. Misc. cleanup
  27  * of IRRecordList manipulations. Full MARC record presentation in
  28  * search.tcl.
  29  *
  30  * Revision 1.7  1995/03/14  17:32:29  adam
  31  * Presentation of full Marc record in popup window.
  32  *
  33  * Revision 1.6  1995/03/12  19:31:55  adam
  34  * Pattern matching implemented when retrieving MARC records. More
  35  * diagnostic functions.
  36  *
  37  * Revision 1.5  1995/03/10  18:00:15  adam
  38  * Actual presentation in line-by-line format. RPN query support.
  39  *
  40  * Revision 1.4  1995/03/09  16:15:08  adam
  41  * First presentRequest attempts. Hot-target list.
  42  *
  43  */
  44
  45 #include <stdlib.h>
  46 #include <stdio.h>
  47 #include <sys/time.h>
  48 #include <assert.h>
  49
  50 #include <yaz-ccl.h>
  51 #include <iso2709p.h>
  52 #include <comstack.h>
  53 #include <tcpip.h>
  54 #include <xmosi.h>
  55
  56 #include <odr.h>
  57 #include <proto.h>
  58 #include <diagbib1.h>
  59
  60 #include <tcl.h>
  61
  62 #include "ir-tcl.h"
  63
  64 typedef struct {
  65     COMSTACK cs_link;
  66
  67     int preferredMessageSize;
  68     int maximumRecordSize;
  69     Odr_bitmask options;
  70     Odr_bitmask protocolVersion;
  71     char *idAuthentication;
  72     char *implementationName;
  73     char *implementationId;
  74
  75     char *hostname;
  76
  77     char *buf_out;
  78     int  len_out;
  79
  80     char *buf_in;
  81     int  len_in;
  82
  83     char *sbuf;
  84     int  slen;
  85
  86     ODR odr_in;
  87     ODR odr_out;
  88     ODR odr_pr;
  89
  90     Tcl_Interp *interp;
  91     char *callback;
  92
  93     int smallSetUpperBound;
  94     int largeSetLowerBound;
  95     int mediumSetPresentNumber;
  96     int replaceIndicator;
  97     char **databaseNames;
  98     int num_databaseNames;
  99     char *query_method;
 100
 101     CCL_bibset bibset;
 102
 103     struct IRSetObj_ *child;
 104 } IRObj;
 105
 106 typedef struct IRRecordList_ {
 107     int no;
 108     int which;
 109     union {
 110         struct {
 111             Iso2709Rec rec;
 112         } marc;
 113         struct {
 114             int  condition;
 115             char *addinfo;
 116         } diag;
 117     } u;
 118     struct IRRecordList_ *next;
 119 } IRRecordList;
 120
 121 typedef struct IRSetObj_ {
 122     IRObj *parent;
 123     int searchStatus;
 124     int resultCount;
 125     int start;
 126     int number;
 127     int numberOfRecordsReturned;
 128     Z_Records *z_records;
 129     int which;
 130     int condition;
 131     char *addinfo;
 132     IRRecordList *record_list;
 133 } IRSetObj;
 134
 135 typedef struct {
 136     int type;
 137     char *name;
 138     int (*method) (void * obj, Tcl_Interp *interp, int argc, char **argv);
 139 } IRMethod;
 140
 141 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
 142
 143 static IRRecordList *new_IR_record (IRSetObj *setobj, int no, int which)
 144 {
 145     IRRecordList *rl;
 146
 147     for (rl = setobj->record_list; rl; rl = rl->next)
 148     {
 149         if (no == rl->no)
 150         {
 151             switch (rl->which)
 152             {
 153             case Z_NamePlusRecord_databaseRecord:
 154                 iso2709_rm (rl->u.marc.rec);
 155                 break;
 156             case Z_NamePlusRecord_surrogateDiagnostic:
 157                 free (rl->u.diag.addinfo);
 158                 rl->u.diag.addinfo = NULL;
 159                 break;
 160             }
 161             break;
 162         }
 163     }
 164     if (!rl)
 165     {
 166         rl = malloc (sizeof(*rl));
 167         assert (rl);
 168         rl->next = setobj->record_list;
 169         rl->no = no;
 170         setobj->record_list = rl;
 171     }
 172     rl->which = which;
 173     return rl;
 174 }
 175
 176 static IRRecordList *find_IR_record (IRSetObj *setobj, int no)
 177 {
 178     IRRecordList *rl;
 179
 180     for (rl = setobj->record_list; rl; rl = rl->next)
 181         if (no == rl->no)
 182             return rl;
 183     return NULL;
 184 }
 185
 186 /*
 187  * get_parent_info: Returns information about parent object.
 188  */
 189 static int get_parent_info (Tcl_Interp *interp, const char *name,
 190                             Tcl_CmdInfo *parent_info)
 191 {
 192     char parent_name[128];
 193     const char *csep = strrchr (name, '.');
 194     int pos;
 195
 196     if (!csep)
 197     {
 198         interp->result = "missing .";
 199         return TCL_ERROR;
 200     }
 201     pos = csep-name;
 202     if (pos > 127)
 203         pos = 127;
 204     memcpy (parent_name, name, pos);
 205     parent_name[pos] = '\0';
 206     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
 207     {
 208         interp->result = "No parent";
 209         return TCL_ERROR;
 210     }
 211     return TCL_OK;
 212 }
 213
 214 /*
 215  * ir_method: Search for method in table and invoke method handler
 216  */
 217 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 218                IRMethod *tab)
 219 {
 220     IRMethod *t;
 221     for (t = tab; t->name; t++)
 222         if (!strcmp (t->name, argv[1]))
 223             return (*t->method)(obj, interp, argc, argv);
 224     Tcl_AppendResult (interp, "Bad method. Possible values:", NULL);
 225     for (t = tab; t->name; t++)
 226         Tcl_AppendResult (interp, " ", t->name, NULL);
 227     return TCL_ERROR;
 228 }
 229
 230 /*
 231  * ir_method_r: Get status for all readable elements
 232  */
 233 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,
 234                  IRMethod *tab)
 235 {
 236     char *argv_n[3];
 237     int argc_n;
 238
 239     argv_n[0] = argv[0];
 240     argc_n = 2;
 241     for (; tab->name; tab++)
 242         if (tab->type)
 243         {
 244             argv_n[1] = tab->name;
 245             Tcl_AppendResult (interp, "{", NULL);
 246             (*tab->method)(obj, interp, argc_n, argv_n);
 247             Tcl_AppendResult (interp, "} ", NULL);
 248         }
 249     return TCL_OK;
 250 }
 251
 252 /*
 253  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 254  */
 255 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 256 {
 257     const char *cp = asc + strlen(asc);
 258     int bitno = 0;
 259
 260     ODR_MASK_ZERO (ob);
 261     do
 262     {
 263         if (*--cp == '1')
 264             ODR_MASK_SET (ob, bitno);
 265         bitno++;
 266     } while (cp != asc);
 267     return bitno;
 268 }
 269
 270 /*
 271  * ir_strdup: Duplicate string
 272  */
 273 int ir_strdup (Tcl_Interp *interp, char** p, char *s)
 274 {
 275     *p = malloc (strlen(s)+1);
 276     if (!*p)
 277     {
 278         interp->result = "strdup fail";
 279         return TCL_ERROR;
 280     }
 281     strcpy (*p, s);
 282     return TCL_OK;
 283 }
 284
 285 /*
 286  * ir_malloc: Malloc function
 287  */
 288 void *ir_malloc (Tcl_Interp *interp, size_t size)
 289 {
 290     static char buf[128];
 291     void *p = malloc (size);
 292
 293     if (!p)
 294     {
 295         sprintf (buf, "Malloc fail. %ld bytes requested", (long) size);
 296         interp->result = buf;
 297         return NULL;
 298     }
 299     return p;
 300 }
 301
 302 /* ------------------------------------------------------- */
 303
 304 /*
 305  * do_init_request: init method on IR object
 306  */
 307 static int do_init_request (void *obj, Tcl_Interp *interp,
 308                        int argc, char **argv)
 309 {
 310     Z_APDU apdu, *apdup;
 311     IRObj *p = obj;
 312     Z_InitRequest req;
 313     int r;
 314
 315     req.referenceId = 0;
 316     req.options = &p->options;
 317     req.protocolVersion = &p->protocolVersion;
 318     req.preferredMessageSize = &p->preferredMessageSize;
 319     req.maximumRecordSize = &p->maximumRecordSize;
 320
 321     req.idAuthentication = p->idAuthentication;
 322     req.implementationId = p->implementationId;
 323     req.implementationName = p->implementationName;
 324     req.implementationVersion = "0.1";
 325     req.userInformationField = 0;
 326
 327     apdu.u.initRequest = &req;
 328     apdu.which = Z_APDU_initRequest;
 329     apdup = &apdu;
 330
 331     if (!z_APDU (p->odr_out, &apdup, 0))
 332     {
 333         Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
 334                           NULL);
 335         odr_reset (p->odr_out);
 336         return TCL_ERROR;
 337     }
 338     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
 339     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 340     {
 341         interp->result = "cs_put failed in init";
 342         return TCL_ERROR;
 343     }
 344     else if (r == 1)
 345     {
 346         ir_select_add_write (cs_fileno(p->cs_link), p);
 347         printf("Sent part of initializeRequest (%d bytes).\n", p->slen);
 348     }
 349     else
 350         printf("Sent whole initializeRequest (%d bytes).\n", p->slen);
 351     return TCL_OK;
 352 }
 353
 354 /*
 355  * do_protocolVersion: Set protocol Version
 356  */
 357 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 358                                int argc, char **argv)
 359 {
 360     if (argc == 3)
 361         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 362     return TCL_OK;
 363 }
 364
 365 /*
 366  * do_options: Set options
 367  */
 368 static int do_options (void *obj, Tcl_Interp *interp,
 369                        int argc, char **argv)
 370 {
 371     if (argc == 3)
 372         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 373     return TCL_OK;
 374 }
 375
 376 /*
 377  * do_preferredMessageSize: Set/get preferred message size
 378  */
 379 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 380                                     int argc, char **argv)
 381 {
 382     char buf[20];
 383     if (argc == 3)
 384     {
 385         if (Tcl_GetInt (interp, argv[2],
 386                         &((IRObj *)obj)->preferredMessageSize)==TCL_ERROR)
 387             return TCL_ERROR;
 388     }
 389     sprintf (buf, "%d", ((IRObj *)obj)->preferredMessageSize);
 390     Tcl_AppendResult (interp, buf, NULL);
 391     return TCL_OK;
 392 }
 393
 394 /*
 395  * do_maximumRecordSize: Set/get maximum record size
 396  */
 397 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 398                                     int argc, char **argv)
 399 {
 400     char buf[20];
 401     if (argc == 3)
 402     {
 403         if (Tcl_GetInt (interp, argv[2],
 404                         &((IRObj *)obj)->maximumRecordSize)==TCL_ERROR)
 405             return TCL_ERROR;
 406     }
 407     sprintf (buf, "%d", ((IRObj *)obj)->maximumRecordSize);
 408     Tcl_AppendResult (interp, buf, NULL);
 409     return TCL_OK;
 410 }
 411
 412
 413 /*
 414  * do_implementationName: Set/get Implementation Name.
 415  */
 416 static int do_implementationName (void *obj, Tcl_Interp *interp,
 417                                     int argc, char **argv)
 418 {
 419     if (argc == 3)
 420     {
 421         free (((IRObj*)obj)->implementationName);
 422         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 423             == TCL_ERROR)
 424             return TCL_ERROR;
 425     }
 426     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 427                       (char*) NULL);
 428     return TCL_OK;
 429 }
 430
 431 /*
 432  * do_implementationId: Set/get Implementation Id.
 433  */
 434 static int do_implementationId (void *obj, Tcl_Interp *interp,
 435                                 int argc, char **argv)
 436 {
 437     if (argc == 3)
 438     {
 439         free (((IRObj*)obj)->implementationId);
 440         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 441             == TCL_ERROR)
 442             return TCL_ERROR;
 443     }
 444     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 445                       (char*) NULL);
 446     return TCL_OK;
 447 }
 448
 449 /*
 450  * do_idAuthentication: Set/get id Authentication
 451  */
 452 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 453                                 int argc, char **argv)
 454 {
 455     if (argc == 3)
 456     {
 457         free (((IRObj*)obj)->idAuthentication);
 458         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 459             == TCL_ERROR)
 460             return TCL_ERROR;
 461     }
 462     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 463                       (char*) NULL);
 464     return TCL_OK;
 465 }
 466
 467 /*
 468  * do_connect: connect method on IR object
 469  */
 470 static int do_connect (void *obj, Tcl_Interp *interp,
 471                        int argc, char **argv)
 472 {
 473     void *addr;
 474     IRObj *p = obj;
 475
 476     if (argc == 3)
 477     {
 478         if (p->hostname)
 479         {
 480             interp->result = "already connected";
 481             return TCL_ERROR;
 482         }
 483         if (cs_type(p->cs_link) == tcpip_type)
 484         {
 485             addr = tcpip_strtoaddr (argv[2]);
 486             if (!addr)
 487             {
 488                 interp->result = "tcpip_strtoaddr fail";
 489                 return TCL_ERROR;
 490             }
 491             printf ("tcp/ip connect %s\n", argv[2]);
 492         }
 493         else if (cs_type (p->cs_link) == mosi_type)
 494         {
 495             addr = mosi_strtoaddr (argv[2]);
 496             if (!addr)
 497             {
 498                 interp->result = "mosi_strtoaddr fail";
 499                 return TCL_ERROR;
 500             }
 501             printf ("mosi connect %s\n", argv[2]);
 502         }
 503         if (cs_connect (p->cs_link, addr) < 0)
 504         {
 505             interp->result = "cs_connect fail";
 506             do_disconnect (p, interp, argc, argv);
 507             return TCL_ERROR;
 508         }
 509         if (ir_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 510             return TCL_ERROR;
 511         ir_select_add (cs_fileno (p->cs_link), p);
 512     }
 513     Tcl_AppendResult (interp, p->hostname, NULL);
 514     return TCL_OK;
 515 }
 516
 517 /*
 518  * do_disconnect: disconnect method on IR object
 519  */
 520 static int do_disconnect (void *obj, Tcl_Interp *interp,
 521                           int argc, char **argv)
 522 {
 523     IRObj *p = obj;
 524
 525     if (p->hostname)
 526     {
 527         free (p->hostname);
 528         p->hostname = NULL;
 529         ir_select_remove (cs_fileno (p->cs_link), p);
 530     }
 531     if (cs_type (p->cs_link) == tcpip_type)
 532     {
 533         cs_close (p->cs_link);
 534         p->cs_link = cs_create (tcpip_type, 0);
 535     }
 536     else if (cs_type (p->cs_link) == mosi_type)
 537     {
 538         cs_close (p->cs_link);
 539         p->cs_link = cs_create (mosi_type, 0);
 540     }
 541     else
 542     {
 543         interp->result = "unknown comstack type";
 544         return TCL_ERROR;
 545     }
 546     return TCL_OK;
 547 }
 548
 549 /*
 550  * do_comstack: Set/get comstack method on IR object
 551  */
 552 static int do_comstack (void *obj, Tcl_Interp *interp,
 553                         int argc, char **argv)
 554 {
 555     char *cs_type = NULL;
 556     if (argc == 3)
 557     {
 558         cs_close (((IRObj*) obj)->cs_link);
 559         if (!strcmp (argv[2], "tcpip"))
 560             ((IRObj *)obj)->cs_link = cs_create (tcpip_type, 0);
 561         else if (!strcmp (argv[2], "mosi"))
 562             ((IRObj *)obj)->cs_link = cs_create (mosi_type, 0);
 563         else
 564         {
 565             interp->result = "wrong comstack type";
 566             return TCL_ERROR;
 567         }
 568     }
 569     if (cs_type(((IRObj *)obj)->cs_link) == tcpip_type)
 570         cs_type = "tcpip";
 571     else if (cs_type(((IRObj *)obj)->cs_link) == mosi_type)
 572         cs_type = "comstack";
 573     Tcl_AppendResult (interp, cs_type, NULL);
 574     return TCL_OK;
 575 }
 576
 577 /*
 578  * do_callback: add callback
 579  */
 580 static int do_callback (void *obj, Tcl_Interp *interp,
 581                           int argc, char **argv)
 582 {
 583     IRObj *p = obj;
 584
 585     if (argc == 3)
 586     {
 587         free (p->callback);
 588         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 589             return TCL_ERROR;
 590         p->interp = interp;
 591     }
 592     return TCL_OK;
 593 }
 594
 595 /*
 596  * do_databaseNames: specify database names
 597  */
 598 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 599                           int argc, char **argv)
 600 {
 601     int i;
 602     IRObj *p = obj;
 603
 604     if (argc < 3)
 605     {
 606         for (i=0; i<p->num_databaseNames; i++)
 607             Tcl_AppendElement (interp, p->databaseNames[i]);
 608         return TCL_OK;
 609     }
 610     if (p->databaseNames)
 611     {
 612         for (i=0; i<p->num_databaseNames; i++)
 613             free (p->databaseNames[i]);
 614         free (p->databaseNames);
 615     }
 616     p->num_databaseNames = argc - 2;
 617     if (!(p->databaseNames = ir_malloc (interp,
 618           sizeof(*p->databaseNames) * p->num_databaseNames)))
 619         return TCL_ERROR;
 620     for (i=0; i<p->num_databaseNames; i++)
 621     {
 622         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 623             == TCL_ERROR)
 624             return TCL_ERROR;
 625     }
 626     return TCL_OK;
 627 }
 628
 629 /*
 630  * do_query: Set/Get query mothod
 631  */
 632 static int do_query (void *obj, Tcl_Interp *interp,
 633                        int argc, char **argv)
 634 {
 635     IRObj *p = obj;
 636     if (argc == 3)
 637     {
 638         free (p->query_method);
 639         if (ir_strdup (interp, &p->query_method, argv[2]) == TCL_ERROR)
 640             return TCL_ERROR;
 641     }
 642     Tcl_AppendResult (interp, p->query_method, NULL);
 643     return TCL_OK;
 644 }
 645
 646 /*
 647  * ir_obj_method: IR Object methods
 648  */
 649 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 650                           int argc, char **argv)
 651 {
 652     static IRMethod tab[] = {
 653     { 1, "comstack",                do_comstack },
 654     { 1, "connect",                 do_connect },
 655     { 0, "protocolVersion",         do_protocolVersion },
 656     { 0, "options",                 do_options },
 657     { 1, "preferredMessageSize",    do_preferredMessageSize },
 658     { 1, "maximumRecordSize",       do_maximumRecordSize },
 659     { 1, "implementationName",      do_implementationName },
 660     { 1, "implementationId",        do_implementationId },
 661     { 1, "idAuthentication",        do_idAuthentication },
 662     { 0, "init",                    do_init_request },
 663     { 0, "disconnect",              do_disconnect },
 664     { 0, "callback",                do_callback },
 665     { 1, "databaseNames",           do_databaseNames},
 666     { 1, "query",                   do_query },
 667     { 0, NULL, NULL}
 668     };
 669     if (argc < 2)
 670         return ir_method_r (clientData, interp, argc, argv, tab);
 671     return ir_method (clientData, interp, argc, argv, tab);
 672 }
 673
 674 /*
 675  * ir_obj_delete: IR Object disposal
 676  */
 677 static void ir_obj_delete (ClientData clientData)
 678 {
 679     free ( (void*) clientData);
 680 }
 681
 682 /*
 683  * ir_obj_mk: IR Object creation
 684  */
 685 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 686               int argc, char **argv)
 687 {
 688     IRObj *obj;
 689     FILE *inf;
 690
 691     if (argc != 2)
 692     {
 693         interp->result = "wrong # args";
 694         return TCL_ERROR;
 695     }
 696     if (!(obj = ir_malloc (interp, sizeof(*obj))))
 697         return TCL_ERROR;
 698     obj->cs_link = cs_create (tcpip_type, 0);
 699
 700     obj->maximumRecordSize = 32768;
 701     obj->preferredMessageSize = 4096;
 702
 703     obj->idAuthentication = NULL;
 704
 705     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 706         == TCL_ERROR)
 707         return TCL_ERROR;
 708
 709     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 710         == TCL_ERROR)
 711         return TCL_ERROR;
 712
 713     obj->smallSetUpperBound = 0;
 714     obj->largeSetLowerBound = 2;
 715     obj->mediumSetPresentNumber = 0;
 716     obj->replaceIndicator = 1;
 717     obj->databaseNames = NULL;
 718     obj->num_databaseNames = 0;
 719
 720     obj->hostname = NULL;
 721
 722     if (ir_strdup (interp, &obj->query_method, "rpn") == TCL_ERROR)
 723         return TCL_ERROR;
 724     obj->bibset = ccl_qual_mk ();
 725     if ((inf = fopen ("default.bib", "r")))
 726     {
 727         ccl_qual_file (obj->bibset, inf);
 728         fclose (inf);
 729     }
 730     ODR_MASK_ZERO (&obj->protocolVersion);
 731     ODR_MASK_SET (&obj->protocolVersion, 0);
 732     ODR_MASK_SET (&obj->protocolVersion, 1);
 733
 734     ODR_MASK_ZERO (&obj->options);
 735     ODR_MASK_SET (&obj->options, 0);
 736
 737     obj->odr_in = odr_createmem (ODR_DECODE);
 738     obj->odr_out = odr_createmem (ODR_ENCODE);
 739     obj->odr_pr = odr_createmem (ODR_PRINT);
 740
 741     obj->len_out = 10000;
 742     if (!(obj->buf_out = ir_malloc (interp, obj->len_out)))
 743         return TCL_ERROR;
 744     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 745
 746     obj->len_in = 0;
 747     obj->buf_in = NULL;
 748
 749     obj->callback = NULL;
 750     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 751                        (ClientData) obj, ir_obj_delete);
 752     return TCL_OK;
 753 }
 754
 755 /* ------------------------------------------------------- */
 756 /*
 757  * do_search: Do search request
 758  */
 759 static int do_search (void *o, Tcl_Interp *interp,
 760                        int argc, char **argv)
 761 {
 762     Z_SearchRequest req;
 763     Z_Query query;
 764     Z_APDU apdu, *apdup;
 765     static Odr_oid bib1[] = {1, 2, 840, 10003, 3, 1, -1};
 766     Odr_oct ccl_query;
 767     IRSetObj *obj = o;
 768     IRObj *p = obj->parent;
 769     int r;
 770
 771     p->child = o;
 772     if (argc != 3)
 773     {
 774         interp->result = "wrong # args";
 775         return TCL_ERROR;
 776     }
 777     if (!p->num_databaseNames)
 778     {
 779         interp->result = "no databaseNames";
 780         return TCL_ERROR;
 781     }
 782     apdu.which = Z_APDU_searchRequest;
 783     apdu.u.searchRequest = &req;
 784     apdup = &apdu;
 785
 786     req.referenceId = 0;
 787     req.smallSetUpperBound = &p->smallSetUpperBound;
 788     req.largeSetLowerBound = &p->largeSetLowerBound;
 789     req.mediumSetPresentNumber = &p->mediumSetPresentNumber;
 790     req.replaceIndicator = &p->replaceIndicator;
 791     req.resultSetName = "Default";
 792     req.num_databaseNames = p->num_databaseNames;
 793     req.databaseNames = p->databaseNames;
 794     req.smallSetElementSetNames = 0;
 795     req.mediumSetElementSetNames = 0;
 796     req.preferredRecordSyntax = 0;
 797     req.query = &query;
 798
 799     if (!strcmp (p->query_method, "rpn"))
 800     {
 801         int error;
 802         int pos;
 803         struct ccl_rpn_node *rpn;
 804         Z_RPNQuery *RPNquery;
 805
 806         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
 807         if (error)
 808         {
 809             Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg(error),NULL);
 810             return TCL_ERROR;
 811         }
 812         query.which = Z_Query_type_1;
 813         assert((RPNquery = ccl_rpn_query(rpn)));
 814         RPNquery->attributeSetId = bib1;
 815         query.u.type_1 = RPNquery;
 816     }
 817     else if (!strcmp (p->query_method, "ccl"))
 818     {
 819         query.which = Z_Query_type_2;
 820         query.u.type_2 = &ccl_query;
 821         ccl_query.buf = argv[2];
 822         ccl_query.len = strlen (argv[2]);
 823     }
 824     else
 825     {
 826         interp->result = "unknown query method";
 827         return TCL_ERROR;
 828     }
 829     if (!z_APDU (p->odr_out, &apdup, 0))
 830     {
 831         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 832         odr_reset (p->odr_out);
 833         return TCL_ERROR;
 834     }
 835     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
 836     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 837     {
 838         interp->result = "cs_put failed in init";
 839         return TCL_ERROR;
 840     }
 841     else if (r == 1)
 842     {
 843         ir_select_add_write (cs_fileno(p->cs_link), p);
 844         printf("Sent part of searchRequest (%d bytes).\n", p->slen);
 845     }
 846     else
 847     {
 848         printf ("Whole search request\n");
 849     }
 850     return TCL_OK;
 851 }
 852
 853 /*
 854  * do_resultCount: Get number of hits
 855  */
 856 static int do_resultCount (void *o, Tcl_Interp *interp,
 857                        int argc, char **argv)
 858 {
 859     IRSetObj *obj = o;
 860
 861     sprintf (interp->result, "%d", obj->resultCount);
 862     return TCL_OK;
 863 }
 864
 865 /*
 866  * do_searchStatus: Get search status (after search response)
 867  */
 868 static int do_searchStatus (void *o, Tcl_Interp *interp,
 869                             int argc, char **argv)
 870 {
 871     IRSetObj *obj = o;
 872
 873     sprintf (interp->result, "%d", obj->searchStatus);
 874     return TCL_OK;
 875 }
 876
 877 /*
 878  * do_numberOfRecordsReturned: Get number of records returned
 879  */
 880 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
 881                        int argc, char **argv)
 882 {
 883     IRSetObj *obj = o;
 884
 885     sprintf (interp->result, "%d", obj->numberOfRecordsReturned);
 886     return TCL_OK;
 887 }
 888
 889 static int marc_cmp (const char *field, const char *pattern)
 890 {
 891     if (*pattern == '*')
 892         return 0;
 893     for (; *field && *pattern; field++, pattern++)
 894     {
 895         if (*pattern == '?')
 896             continue;
 897         if (*pattern != *field)
 898             break;
 899     }
 900     return *field - *pattern;
 901 }
 902
 903 static int get_marc_fields(Tcl_Interp *interp, Iso2709Rec rec,
 904                            int argc, char **argv)
 905 {
 906     struct iso2709_dir *dir;
 907     struct iso2709_field *field;
 908
 909     for (dir = rec->directory; dir; dir = dir->next)
 910     {
 911         if (argc > 4 && marc_cmp (dir->tag, argv[4]))
 912             continue;
 913         if (argc > 5 && marc_cmp (dir->indicator, argv[5]))
 914             continue;
 915         for (field = dir->fields; field; field = field->next)
 916         {
 917             if (argc > 6 && marc_cmp (field->identifier, argv[6]))
 918                 continue;
 919             Tcl_AppendElement (interp, field->data);
 920         }
 921     }
 922     return TCL_OK;
 923 }
 924
 925 static int get_marc_lines (Tcl_Interp *interp, Iso2709Rec rec,
 926                            int argc, char **argv)
 927 {
 928     struct iso2709_dir *dir;
 929     struct iso2709_field *field;
 930
 931     for (dir = rec->directory; dir; dir = dir->next)
 932     {
 933         if (argc > 4 && marc_cmp (dir->tag, argv[4]))
 934             continue;
 935         if (!dir->indicator)
 936             Tcl_AppendResult (interp, "{", dir->tag, " {} {", NULL);
 937         else
 938         {
 939             if (argc > 5 && marc_cmp (dir->indicator, argv[5]))
 940                 continue;
 941             Tcl_AppendResult (interp, "{", dir->tag, " {", dir->indicator,
 942                               "} {", NULL);
 943         }
 944         for (field = dir->fields; field; field = field->next)
 945         {
 946             if (!field->identifier)
 947                 Tcl_AppendResult (interp, "{{}", NULL);
 948             else
 949             {
 950                 if (argc > 6 && marc_cmp (field->identifier, argv[6]))
 951                     continue;
 952                 Tcl_AppendResult (interp, "{", field->identifier, NULL);
 953             }
 954             Tcl_AppendElement (interp, field->data);
 955             Tcl_AppendResult (interp, "} ", NULL);
 956         }
 957         Tcl_AppendResult (interp, "}} ", NULL);
 958     }
 959     return TCL_OK;
 960 }
 961
 962 /*
 963  * do_recordType: Return record type (if any) at position.
 964  */
 965 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
 966 {
 967     IRSetObj *obj = o;
 968     int offset;
 969     IRRecordList *rl;
 970
 971     if (argc < 3)
 972     {
 973         sprintf (interp->result, "wrong # args");
 974         return TCL_ERROR;
 975     }
 976     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 977         return TCL_ERROR;
 978     rl = find_IR_record (obj, offset);
 979     if (!rl)
 980         return TCL_OK;
 981     switch (rl->which)
 982     {
 983     case Z_NamePlusRecord_databaseRecord:
 984         interp->result = "databaseRecord";
 985         break;
 986     case Z_NamePlusRecord_surrogateDiagnostic:
 987         interp->result = "surrogateDiagnostic";
 988         break;
 989     }
 990     return TCL_OK;
 991 }
 992
 993 /*
 994  * do_recordDiag: Return diagnostic record info
 995  */
 996 static int do_recordDiag (void *o, Tcl_Interp *interp, int argc, char **argv)
 997 {
 998     IRSetObj *obj = o;
 999     int offset;
1000     IRRecordList *rl;
1001     char buf[20];
1002
1003     if (argc < 3)
1004     {
1005         sprintf (interp->result, "wrong # args");
1006         return TCL_ERROR;
1007     }
1008     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1009         return TCL_ERROR;
1010     rl = find_IR_record (obj, offset);
1011     if (!rl)
1012     {
1013         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1014         return TCL_ERROR;
1015     }
1016     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
1017     {
1018         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
1019         return TCL_ERROR;
1020     }
1021     sprintf (buf, "%d", rl->u.diag.condition);
1022     Tcl_AppendResult (interp, buf, " {",
1023                       (rl->u.diag.addinfo ? rl->u.diag.addinfo : ""),
1024                       "}", NULL);
1025     return TCL_OK;
1026 }
1027
1028 /*
1029  * do_recordMarc: Get ISO2709 Record lines/fields
1030  */
1031 static int do_recordMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
1032 {
1033     IRSetObj *obj = o;
1034     int offset;
1035     IRRecordList *rl;
1036
1037     if (argc < 4)
1038     {
1039         sprintf (interp->result, "wrong # args");
1040         return TCL_ERROR;
1041     }
1042     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1043         return TCL_ERROR;
1044     rl = find_IR_record (obj, offset);
1045     if (!rl)
1046     {
1047         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1048         return TCL_ERROR;
1049     }
1050     if (rl->which != Z_NamePlusRecord_databaseRecord)
1051     {
1052         Tcl_AppendResult (interp, "No MARC record at #", argv[2], NULL);
1053         return TCL_ERROR;
1054     }
1055     if (!strcmp (argv[3], "field"))
1056         return get_marc_fields (interp, rl->u.marc.rec, argc, argv);
1057     else if (!strcmp (argv[3], "line"))
1058         return get_marc_lines (interp, rl->u.marc.rec, argc, argv);
1059     else
1060     {
1061         Tcl_AppendResult (interp, "field/line expected", NULL);
1062         return TCL_ERROR;
1063     }
1064 }
1065
1066 /*
1067  * do_presentStatus: Return present status (after present response)
1068  */
1069 static int do_presentStatus (void *o, Tcl_Interp *interp,
1070                              int argc, char **argv)
1071 {
1072     IRSetObj *obj = o;
1073     const char *cp;
1074     char buf[28];
1075
1076     switch (obj->which)
1077     {
1078     case Z_Records_DBOSD:
1079         Tcl_AppendElement (interp, "DBOSD");
1080         break;
1081     case Z_Records_NSD:
1082         Tcl_AppendElement (interp, "NSD");
1083         sprintf (buf, "%d", obj->condition);
1084         Tcl_AppendElement (interp, buf);
1085         cp = diagbib1_str (obj->condition);
1086         if (cp)
1087             Tcl_AppendElement (interp, (char*) cp);
1088         else
1089             Tcl_AppendElement (interp, "");
1090         if (obj->addinfo)
1091             Tcl_AppendElement (interp, obj->addinfo);
1092         else
1093             Tcl_AppendElement (interp, "");
1094         break;
1095     }
1096     return TCL_OK;
1097 }
1098
1099 /*
1100  * do_present: Perform Present Request
1101  */
1102
1103 static int do_present (void *o, Tcl_Interp *interp,
1104                        int argc, char **argv)
1105 {
1106     IRSetObj *obj = o;
1107     IRObj *p = obj->parent;
1108     Z_APDU apdu, *apdup;
1109     Z_PresentRequest req;
1110     int start;
1111     int number;
1112     int r;
1113
1114     if (argc >= 3)
1115     {
1116         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
1117             return TCL_ERROR;
1118     }
1119     else
1120         start = 1;
1121     if (argc >= 4)
1122     {
1123         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
1124             return TCL_ERROR;
1125     }
1126     else
1127         number = 10;
1128     obj->start = start;
1129     obj->number = number;
1130
1131     apdup = &apdu;
1132     apdu.which = Z_APDU_presentRequest;
1133     apdu.u.presentRequest = &req;
1134     req.referenceId = 0;
1135     /* sprintf(setstring, "%d", setnumber); */
1136     req.resultSetId = "Default";
1137     req.resultSetStartPoint = &start;
1138     req.numberOfRecordsRequested = &number;
1139     req.elementSetNames = 0;
1140     req.preferredRecordSyntax = 0;
1141
1142     if (!z_APDU (p->odr_out, &apdup, 0))
1143     {
1144         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1145         odr_reset (p->odr_out);
1146         return TCL_ERROR;
1147     }
1148     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
1149     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1150     {
1151         interp->result = "cs_put failed in init";
1152         return TCL_ERROR;
1153     }
1154     else if (r == 1)
1155     {
1156         ir_select_add_write (cs_fileno(p->cs_link), p);
1157         printf ("Part of present request, start=%d, num=%d (%d bytes)\n",
1158                 start, number, p->slen);
1159     }
1160     else
1161     {
1162         printf ("Whole present request, start=%d, num=%d (%d bytes)\n",
1163                 start, number, p->slen);
1164     }
1165     return TCL_OK;
1166 }
1167
1168 /*
1169  * do_loadFile: Load result set from file
1170  */
1171
1172 static int do_loadFile (void *o, Tcl_Interp *interp,
1173                         int argc, char **argv)
1174 {
1175     IRSetObj *setobj = o;
1176     FILE *inf;
1177     int  no = 1;
1178     const char *buf;
1179
1180     if (argc < 3)
1181     {
1182         interp->result = "wrong # args";
1183         return TCL_ERROR;
1184     }
1185     inf = fopen (argv[2], "r");
1186     if (!inf)
1187     {
1188         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
1189         return TCL_ERROR;
1190     }
1191     while ((buf = iso2709_read (inf)))
1192     {
1193         IRRecordList *rl;
1194         Iso2709Rec rec;
1195
1196         rec = iso2709_cvt (buf);
1197         if (!rec)
1198             break;
1199         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
1200         rl->u.marc.rec = rec;
1201         no++;
1202     }
1203     setobj->numberOfRecordsReturned = no-1;
1204     fclose (inf);
1205     return TCL_OK;
1206 }
1207
1208
1209 /*
1210  * ir_set_obj_method: IR Set Object methods
1211  */
1212 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1213                           int argc, char **argv)
1214 {
1215     static IRMethod tab[] = {
1216     { 0, "search",                  do_search },
1217     { 0, "searchStatus",            do_searchStatus },
1218     { 0, "resultCount",             do_resultCount },
1219     { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },
1220     { 0, "present",                 do_present },
1221     { 0, "recordType",              do_recordType },
1222     { 0, "recordMarc",              do_recordMarc },
1223     { 0, "recordDiag",              do_recordDiag },
1224     { 0, "presentStatus",           do_presentStatus },
1225     { 0, "loadFile",                do_loadFile },
1226     { 0, NULL, NULL}
1227     };
1228
1229     if (argc < 2)
1230     {
1231         interp->result = "wrong # args";
1232         return TCL_ERROR;
1233     }
1234     return ir_method (clientData, interp, argc, argv, tab);
1235 }
1236
1237 /*
1238  * ir_set_obj_delete: IR Set Object disposal
1239  */
1240 static void ir_set_obj_delete (ClientData clientData)
1241 {
1242     free ( (void*) clientData);
1243 }
1244
1245 /*
1246  * ir_set_obj_mk: IR Set Object creation
1247  */
1248 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1249                              int argc, char **argv)
1250 {
1251     Tcl_CmdInfo parent_info;
1252     IRSetObj *obj;
1253
1254     if (argc != 2)
1255     {
1256         interp->result = "wrong # args";
1257         return TCL_ERROR;
1258     }
1259     if (get_parent_info (interp, argv[1], &parent_info) == TCL_ERROR)
1260         return TCL_ERROR;
1261     if (!(obj = ir_malloc (interp, sizeof(*obj))))
1262         return TCL_ERROR;
1263     obj->z_records = NULL;
1264     obj->record_list = NULL;
1265     obj->addinfo = NULL;
1266     obj->parent = (IRObj *) parent_info.clientData;
1267     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
1268                        (ClientData) obj, ir_set_obj_delete);
1269     return TCL_OK;
1270 }
1271
1272 /* ------------------------------------------------------- */
1273
1274 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
1275 {
1276     IRObj *p = o;
1277     IRSetObj *obj = p->child;
1278
1279     if (obj)
1280     {
1281         obj->searchStatus = searchrs->searchStatus ? 1 : 0;
1282         obj->resultCount = *searchrs->resultCount;
1283         printf ("Search response %d, %d hits\n",
1284                  obj->searchStatus, obj->resultCount);
1285     }
1286     else
1287         printf ("Search response, no object!\n");
1288 }
1289
1290 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
1291 {
1292     if (!*initrs->result)
1293         printf("Connection rejected by target.\n");
1294     else
1295         printf("Connection accepted by target.\n");
1296     if (initrs->implementationId)
1297             printf("ID     : %s\n", initrs->implementationId);
1298     if (initrs->implementationName)
1299         printf("Name   : %s\n", initrs->implementationName);
1300     if (initrs->implementationVersion)
1301         printf("Version: %s\n", initrs->implementationVersion);
1302     if (initrs->maximumRecordSize)
1303         printf ("MaximumRecordSize=%d\n", *initrs->maximumRecordSize);
1304     if (initrs->preferredMessageSize)
1305         printf ("PreferredMessageSize=%d\n", *initrs->preferredMessageSize);
1306 #if 0
1307     if (initrs->userInformationField)
1308     {
1309         printf("UserInformationfield:\n");
1310         odr_external(&print, (Odr_external**)&initrs->
1311                          userInformationField, 0);
1312     }
1313 #endif
1314 }
1315
1316 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
1317 {
1318     IRObj *p = o;
1319     IRSetObj *setobj = p->child;
1320     Z_Records *zrs = presrs->records;
1321     setobj->z_records = presrs->records;
1322
1323     printf ("Received presentResponse\n");
1324     if (zrs)
1325     {
1326         setobj->which = zrs->which;
1327         if (zrs->which == Z_Records_NSD)
1328         {
1329             const char *addinfo;
1330
1331             printf ("They are diagnostic!!!\n");
1332
1333             setobj->numberOfRecordsReturned = 0;
1334             setobj->condition = *zrs->u.nonSurrogateDiagnostic->condition;
1335             free (setobj->addinfo);
1336             setobj->addinfo = NULL;
1337             addinfo = zrs->u.nonSurrogateDiagnostic->addinfo;
1338             if (addinfo && (setobj->addinfo = malloc (strlen(addinfo) + 1)))
1339                 strcpy (setobj->addinfo, addinfo);
1340             return;
1341         }
1342         else
1343         {
1344             int offset;
1345             IRRecordList *rl;
1346
1347             setobj->numberOfRecordsReturned =
1348                 zrs->u.databaseOrSurDiagnostics->num_records;
1349             printf ("Got %d records\n", setobj->numberOfRecordsReturned);
1350             for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
1351             {
1352                 rl = new_IR_record (setobj, setobj->start + offset,
1353                                     zrs->u.databaseOrSurDiagnostics->
1354                                     records[offset]->which);
1355                 if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
1356                 {
1357                     Z_DiagRec *diagrec;
1358
1359                     diagrec = zrs->u.databaseOrSurDiagnostics->
1360                               records[offset]->u.surrogateDiagnostic;
1361
1362                     rl->u.diag.condition = *diagrec->condition;
1363                     if (diagrec->addinfo && (rl->u.diag.addinfo =
1364                         malloc (strlen (diagrec->addinfo)+1)))
1365                         strcpy (rl->u.diag.addinfo, diagrec->addinfo);
1366                 }
1367                 else
1368                 {
1369                     Z_DatabaseRecord *zr;
1370                     Odr_external *oe;
1371
1372                     zr = zrs->u.databaseOrSurDiagnostics->records[offset]
1373                         ->u.databaseRecord;
1374                     oe = (Odr_external*) zr;
1375                     if (oe->which == ODR_EXTERNAL_octet
1376                         && zr->u.octet_aligned->len)
1377                     {
1378                         const char *buf = (char*) zr->u.octet_aligned->buf;
1379                         rl->u.marc.rec = iso2709_cvt (buf);
1380                     }
1381                     else
1382                         rl->u.marc.rec = NULL;
1383                 }
1384             }
1385         }
1386     }
1387     else
1388     {
1389         printf ("No records!\n");
1390     }
1391 }
1392
1393 /*
1394  * ir_select_read: handle incoming packages
1395  */
1396 void ir_select_read (ClientData clientData)
1397 {
1398     IRObj *p = clientData;
1399     Z_APDU *apdu;
1400     int r;
1401
1402     do
1403     {
1404         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  <= 0)
1405         {
1406             printf ("cs_get failed\n");
1407             ir_select_remove (cs_fileno (p->cs_link), p);
1408             return;
1409         }
1410         if (r == 1)
1411             return ;
1412         odr_setbuf (p->odr_in, p->buf_in, r);
1413         printf ("cs_get ok, got %d\n", r);
1414         if (!z_APDU (p->odr_in, &apdu, 0))
1415         {
1416             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
1417             return;
1418         }
1419         switch(apdu->which)
1420         {
1421         case Z_APDU_initResponse:
1422             ir_initResponse (p, apdu->u.initResponse);
1423             break;
1424         case Z_APDU_searchResponse:
1425             ir_searchResponse (p, apdu->u.searchResponse);
1426             break;
1427         case Z_APDU_presentResponse:
1428             ir_presentResponse (p, apdu->u.presentResponse);
1429             break;
1430         default:
1431             printf("Received unknown APDU type (%d).\n",
1432                    apdu->which);
1433         }
1434         if (p->callback)
1435             Tcl_Eval (p->interp, p->callback);
1436     } while (cs_more (p->cs_link));
1437 }
1438
1439 /*
1440  * ir_select_write: handle outgoing packages - not yet written.
1441  */
1442 void ir_select_write (ClientData clientData)
1443 {
1444     IRObj *p = clientData;
1445     int r;
1446
1447     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1448     {
1449         printf ("select write fail\n");
1450         cs_close (p->cs_link);
1451     }
1452     else if (r == 0)            /* remove select bit */
1453     {
1454         ir_select_remove_write (cs_fileno (p->cs_link), p);
1455     }
1456 }
1457
1458 /* ------------------------------------------------------- */
1459
1460 /*
1461  * ir_tcl_init: Registration of TCL commands.
1462  */
1463 int ir_tcl_init (Tcl_Interp *interp)
1464 {
1465     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
1466                        (Tcl_CmdDeleteProc *) NULL);
1467     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
1468                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1469     return TCL_OK;
1470 }
1471
1472