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