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