ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  *
   5  * $Log: ir-tcl.c,v $
   6  * Revision 1.4  1995-03-09 16:15:08  adam
   7  * First presentRequest attempts. Hot-target list.
   8  *
   9  */
  10
  11 #include <stdlib.h>
  12 #include <stdio.h>
  13 #include <sys/time.h>
  14 #include <assert.h>
  15
  16 #include <comstack.h>
  17 #include <tcpip.h>
  18 #include <xmosi.h>
  19
  20 #include <odr.h>
  21 #include <proto.h>
  22
  23 #include <tcl.h>
  24
  25 #include "ir-tcl.h"
  26
  27 typedef struct {
  28     COMSTACK cs_link;
  29
  30     int preferredMessageSize;
  31     int maximumMessageSize;
  32     Odr_bitmask options;
  33     Odr_bitmask protocolVersion;
  34     char *idAuthentication;
  35     char *implementationName;
  36     char *implementationId;
  37
  38     char *buf_out;
  39     int  len_out;
  40
  41     char *buf_in;
  42     int  len_in;
  43
  44     ODR odr_in;
  45     ODR odr_out;
  46     ODR odr_pr;
  47
  48     Tcl_Interp *interp;
  49     char *callback;
  50
  51     int smallSetUpperBound;
  52     int largeSetLowerBound;
  53     int mediumSetPresentNumber;
  54     int replaceIndicator;
  55     char **databaseNames;
  56     int num_databaseNames;
  57
  58     struct IRSetObj_ *child;
  59 } IRObj;
  60
  61 typedef struct IRSetObj_ {
  62     IRObj *parent;
  63     int resultCount;
  64 } IRSetObj;
  65
  66 typedef struct {
  67     char *name;
  68     int (*method) (void * obj, Tcl_Interp *interp, int argc, char **argv);
  69 } IRMethod;
  70
  71 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
  72
  73 /*
  74  * get_parent_info: Returns information about parent object.
  75  */
  76 static int get_parent_info (Tcl_Interp *interp, const char *name,
  77                             Tcl_CmdInfo *parent_info)
  78 {
  79     char parent_name[128];
  80     const char *csep = strrchr (name, '.');
  81     int pos;
  82
  83     if (!csep)
  84     {
  85         interp->result = "missing .";
  86         return TCL_ERROR;
  87     }
  88     pos = csep-name;
  89     if (pos > 127)
  90         pos = 127;
  91     memcpy (parent_name, name, pos);
  92     parent_name[pos] = '\0';
  93     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
  94     {
  95         interp->result = "No parent";
  96         return TCL_ERROR;
  97     }
  98     return TCL_OK;
  99 }
 100
 101 /*
 102  * ir_method: Search for method in table and invoke method handler
 103  */
 104 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 105                    IRMethod *tab)
 106 {
 107     while (tab->name)
 108     {
 109         if (!strcmp (tab->name, argv[1]))
 110             return (*tab->method)(obj, interp, argc, argv);
 111         tab++;
 112     }
 113     Tcl_AppendResult (interp, "unknown method: ", argv[1], NULL);
 114     return TCL_ERROR;
 115 }
 116
 117 /*
 118  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 119  */
 120 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 121 {
 122     const char *cp = asc + strlen(asc);
 123     int bitno = 0;
 124
 125     ODR_MASK_ZERO (ob);
 126     do
 127     {
 128         if (*--cp == '1')
 129             ODR_MASK_SET (ob, bitno);
 130         bitno++;
 131     } while (cp != asc);
 132     return bitno;
 133 }
 134
 135 /*
 136  * ir_strdup: Duplicate string
 137  */
 138 int ir_strdup (Tcl_Interp *interp, char** p, char *s)
 139 {
 140     *p = malloc (strlen(s)+1);
 141     if (!*p)
 142     {
 143         interp->result = "malloc fail";
 144         return TCL_ERROR;
 145     }
 146     strcpy (*p, s);
 147     return TCL_OK;
 148 }
 149
 150 /* ------------------------------------------------------- */
 151
 152 /*
 153  * do_init_request: init method on IR object
 154  */
 155 static int do_init_request (void *obj, Tcl_Interp *interp,
 156                        int argc, char **argv)
 157 {
 158     Z_APDU apdu, *apdup;
 159     IRObj *p = obj;
 160     Z_InitRequest req;
 161     char *sbuf;
 162     int slen;
 163
 164     req.referenceId = 0;
 165     req.options = &p->options;
 166     req.protocolVersion = &p->protocolVersion;
 167     req.preferredMessageSize = &p->preferredMessageSize;
 168     req.maximumRecordSize = &p->maximumMessageSize;
 169
 170     req.idAuthentication = p->idAuthentication;
 171     req.implementationId = p->implementationId;
 172     req.implementationName = p->implementationName;
 173     req.implementationVersion = "0.1";
 174     req.userInformationField = 0;
 175
 176     apdu.u.initRequest = &req;
 177     apdu.which = Z_APDU_initRequest;
 178     apdup = &apdu;
 179
 180     if (!z_APDU (p->odr_out, &apdup, 0))
 181     {
 182         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 183         odr_reset (p->odr_out);
 184         return TCL_ERROR;
 185     }
 186     sbuf = odr_getbuf (p->odr_out, &slen);
 187     if (cs_put (p->cs_link, sbuf, slen) < 0)
 188     {
 189         interp->result = "cs_put failed in init";
 190         return TCL_ERROR;
 191     }
 192     printf("Sent initializeRequest (%d bytes).\n", slen);
 193     return TCL_OK;
 194 }
 195
 196 /*
 197  * do_protocolVersion: Set protocol Version
 198  */
 199 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 200                                int argc, char **argv)
 201 {
 202     if (argc == 3)
 203         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 204     return TCL_OK;
 205 }
 206
 207 /*
 208  * do_options: Set options
 209  */
 210 static int do_options (void *obj, Tcl_Interp *interp,
 211                        int argc, char **argv)
 212 {
 213     if (argc == 3)
 214         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 215     return TCL_OK;
 216 }
 217
 218 /*
 219  * do_preferredMessageSize: Set preferred message size
 220  */
 221 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 222                                     int argc, char **argv)
 223 {
 224     if (argc == 3)
 225     {
 226         if (Tcl_GetInt (interp, argv[2],
 227                         &((IRObj *)obj)->preferredMessageSize)==TCL_ERROR)
 228             return TCL_ERROR;
 229     }
 230     sprintf (interp->result, "%d", ((IRObj *)obj)->preferredMessageSize);
 231     return TCL_OK;
 232 }
 233
 234 /*
 235  * do_maximumMessageSize: Set maximum message size
 236  */
 237 static int do_maximumMessageSize (void *obj, Tcl_Interp *interp,
 238                                     int argc, char **argv)
 239 {
 240     if (argc == 3)
 241     {
 242         if (Tcl_GetInt (interp, argv[2],
 243                         &((IRObj *)obj)->maximumMessageSize)==TCL_ERROR)
 244             return TCL_ERROR;
 245     }
 246     sprintf (interp->result, "%d", ((IRObj *)obj)->maximumMessageSize);
 247     return TCL_OK;
 248 }
 249
 250
 251 /*
 252  * do_implementationName: Set Implementation Name.
 253  */
 254 static int do_implementationName (void *obj, Tcl_Interp *interp,
 255                                     int argc, char **argv)
 256 {
 257     if (argc == 3)
 258     {
 259         free (((IRObj*)obj)->implementationName);
 260         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 261             == TCL_ERROR)
 262             return TCL_ERROR;
 263     }
 264     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 265                       (char*) NULL);
 266     return TCL_OK;
 267 }
 268
 269 /*
 270  * do_implementationId: Set Implementation Name.
 271  */
 272 static int do_implementationId (void *obj, Tcl_Interp *interp,
 273                                 int argc, char **argv)
 274 {
 275     if (argc == 3)
 276     {
 277         free (((IRObj*)obj)->implementationId);
 278         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 279             == TCL_ERROR)
 280             return TCL_ERROR;
 281     }
 282     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 283                       (char*) NULL);
 284     return TCL_OK;
 285 }
 286
 287 /*
 288  * do_idAuthentication: Set id Authentication
 289  */
 290 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 291                                 int argc, char **argv)
 292 {
 293     if (argc == 3)
 294     {
 295         free (((IRObj*)obj)->idAuthentication);
 296         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 297             == TCL_ERROR)
 298             return TCL_ERROR;
 299     }
 300     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 301                       (char*) NULL);
 302     return TCL_OK;
 303 }
 304
 305 /*
 306  * do_connect: connect method on IR object
 307  */
 308 static int do_connect (void *obj, Tcl_Interp *interp,
 309                        int argc, char **argv)
 310 {
 311     void *addr;
 312     IRObj *p = obj;
 313
 314     if (argc < 3)
 315     {
 316         interp->result = "missing hostname";
 317         return TCL_ERROR;
 318     }
 319     if (cs_type(p->cs_link) == tcpip_type)
 320     {
 321         addr = tcpip_strtoaddr (argv[2]);
 322         if (!addr)
 323         {
 324             interp->result = "tcpip_strtoaddr fail";
 325             return TCL_ERROR;
 326         }
 327         printf ("tcp/ip connect %s\n", argv[2]);
 328     }
 329     else if (cs_type (p->cs_link) == mosi_type)
 330     {
 331         addr = mosi_strtoaddr (argv[2]);
 332         if (!addr)
 333         {
 334             interp->result = "mosi_strtoaddr fail";
 335             return TCL_ERROR;
 336         }
 337         printf ("mosi connect %s\n", argv[2]);
 338     }
 339     if (cs_connect (p->cs_link, addr) < 0)
 340     {
 341         interp->result = "cs_connect fail";
 342         do_disconnect (p, interp, argc, argv);
 343         return TCL_ERROR;
 344     }
 345     ir_select_add (cs_fileno (p->cs_link), p);
 346     return TCL_OK;
 347 }
 348
 349 /*
 350  * do_disconnect: disconnect method on IR object
 351  */
 352 static int do_disconnect (void *obj, Tcl_Interp *interp,
 353                           int argc, char **argv)
 354 {
 355     IRObj *p = obj;
 356
 357     ir_select_remove (cs_fileno (p->cs_link), p);
 358     if (cs_type (p->cs_link) == tcpip_type)
 359     {
 360         cs_close (p->cs_link);
 361         p->cs_link = cs_create (tcpip_type);
 362     }
 363     else if (cs_type (p->cs_link) == mosi_type)
 364     {
 365         cs_close (p->cs_link);
 366         p->cs_link = cs_create (mosi_type);
 367     }
 368     else
 369     {
 370         interp->result = "unknown comstack type";
 371         return TCL_ERROR;
 372     }
 373     return TCL_OK;
 374 }
 375
 376 /*
 377  * do_comstack: comstack method on IR object
 378  */
 379 static int do_comstack (void *obj, Tcl_Interp *interp,
 380                         int argc, char **argv)
 381 {
 382     if (argc == 3)
 383     {
 384         if (!strcmp (argv[2], "tcpip"))
 385             ((IRObj *)obj)->cs_link = cs_create (tcpip_type);
 386         else if (!strcmp (argv[2], "mosi"))
 387             ((IRObj *)obj)->cs_link = cs_create (mosi_type);
 388         else
 389         {
 390             interp->result = "wrong comstack type";
 391             return TCL_ERROR;
 392         }
 393     }
 394     if (cs_type(((IRObj *)obj)->cs_link) == tcpip_type)
 395         interp->result = "tcpip";
 396     else if (cs_type(((IRObj *)obj)->cs_link) == mosi_type)
 397         interp->result = "comstack";
 398     return TCL_OK;
 399 }
 400
 401 /*
 402  * do_callback: add callback
 403  */
 404 static int do_callback (void *obj, Tcl_Interp *interp,
 405                           int argc, char **argv)
 406 {
 407     IRObj *p = obj;
 408
 409     if (argc == 3)
 410     {
 411         free (p->callback);
 412         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 413             return TCL_ERROR;
 414         p->interp = interp;
 415     }
 416     return TCL_OK;
 417 }
 418
 419 /*
 420  * do_databaseNames: specify database names
 421  */
 422 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 423                           int argc, char **argv)
 424 {
 425     int i;
 426     IRObj *p = obj;
 427
 428     if (argc < 3)
 429     {
 430         interp->result = "wrong # args";
 431         return TCL_ERROR;
 432     }
 433     if (p->databaseNames)
 434     {
 435         for (i=0; i<p->num_databaseNames; i++)
 436             free (p->databaseNames[i]);
 437         free (p->databaseNames);
 438     }
 439     p->num_databaseNames = argc - 2;
 440     if (!(p->databaseNames = malloc (sizeof(*p->databaseNames) *
 441                                p->num_databaseNames)))
 442     {
 443         interp->result = "malloc fail";
 444         return TCL_ERROR;
 445     }
 446     for (i=0; i<p->num_databaseNames; i++)
 447     {
 448         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 449             == TCL_ERROR)
 450             return TCL_ERROR;
 451     }
 452     return TCL_OK;
 453 }
 454
 455 /*
 456  * ir_obj_method: IR Object methods
 457  */
 458 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 459                           int argc, char **argv)
 460 {
 461     static IRMethod tab[] = {
 462     { "comstack", do_comstack },
 463     { "connect", do_connect },
 464     { "protocolVersion", do_protocolVersion },
 465     { "options", do_options },
 466     { "preferredMessageSize", do_preferredMessageSize },
 467     { "maximumMessageSize",   do_maximumMessageSize },
 468     { "implementationName", do_implementationName },
 469     { "implementationId",   do_implementationId },
 470     { "idAuthentication",   do_idAuthentication },
 471     { "init", do_init_request },
 472     { "disconnect", do_disconnect },
 473     { "callback", do_callback },
 474     { "databaseNames", do_databaseNames},
 475     { NULL, NULL}
 476     };
 477     if (argc < 2)
 478     {
 479         interp->result = "wrong # args";
 480         return TCL_ERROR;
 481     }
 482     return ir_method (clientData, interp, argc, argv, tab);
 483 }
 484
 485 /*
 486  * ir_obj_delete: IR Object disposal
 487  */
 488 static void ir_obj_delete (ClientData clientData)
 489 {
 490     free ( (void*) clientData);
 491 }
 492
 493 /*
 494  * ir_obj_mk: IR Object creation
 495  */
 496 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 497               int argc, char **argv)
 498 {
 499     IRObj *obj;
 500
 501     if (argc != 2)
 502     {
 503         interp->result = "wrong # args";
 504         return TCL_ERROR;
 505     }
 506     obj = malloc (sizeof(*obj));
 507     if (!obj)
 508     {
 509         interp->result = "malloc fail";
 510         return TCL_ERROR;
 511     }
 512     obj->cs_link = cs_create (tcpip_type);
 513
 514     obj->maximumMessageSize = 9000;
 515     obj->preferredMessageSize = 4096;
 516
 517     obj->idAuthentication = NULL;
 518
 519     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 520         == TCL_ERROR)
 521         return TCL_ERROR;
 522
 523     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 524         == TCL_ERROR)
 525         return TCL_ERROR;
 526
 527     obj->smallSetUpperBound = 0;
 528     obj->largeSetLowerBound = 2;
 529     obj->mediumSetPresentNumber = 0;
 530     obj->replaceIndicator = 1;
 531     obj->databaseNames = NULL;
 532     obj->num_databaseNames = 0;
 533
 534     ODR_MASK_ZERO (&obj->protocolVersion);
 535     ODR_MASK_SET (&obj->protocolVersion, 0);
 536     ODR_MASK_SET (&obj->protocolVersion, 1);
 537
 538     ODR_MASK_ZERO (&obj->options);
 539     ODR_MASK_SET (&obj->options, 0);
 540
 541     obj->odr_in = odr_createmem (ODR_DECODE);
 542     obj->odr_out = odr_createmem (ODR_ENCODE);
 543     obj->odr_pr = odr_createmem (ODR_PRINT);
 544
 545     obj->len_out = 10000;
 546     obj->buf_out = malloc (obj->len_out);
 547     if (!obj->buf_out)
 548     {
 549         interp->result = "malloc fail";
 550         return TCL_ERROR;
 551     }
 552     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 553
 554     obj->len_in = 0;
 555     obj->buf_in = NULL;
 556
 557     obj->callback = NULL;
 558
 559     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 560                        (ClientData) obj, ir_obj_delete);
 561     return TCL_OK;
 562 }
 563
 564 /* ------------------------------------------------------- */
 565 /*
 566  * do_search: Do search request
 567  */
 568 static int do_search (void *o, Tcl_Interp *interp,
 569                        int argc, char **argv)
 570 {
 571     Z_SearchRequest req;
 572     Z_Query query;
 573     Z_APDU apdu, *apdup;
 574     static Odr_oid bib1[] = {1, 2, 840, 10003, 3, 1, -1};
 575     Odr_oct ccl_query;
 576     IRSetObj *obj = o;
 577     IRObj *p = obj->parent;
 578     char *sbuf;
 579     int slen;
 580
 581     p->child = o;
 582     if (argc != 3)
 583     {
 584         interp->result = "wrong # args";
 585         return TCL_ERROR;
 586     }
 587     if (!p->num_databaseNames)
 588     {
 589         interp->result = "no databaseNames";
 590         return TCL_ERROR;
 591     }
 592     apdu.which = Z_APDU_searchRequest;
 593     apdu.u.searchRequest = &req;
 594     apdup = &apdu;
 595
 596     req.referenceId = 0;
 597     req.smallSetUpperBound = &p->smallSetUpperBound;
 598     req.largeSetLowerBound = &p->largeSetLowerBound;
 599     req.mediumSetPresentNumber = &p->mediumSetPresentNumber;
 600     req.replaceIndicator = &p->replaceIndicator;
 601     req.resultSetName = "Default";
 602     req.num_databaseNames = p->num_databaseNames;
 603     req.databaseNames = p->databaseNames;
 604     req.smallSetElementSetNames = 0;
 605     req.mediumSetElementSetNames = 0;
 606     req.preferredRecordSyntax = 0;
 607     req.query = &query;
 608
 609     query.which = Z_Query_type_2;
 610     query.u.type_2 = &ccl_query;
 611     ccl_query.buf = argv[2];
 612     ccl_query.len = strlen (argv[2]);
 613
 614     if (!z_APDU (p->odr_out, &apdup, 0))
 615     {
 616         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 617         odr_reset (p->odr_out);
 618         return TCL_ERROR;
 619     }
 620     sbuf = odr_getbuf (p->odr_out, &slen);
 621     if (cs_put (p->cs_link, sbuf, slen) < 0)
 622     {
 623         interp->result = "cs_put failed in init";
 624         return TCL_ERROR;
 625     }
 626     return TCL_OK;
 627 }
 628
 629 /*
 630  * do_query: Set query for a Set Object
 631  */
 632 static int do_query (void *obj, Tcl_Interp *interp,
 633                        int argc, char **argv)
 634 {
 635     return TCL_OK;
 636 }
 637
 638 /*
 639  * do_resultCount: Get number of hits
 640  */
 641 static int do_resultCount (void *o, Tcl_Interp *interp,
 642                        int argc, char **argv)
 643 {
 644     IRSetObj *obj = o;
 645
 646     sprintf (interp->result, "%d", obj->resultCount);
 647     return TCL_OK;
 648 }
 649
 650
 651 /*
 652  * do_present: Perform present Request
 653  */
 654
 655 static int do_present (void *o, Tcl_Interp *interp,
 656                        int argc, char **argv)
 657 {
 658     IRSetObj *obj = o;
 659     IRObj *p = obj->parent;
 660     Z_APDU apdu, *apdup;
 661     Z_PresentRequest req;
 662     int start;
 663     int number;
 664     char *sbuf;
 665     int slen;
 666
 667     if (argc >= 3)
 668     {
 669         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
 670             return TCL_ERROR;
 671     }
 672     else
 673         start = 1;
 674     if (argc >= 4)
 675     {
 676         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
 677             return TCL_ERROR;
 678     }
 679     else
 680         number = 10;
 681     apdup = &apdu;
 682     apdu.which = Z_APDU_presentRequest;
 683     apdu.u.presentRequest = &req;
 684     req.referenceId = 0;
 685     /* sprintf(setstring, "%d", setnumber); */
 686     req.resultSetId = "Default";
 687     req.resultSetStartPoint = &start;
 688     req.numberOfRecordsRequested = &number;
 689     req.elementSetNames = 0;
 690     req.preferredRecordSyntax = 0;
 691
 692     if (!z_APDU (p->odr_out, &apdup, 0))
 693     {
 694         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 695         odr_reset (p->odr_out);
 696         return TCL_ERROR;
 697     }
 698     sbuf = odr_getbuf (p->odr_out, &slen);
 699     if (cs_put (p->cs_link, sbuf, slen) < 0)
 700     {
 701         interp->result = "cs_put failed in init";
 702         return TCL_ERROR;
 703     }
 704     printf ("Present request\n");
 705     return TCL_OK;
 706 }
 707
 708 /*
 709  * ir_set_obj_method: IR Set Object methods
 710  */
 711 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
 712                           int argc, char **argv)
 713 {
 714     static IRMethod tab[] = {
 715     { "query", do_query },
 716     { "search", do_search },
 717     { "resultCount", do_resultCount },
 718     { "present", do_present },
 719     { NULL, NULL}
 720     };
 721
 722     if (argc < 2)
 723     {
 724         interp->result = "wrong # args";
 725         return TCL_ERROR;
 726     }
 727     return ir_method (clientData, interp, argc, argv, tab);
 728 }
 729
 730 /*
 731  * ir_set_obj_delete: IR Set Object disposal
 732  */
 733 static void ir_set_obj_delete (ClientData clientData)
 734 {
 735     free ( (void*) clientData);
 736 }
 737
 738 /*
 739  * ir_set_obj_mk: IR Set Object creation
 740  */
 741 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
 742                              int argc, char **argv)
 743 {
 744     Tcl_CmdInfo parent_info;
 745     IRSetObj *obj;
 746
 747     if (argc != 2)
 748     {
 749         interp->result = "wrong # args";
 750         return TCL_ERROR;
 751     }
 752     if (get_parent_info (interp, argv[1], &parent_info) == TCL_ERROR)
 753         return TCL_ERROR;
 754     obj = malloc (sizeof(*obj));
 755     if (!obj)
 756     {
 757         interp->result = "malloc fail";
 758         return TCL_ERROR;
 759     }
 760     obj->parent = (IRObj *) parent_info.clientData;
 761     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
 762                        (ClientData) obj, ir_set_obj_delete);
 763     return TCL_OK;
 764 }
 765
 766 /* ------------------------------------------------------- */
 767
 768 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
 769 {
 770     IRObj *p = o;
 771     IRSetObj *obj = p->child;
 772
 773     if (obj)
 774         obj->resultCount = *searchrs->resultCount;
 775     if (searchrs->searchStatus)
 776         printf("Search was a success.\n");
 777     else
 778         printf("Search was a bloomin' failure.\n");
 779     printf("Number of hits: %d\n", *searchrs->resultCount);
 780 #if 0
 781     if (searchrs->records)
 782         display_records(searchrs->records);
 783 #endif
 784 }
 785
 786 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
 787 {
 788     IRObj *p = obj;
 789
 790     if (!*initrs->result)
 791         printf("Connection rejected by target.\n");
 792     else
 793         printf("Connection accepted by target.\n");
 794     if (initrs->implementationId)
 795             printf("ID     : %s\n", initrs->implementationId);
 796     if (initrs->implementationName)
 797         printf("Name   : %s\n", initrs->implementationName);
 798     if (initrs->implementationVersion)
 799         printf("Version: %s\n", initrs->implementationVersion);
 800 #if 0
 801     if (initrs->userInformationField)
 802     {
 803         printf("UserInformationfield:\n");
 804         odr_external(&print, (Odr_external**)&initrs->
 805                          userInformationField, 0);
 806     }
 807 #endif
 808 }
 809
 810 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
 811 {
 812     IRObj *p = o;
 813     IRSetObj *obj = p->child;
 814
 815     printf("Received presentResponse.\n");
 816     if (presrs->records)
 817         printf ("Got records\n");
 818     else
 819         printf("No records\n");
 820 }
 821
 822 void ir_select_proc (ClientData clientData)
 823 {
 824     IRObj *p = clientData;
 825     Z_APDU *apdu;
 826     int r;
 827
 828     do
 829     {
 830         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  < 0)
 831         {
 832             printf ("cs_get failed\n");
 833             ir_select_remove (cs_fileno (p->cs_link), p);
 834             return;
 835         }
 836         odr_setbuf (p->odr_in, p->buf_in, r);
 837         printf ("cs_get ok, got %d\n", r);
 838         if (!z_APDU (p->odr_in, &apdu, 0))
 839         {
 840             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
 841             return;
 842         }
 843         switch(apdu->which)
 844         {
 845         case Z_APDU_initResponse:
 846             ir_initResponse (p, apdu->u.initResponse);
 847             break;
 848         case Z_APDU_searchResponse:
 849             ir_searchResponse (p, apdu->u.searchResponse);
 850             break;
 851         case Z_APDU_presentResponse:
 852             ir_presentResponse (p, apdu->u.presentResponse);
 853             break;
 854         default:
 855             printf("Received unknown APDU type (%d).\n",
 856                    apdu->which);
 857         }
 858         if (p->callback)
 859             Tcl_Eval (p->interp, p->callback);
 860     } while (cs_more (p->cs_link));
 861 }
 862
 863 /* ------------------------------------------------------- */
 864
 865 /*
 866  * ir_tcl_init: Registration of TCL commands.
 867  */
 868 int ir_tcl_init (Tcl_Interp *interp)
 869 {
 870     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
 871                        (Tcl_CmdDeleteProc *) NULL);
 872     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
 873                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
 874     return TCL_OK;
 875 }