ir-tcl.c

   1 /*
   2  * IR toolkit for tcl/tk
   3  * (c) Index Data 1995
   4  * Sebastian Hammer, Adam Dickmeiss
   5  *
   6  * $Log: ir-tcl.c,v $
   7  * Revision 1.26  1995-04-18 16:11:51  adam
   8  * First version of graphical Scan. Some work on query-by-form.
   9  *
  10  * Revision 1.25  1995/04/17  09:37:17  adam
  11  * Further development of scan.
  12  *
  13  * Revision 1.24  1995/04/11  14:16:42  adam
  14  * Further work on scan. Response works. Entries aren't saved yet.
  15  *
  16  * Revision 1.23  1995/04/10  10:50:27  adam
  17  * Result-set name defaults to suffix of ir-set name.
  18  * Started working on scan. Not finished at this point.
  19  *
  20  * Revision 1.22  1995/03/31  10:43:03  adam
  21  * More robust when getting bad MARC records.
  22  *
  23  * Revision 1.21  1995/03/31  08:56:37  adam
  24  * New button "Search".
  25  *
  26  * Revision 1.20  1995/03/29  16:07:09  adam
  27  * Bug fix: Didn't use setName in present request.
  28  *
  29  * Revision 1.19  1995/03/28  12:45:23  adam
  30  * New ir method failback: called on disconnect/protocol error.
  31  * New ir set/get method: protocol: SR / Z3950.
  32  * Simple popup and disconnect when failback is invoked.
  33  *
  34  * Revision 1.18  1995/03/21  15:50:12  adam
  35  * Minor changes.
  36  *
  37  * Revision 1.17  1995/03/21  13:41:03  adam
  38  * Comstack cs_create not used too often. Non-blocking connect.
  39  *
  40  * Revision 1.16  1995/03/21  08:26:06  adam
  41  * New method, setName, to specify the result set name (other than Default).
  42  * New method, responseStatus, which returns diagnostic info, if any, after
  43  * present response / search response.
  44  *
  45  * Revision 1.15  1995/03/20  15:24:07  adam
  46  * Diagnostic records saved on searchResponse.
  47  *
  48  * Revision 1.14  1995/03/20  08:53:22  adam
  49  * Event loop in tclmain.c rewritten. New method searchStatus.
  50  *
  51  * Revision 1.13  1995/03/17  18:26:17  adam
  52  * Non-blocking i/o used now. Database names popup as cascade items.
  53  *
  54  * Revision 1.12  1995/03/17  15:45:00  adam
  55  * Improved target/database setup.
  56  *
  57  * Revision 1.11  1995/03/16  17:54:03  adam
  58  * Minor changes really.
  59  *
  60  * Revision 1.10  1995/03/15  16:14:50  adam
  61  * Blocking arg in cs_create changed.
  62  *
  63  * Revision 1.9  1995/03/15  13:59:24  adam
  64  * Minor changes.
  65  *
  66  * Revision 1.8  1995/03/15  08:25:16  adam
  67  * New method presentStatus to check for error on present. Misc. cleanup
  68  * of IRRecordList manipulations. Full MARC record presentation in
  69  * search.tcl.
  70  *
  71  * Revision 1.7  1995/03/14  17:32:29  adam
  72  * Presentation of full Marc record in popup window.
  73  *
  74  * Revision 1.6  1995/03/12  19:31:55  adam
  75  * Pattern matching implemented when retrieving MARC records. More
  76  * diagnostic functions.
  77  *
  78  * Revision 1.5  1995/03/10  18:00:15  adam
  79  * Actual presentation in line-by-line format. RPN query support.
  80  *
  81  * Revision 1.4  1995/03/09  16:15:08  adam
  82  * First presentRequest attempts. Hot-target list.
  83  *
  84  */
  85
  86 #include <stdlib.h>
  87 #include <stdio.h>
  88 #include <sys/time.h>
  89 #include <assert.h>
  90
  91 #include <tcl.h>
  92
  93 #include <yaz-ccl.h>
  94 #include <iso2709.h>
  95 #include <comstack.h>
  96 #include <tcpip.h>
  97
  98 #if MOSI
  99 #include <xmosi.h>
 100 #endif
 101
 102 #include <odr.h>
 103 #include <proto.h>
 104 #include <oid.h>
 105 #include <diagbib1.h>
 106
 107 #include "ir-tcl.h"
 108
 109 #define CS_BLOCK 0
 110
 111 typedef struct {
 112     char       *cs_type;
 113     char       *protocol_type;
 114     int         connectFlag;
 115     COMSTACK    cs_link;
 116
 117     int         preferredMessageSize;
 118     int         maximumRecordSize;
 119     Odr_bitmask options;
 120     Odr_bitmask protocolVersion;
 121     char       *idAuthentication;
 122     char       *implementationName;
 123     char       *implementationId;
 124
 125     char       *hostname;
 126
 127     char       *buf_out;
 128     int         len_out;
 129
 130     char       *buf_in;
 131     int         len_in;
 132
 133     char       *sbuf;
 134     int         slen;
 135
 136     ODR         odr_in;
 137     ODR         odr_out;
 138     ODR         odr_pr;
 139
 140     Tcl_Interp *interp;
 141     char       *callback;
 142     char       *failback;
 143
 144     int         smallSetUpperBound;
 145     int         largeSetLowerBound;
 146     int         mediumSetPresentNumber;
 147     int         replaceIndicator;
 148     char      **databaseNames;
 149     int         num_databaseNames;
 150     char       *query_method;
 151
 152     CCL_bibset  bibset;
 153     oident      bib1;
 154
 155     struct IRSetObj_ *set_child;
 156     struct IRScanObj_ *scan_child;
 157 } IRObj;
 158
 159 typedef struct IRRecordList_ {
 160     int no;
 161     int which;
 162     union {
 163         struct {
 164             Iso2709Rec rec;
 165         } marc;
 166         struct {
 167             int  condition;
 168             char *addinfo;
 169         } diag;
 170     } u;
 171     struct IRRecordList_ *next;
 172 } IRRecordList;
 173
 174 typedef struct IRSetObj_ {
 175     IRObj      *parent;
 176     int         searchStatus;
 177     int         resultCount;
 178     int         start;
 179     int         number;
 180     int         numberOfRecordsReturned;
 181     char       *setName;
 182     int         recordFlag;
 183     int         which;
 184     int         condition;
 185     char       *addinfo;
 186     IRRecordList *record_list;
 187 } IRSetObj;
 188
 189 typedef struct IRScanEntry_ {
 190     int         which;
 191     union {
 192         struct {
 193             char *buf;
 194             int  globalOccurrences;
 195         } term;
 196         struct {
 197             int  condition;
 198             char *addinfo;
 199         } diag;
 200     } u;
 201 } IRScanEntry;
 202
 203 typedef struct IRScanDiag_ {
 204     int         dummy;
 205 } IRScanDiag;
 206
 207 typedef struct IRScanObj_ {
 208     IRObj      *parent;
 209     int         stepSize;
 210     int         numberOfTermsRequested;
 211     int         preferredPositionInResponse;
 212
 213     int         scanStatus;
 214     int         numberOfEntriesReturned;
 215     int         positionOfTerm;
 216
 217     int         entries_flag;
 218     int         which;
 219
 220     int         num_entries;
 221     int         num_diagRecs;
 222
 223     IRScanEntry *entries;
 224     IRScanDiag  *nonSurrogateDiagnostics;
 225 } IRScanObj;
 226
 227 typedef struct {
 228     int type;
 229     char *name;
 230     int (*method) (void *obj, Tcl_Interp *interp, int argc, char **argv);
 231 } IRMethod;
 232
 233 static int do_disconnect (void *obj,Tcl_Interp *interp, int argc, char **argv);
 234
 235 static IRRecordList *new_IR_record (IRSetObj *setobj, int no, int which)
 236 {
 237     IRRecordList *rl;
 238
 239     for (rl = setobj->record_list; rl; rl = rl->next)
 240     {
 241         if (no == rl->no)
 242         {
 243             switch (rl->which)
 244             {
 245             case Z_NamePlusRecord_databaseRecord:
 246                 iso2709_rm (rl->u.marc.rec);
 247                 break;
 248             case Z_NamePlusRecord_surrogateDiagnostic:
 249                 free (rl->u.diag.addinfo);
 250                 rl->u.diag.addinfo = NULL;
 251                 break;
 252             }
 253             break;
 254         }
 255     }
 256     if (!rl)
 257     {
 258         rl = malloc (sizeof(*rl));
 259         assert (rl);
 260         rl->next = setobj->record_list;
 261         rl->no = no;
 262         setobj->record_list = rl;
 263     }
 264     rl->which = which;
 265     return rl;
 266 }
 267
 268 static IRRecordList *find_IR_record (IRSetObj *setobj, int no)
 269 {
 270     IRRecordList *rl;
 271
 272     for (rl = setobj->record_list; rl; rl = rl->next)
 273         if (no == rl->no)
 274             return rl;
 275     return NULL;
 276 }
 277
 278 /*
 279  * getsetint: Set/get integer value
 280  */
 281 static int get_set_int (int *val, Tcl_Interp *interp, int argc, char **argv)
 282 {
 283     char buf[20];
 284
 285     if (argc == 3)
 286     {
 287         if (Tcl_GetInt (interp, argv[2], val)==TCL_ERROR)
 288             return TCL_ERROR;
 289     }
 290     sprintf (buf, "%d", *val);
 291     Tcl_AppendResult (interp, buf, NULL);
 292     return TCL_OK;
 293 }
 294
 295 /*
 296  * mk_nonSurrogateDiagnostics: Make Tcl result with diagnostic info
 297  */
 298 static int mk_nonSurrogateDiagnostics (Tcl_Interp *interp,
 299                                        int condition,
 300                                        const char *addinfo)
 301 {
 302     char buf[20];
 303     const char *cp;
 304
 305     Tcl_AppendElement (interp, "NSD");
 306     sprintf (buf, "%d", condition);
 307     Tcl_AppendElement (interp, buf);
 308     cp = diagbib1_str (condition);
 309     if (cp)
 310         Tcl_AppendElement (interp, (char*) cp);
 311     else
 312         Tcl_AppendElement (interp, "");
 313     if (addinfo)
 314         Tcl_AppendElement (interp, (char*) addinfo);
 315     else
 316         Tcl_AppendElement (interp, "");
 317     return TCL_OK;
 318 }
 319
 320 /*
 321  * get_parent_info: Returns information about parent object.
 322  */
 323 static int get_parent_info (Tcl_Interp *interp, const char *name,
 324                             Tcl_CmdInfo *parent_info,
 325                             const char **suffix)
 326 {
 327     char parent_name[128];
 328     const char *csep = strrchr (name, '.');
 329     int pos;
 330
 331     if (!csep)
 332     {
 333         interp->result = "missing .";
 334         return TCL_ERROR;
 335     }
 336     if (suffix)
 337         *suffix = csep+1;
 338     pos = csep-name;
 339     if (pos > 127)
 340         pos = 127;
 341     memcpy (parent_name, name, pos);
 342     parent_name[pos] = '\0';
 343     if (!Tcl_GetCommandInfo (interp, parent_name, parent_info))
 344     {
 345         interp->result = "No parent";
 346         return TCL_ERROR;
 347     }
 348     return TCL_OK;
 349 }
 350
 351 /*
 352  * ir_method: Search for method in table and invoke method handler
 353  */
 354 int ir_method (void *obj, Tcl_Interp *interp, int argc, char **argv,
 355                IRMethod *tab)
 356 {
 357     IRMethod *t;
 358     for (t = tab; t->name; t++)
 359         if (!strcmp (t->name, argv[1]))
 360             return (*t->method)(obj, interp, argc, argv);
 361     Tcl_AppendResult (interp, "Bad method. Possible values:", NULL);
 362     for (t = tab; t->name; t++)
 363         Tcl_AppendResult (interp, " ", t->name, NULL);
 364     return TCL_ERROR;
 365 }
 366
 367 /*
 368  * ir_method_r: Get status for all readable elements
 369  */
 370 int ir_method_r (void *obj, Tcl_Interp *interp, int argc, char **argv,
 371                  IRMethod *tab)
 372 {
 373     char *argv_n[3];
 374     int argc_n;
 375
 376     argv_n[0] = argv[0];
 377     argc_n = 2;
 378     for (; tab->name; tab++)
 379         if (tab->type)
 380         {
 381             argv_n[1] = tab->name;
 382             Tcl_AppendResult (interp, "{", NULL);
 383             (*tab->method)(obj, interp, argc_n, argv_n);
 384             Tcl_AppendResult (interp, "} ", NULL);
 385         }
 386     return TCL_OK;
 387 }
 388
 389 /*
 390  * ir_asc2bitmask: Ascii to ODR bitmask conversion
 391  */
 392 int ir_asc2bitmask (const char *asc, Odr_bitmask *ob)
 393 {
 394     const char *cp = asc + strlen(asc);
 395     int bitno = 0;
 396
 397     ODR_MASK_ZERO (ob);
 398     do
 399     {
 400         if (*--cp == '1')
 401             ODR_MASK_SET (ob, bitno);
 402         bitno++;
 403     } while (cp != asc);
 404     return bitno;
 405 }
 406
 407 /*
 408  * ir_strdup: Duplicate string
 409  */
 410 int ir_strdup (Tcl_Interp *interp, char** p, const char *s)
 411 {
 412     *p = malloc (strlen(s)+1);
 413     if (!*p)
 414     {
 415         interp->result = "strdup fail";
 416         return TCL_ERROR;
 417     }
 418     strcpy (*p, s);
 419     return TCL_OK;
 420 }
 421
 422 /*
 423  * ir_malloc: Malloc function
 424  */
 425 void *ir_malloc (Tcl_Interp *interp, size_t size)
 426 {
 427     static char buf[128];
 428     void *p = malloc (size);
 429
 430     if (!p)
 431     {
 432         sprintf (buf, "Malloc fail. %ld bytes requested", (long) size);
 433         interp->result = buf;
 434         return NULL;
 435     }
 436     return p;
 437 }
 438
 439 /* ------------------------------------------------------- */
 440
 441 /*
 442  * do_init_request: init method on IR object
 443  */
 444 static int do_init_request (void *obj, Tcl_Interp *interp,
 445                        int argc, char **argv)
 446 {
 447     Z_APDU apdu, *apdup = &apdu;
 448     IRObj *p = obj;
 449     Z_InitRequest req;
 450     int r;
 451
 452     if (!p->cs_link)
 453     {
 454         interp->result = "not connected";
 455         return TCL_ERROR;
 456     }
 457     req.referenceId = 0;
 458     req.options = &p->options;
 459     req.protocolVersion = &p->protocolVersion;
 460     req.preferredMessageSize = &p->preferredMessageSize;
 461     req.maximumRecordSize = &p->maximumRecordSize;
 462
 463     req.idAuthentication = p->idAuthentication;
 464     req.implementationId = p->implementationId;
 465     req.implementationName = p->implementationName;
 466     req.implementationVersion = "0.1";
 467     req.userInformationField = 0;
 468
 469     apdu.u.initRequest = &req;
 470     apdu.which = Z_APDU_initRequest;
 471
 472     if (!z_APDU (p->odr_out, &apdup, 0))
 473     {
 474         Tcl_AppendResult (interp, odr_errlist [odr_geterror (p->odr_out)],
 475                           NULL);
 476         odr_reset (p->odr_out);
 477         return TCL_ERROR;
 478     }
 479     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
 480     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
 481     {
 482         interp->result = "cs_put failed in init";
 483         do_disconnect (p, NULL, 0, NULL);
 484         return TCL_ERROR;
 485     }
 486     else if (r == 1)
 487     {
 488         ir_select_add_write (cs_fileno(p->cs_link), p);
 489         printf("Sent part of initializeRequest (%d bytes).\n", p->slen);
 490     }
 491     else
 492         printf("Sent whole initializeRequest (%d bytes).\n", p->slen);
 493     return TCL_OK;
 494 }
 495
 496 /*
 497  * do_protocolVersion: Set protocol Version
 498  */
 499 static int do_protocolVersion (void *obj, Tcl_Interp *interp,
 500                                int argc, char **argv)
 501 {
 502     if (argc == 3)
 503         ir_asc2bitmask (argv[2], &((IRObj *) obj)->protocolVersion);
 504     return TCL_OK;
 505 }
 506
 507 /*
 508  * do_options: Set options
 509  */
 510 static int do_options (void *obj, Tcl_Interp *interp,
 511                        int argc, char **argv)
 512 {
 513     if (argc == 3)
 514         ir_asc2bitmask (argv[2], &((IRObj *) obj)->options);
 515     return TCL_OK;
 516 }
 517
 518 /*
 519  * do_preferredMessageSize: Set/get preferred message size
 520  */
 521 static int do_preferredMessageSize (void *obj, Tcl_Interp *interp,
 522                                     int argc, char **argv)
 523 {
 524     IRObj *p = obj;
 525     return get_set_int (&p->preferredMessageSize, interp, argc, argv);
 526 }
 527
 528 /*
 529  * do_maximumRecordSize: Set/get maximum record size
 530  */
 531 static int do_maximumRecordSize (void *obj, Tcl_Interp *interp,
 532                                     int argc, char **argv)
 533 {
 534     IRObj *p = obj;
 535     return get_set_int (&p->maximumRecordSize, interp, argc, argv);
 536 }
 537
 538
 539 /*
 540  * do_implementationName: Set/get Implementation Name.
 541  */
 542 static int do_implementationName (void *obj, Tcl_Interp *interp,
 543                                     int argc, char **argv)
 544 {
 545     if (argc == 3)
 546     {
 547         free (((IRObj*)obj)->implementationName);
 548         if (ir_strdup (interp, &((IRObj*) obj)->implementationName, argv[2])
 549             == TCL_ERROR)
 550             return TCL_ERROR;
 551     }
 552     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationName,
 553                       (char*) NULL);
 554     return TCL_OK;
 555 }
 556
 557 /*
 558  * do_implementationId: Set/get Implementation Id.
 559  */
 560 static int do_implementationId (void *obj, Tcl_Interp *interp,
 561                                 int argc, char **argv)
 562 {
 563     if (argc == 3)
 564     {
 565         free (((IRObj*)obj)->implementationId);
 566         if (ir_strdup (interp, &((IRObj*) obj)->implementationId, argv[2])
 567             == TCL_ERROR)
 568             return TCL_ERROR;
 569     }
 570     Tcl_AppendResult (interp, ((IRObj*)obj)->implementationId,
 571                       (char*) NULL);
 572     return TCL_OK;
 573 }
 574
 575 /*
 576  * do_idAuthentication: Set/get id Authentication
 577  */
 578 static int do_idAuthentication (void *obj, Tcl_Interp *interp,
 579                                 int argc, char **argv)
 580 {
 581     if (argc == 3)
 582     {
 583         free (((IRObj*)obj)->idAuthentication);
 584         if (ir_strdup (interp, &((IRObj*) obj)->idAuthentication, argv[2])
 585             == TCL_ERROR)
 586             return TCL_ERROR;
 587     }
 588     Tcl_AppendResult (interp, ((IRObj*)obj)->idAuthentication,
 589                       (char*) NULL);
 590     return TCL_OK;
 591 }
 592
 593 /*
 594  * do_connect: connect method on IR object
 595  */
 596 static int do_connect (void *obj, Tcl_Interp *interp,
 597                        int argc, char **argv)
 598 {
 599     void *addr;
 600     IRObj *p = obj;
 601     int r;
 602     int protocol_type = CS_Z3950;
 603
 604     if (argc == 3)
 605     {
 606         if (p->hostname)
 607         {
 608             interp->result = "already connected";
 609             return TCL_ERROR;
 610         }
 611         if (!strcmp (p->protocol_type, "Z3950"))
 612             protocol_type = CS_Z3950;
 613         else if (!strcmp (p->protocol_type, "SR"))
 614             protocol_type = CS_SR;
 615         else
 616         {
 617             interp->result = "bad protocol type";
 618             return TCL_ERROR;
 619         }
 620         if (!strcmp (p->cs_type, "tcpip"))
 621         {
 622             p->cs_link = cs_create (tcpip_type, CS_BLOCK, protocol_type);
 623             addr = tcpip_strtoaddr (argv[2]);
 624             if (!addr)
 625             {
 626                 interp->result = "tcpip_strtoaddr fail";
 627                 return TCL_ERROR;
 628             }
 629             printf ("tcp/ip connect %s\n", argv[2]);
 630         }
 631 #if MOSI
 632         else if (!strcmp (p->cs_type, "mosi"))
 633         {
 634             p->cs_link = cs_create (mosi_type, CS_BLOCK, protocol_type);
 635             addr = mosi_strtoaddr (argv[2]);
 636             if (!addr)
 637             {
 638                 interp->result = "mosi_strtoaddr fail";
 639                 return TCL_ERROR;
 640             }
 641             printf ("mosi connect %s\n", argv[2]);
 642         }
 643 #endif
 644         else
 645         {
 646             interp->result = "unknown comstack type";
 647             return TCL_ERROR;
 648         }
 649         if (ir_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 650             return TCL_ERROR;
 651         if ((r=cs_connect (p->cs_link, addr)) < 0)
 652         {
 653             interp->result = "cs_connect fail";
 654             do_disconnect (p, NULL, 0, NULL);
 655             return TCL_ERROR;
 656         }
 657         ir_select_add (cs_fileno (p->cs_link), p);
 658         if (r == 1)
 659         {
 660             ir_select_add_write (cs_fileno (p->cs_link), p);
 661             p->connectFlag = 1;
 662         }
 663         else
 664         {
 665             p->connectFlag = 0;
 666             if (p->callback)
 667                 Tcl_Eval (p->interp, p->callback);
 668         }
 669     }
 670     if (p->hostname)
 671         Tcl_AppendElement (interp, p->hostname);
 672     return TCL_OK;
 673 }
 674
 675 /*
 676  * do_disconnect: disconnect method on IR object
 677  */
 678 static int do_disconnect (void *obj, Tcl_Interp *interp,
 679                           int argc, char **argv)
 680 {
 681     IRObj *p = obj;
 682
 683     if (p->hostname)
 684     {
 685         free (p->hostname);
 686         p->hostname = NULL;
 687         ir_select_remove_write (cs_fileno (p->cs_link), p);
 688         ir_select_remove (cs_fileno (p->cs_link), p);
 689
 690         assert (p->cs_link);
 691         cs_close (p->cs_link);
 692         p->cs_link = NULL;
 693     }
 694     assert (!p->cs_link);
 695     return TCL_OK;
 696 }
 697
 698 /*
 699  * do_comstack: Set/get comstack method on IR object
 700  */
 701 static int do_comstack (void *o, Tcl_Interp *interp,
 702                         int argc, char **argv)
 703 {
 704     IRObj *obj = o;
 705
 706     if (argc == 3)
 707     {
 708         free (obj->cs_type);
 709         if (ir_strdup (interp, &obj->cs_type, argv[2]) == TCL_ERROR)
 710             return TCL_ERROR;
 711     }
 712     Tcl_AppendElement (interp, obj->cs_type);
 713     return TCL_OK;
 714 }
 715
 716 /*
 717  * do_protocol: Set/get protocol method on IR object
 718  */
 719 static int do_protocol (void *o, Tcl_Interp *interp,
 720                         int argc, char **argv)
 721 {
 722     IRObj *obj = o;
 723
 724     if (argc == 3)
 725     {
 726         free (obj->protocol_type);
 727         if (ir_strdup (interp, &obj->protocol_type, argv[2]) == TCL_ERROR)
 728             return TCL_ERROR;
 729     }
 730     Tcl_AppendElement (interp, obj->protocol_type);
 731     return TCL_OK;
 732 }
 733
 734 /*
 735  * do_callback: add callback
 736  */
 737 static int do_callback (void *obj, Tcl_Interp *interp,
 738                           int argc, char **argv)
 739 {
 740     IRObj *p = obj;
 741
 742     if (argc == 3)
 743     {
 744         free (p->callback);
 745         if (ir_strdup (interp, &p->callback, argv[2]) == TCL_ERROR)
 746             return TCL_ERROR;
 747         p->interp = interp;
 748     }
 749     return TCL_OK;
 750 }
 751
 752 /*
 753  * do_failback: add error handle callback
 754  */
 755 static int do_failback (void *obj, Tcl_Interp *interp,
 756                           int argc, char **argv)
 757 {
 758     IRObj *p = obj;
 759
 760     if (argc == 3)
 761     {
 762         free (p->failback);
 763         if (ir_strdup (interp, &p->failback, argv[2]) == TCL_ERROR)
 764             return TCL_ERROR;
 765         p->interp = interp;
 766     }
 767     return TCL_OK;
 768 }
 769
 770 /*
 771  * do_databaseNames: specify database names
 772  */
 773 static int do_databaseNames (void *obj, Tcl_Interp *interp,
 774                           int argc, char **argv)
 775 {
 776     int i;
 777     IRObj *p = obj;
 778
 779     if (argc < 3)
 780     {
 781         for (i=0; i<p->num_databaseNames; i++)
 782             Tcl_AppendElement (interp, p->databaseNames[i]);
 783         return TCL_OK;
 784     }
 785     if (p->databaseNames)
 786     {
 787         for (i=0; i<p->num_databaseNames; i++)
 788             free (p->databaseNames[i]);
 789         free (p->databaseNames);
 790     }
 791     p->num_databaseNames = argc - 2;
 792     if (!(p->databaseNames = ir_malloc (interp,
 793           sizeof(*p->databaseNames) * p->num_databaseNames)))
 794         return TCL_ERROR;
 795     for (i=0; i<p->num_databaseNames; i++)
 796     {
 797         if (ir_strdup (interp, &p->databaseNames[i], argv[2+i])
 798             == TCL_ERROR)
 799             return TCL_ERROR;
 800     }
 801     return TCL_OK;
 802 }
 803
 804 /*
 805  * do_query: Set/Get query mothod
 806  */
 807 static int do_query (void *obj, Tcl_Interp *interp,
 808                        int argc, char **argv)
 809 {
 810     IRObj *p = obj;
 811     if (argc == 3)
 812     {
 813         free (p->query_method);
 814         if (ir_strdup (interp, &p->query_method, argv[2]) == TCL_ERROR)
 815             return TCL_ERROR;
 816     }
 817     Tcl_AppendResult (interp, p->query_method, NULL);
 818     return TCL_OK;
 819 }
 820
 821 /*
 822  * do_replaceIndicator: Set/get replace Set indicator
 823  */
 824 static int do_replaceIndicator (void *obj, Tcl_Interp *interp,
 825                                 int argc, char **argv)
 826 {
 827     IRObj *p = obj;
 828     return get_set_int (&p->replaceIndicator, interp, argc, argv);
 829 }
 830
 831 /*
 832  * ir_obj_method: IR Object methods
 833  */
 834 static int ir_obj_method (ClientData clientData, Tcl_Interp *interp,
 835                           int argc, char **argv)
 836 {
 837     static IRMethod tab[] = {
 838     { 1, "comstack",                do_comstack },
 839     { 1, "protocol",                do_protocol },
 840     { 1, "connect",                 do_connect },
 841     { 0, "protocolVersion",         do_protocolVersion },
 842     { 0, "options",                 do_options },
 843     { 1, "preferredMessageSize",    do_preferredMessageSize },
 844     { 1, "maximumRecordSize",       do_maximumRecordSize },
 845     { 1, "implementationName",      do_implementationName },
 846     { 1, "implementationId",        do_implementationId },
 847     { 1, "idAuthentication",        do_idAuthentication },
 848     { 0, "init",                    do_init_request },
 849     { 0, "disconnect",              do_disconnect },
 850     { 0, "callback",                do_callback },
 851     { 0, "failback",                do_failback },
 852     { 1, "databaseNames",           do_databaseNames},
 853     { 1, "replaceIndicator",        do_replaceIndicator},
 854     { 1, "query",                   do_query },
 855     { 0, NULL, NULL}
 856     };
 857     if (argc < 2)
 858         return ir_method_r (clientData, interp, argc, argv, tab);
 859     return ir_method (clientData, interp, argc, argv, tab);
 860 }
 861
 862 /*
 863  * ir_obj_delete: IR Object disposal
 864  */
 865 static void ir_obj_delete (ClientData clientData)
 866 {
 867     free ( (void*) clientData);
 868 }
 869
 870 /*
 871  * ir_obj_mk: IR Object creation
 872  */
 873 static int ir_obj_mk (ClientData clientData, Tcl_Interp *interp,
 874               int argc, char **argv)
 875 {
 876     IRObj *obj;
 877     FILE *inf;
 878
 879     if (argc != 2)
 880     {
 881         interp->result = "wrong # args";
 882         return TCL_ERROR;
 883     }
 884     if (!(obj = ir_malloc (interp, sizeof(*obj))))
 885         return TCL_ERROR;
 886     if (ir_strdup (interp, &obj->cs_type, "tcpip") == TCL_ERROR)
 887         return TCL_ERROR;
 888     if (ir_strdup (interp, &obj->protocol_type, "Z3950") == TCL_ERROR)
 889         return TCL_ERROR;
 890     obj->cs_link = NULL;
 891     obj->bib1.proto = PROTO_Z3950;
 892     obj->bib1.class = CLASS_ATTSET;
 893     obj->bib1.value = VAL_BIB1;
 894
 895     obj->maximumRecordSize = 32768;
 896     obj->preferredMessageSize = 4096;
 897     obj->connectFlag = 0;
 898
 899     obj->idAuthentication = NULL;
 900
 901     if (ir_strdup (interp, &obj->implementationName, "TCL/TK on YAZ")
 902         == TCL_ERROR)
 903         return TCL_ERROR;
 904
 905     if (ir_strdup (interp, &obj->implementationId, "TCL/TK/YAZ")
 906         == TCL_ERROR)
 907         return TCL_ERROR;
 908
 909     obj->smallSetUpperBound = 0;
 910     obj->largeSetLowerBound = 2;
 911     obj->mediumSetPresentNumber = 0;
 912     obj->replaceIndicator = 1;
 913 #if 0
 914     obj->databaseNames = NULL;
 915     obj->num_databaseNames = 0;
 916 #else
 917     obj->num_databaseNames = 1;
 918     if (!(obj->databaseNames = ir_malloc (interp,
 919                                           sizeof(*obj->databaseNames))))
 920         return TCL_ERROR;
 921     if (ir_strdup (interp, &obj->databaseNames[0], "Default") == TCL_ERROR)
 922         return TCL_ERROR;
 923 #endif
 924
 925     obj->hostname = NULL;
 926
 927     if (ir_strdup (interp, &obj->query_method, "rpn") == TCL_ERROR)
 928         return TCL_ERROR;
 929     obj->bibset = ccl_qual_mk ();
 930     if ((inf = fopen ("default.bib", "r")))
 931     {
 932         ccl_qual_file (obj->bibset, inf);
 933         fclose (inf);
 934     }
 935     ODR_MASK_ZERO (&obj->protocolVersion);
 936     ODR_MASK_SET (&obj->protocolVersion, 0);
 937     ODR_MASK_SET (&obj->protocolVersion, 1);
 938
 939     ODR_MASK_ZERO (&obj->options);
 940     ODR_MASK_SET (&obj->options, 0);
 941
 942     obj->odr_in = odr_createmem (ODR_DECODE);
 943     obj->odr_out = odr_createmem (ODR_ENCODE);
 944     obj->odr_pr = odr_createmem (ODR_PRINT);
 945
 946     obj->len_out = 10000;
 947     if (!(obj->buf_out = ir_malloc (interp, obj->len_out)))
 948         return TCL_ERROR;
 949     odr_setbuf (obj->odr_out, obj->buf_out, obj->len_out);
 950
 951     obj->len_in = 0;
 952     obj->buf_in = NULL;
 953
 954     obj->callback = NULL;
 955     obj->failback = NULL;
 956     Tcl_CreateCommand (interp, argv[1], ir_obj_method,
 957                        (ClientData) obj, ir_obj_delete);
 958     return TCL_OK;
 959 }
 960
 961 /* ------------------------------------------------------- */
 962 /*
 963  * do_search: Do search request
 964  */
 965 static int do_search (void *o, Tcl_Interp *interp,
 966                        int argc, char **argv)
 967 {
 968     Z_SearchRequest req;
 969     Z_Query query;
 970     Z_APDU apdu, *apdup = &apdu;
 971     Odr_oct ccl_query;
 972     IRSetObj *obj = o;
 973     IRObj *p = obj->parent;
 974     int r;
 975
 976     p->set_child = o;
 977     if (argc != 3)
 978     {
 979         interp->result = "wrong # args";
 980         return TCL_ERROR;
 981     }
 982     if (!p->num_databaseNames)
 983     {
 984         interp->result = "no databaseNames";
 985         return TCL_ERROR;
 986     }
 987     if (!p->cs_link)
 988     {
 989         interp->result = "not connected";
 990         return TCL_ERROR;
 991     }
 992     apdu.which = Z_APDU_searchRequest;
 993     apdu.u.searchRequest = &req;
 994
 995     req.referenceId = 0;
 996     req.smallSetUpperBound = &p->smallSetUpperBound;
 997     req.largeSetLowerBound = &p->largeSetLowerBound;
 998     req.mediumSetPresentNumber = &p->mediumSetPresentNumber;
 999     req.replaceIndicator = &p->replaceIndicator;
1000     req.resultSetName = obj->setName ? obj->setName : "Default";
1001     req.num_databaseNames = p->num_databaseNames;
1002     req.databaseNames = p->databaseNames;
1003     printf ("Search:");
1004     for (r=0; r<p->num_databaseNames; r++)
1005     {
1006         printf (" %s", p->databaseNames[r]);
1007     }
1008     req.smallSetElementSetNames = 0;
1009     req.mediumSetElementSetNames = 0;
1010     req.preferredRecordSyntax = 0;
1011     req.query = &query;
1012
1013     if (!strcmp (p->query_method, "rpn"))
1014     {
1015         int error;
1016         int pos;
1017         struct ccl_rpn_node *rpn;
1018         Z_RPNQuery *RPNquery;
1019
1020         rpn = ccl_find_str(p->bibset, argv[2], &error, &pos);
1021         if (error)
1022         {
1023             Tcl_AppendResult (interp, "CCL error: ", ccl_err_msg(error),NULL);
1024             return TCL_ERROR;
1025         }
1026         query.which = Z_Query_type_1;
1027         assert((RPNquery = ccl_rpn_query(rpn)));
1028         RPNquery->attributeSetId = oid_getoidbyent (&p->bib1);
1029         query.u.type_1 = RPNquery;
1030         printf ("- RPN\n");
1031     }
1032     else if (!strcmp (p->query_method, "ccl"))
1033     {
1034         query.which = Z_Query_type_2;
1035         query.u.type_2 = &ccl_query;
1036         ccl_query.buf = (unsigned char *) argv[2];
1037         ccl_query.len = strlen (argv[2]);
1038         printf ("- CCL\n");
1039     }
1040     else
1041     {
1042         interp->result = "unknown query method";
1043         return TCL_ERROR;
1044     }
1045     if (!z_APDU (p->odr_out, &apdup, 0))
1046     {
1047         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1048         odr_reset (p->odr_out);
1049         return TCL_ERROR;
1050     }
1051     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
1052     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1053     {
1054         interp->result = "cs_put failed in search";
1055         return TCL_ERROR;
1056     }
1057     else if (r == 1)
1058     {
1059         ir_select_add_write (cs_fileno(p->cs_link), p);
1060         printf("Sent part of searchRequest (%d bytes).\n", p->slen);
1061     }
1062     else
1063     {
1064         printf ("Whole search request\n");
1065     }
1066     return TCL_OK;
1067 }
1068
1069 /*
1070  * do_resultCount: Get number of hits
1071  */
1072 static int do_resultCount (void *o, Tcl_Interp *interp,
1073                        int argc, char **argv)
1074 {
1075     IRSetObj *obj = o;
1076
1077     return get_set_int (&obj->resultCount, interp, argc, argv);
1078 }
1079
1080 /*
1081  * do_searchStatus: Get search status (after search response)
1082  */
1083 static int do_searchStatus (void *o, Tcl_Interp *interp,
1084                             int argc, char **argv)
1085 {
1086     IRSetObj *obj = o;
1087
1088     return get_set_int (&obj->searchStatus, interp, argc, argv);
1089 }
1090
1091 /*
1092  * do_setName: Set result Set name
1093  */
1094 static int do_setName (void *o, Tcl_Interp *interp,
1095                        int argc, char **argv)
1096 {
1097     IRSetObj *obj = o;
1098
1099     if (argc == 3)
1100     {
1101         free (obj->setName);
1102         if (ir_strdup (interp, &obj->setName, argv[2])
1103             == TCL_ERROR)
1104             return TCL_ERROR;
1105     }
1106     Tcl_AppendElement (interp, obj->setName);
1107     return TCL_OK;
1108 }
1109
1110 /*
1111  * do_numberOfRecordsReturned: Get number of records returned
1112  */
1113 static int do_numberOfRecordsReturned (void *o, Tcl_Interp *interp,
1114                        int argc, char **argv)
1115 {
1116     IRSetObj *obj = o;
1117
1118     return get_set_int (&obj->numberOfRecordsReturned, interp, argc, argv);
1119 }
1120
1121 static int get_marc_fields(Tcl_Interp *interp, Iso2709Rec rec,
1122                            int argc, char **argv)
1123 {
1124     Iso2709Anchor a;
1125     char *data;
1126
1127     if (!rec)
1128         return TCL_OK;
1129     a = iso2709_a_mk (rec);
1130     while (iso2709_a_search (a, argv[4], argv[5], argv[6]))
1131     {
1132         if (!(iso2709_a_info_field (a, NULL, NULL, NULL, &data)))
1133             break;
1134         Tcl_AppendElement (interp, data);
1135         iso2709_a_next (a);
1136     }
1137
1138     iso2709_a_rm (a);
1139     return TCL_OK;
1140 }
1141
1142 static int get_marc_lines(Tcl_Interp *interp, Iso2709Rec rec,
1143                          int argc, char **argv)
1144 {
1145     Iso2709Anchor a;
1146     char *tag;
1147     char *indicator;
1148     char *identifier;
1149     char *data;
1150     char *ptag = "";
1151
1152     if (!rec)
1153         return TCL_OK;
1154     a = iso2709_a_mk (rec);
1155     while (iso2709_a_search (a, argv[4], argv[5], argv[6]))
1156     {
1157         if (!(iso2709_a_info_field (a, &tag, &indicator, &identifier, &data)))
1158             break;
1159         if (strcmp (tag, ptag))
1160         {
1161             if (*ptag)
1162                 Tcl_AppendResult (interp, "}} ", NULL);
1163             if (!indicator)
1164                 Tcl_AppendResult (interp, "{", tag, " {} {", NULL);
1165             else
1166                 Tcl_AppendResult (interp, "{", tag, " {", indicator,
1167                                   "} {", NULL);
1168             ptag = tag;
1169         }
1170         if (!identifier)
1171             Tcl_AppendResult (interp, "{{}", NULL);
1172         else
1173             Tcl_AppendResult (interp, "{", identifier, NULL);
1174         Tcl_AppendElement (interp, data);
1175         Tcl_AppendResult (interp, "} ", NULL);
1176         iso2709_a_next (a);
1177     }
1178     if (*ptag)
1179         Tcl_AppendResult (interp, "}} ", NULL);
1180     iso2709_a_rm (a);
1181     return TCL_OK;
1182 }
1183
1184 /*
1185  * do_recordType: Return record type (if any) at position.
1186  */
1187 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
1188 {
1189     IRSetObj *obj = o;
1190     int offset;
1191     IRRecordList *rl;
1192
1193     if (argc < 3)
1194     {
1195         sprintf (interp->result, "wrong # args");
1196         return TCL_ERROR;
1197     }
1198     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1199         return TCL_ERROR;
1200     rl = find_IR_record (obj, offset);
1201     if (!rl)
1202         return TCL_OK;
1203     switch (rl->which)
1204     {
1205     case Z_NamePlusRecord_databaseRecord:
1206         interp->result = "databaseRecord";
1207         break;
1208     case Z_NamePlusRecord_surrogateDiagnostic:
1209         interp->result = "surrogateDiagnostic";
1210         break;
1211     }
1212     return TCL_OK;
1213 }
1214
1215 /*
1216  * do_recordDiag: Return diagnostic record info
1217  */
1218 static int do_recordDiag (void *o, Tcl_Interp *interp, int argc, char **argv)
1219 {
1220     IRSetObj *obj = o;
1221     int offset;
1222     IRRecordList *rl;
1223     char buf[20];
1224
1225     if (argc < 3)
1226     {
1227         sprintf (interp->result, "wrong # args");
1228         return TCL_ERROR;
1229     }
1230     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1231         return TCL_ERROR;
1232     rl = find_IR_record (obj, offset);
1233     if (!rl)
1234     {
1235         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1236         return TCL_ERROR;
1237     }
1238     if (rl->which != Z_NamePlusRecord_surrogateDiagnostic)
1239     {
1240         Tcl_AppendResult (interp, "No Diagnostic record at #", argv[2], NULL);
1241         return TCL_ERROR;
1242     }
1243     sprintf (buf, "%d", rl->u.diag.condition);
1244     Tcl_AppendResult (interp, buf, " {",
1245                       (rl->u.diag.addinfo ? rl->u.diag.addinfo : ""),
1246                       "}", NULL);
1247     return TCL_OK;
1248 }
1249
1250 /*
1251  * do_recordMarc: Get ISO2709 Record lines/fields
1252  */
1253 static int do_recordMarc (void *o, Tcl_Interp *interp, int argc, char **argv)
1254 {
1255     IRSetObj *obj = o;
1256     int offset;
1257     IRRecordList *rl;
1258
1259     if (argc < 4)
1260     {
1261         sprintf (interp->result, "wrong # args");
1262         return TCL_ERROR;
1263     }
1264     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
1265         return TCL_ERROR;
1266     rl = find_IR_record (obj, offset);
1267     if (!rl)
1268     {
1269         Tcl_AppendResult (interp, "No record at #", argv[2], NULL);
1270         return TCL_ERROR;
1271     }
1272     if (rl->which != Z_NamePlusRecord_databaseRecord)
1273     {
1274         Tcl_AppendResult (interp, "No MARC record at #", argv[2], NULL);
1275         return TCL_ERROR;
1276     }
1277     if (!strcmp (argv[3], "field"))
1278         return get_marc_fields (interp, rl->u.marc.rec, argc, argv);
1279     else if (!strcmp (argv[3], "line"))
1280         return get_marc_lines (interp, rl->u.marc.rec, argc, argv);
1281     else
1282     {
1283         Tcl_AppendResult (interp, "field/line expected", NULL);
1284         return TCL_ERROR;
1285     }
1286 }
1287
1288
1289 /*
1290  * do_responseStatus: Return response status (present or search)
1291  */
1292 static int do_responseStatus (void *o, Tcl_Interp *interp,
1293                              int argc, char **argv)
1294 {
1295     IRSetObj *obj = o;
1296
1297     if (!obj->recordFlag)
1298         return TCL_OK;
1299     switch (obj->which)
1300     {
1301     case Z_Records_DBOSD:
1302         Tcl_AppendElement (interp, "DBOSD");
1303         break;
1304     case Z_Records_NSD:
1305         return mk_nonSurrogateDiagnostics (interp, obj->condition,
1306                                            obj->addinfo);
1307     }
1308     return TCL_OK;
1309 }
1310
1311 /*
1312  * do_present: Perform Present Request
1313  */
1314
1315 static int do_present (void *o, Tcl_Interp *interp,
1316                        int argc, char **argv)
1317 {
1318     IRSetObj *obj = o;
1319     IRObj *p = obj->parent;
1320     Z_APDU apdu, *apdup = &apdu;
1321     Z_PresentRequest req;
1322     int start;
1323     int number;
1324     int r;
1325
1326     if (argc >= 3)
1327     {
1328         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
1329             return TCL_ERROR;
1330     }
1331     else
1332         start = 1;
1333     if (argc >= 4)
1334     {
1335         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
1336             return TCL_ERROR;
1337     }
1338     else
1339         number = 10;
1340     if (!p->cs_link)
1341     {
1342         interp->result = "not connected";
1343         return TCL_ERROR;
1344     }
1345     obj->start = start;
1346     obj->number = number;
1347
1348     apdu.which = Z_APDU_presentRequest;
1349     apdu.u.presentRequest = &req;
1350     req.referenceId = 0;
1351     /* sprintf(setstring, "%d", setnumber); */
1352
1353     req.resultSetId = obj->setName ? obj->setName : "Default";
1354
1355     req.resultSetStartPoint = &start;
1356     req.numberOfRecordsRequested = &number;
1357     req.elementSetNames = 0;
1358     req.preferredRecordSyntax = 0;
1359
1360     if (!z_APDU (p->odr_out, &apdup, 0))
1361     {
1362         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1363         odr_reset (p->odr_out);
1364         return TCL_ERROR;
1365     }
1366     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
1367     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1368     {
1369         interp->result = "cs_put failed in present";
1370         return TCL_ERROR;
1371     }
1372     else if (r == 1)
1373     {
1374         ir_select_add_write (cs_fileno(p->cs_link), p);
1375         printf ("Part of present request, start=%d, num=%d (%d bytes)\n",
1376                 start, number, p->slen);
1377     }
1378     else
1379     {
1380         printf ("Whole present request, start=%d, num=%d (%d bytes)\n",
1381                 start, number, p->slen);
1382     }
1383     return TCL_OK;
1384 }
1385
1386 /*
1387  * do_loadFile: Load result set from file
1388  */
1389
1390 static int do_loadFile (void *o, Tcl_Interp *interp,
1391                         int argc, char **argv)
1392 {
1393     IRSetObj *setobj = o;
1394     FILE *inf;
1395     int  no = 1;
1396     const char *buf;
1397
1398     if (argc < 3)
1399     {
1400         interp->result = "wrong # args";
1401         return TCL_ERROR;
1402     }
1403     inf = fopen (argv[2], "r");
1404     if (!inf)
1405     {
1406         Tcl_AppendResult (interp, "Cannot open ", argv[2], NULL);
1407         return TCL_ERROR;
1408     }
1409     while ((buf = iso2709_read (inf)))
1410     {
1411         IRRecordList *rl;
1412         Iso2709Rec rec;
1413
1414         rec = iso2709_cvt (buf);
1415         if (!rec)
1416             break;
1417         rl = new_IR_record (setobj, no, Z_NamePlusRecord_databaseRecord);
1418         rl->u.marc.rec = rec;
1419         no++;
1420     }
1421     setobj->numberOfRecordsReturned = no-1;
1422     fclose (inf);
1423     return TCL_OK;
1424 }
1425
1426 /*
1427  * ir_set_obj_method: IR Set Object methods
1428  */
1429 static int ir_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1430                           int argc, char **argv)
1431 {
1432     static IRMethod tab[] = {
1433     { 0, "search",                  do_search },
1434     { 0, "searchStatus",            do_searchStatus },
1435     { 0, "setName",                 do_setName },
1436     { 0, "resultCount",             do_resultCount },
1437     { 0, "numberOfRecordsReturned", do_numberOfRecordsReturned },
1438     { 0, "present",                 do_present },
1439     { 0, "recordType",              do_recordType },
1440     { 0, "recordMarc",              do_recordMarc },
1441     { 0, "recordDiag",              do_recordDiag },
1442     { 0, "responseStatus",          do_responseStatus },
1443     { 0, "loadFile",                do_loadFile },
1444     { 0, NULL, NULL}
1445     };
1446
1447     if (argc < 2)
1448     {
1449         interp->result = "wrong # args";
1450         return TCL_ERROR;
1451     }
1452     return ir_method (clientData, interp, argc, argv, tab);
1453 }
1454
1455 /*
1456  * ir_set_obj_delete: IR Set Object disposal
1457  */
1458 static void ir_set_obj_delete (ClientData clientData)
1459 {
1460     free ( (void*) clientData);
1461 }
1462
1463 /*
1464  * ir_set_obj_mk: IR Set Object creation
1465  */
1466 static int ir_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1467                              int argc, char **argv)
1468 {
1469     Tcl_CmdInfo parent_info;
1470     IRSetObj *obj;
1471     const char *suffix;
1472
1473     if (argc != 2)
1474     {
1475         interp->result = "wrong # args";
1476         return TCL_ERROR;
1477     }
1478     if (get_parent_info (interp, argv[1], &parent_info, &suffix) == TCL_ERROR)
1479         return TCL_ERROR;
1480     if (!(obj = ir_malloc (interp, sizeof(*obj))))
1481         return TCL_ERROR;
1482     if (ir_strdup (interp, &obj->setName, suffix) == TCL_ERROR)
1483         return TCL_ERROR;
1484     obj->record_list = NULL;
1485     obj->addinfo = NULL;
1486     obj->parent = (IRObj *) parent_info.clientData;
1487     Tcl_CreateCommand (interp, argv[1], ir_set_obj_method,
1488                        (ClientData) obj, ir_set_obj_delete);
1489     return TCL_OK;
1490 }
1491
1492 /* ------------------------------------------------------- */
1493
1494 /*
1495  * do_scan: Perform scan
1496  */
1497 static int do_scan (void *o, Tcl_Interp *interp, int argc, char **argv)
1498 {
1499     Z_ScanRequest req;
1500     Z_APDU apdu, *apdup = &apdu;
1501     IRScanObj *obj = o;
1502     IRObj *p = obj->parent;
1503     int r;
1504
1505     p->scan_child = o;
1506     if (argc != 3)
1507     {
1508         interp->result = "wrong # args";
1509         return TCL_ERROR;
1510     }
1511     if (!p->num_databaseNames)
1512     {
1513         interp->result = "no databaseNames";
1514         return TCL_ERROR;
1515     }
1516     if (!p->cs_link)
1517     {
1518         interp->result = "not connected";
1519         return TCL_ERROR;
1520     }
1521     apdu.which = Z_APDU_scanRequest;
1522     apdu.u.scanRequest = &req;
1523     req.referenceId = NULL;
1524     req.num_databaseNames = p->num_databaseNames;
1525     req.databaseNames = p->databaseNames;
1526     req.attributeSet = oid_getoidbyent (&p->bib1);
1527
1528     if (!(req.termListAndStartPoint =
1529           ir_malloc (interp, sizeof(*req.termListAndStartPoint))))
1530         return TCL_ERROR;
1531     req.termListAndStartPoint->num_attributes = 0;
1532     req.termListAndStartPoint->attributeList = NULL;
1533     if (!(req.termListAndStartPoint->term = ir_malloc (interp,
1534                                                        sizeof(Z_Term))))
1535         return TCL_ERROR;
1536     req.termListAndStartPoint->term->which = Z_Term_general;
1537     if (!(req.termListAndStartPoint->term->u.general =
1538         ir_malloc (interp, sizeof(*req.termListAndStartPoint->
1539                                   term->u.general))))
1540         return TCL_ERROR;
1541     if (ir_strdup (interp, &req.termListAndStartPoint->term->u.general->buf,
1542                    argv[2]) == TCL_ERROR)
1543         return TCL_ERROR;
1544     req.termListAndStartPoint->term->u.general->len =
1545         req.termListAndStartPoint->term->u.general->size = strlen(argv[2]);
1546     req.stepSize = &obj->stepSize;
1547     req.numberOfTermsRequested = &obj->numberOfTermsRequested;
1548     req.preferredPositionInResponse = &obj->preferredPositionInResponse;
1549     printf ("stepSize=%d\n", *req.stepSize);
1550     printf ("numberOfTermsRequested=%d\n", *req.numberOfTermsRequested);
1551     printf ("preferredPositionInResponse=%d\n",
1552             *req.preferredPositionInResponse);
1553
1554     if (!z_APDU (p->odr_out, &apdup, 0))
1555     {
1556         interp->result = odr_errlist [odr_geterror (p->odr_out)];
1557         odr_reset (p->odr_out);
1558         return TCL_ERROR;
1559     }
1560     p->sbuf = odr_getbuf (p->odr_out, &p->slen);
1561     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
1562     {
1563         interp->result = "cs_put failed in scan";
1564         return TCL_ERROR;
1565     }
1566     else if (r == 1)
1567     {
1568         ir_select_add_write (cs_fileno(p->cs_link), p);
1569         printf("Sent part of scanRequest (%d bytes).\n", p->slen);
1570     }
1571     else
1572     {
1573         printf ("Whole scan request\n");
1574     }
1575     return TCL_OK;
1576 }
1577
1578 /*
1579  * do_stepSize: Set/get replace Step Size
1580  */
1581 static int do_stepSize (void *obj, Tcl_Interp *interp,
1582                         int argc, char **argv)
1583 {
1584     IRScanObj *p = obj;
1585     return get_set_int (&p->stepSize, interp, argc, argv);
1586 }
1587
1588 /*
1589  * do_numberOfTermsRequested: Set/get Number of Terms requested
1590  */
1591 static int do_numberOfTermsRequested (void *obj, Tcl_Interp *interp,
1592                                       int argc, char **argv)
1593 {
1594     IRScanObj *p = obj;
1595     return get_set_int (&p->numberOfTermsRequested, interp, argc, argv);
1596 }
1597
1598
1599 /*
1600  * do_preferredPositionInResponse: Set/get preferred Position
1601  */
1602 static int do_preferredPositionInResponse (void *obj, Tcl_Interp *interp,
1603                                            int argc, char **argv)
1604 {
1605     IRScanObj *p = obj;
1606     return get_set_int (&p->preferredPositionInResponse, interp, argc, argv);
1607 }
1608
1609 /*
1610  * do_scanStatus: Get scan status
1611  */
1612 static int do_scanStatus (void *obj, Tcl_Interp *interp,
1613                           int argc, char **argv)
1614 {
1615     IRScanObj *p = obj;
1616     return get_set_int (&p->scanStatus, interp, argc, argv);
1617 }
1618
1619 /*
1620  * do_numberOfEntriesReturned: Get number of Entries returned
1621  */
1622 static int do_numberOfEntriesReturned (void *obj, Tcl_Interp *interp,
1623                                        int argc, char **argv)
1624 {
1625     IRScanObj *p = obj;
1626     return get_set_int (&p->numberOfEntriesReturned, interp, argc, argv);
1627 }
1628
1629 /*
1630  * do_positionOfTerm: Get position of Term
1631  */
1632 static int do_positionOfTerm (void *obj, Tcl_Interp *interp,
1633                               int argc, char **argv)
1634 {
1635     IRScanObj *p = obj;
1636     return get_set_int (&p->positionOfTerm, interp, argc, argv);
1637 }
1638
1639 /*
1640  * do_scanLine: get Scan Line (surrogate or normal) after response
1641  */
1642 static int do_scanLine (void *obj, Tcl_Interp *interp, int argc, char **argv)
1643 {
1644     IRScanObj *p = obj;
1645     int i;
1646     char numstr[20];
1647
1648     if (argc != 3)
1649     {
1650         interp->result = "wrong # args";
1651         return TCL_ERROR;
1652     }
1653     if (Tcl_GetInt (interp, argv[2], &i) == TCL_ERROR)
1654         return TCL_ERROR;
1655     if (!p->entries_flag || p->which != Z_ListEntries_entries || !p->entries
1656         || i >= p->num_entries || i < 0)
1657         return TCL_OK;
1658     switch (p->entries[i].which)
1659     {
1660     case Z_Entry_termInfo:
1661         Tcl_AppendElement (interp, "T");
1662         if (p->entries[i].u.term.buf)
1663             Tcl_AppendElement (interp, p->entries[i].u.term.buf);
1664         else
1665             Tcl_AppendElement (interp, "");
1666         sprintf (numstr, "%d", p->entries[i].u.term.globalOccurrences);
1667         Tcl_AppendElement (interp, numstr);
1668         break;
1669     case Z_Entry_surrogateDiagnostic:
1670         return
1671             mk_nonSurrogateDiagnostics (interp, p->entries[i].u.diag.condition,
1672                                         p->entries[i].u.diag.addinfo);
1673         break;
1674     }
1675     return TCL_OK;
1676 }
1677
1678 /*
1679  * ir_scan_obj_method: IR Scan Object methods
1680  */
1681 static int ir_scan_obj_method (ClientData clientData, Tcl_Interp *interp,
1682                                int argc, char **argv)
1683 {
1684     static IRMethod tab[] = {
1685     { 0, "scan",                    do_scan },
1686     { 0, "stepSize",                do_stepSize },
1687     { 0, "numberOfTermsRequested",  do_numberOfTermsRequested },
1688     { 0, "preferredPositionInResponse", do_preferredPositionInResponse },
1689     { 0, "scanStatus",              do_scanStatus },
1690     { 0, "numberOfEntriesReturned", do_numberOfEntriesReturned },
1691     { 0, "positionOfTerm",          do_positionOfTerm },
1692     { 0, "scanLine",                do_scanLine },
1693     { 0, NULL, NULL}
1694     };
1695
1696     if (argc < 2)
1697     {
1698         interp->result = "wrong # args";
1699         return TCL_ERROR;
1700     }
1701     return ir_method (clientData, interp, argc, argv, tab);
1702 }
1703
1704 /*
1705  * ir_scan_obj_delete: IR Scan Object disposal
1706  */
1707 static void ir_scan_obj_delete (ClientData clientData)
1708 {
1709     free ( (void*) clientData);
1710 }
1711
1712 /*
1713  * ir_scan_obj_mk: IR Scan Object creation
1714  */
1715 static int ir_scan_obj_mk (ClientData clientData, Tcl_Interp *interp,
1716                            int argc, char **argv)
1717 {
1718     Tcl_CmdInfo parent_info;
1719     IRScanObj *obj;
1720
1721     if (argc != 2)
1722     {
1723         interp->result = "wrong # args";
1724         return TCL_ERROR;
1725     }
1726     if (get_parent_info (interp, argv[1], &parent_info, NULL) == TCL_ERROR)
1727         return TCL_ERROR;
1728     if (!(obj = ir_malloc (interp, sizeof(*obj))))
1729         return TCL_ERROR;
1730
1731     obj->stepSize = 0;
1732     obj->numberOfTermsRequested = 20;
1733     obj->preferredPositionInResponse = 1;
1734
1735     obj->entries = NULL;
1736     obj->nonSurrogateDiagnostics = NULL;
1737
1738     obj->parent = (IRObj *) parent_info.clientData;
1739     Tcl_CreateCommand (interp, argv[1], ir_scan_obj_method,
1740                        (ClientData) obj, ir_scan_obj_delete);
1741     return TCL_OK;
1742 }
1743
1744 /* ------------------------------------------------------- */
1745
1746 static void ir_initResponse (void *obj, Z_InitResponse *initrs)
1747 {
1748     if (!*initrs->result)
1749         printf("Connection rejected by target.\n");
1750     else
1751         printf("Connection accepted by target.\n");
1752     if (initrs->implementationId)
1753             printf("ID     : %s\n", initrs->implementationId);
1754     if (initrs->implementationName)
1755         printf("Name   : %s\n", initrs->implementationName);
1756     if (initrs->implementationVersion)
1757         printf("Version: %s\n", initrs->implementationVersion);
1758     if (initrs->maximumRecordSize)
1759         printf ("MaximumRecordSize=%d\n", *initrs->maximumRecordSize);
1760     if (initrs->preferredMessageSize)
1761         printf ("PreferredMessageSize=%d\n", *initrs->preferredMessageSize);
1762 #if 0
1763     if (initrs->userInformationField)
1764     {
1765         printf("UserInformationfield:\n");
1766         odr_external(&print, (Odr_external**)&initrs->
1767                          userInformationField, 0);
1768     }
1769 #endif
1770 }
1771
1772 static void ir_handleRecords (void *o, Z_Records *zrs)
1773 {
1774     IRObj *p = o;
1775     IRSetObj *setobj = p->set_child;
1776
1777     setobj->which = zrs->which;
1778     setobj->recordFlag = 1;
1779     if (zrs->which == Z_Records_NSD)
1780     {
1781         const char *addinfo;
1782
1783         setobj->numberOfRecordsReturned = 0;
1784         setobj->condition = *zrs->u.nonSurrogateDiagnostic->condition;
1785         free (setobj->addinfo);
1786         setobj->addinfo = NULL;
1787         addinfo = zrs->u.nonSurrogateDiagnostic->addinfo;
1788         if (addinfo && (setobj->addinfo = malloc (strlen(addinfo) + 1)))
1789             strcpy (setobj->addinfo, addinfo);
1790         printf ("Diagnostic response. %s (%d): %s\n",
1791                 diagbib1_str (setobj->condition),
1792                 setobj->condition,
1793                 setobj->addinfo ? setobj->addinfo : "");
1794     }
1795     else
1796     {
1797         int offset;
1798         IRRecordList *rl;
1799
1800         setobj->numberOfRecordsReturned =
1801             zrs->u.databaseOrSurDiagnostics->num_records;
1802         printf ("Got %d records\n", setobj->numberOfRecordsReturned);
1803         for (offset = 0; offset<setobj->numberOfRecordsReturned; offset++)
1804         {
1805             rl = new_IR_record (setobj, setobj->start + offset,
1806                                 zrs->u.databaseOrSurDiagnostics->
1807                                 records[offset]->which);
1808             if (rl->which == Z_NamePlusRecord_surrogateDiagnostic)
1809             {
1810                 Z_DiagRec *diagrec;
1811
1812                 diagrec = zrs->u.databaseOrSurDiagnostics->
1813                     records[offset]->u.surrogateDiagnostic;
1814
1815                 rl->u.diag.condition = *diagrec->condition;
1816                 if (diagrec->addinfo && (rl->u.diag.addinfo =
1817                                          malloc (strlen (diagrec->addinfo)+1)))
1818                     strcpy (rl->u.diag.addinfo, diagrec->addinfo);
1819             }
1820             else
1821             {
1822                 Z_DatabaseRecord *zr;
1823                 Odr_external *oe;
1824
1825                 zr = zrs->u.databaseOrSurDiagnostics->records[offset]
1826                     ->u.databaseRecord;
1827                 oe = (Odr_external*) zr;
1828                 if (oe->which == ODR_EXTERNAL_octet
1829                     && zr->u.octet_aligned->len)
1830                 {
1831                     const char *buf = (char*) zr->u.octet_aligned->buf;
1832                     rl->u.marc.rec = iso2709_cvt (buf);
1833                 }
1834                 else
1835                     rl->u.marc.rec = NULL;
1836             }
1837         }
1838     }
1839 }
1840
1841 static void ir_searchResponse (void *o, Z_SearchResponse *searchrs)
1842 {
1843     IRObj *p = o;
1844     IRSetObj *setobj = p->set_child;
1845     Z_Records *zrs = searchrs->records;
1846
1847     if (setobj)
1848     {
1849         setobj->searchStatus = searchrs->searchStatus ? 1 : 0;
1850         setobj->resultCount = *searchrs->resultCount;
1851         printf ("Search response %d, %d hits\n",
1852                  setobj->searchStatus, setobj->resultCount);
1853         if (zrs)
1854             ir_handleRecords (o, zrs);
1855         else
1856             setobj->recordFlag = 0;
1857     }
1858     else
1859         printf ("Search response, no object!\n");
1860 }
1861
1862
1863 static void ir_presentResponse (void *o, Z_PresentResponse *presrs)
1864 {
1865     IRObj *p = o;
1866     IRSetObj *setobj = p->set_child;
1867     Z_Records *zrs = presrs->records;
1868
1869     printf ("Received presentResponse\n");
1870     if (zrs)
1871         ir_handleRecords (o, zrs);
1872     else
1873     {
1874         setobj->recordFlag = 0;
1875         printf ("No records!\n");
1876     }
1877 }
1878
1879 static void ir_scanResponse (void *o, Z_ScanResponse *scanrs)
1880 {
1881     IRObj *p = o;
1882     IRScanObj *scanobj = p->scan_child;
1883
1884     printf ("Received scanResponse\n");
1885
1886     scanobj->scanStatus = *scanrs->scanStatus;
1887     printf ("scanStatus=%d\n", scanobj->scanStatus);
1888
1889     if (scanrs->stepSize)
1890         scanobj->stepSize = *scanrs->stepSize;
1891     printf ("stepSize=%d\n", scanobj->stepSize);
1892
1893     scanobj->numberOfEntriesReturned = *scanrs->numberOfEntriesReturned;
1894     printf ("numberOfEntriesReturned=%d\n", scanobj->numberOfEntriesReturned);
1895
1896     if (scanrs->positionOfTerm)
1897         scanobj->positionOfTerm = *scanrs->positionOfTerm;
1898     else
1899         scanobj->positionOfTerm = -1;
1900     printf ("positionOfTerm=%d\n", scanobj->positionOfTerm);
1901
1902     free (scanobj->entries);
1903     scanobj->entries = NULL;
1904     free (scanobj->nonSurrogateDiagnostics);
1905     scanobj->nonSurrogateDiagnostics = NULL;
1906
1907     if (scanrs->entries)
1908     {
1909         int i;
1910         Z_Entry *ze;
1911
1912         scanobj->entries_flag = 1;
1913         scanobj->which = scanrs->entries->which;
1914         switch (scanobj->which)
1915         {
1916         case Z_ListEntries_entries:
1917             scanobj->num_entries = scanrs->entries->u.entries->num_entries;
1918             scanobj->entries = malloc (scanobj->num_entries *
1919                                        sizeof(*scanobj->entries));
1920             for (i=0; i<scanobj->num_entries; i++)
1921             {
1922                 ze = scanrs->entries->u.entries->entries[i];
1923                 scanobj->entries[i].which = ze->which;
1924                 switch (ze->which)
1925                 {
1926                 case Z_Entry_termInfo:
1927                     if (ze->u.termInfo->term->which == Z_Term_general)
1928                     {
1929                         int l = ze->u.termInfo->term->u.general->len;
1930                         scanobj->entries[i].u.term.buf = malloc (1+l);
1931                         memcpy (scanobj->entries[i].u.term.buf,
1932                                 ze->u.termInfo->term->u.general->buf,
1933                                 l);
1934                         scanobj->entries[i].u.term.buf[l] = '\0';
1935                     }
1936                     else
1937                         scanobj->entries[i].u.term.buf = NULL;
1938                     if (ze->u.termInfo->globalOccurrences)
1939                         scanobj->entries[i].u.term.globalOccurrences =
1940                             *ze->u.termInfo->globalOccurrences;
1941                     else
1942                         scanobj->entries[i].u.term.globalOccurrences = 0;
1943                     break;
1944                 case Z_Entry_surrogateDiagnostic:
1945                     scanobj->entries[i].u.diag.addinfo =
1946                             malloc (1+strlen(ze->u.surrogateDiagnostic->
1947                                              addinfo));
1948                     strcpy (scanobj->entries[i].u.diag.addinfo,
1949                             ze->u.surrogateDiagnostic->addinfo);
1950                     scanobj->entries[i].u.diag.condition =
1951                         *ze->u.surrogateDiagnostic->condition;
1952                     break;
1953                 }
1954             }
1955             break;
1956         case Z_ListEntries_nonSurrogateDiagnostics:
1957             scanobj->num_diagRecs = scanrs->entries->
1958                                   u.nonSurrogateDiagnostics->num_diagRecs;
1959             scanobj->nonSurrogateDiagnostics = malloc (scanobj->num_diagRecs *
1960                                   sizeof(*scanobj->nonSurrogateDiagnostics));
1961             break;
1962         }
1963     }
1964     else
1965         scanobj->entries_flag = 0;
1966 }
1967
1968 /*
1969  * ir_select_read: handle incoming packages
1970  */
1971 void ir_select_read (ClientData clientData)
1972 {
1973     IRObj *p = clientData;
1974     Z_APDU *apdu;
1975     int r;
1976
1977     if (p->connectFlag)
1978     {
1979         r = cs_rcvconnect (p->cs_link);
1980         if (r == 1)
1981             return;
1982         p->connectFlag = 0;
1983         ir_select_remove_write (cs_fileno (p->cs_link), p);
1984         if (r < 0)
1985         {
1986             printf ("cs_rcvconnect error\n");
1987             if (p->failback)
1988                 Tcl_Eval (p->interp, p->failback);
1989             do_disconnect (p, NULL, 0, NULL);
1990             return;
1991         }
1992         if (p->callback)
1993             Tcl_Eval (p->interp, p->callback);
1994         return;
1995     }
1996     do
1997     {
1998         if ((r=cs_get (p->cs_link, &p->buf_in, &p->len_in))  <= 0)
1999         {
2000             printf ("cs_get failed\n");
2001             ir_select_remove (cs_fileno (p->cs_link), p);
2002             if (p->failback)
2003                 Tcl_Eval (p->interp, p->failback);
2004             do_disconnect (p, NULL, 0, NULL);
2005             return;
2006         }
2007         if (r == 1)
2008             return ;
2009         odr_setbuf (p->odr_in, p->buf_in, r);
2010         printf ("cs_get ok, got %d\n", r);
2011         if (!z_APDU (p->odr_in, &apdu, 0))
2012         {
2013             printf ("%s\n", odr_errlist [odr_geterror (p->odr_in)]);
2014             if (p->failback)
2015                 Tcl_Eval (p->interp, p->failback);
2016             do_disconnect (p, NULL, 0, NULL);
2017             return;
2018         }
2019         switch(apdu->which)
2020         {
2021         case Z_APDU_initResponse:
2022             ir_initResponse (p, apdu->u.initResponse);
2023             break;
2024         case Z_APDU_searchResponse:
2025             ir_searchResponse (p, apdu->u.searchResponse);
2026             break;
2027         case Z_APDU_presentResponse:
2028             ir_presentResponse (p, apdu->u.presentResponse);
2029             break;
2030         case Z_APDU_scanResponse:
2031             ir_scanResponse (p, apdu->u.scanResponse);
2032             break;
2033         default:
2034             printf("Received unknown APDU type (%d).\n",
2035                    apdu->which);
2036             if (p->failback)
2037                 Tcl_Eval (p->interp, p->failback);
2038             do_disconnect (p, NULL, 0, NULL);
2039         }
2040         if (p->callback)
2041             Tcl_Eval (p->interp, p->callback);
2042     } while (cs_more (p->cs_link));
2043 }
2044
2045 /*
2046  * ir_select_write: handle outgoing packages - not yet written.
2047  */
2048 void ir_select_write (ClientData clientData)
2049 {
2050     IRObj *p = clientData;
2051     int r;
2052
2053     printf ("In write handler.....\n");
2054     if (p->connectFlag)
2055     {
2056         r = cs_rcvconnect (p->cs_link);
2057         if (r == 1)
2058             return;
2059         p->connectFlag = 0;
2060         if (r < 0)
2061         {
2062             printf ("cs_rcvconnect error\n");
2063             ir_select_remove_write (cs_fileno (p->cs_link), p);
2064             if (p->failback)
2065                 Tcl_Eval (p->interp, p->failback);
2066             do_disconnect (p, NULL, 0, NULL);
2067             return;
2068         }
2069         ir_select_remove_write (cs_fileno (p->cs_link), p);
2070         if (p->callback)
2071             Tcl_Eval (p->interp, p->callback);
2072         return;
2073     }
2074     if ((r=cs_put (p->cs_link, p->sbuf, p->slen)) < 0)
2075     {
2076         printf ("select write fail\n");
2077         if (p->failback)
2078             Tcl_Eval (p->interp, p->failback);
2079         do_disconnect (p, NULL, 0, NULL);
2080     }
2081     else if (r == 0)            /* remove select bit */
2082     {
2083         ir_select_remove_write (cs_fileno (p->cs_link), p);
2084     }
2085 }
2086
2087 /* ------------------------------------------------------- */
2088
2089 /*
2090  * ir_tcl_init: Registration of TCL commands.
2091  */
2092 int ir_tcl_init (Tcl_Interp *interp)
2093 {
2094     Tcl_CreateCommand (interp, "ir", ir_obj_mk, (ClientData) NULL,
2095                        (Tcl_CmdDeleteProc *) NULL);
2096     Tcl_CreateCommand (interp, "ir-set", ir_set_obj_mk,
2097                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2098     Tcl_CreateCommand (interp, "ir-scan", ir_scan_obj_mk,
2099                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
2100     return TCL_OK;
2101 }
2102
2103