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