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