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.5  1995-03-10 18:00:15  adam
   7  * Actual presentation in line-by-line format. RPN query support.
   8  *
   9  * Revision 1.4  1995/03/09  16:15:08  adam
  10  * First presentRequest attempts. Hot-target list.
  11  *
  12  */
  13
  14 #include <stdlib.h>
  15 #include <stdio.h>
  16 #include <sys/time.h>
  17 #include <assert.h>
  18
  19 #include <yaz-ccl.h>
  20 #include <iso2709p.h>
  21 #include <comstack.h>
  22 #include <tcpip.h>
  23 #include <xmosi.h>
  24
  25 #include <odr.h>
  26 #include <proto.h>
  27
  28 #include <tcl.h>
  29
  30 #include "ir-tcl.h"
  31
  32 typedef struct {
  33     COMSTACK cs_link;
  34
  35     int preferredMessageSize;
  36     int maximumMessageSize;
  37     Odr_bitmask options;
  38     Odr_bitmask protocolVersion;
  39     char *idAuthentication;
  40     char *implementationName;
  41     char *implementationId;
  42
  43     char *buf_out;
  44     int  len_out;
  45
  46     char *buf_in;
  47     int  len_in;
  48
  49     ODR odr_in;
  50     ODR odr_out;
  51     ODR odr_pr;
  52
  53     Tcl_Interp *interp;
  54     char *callback;
  55
  56     int smallSetUpperBound;
  57     int largeSetLowerBound;
  58     int mediumSetPresentNumber;
  59     int replaceIndicator;
  60     char **databaseNames;
  61     int num_databaseNames;
  62     char *query_method;
  63
  64     CCL_bibset bibset;
  65
  66     struct IRSetObj_ *child;
  67 } IRObj;
  68
  69 typedef struct IRRecordList_ {
  70     int status;
  71     Iso2709Rec rec;
  72     int no;
  73     struct IRRecordList_ *next;
  74 } IRRecordList;
  75
  76 typedef struct IRSetObj_ {
  77     IRObj *parent;
  78     int resultCount;
  79     int start;
  80     int number;
  81     int numberOfRecordsReturned;
  82     Z_Records *z_records;
  83     IRRecordList *record_list;
  84 } IRSetObj;
  85
  86 typedef struct {
  87     char *name;
  88     int (*method) (void * obj, Tcl_Interp *interp, int argc, char **argv);
  89 } IRMethod;
  90
  91 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
  92
  93 /*
  94  * get_parent_info: Returns information about parent object.
  95  */
  96 static int get_parent_info (Tcl_Interp *interp, const char *name,
  97                             Tcl_CmdInfo *parent_info)
  98 {
  99     char parent_name[128];
 100     const char *csep = strrchr (name, '.');
 101     int pos;
 102
 103     if (!csep)
 104     {
 105         interp->result = "missing .";
 106         return TCL_ERROR;
 107     }
 108     pos = csep-name;
 109     if (pos > 127)
 110         pos = 127;
 111     memcpy (parent_name, name, pos);
 112     parent_name[pos] = '\0';
 113     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
 114     {
 115         interp->result = "No parent";
 116         return TCL_ERROR;
 117     }
 118     return TCL_OK;
 119 }
 120
 121 /*
 122  * ir_method: Search for method in table and invoke method handler
 123  */
 124 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 125                    IRMethod *tab)
 126 {
 127     while (tab->name)
 128     {
 129         if (!strcmp (tab->name, argv[1]))
 130             return (*tab->method)(obj, interp, argc, argv);
 131         tab++;
 132     }
 133     Tcl_AppendResult (interp, "unknown method: ", argv[1], NULL);
 134     return TCL_ERROR;
 135 }
 136
 137 /*
 138  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 139  */
 140 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 141 {
 142     const char *cp = asc + strlen(asc);
 143     int bitno = 0;
 144
 145     ODR_MASK_ZERO (ob);
 146     do
 147     {
 148         if (*--cp == '1')
 149             ODR_MASK_SET (ob, bitno);
 150         bitno++;
 151     } while (cp != asc);
 152     return bitno;
 153 }
 154
 155 /*
 156  * ir_strdup: Duplicate string
 157  */
 158 int ir_strdup (Tcl_Interp *interp, char** p, char *s)
 159 {
 160     *p = malloc (strlen(s)+1);
 161     if (!*p)
 162     {
 163         interp->result = "malloc fail";
 164         return TCL_ERROR;
 165     }
 166     strcpy (*p, s);
 167     return TCL_OK;
 168 }
 169
 170 /* ------------------------------------------------------- */
 171
 172 /*
 173  * do_init_request: init method on IR object
 174  */
 175 static int do_init_request (void *obj, Tcl_Interp *interp,
 176                        int argc, char **argv)
 177 {
 178     Z_APDU apdu, *apdup;
 179     IRObj *p = obj;
 180     Z_InitRequest req;
 181     char *sbuf;
 182     int slen;
 183
 184     req.referenceId = 0;
 185     req.options = &p->options;
 186     req.protocolVersion = &p->protocolVersion;
 187     req.preferredMessageSize = &p->preferredMessageSize;
 188     req.maximumRecordSize = &p->maximumMessageSize;
 189
 190     req.idAuthentication = p->idAuthentication;
 191     req.implementationId = p->implementationId;
 192     req.implementationName = p->implementationName;
 193     req.implementationVersion = "0.1";
 194     req.userInformationField = 0;
 195
 196     apdu.u.initRequest = &req;
 197     apdu.which = Z_APDU_initRequest;
 198     apdup = &apdu;
 199
 200     if (!z_APDU (p->odr_out, &apdup, 0))
 201     {
 202         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 203         odr_reset (p->odr_out);
 204         return TCL_ERROR;
 205     }
 206     sbuf = odr_getbuf (p->odr_out, &slen);
 207     if (cs_put (p->cs_link, sbuf, slen) < 0)
 208     {
 209         interp->result = "cs_put failed in init";
 210         return TCL_ERROR;
 211     }
 212     printf("Sent initializeRequest (%d bytes).\n", slen);
 213     return TCL_OK;
 214 }
 215
 216 /*
 217  * do_protocolVersion: Set protocol Version
 218  */
 219 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 220                                int argc, char **argv)
 221 {
 222     if (argc == 3)
 223         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 224     return TCL_OK;
 225 }
 226
 227 /*
 228  * do_options: Set options
 229  */
 230 static int do_options (void *obj, Tcl_Interp *interp,
 231                        int argc, char **argv)
 232 {
 233     if (argc == 3)
 234         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 235     return TCL_OK;
 236 }
 237
 238 /*
 239  * do_preferredMessageSize: Set preferred message size
 240  */
 241 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 242                                     int argc, char **argv)
 243 {
 244     if (argc == 3)
 245     {
 246         if (Tcl_GetInt (interp, argv[2],
 247                         &((IRObj *)obj)->preferredMessageSize)==TCL_ERROR)
 248             return TCL_ERROR;
 249     }
 250     sprintf (interp->result, "%d", ((IRObj *)obj)->preferredMessageSize);
 251     return TCL_OK;
 252 }
 253
 254 /*
 255  * do_maximumMessageSize: Set maximum message size
 256  */
 257 static int do_maximumMessageSize (void *obj, Tcl_Interp *interp,
 258                                     int argc, char **argv)
 259 {
 260     if (argc == 3)
 261     {
 262         if (Tcl_GetInt (interp, argv[2],
 263                         &((IRObj *)obj)->maximumMessageSize)==TCL_ERROR)
 264             return TCL_ERROR;
 265     }
 266     sprintf (interp->result, "%d", ((IRObj *)obj)->maximumMessageSize);
 267     return TCL_OK;
 268 }
 269
 270
 271 /*
 272  * do_implementationName: Set Implementation Name.
 273  */
 274 static int do_implementationName (void *obj, Tcl_Interp *interp,
 275                                     int argc, char **argv)
 276 {
 277     if (argc == 3)
 278     {
 279         free (((IRObj*)obj)->implementationName);
 280         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 281             == TCL_ERROR)
 282             return TCL_ERROR;
 283     }
 284     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 285                       (char*) NULL);
 286     return TCL_OK;
 287 }
 288
 289 /*
 290  * do_implementationId: Set Implementation Name.
 291  */
 292 static int do_implementationId (void *obj, Tcl_Interp *interp,
 293                                 int argc, char **argv)
 294 {
 295     if (argc == 3)
 296     {
 297         free (((IRObj*)obj)->implementationId);
 298         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 299             == TCL_ERROR)
 300             return TCL_ERROR;
 301     }
 302     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 303                       (char*) NULL);
 304     return TCL_OK;
 305 }
 306
 307 /*
 308  * do_idAuthentication: Set id Authentication
 309  */
 310 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 311                                 int argc, char **argv)
 312 {
 313     if (argc == 3)
 314     {
 315         free (((IRObj*)obj)->idAuthentication);
 316         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 317             == TCL_ERROR)
 318             return TCL_ERROR;
 319     }
 320     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 321                       (char*) NULL);
 322     return TCL_OK;
 323 }
 324
 325 /*
 326  * do_connect: connect method on IR object
 327  */
 328 static int do_connect (void *obj, Tcl_Interp *interp,
 329                        int argc, char **argv)
 330 {
 331     void *addr;
 332     IRObj *p = obj;
 333
 334     if (argc < 3)
 335     {
 336         interp->result = "missing hostname";
 337         return TCL_ERROR;
 338     }
 339     if (cs_type(p->cs_link) == tcpip_type)
 340     {
 341         addr = tcpip_strtoaddr (argv[2]);
 342         if (!addr)
 343         {
 344             interp->result = "tcpip_strtoaddr fail";
 345             return TCL_ERROR;
 346         }
 347         printf ("tcp/ip connect %s\n", argv[2]);
 348     }
 349     else if (cs_type (p->cs_link) == mosi_type)
 350     {
 351         addr = mosi_strtoaddr (argv[2]);
 352         if (!addr)
 353         {
 354             interp->result = "mosi_strtoaddr fail";
 355             return TCL_ERROR;
 356         }
 357         printf ("mosi connect %s\n", argv[2]);
 358     }
 359     if (cs_connect (p->cs_link, addr) < 0)
 360     {
 361         interp->result = "cs_connect fail";
 362         do_disconnect (p, interp, argc, argv);
 363         return TCL_ERROR;
 364     }
 365     ir_select_add (cs_fileno (p->cs_link), p);
 366     return TCL_OK;
 367 }
 368
 369 /*
 370  * do_disconnect: disconnect method on IR object
 371  */
 372 static int do_disconnect (void *obj, Tcl_Interp *interp,
 373                           int argc, char **argv)
 374 {
 375     IRObj *p = obj;
 376
 377     ir_select_remove (cs_fileno (p->cs_link), p);
 378     if (cs_type (p->cs_link) == tcpip_type)
 379     {
 380         cs_close (p->cs_link);
 381         p->cs_link = cs_create (tcpip_type);
 382     }
 383     else if (cs_type (p->cs_link) == mosi_type)
 384     {
 385         cs_close (p->cs_link);
 386         p->cs_link = cs_create (mosi_type);
 387     }
 388     else
 389     {
 390         interp->result = "unknown comstack type";
 391         return TCL_ERROR;
 392     }
 393     return TCL_OK;
 394 }
 395
 396 /*
 397  * do_comstack: comstack method on IR object
 398  */
 399 static int do_comstack (void *obj, Tcl_Interp *interp,
 400                         int argc, char **argv)
 401 {
 402     if (argc == 3)
 403     {
 404         if (!strcmp (argv[2], "tcpip"))
 405             ((IRObj *)obj)->cs_link = cs_create (tcpip_type);
 406         else if (!strcmp (argv[2], "mosi"))
 407             ((IRObj *)obj)->cs_link = cs_create (mosi_type);
 408         else
 409         {
 410             interp->result = "wrong comstack type";
 411             return TCL_ERROR;
 412         }
 413     }
 414     if (cs_type(((IRObj *)obj)->cs_link) == tcpip_type)
 415         interp->result = "tcpip";
 416     else if (cs_type(((IRObj *)obj)->cs_link) == mosi_type)
 417         interp->result = "comstack";
 418     return TCL_OK;
 419 }
 420
 421 /*
 422  * do_callback: add callback
 423  */
 424 static int do_callback (void *obj, Tcl_Interp *interp,
 425                           int argc, char **argv)
 426 {
 427     IRObj *p = obj;
 428
 429     if (argc == 3)
 430     {
 431         free (p->callback);
 432         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 433             return TCL_ERROR;
 434         p->interp = interp;
 435     }
 436     return TCL_OK;
 437 }
 438
 439 /*
 440  * do_databaseNames: specify database names
 441  */
 442 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 443                           int argc, char **argv)
 444 {
 445     int i;
 446     IRObj *p = obj;
 447
 448     if (argc < 3)
 449     {
 450         interp->result = "wrong # args";
 451         return TCL_ERROR;
 452     }
 453     if (p->databaseNames)
 454     {
 455         for (i=0; i<p->num_databaseNames; i++)
 456             free (p->databaseNames[i]);
 457         free (p->databaseNames);
 458     }
 459     p->num_databaseNames = argc - 2;
 460     if (!(p->databaseNames = malloc (sizeof(*p->databaseNames) *
 461                                p->num_databaseNames)))
 462     {
 463         interp->result = "malloc fail";
 464         return TCL_ERROR;
 465     }
 466     for (i=0; i<p->num_databaseNames; i++)
 467     {
 468         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 469             == TCL_ERROR)
 470             return TCL_ERROR;
 471     }
 472     return TCL_OK;
 473 }
 474
 475 /*
 476  * do_query: Set/Get query mothod
 477  */
 478 static int do_query (void *obj, Tcl_Interp *interp,
 479                        int argc, char **argv)
 480 {
 481     IRObj *p = obj;
 482     if (argc == 3)
 483     {
 484         free (p->query_method);
 485         if (ir_strdup (interp, &p->query_method, argv[2]) == TCL_ERROR)
 486             return TCL_ERROR;
 487     }
 488     Tcl_AppendResult (interp, p->query_method, NULL);
 489     return TCL_OK;
 490 }
 491
 492 /*
 493  * ir_obj_method: IR Object methods
 494  */
 495 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 496                           int argc, char **argv)
 497 {
 498     static IRMethod tab[] = {
 499     { "comstack",                do_comstack },
 500     { "connect",                 do_connect },
 501     { "protocolVersion",         do_protocolVersion },
 502     { "options",                 do_options },
 503     { "preferredMessageSize",    do_preferredMessageSize },
 504     { "maximumMessageSize",      do_maximumMessageSize },
 505     { "implementationName",      do_implementationName },
 506     { "implementationId",        do_implementationId },
 507     { "idAuthentication",        do_idAuthentication },
 508     { "init",                    do_init_request },
 509     { "disconnect",              do_disconnect },
 510     { "callback",                do_callback },
 511     { "databaseNames",           do_databaseNames},
 512     { "query",                   do_query },
 513     { NULL, NULL}
 514     };
 515     if (argc < 2)
 516     {
 517         interp->result = "wrong # args";
 518         return TCL_ERROR;
 519     }
 520     return ir_method (clientData, interp, argc, argv, tab);
 521 }
 522
 523 /*
 524  * ir_obj_delete: IR Object disposal
 525  */
 526 static void ir_obj_delete (ClientData clientData)
 527 {
 528     free ( (void*) clientData);
 529 }
 530
 531 /*
 532  * ir_obj_mk: IR Object creation
 533  */
 534 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 535               int argc, char **argv)
 536 {
 537     IRObj *obj;
 538     FILE *inf;
 539
 540     if (argc != 2)
 541     {
 542         interp->result = "wrong # args";
 543         return TCL_ERROR;
 544     }
 545     obj = malloc (sizeof(*obj));
 546     if (!obj)
 547     {
 548         interp->result = "malloc fail";
 549         return TCL_ERROR;
 550     }
 551     obj->cs_link = cs_create (tcpip_type);
 552
 553     obj->maximumMessageSize = 32768;
 554     obj->preferredMessageSize = 4096;
 555
 556     obj->idAuthentication = NULL;
 557
 558     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 559         == TCL_ERROR)
 560         return TCL_ERROR;
 561
 562     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 563         == TCL_ERROR)
 564         return TCL_ERROR;
 565
 566     obj->smallSetUpperBound = 0;
 567     obj->largeSetLowerBound = 2;
 568     obj->mediumSetPresentNumber = 0;
 569     obj->replaceIndicator = 1;
 570     obj->databaseNames = NULL;
 571     obj->num_databaseNames = 0;
 572     if (ir_strdup (interp, &obj->query_method, "rpn") == TCL_ERROR)
 573         return TCL_ERROR;
 574     obj->bibset = ccl_qual_mk ();
 575     if ((inf = fopen ("default.bib", "r")))
 576     {
 577         ccl_qual_file (obj->bibset, inf);
 578         fclose (inf);
 579     }
 580     ODR_MASK_ZERO (&obj->protocolVersion);
 581     ODR_MASK_SET (&obj->protocolVersion, 0);
 582     ODR_MASK_SET (&obj->protocolVersion, 1);
 583
 584     ODR_MASK_ZERO (&obj->options);
 585     ODR_MASK_SET (&obj->options, 0);
 586
 587     obj->odr_in = odr_createmem (ODR_DECODE);
 588     obj->odr_out = odr_createmem (ODR_ENCODE);
 589     obj->odr_pr = odr_createmem (ODR_PRINT);
 590
 591     obj->len_out = 10000;
 592     obj->buf_out = malloc (obj->len_out);
 593     if (!obj->buf_out)
 594     {
 595         interp->result = "malloc fail";
 596         return TCL_ERROR;
 597     }
 598     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 599
 600     obj->len_in = 0;
 601     obj->buf_in = NULL;
 602
 603     obj->callback = NULL;
 604     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 605                        (ClientData) obj, ir_obj_delete);
 606     return TCL_OK;
 607 }
 608
 609 /* ------------------------------------------------------- */
 610 /*
 611  * do_search: Do search request
 612  */
 613 static int do_search (void *o, Tcl_Interp *interp,
 614                        int argc, char **argv)
 615 {
 616     Z_SearchRequest req;
 617     Z_Query query;
 618     Z_APDU apdu, *apdup;
 619     static Odr_oid bib1[] = {1, 2, 840, 10003, 3, 1, -1};
 620     Odr_oct ccl_query;
 621     IRSetObj *obj = o;
 622     IRObj *p = obj->parent;
 623     char *sbuf;
 624     int slen;
 625
 626     p->child = o;
 627     if (argc != 3)
 628     {
 629         interp->result = "wrong # args";
 630         return TCL_ERROR;
 631     }
 632     if (!p->num_databaseNames)
 633     {
 634         interp->result = "no databaseNames";
 635         return TCL_ERROR;
 636     }
 637     apdu.which = Z_APDU_searchRequest;
 638     apdu.u.searchRequest = &req;
 639     apdup = &apdu;
 640
 641     req.referenceId = 0;
 642     req.smallSetUpperBound = &p->smallSetUpperBound;
 643     req.largeSetLowerBound = &p->largeSetLowerBound;
 644     req.mediumSetPresentNumber = &p->mediumSetPresentNumber;
 645     req.replaceIndicator = &p->replaceIndicator;
 646     req.resultSetName = "Default";
 647     req.num_databaseNames = p->num_databaseNames;
 648     req.databaseNames = p->databaseNames;
 649     req.smallSetElementSetNames = 0;
 650     req.mediumSetElementSetNames = 0;
 651     req.preferredRecordSyntax = 0;
 652     req.query = &query;
 653
 654     if (!strcmp (p->query_method, "rpn"))
 655     {
 656         int error;
 657         int pos;
 658         struct ccl_rpn_node *rpn;
 659         Z_RPNQuery *RPNquery;
 660
 661         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
 662         if (error)
 663         {
 664             Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg(error),NULL);
 665             return TCL_ERROR;
 666         }
 667         query.which = Z_Query_type_1;
 668         assert((RPNquery = ccl_rpn_query(rpn)));
 669         RPNquery->attributeSetId = bib1;
 670         query.u.type_1 = RPNquery;
 671     }
 672     else if (!strcmp (p->query_method, "ccl"))
 673     {
 674         query.which = Z_Query_type_2;
 675         query.u.type_2 = &ccl_query;
 676         ccl_query.buf = argv[2];
 677         ccl_query.len = strlen (argv[2]);
 678     }
 679     else
 680     {
 681         interp->result = "unknown query method";
 682         return TCL_ERROR;
 683     }
 684     if (!z_APDU (p->odr_out, &apdup, 0))
 685     {
 686         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 687         odr_reset (p->odr_out);
 688         return TCL_ERROR;
 689     }
 690     sbuf = odr_getbuf (p->odr_out, &slen);
 691     if (cs_put (p->cs_link, sbuf, slen) < 0)
 692     {
 693         interp->result = "cs_put failed in init";
 694         return TCL_ERROR;
 695     }
 696     printf ("Search request\n");
 697     return TCL_OK;
 698 }
 699
 700 /*
 701  * do_resultCount: Get number of hits
 702  */
 703 static int do_resultCount (void *o, Tcl_Interp *interp,
 704                        int argc, char **argv)
 705 {
 706     IRSetObj *obj = o;
 707
 708     sprintf (interp->result, "%d", obj->resultCount);
 709     return TCL_OK;
 710 }
 711
 712 /*
 713  * do_numberOfRecordsReturned: Get number of records returned
 714  */
 715 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
 716                        int argc, char **argv)
 717 {
 718     IRSetObj *obj = o;
 719
 720     sprintf (interp->result, "%d", obj->numberOfRecordsReturned);
 721     return TCL_OK;
 722 }
 723
 724 static int get_marc_record(Tcl_Interp *interp, Iso2709Rec rec,
 725                            int argc, char **argv)
 726 {
 727     struct iso2709_dir *dir;
 728     struct iso2709_field *field;
 729
 730     for (dir = rec->directory; dir; dir = dir->next)
 731     {
 732         if (strcmp (dir->tag, argv[3]))
 733             continue;
 734         for (field = dir->fields; field; field = field->next)
 735         {
 736             if (argc > 4 && strcmp (field->identifier, argv[4]))
 737                 continue;
 738             Tcl_AppendElement (interp, field->data);
 739         }
 740     }
 741     return TCL_OK;
 742 }
 743
 744 /*
 745  * do_getRecord: Get an ISO2709 Record
 746  */
 747 static int do_getRecord (void *o, Tcl_Interp *interp,
 748                        int argc, char **argv)
 749 {
 750     IRSetObj *obj = o;
 751     int offset;
 752     IRRecordList *rl;
 753
 754     if (argc < 3)
 755     {
 756         sprintf (interp->result, "wrong # args");
 757         return TCL_ERROR;
 758     }
 759     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 760         return TCL_ERROR;
 761     for (rl = obj->record_list; rl; rl = rl->next)
 762     {
 763         if (rl->no == offset)
 764             break;
 765     }
 766     if (!rl)
 767     {
 768         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
 769         return TCL_ERROR;
 770     }
 771     if (!rl->rec)
 772     {
 773         Tcl_AppendResult (interp, "Not a MARC record at #", argv[2], NULL);
 774         return TCL_ERROR;
 775     }
 776     return get_marc_record (interp, rl->rec, argc, argv);
 777 }
 778
 779 /*
 780  * do_present: Perform Present Request
 781  */
 782
 783 static int do_present (void *o, Tcl_Interp *interp,
 784                        int argc, char **argv)
 785 {
 786     IRSetObj *obj = o;
 787     IRObj *p = obj->parent;
 788     Z_APDU apdu, *apdup;
 789     Z_PresentRequest req;
 790     int start;
 791     int number;
 792     char *sbuf;
 793     int slen;
 794
 795     if (argc >= 3)
 796     {
 797         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
 798             return TCL_ERROR;
 799     }
 800     else
 801         start = 1;
 802     if (argc >= 4)
 803     {
 804         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
 805             return TCL_ERROR;
 806     }
 807     else
 808         number = 10;
 809     obj->start = start;
 810     obj->number = number;
 811
 812     apdup = &apdu;
 813     apdu.which = Z_APDU_presentRequest;
 814     apdu.u.presentRequest = &req;
 815     req.referenceId = 0;
 816     /* sprintf(setstring, "%d", setnumber); */
 817     req.resultSetId = "Default";
 818     req.resultSetStartPoint = &start;
 819     req.numberOfRecordsRequested = &number;
 820     req.elementSetNames = 0;
 821     req.preferredRecordSyntax = 0;
 822
 823     if (!z_APDU (p->odr_out, &apdup, 0))
 824     {
 825         interp->result = odr_errlist [odr_geterror (p->odr_out)];
 826         odr_reset (p->odr_out);
 827         return TCL_ERROR;
 828     }
 829     sbuf = odr_getbuf (p->odr_out, &slen);
 830     if (cs_put (p->cs_link, sbuf, slen) < 0)
 831     {
 832         interp->result = "cs_put failed in init";
 833         return TCL_ERROR;
 834     }
 835     printf ("Present request, start=%d, num=%d\n", start, number);
 836     return TCL_OK;
 837 }
 838
 839 /*
 840  * ir_set_obj_method: IR Set Object methods
 841  */
 842 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
 843                           int argc, char **argv)
 844 {
 845     static IRMethod tab[] = {
 846     { "search",                  do_search },
 847     { "resultCount",             do_resultCount },
 848     { "numberOfRecordsReturned", do_numberOfRecordsReturned },
 849     { "present",                 do_present },
 850     { "getRecord",               do_getRecord },
 851     { NULL, NULL}
 852     };
 853
 854     if (argc < 2)
 855     {
 856         interp->result = "wrong # args";
 857         return TCL_ERROR;
 858     }
 859     return ir_method (clientData, interp, argc, argv, tab);
 860 }
 861
 862 /*
 863  * ir_set_obj_delete: IR Set Object disposal
 864  */
 865 static void ir_set_obj_delete (ClientData clientData)
 866 {
 867     free ( (void*) clientData);
 868 }
 869
 870 /*
 871  * ir_set_obj_mk: IR Set Object creation
 872  */
 873 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
 874                              int argc, char **argv)
 875 {
 876     Tcl_CmdInfo parent_info;
 877     IRSetObj *obj;
 878
 879     if (argc != 2)
 880     {
 881         interp->result = "wrong # args";
 882         return TCL_ERROR;
 883     }
 884     if (get_parent_info (interp, argv[1], &parent_info) == TCL_ERROR)
 885         return TCL_ERROR;
 886     obj = malloc (sizeof(*obj));
 887     if (!obj)
 888     {
 889         interp->result = "malloc fail";
 890         return TCL_ERROR;
 891     }
 892     obj->z_records = NULL;
 893     obj->record_list = NULL;
 894     obj->parent = (IRObj *) parent_info.clientData;
 895     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
 896                        (ClientData) obj, ir_set_obj_delete);
 897     return TCL_OK;
 898 }
 899
 900 /* ------------------------------------------------------- */
 901
 902 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
 903 {
 904     IRObj *p = o;
 905     IRSetObj *obj = p->child;
 906
 907     if (obj)
 908         obj->resultCount = *searchrs->resultCount;
 909     if (searchrs->searchStatus)
 910         printf("Search was a success.\n");
 911     else
 912         printf("Search was a bloomin' failure.\n");
 913     printf("Number of hits: %d\n", *searchrs->resultCount);
 914 #if 0
 915     if (searchrs->records)
 916         display_records(searchrs->records);
 917 #endif
 918 }
 919
 920 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
 921 {
 922     IRObj *p = obj;
 923
 924     if (!*initrs->result)
 925         printf("Connection rejected by target.\n");
 926     else
 927         printf("Connection accepted by target.\n");
 928     if (initrs->implementationId)
 929             printf("ID     : %s\n", initrs->implementationId);
 930     if (initrs->implementationName)
 931         printf("Name   : %s\n", initrs->implementationName);
 932     if (initrs->implementationVersion)
 933         printf("Version: %s\n", initrs->implementationVersion);
 934 #if 0
 935     if (initrs->userInformationField)
 936     {
 937         printf("UserInformationfield:\n");
 938         odr_external(&print, (Odr_external**)&initrs->
 939                          userInformationField, 0);
 940     }
 941 #endif
 942 }
 943
 944 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
 945 {
 946     IRObj *p = o;
 947     IRSetObj *setobj = p->child;
 948     Z_Records *zrs = presrs->records;
 949     setobj->z_records = presrs->records;
 950
 951     printf ("Received presentResponse\n");
 952     if (zrs)
 953     {
 954         if (zrs->which == Z_Records_NSD)
 955         {
 956             setobj->numberOfRecordsReturned = 0;
 957             printf ("They are diagnostic!!!\n");
 958             /*
 959                char buf[16];
 960                sprintf (buf, "%d", *zrs->u.nonSurrogateDiagnostic->condition);
 961                Tcl_AppendResult (interp, "Diagnostic message: ", buf,
 962                " : ",
 963                zrs->u.nonSurrogateDiagnostic->addinfo, NULL);
 964                return TCL_ERROR;
 965                */
 966             return;
 967         }
 968         else
 969         {
 970             int offset;
 971             IRRecordList *rl;
 972
 973             setobj->numberOfRecordsReturned =
 974                 zrs->u.databaseOrSurDiagnostics->num_records;
 975             printf ("Got %d records\n", setobj->numberOfRecordsReturned);
 976             for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
 977             {
 978                 int no = setobj->start + offset;
 979
 980                 for (rl = setobj->record_list; rl; rl = rl->next)
 981                 {
 982                     if (no == rl->no)
 983                     {
 984                         if (rl->rec)
 985                             iso2709_rm (rl->rec);
 986                         break;
 987                     }
 988                 }
 989                 if (!rl)
 990                 {
 991                     rl = malloc (sizeof(*rl));
 992                     assert (rl);
 993                     rl->next = setobj->record_list;
 994                     rl->no = no;
 995                     rl->status = 0;
 996                     setobj->record_list = rl;
 997                 }
 998                 if (zrs->u.databaseOrSurDiagnostics->records[offset]->which ==
 999                     Z_NamePlusRecord_surrogateDiagnostic)
1000                 {
1001                     rl->status = -1;
1002                     rl->rec = NULL;
1003                 }
1004                 else
1005                 {
1006                     Z_DatabaseRecord *zr;
1007                     Odr_external *oe;
1008
1009                     rl->status = 0;
1010                     zr = zrs->u.databaseOrSurDiagnostics->records[offset]
1011                         ->u.databaseRecord;
1012                     oe = (Odr_external*) zr;
1013                     if (oe->which == ODR_EXTERNAL_octet
1014                         && zr->u.octet_aligned->len)
1015                     {
1016                         const char *buf = (char*) zr->u.octet_aligned->buf;
1017                         rl->rec = iso2709_cvt (buf);
1018                     }
1019                 }
1020             }
1021         }
1022     }
1023     else
1024     {
1025         printf ("No records!\n");
1026     }
1027 }
1028
1029 void ir_select_proc (ClientData clientData)
1030 {
1031     IRObj *p = clientData;
1032     Z_APDU *apdu;
1033     int r;
1034
1035     do
1036     {
1037         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  < 0)
1038         {
1039             printf ("cs_get failed\n");
1040             ir_select_remove (cs_fileno (p->cs_link), p);
1041             return;
1042         }
1043         odr_setbuf (p->odr_in, p->buf_in, r);
1044         printf ("cs_get ok, got %d\n", r);
1045         if (!z_APDU (p->odr_in, &apdu, 0))
1046         {
1047             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
1048             return;
1049         }
1050         switch(apdu->which)
1051         {
1052         case Z_APDU_initResponse:
1053             ir_initResponse (p, apdu->u.initResponse);
1054             break;
1055         case Z_APDU_searchResponse:
1056             ir_searchResponse (p, apdu->u.searchResponse);
1057             break;
1058         case Z_APDU_presentResponse:
1059             ir_presentResponse (p, apdu->u.presentResponse);
1060             break;
1061         default:
1062             printf("Received unknown APDU type (%d).\n",
1063                    apdu->which);
1064         }
1065         if (p->callback)
1066             Tcl_Eval (p->interp, p->callback);
1067     } while (cs_more (p->cs_link));
1068 }
1069
1070 /* ------------------------------------------------------- */
1071
1072 /*
1073  * ir_tcl_init: Registration of TCL commands.
1074  */
1075 int ir_tcl_init (Tcl_Interp *interp)
1076 {
1077     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
1078                        (Tcl_CmdDeleteProc *) NULL);
1079     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
1080                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1081     return TCL_OK;
1082 }