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