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