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