wais-tcl.c

   1 /*
   2  * NWI - Nordic Web Index
   3  * Technical Knowledge Centre & Library of Denmark (DTV)
   4  *
   5  * Wais extension to IrTcl
   6  *
   7  * $Log: wais-tcl.c,v $
   8  * Revision 1.1  1996-02-29 15:28:08  adam
   9  * First version of Wais extension to IrTcl.
  10  *
  11  */
  12
  13 #include <stdio.h>
  14 #include <stdlib.h>
  15 #include <assert.h>
  16
  17 /* YAZ headers ... */
  18 #include <comstack.h>
  19 #include <tcpip.h>
  20 #include <oid.h>
  21
  22 /* IrTcl internal header */
  23 #include <ir-tclp.h>
  24
  25 /* FreeWAIS-sf header */
  26 #include <ui.h>
  27
  28 typedef struct {
  29     int           position;
  30     any           *documentID;
  31     long          score;
  32     long          documentLength;
  33     long          lines;
  34     char          *headline;
  35     char          *documentText;
  36 } WaisTcl_Record;
  37
  38 typedef struct WaisTcl_Records {
  39     WaisTcl_Record *record;
  40     struct WaisTcl_Records *next;
  41 } WaisTcl_Records;
  42
  43 typedef struct {
  44     IrTcl_Obj     *irtcl_obj;
  45     Tcl_Interp    *interp;
  46     int           ref_count;
  47     COMSTACK      wais_link;
  48     char          *hostname;
  49     char          *buf_out;
  50     int           len_out;
  51     int           max_out;
  52     char          *object;
  53 } WaisTcl_Obj;
  54
  55 typedef struct {
  56     WaisTcl_Obj   *parent;
  57     IrTcl_SetObj  *irtcl_set_obj;
  58     Tcl_Interp    *interp;
  59     WaisTcl_Records *records;
  60     char          *diag;
  61     char          *addinfo;
  62     int           maxDocs;
  63 } WaisSetTcl_Obj;
  64
  65 static void wais_obj_delete (ClientData clientData);
  66 static void wais_select_notify (ClientData clientData, int r, int w, int e);
  67 static int do_disconnect (void *obj, Tcl_Interp *interp,
  68                           int argc, char **argv);
  69
  70 /* --- N E T W O R K    I / O ----------------------------------------- */
  71
  72 static void wais_select_write (ClientData clientData)
  73 {
  74     WaisTcl_Obj *p = clientData;
  75     int r;
  76
  77     logf (LOG_DEBUG, "Wais write handler fd=%d", cs_fileno(p->wais_link));
  78     switch (p->irtcl_obj->state)
  79     {
  80     case IR_TCL_R_Connecting:
  81         logf(LOG_DEBUG, "Connect handler");
  82         r = cs_rcvconnect (p->wais_link);
  83         if (r == 1)
  84             return;
  85         p->irtcl_obj->state = IR_TCL_R_Idle;
  86         if (r < 0)
  87         {
  88             logf (LOG_DEBUG, "cs_rcvconnect error");
  89             if (p->irtcl_obj->failback)
  90             {
  91                 p->irtcl_obj->failInfo = IR_TCL_FAIL_CONNECT;
  92                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
  93             }
  94             do_disconnect (p, NULL, 2, NULL);
  95             return;
  96         }
  97         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
  98                            clientData, 1, 0, 0);
  99         if (p->irtcl_obj->callback)
 100         {
 101             logf (LOG_DEBUG, "Invoking connect callback");
 102             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 103         }
 104         break;
 105     case IR_TCL_R_Writing:
 106         if ((r=cs_put (p->wais_link, p->buf_out, p->len_out)) < 0)
 107         {
 108             logf (LOG_DEBUG, "cs_put write fail");
 109             if (p->irtcl_obj->failback)
 110             {
 111                 p->irtcl_obj->failInfo = IR_TCL_FAIL_WRITE;
 112                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 113             }
 114             do_disconnect (p, NULL, 2, NULL);
 115         }
 116         else if (r == 0)            /* remove select bit */
 117         {
 118             logf(LOG_DEBUG, "Write completed");
 119             p->irtcl_obj->state = IR_TCL_R_Waiting;
 120
 121             ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 122                                clientData, 1, 0, 0);
 123         }
 124         break;
 125     default:
 126         logf (LOG_FATAL|LOG_ERRNO, "Wais read. state=%d", p->irtcl_obj->state);
 127         abort ();
 128     }
 129 }
 130
 131 static WaisTcl_Record *wais_lookup_record_pos (WaisSetTcl_Obj *p, int pos)
 132 {
 133     WaisTcl_Records *recs;
 134
 135     for (recs = p->records; recs; recs = recs->next)
 136         if (recs->record->position == pos)
 137             return recs->record;
 138     return NULL;
 139 }
 140
 141 static WaisTcl_Record *wais_lookup_record_pos_bf (WaisSetTcl_Obj *p, int pos)
 142 {
 143     WaisTcl_Record *rec;
 144
 145     rec = wais_lookup_record_pos (p, pos);
 146     if (!rec)
 147     {
 148         return NULL;
 149     }
 150     if (rec->documentText ||
 151         !p->irtcl_set_obj->recordElements ||
 152         !*p->irtcl_set_obj->recordElements ||
 153         strcmp (p->irtcl_set_obj->recordElements, "F"))
 154         return rec;
 155     return NULL;
 156 }
 157
 158 static WaisTcl_Record *wais_lookup_record_id (WaisSetTcl_Obj *p, any *id)
 159 {
 160     WaisTcl_Records *recs;
 161
 162     for (recs = p->records; recs; recs = recs->next)
 163         if (recs->record->documentID->size == id->size &&
 164             !memcmp (recs->record->documentID->bytes, id->bytes, id->size))
 165             return recs->record;
 166     return NULL;
 167 }
 168
 169 static void wais_delete_record (WaisTcl_Record *rec)
 170 {
 171     freeAny (rec->documentID);
 172     free (rec->headline);
 173     if (rec->documentText)
 174         free (rec->documentText);
 175     free (rec);
 176 }
 177
 178 static void wais_add_record_brief (WaisSetTcl_Obj *p,
 179                                    int position,
 180                                    any *documentID,
 181                                    long score,
 182                                    long documentLength,
 183                                    long lines,
 184                                    char *headline)
 185 {
 186     WaisTcl_Record *rec;
 187     WaisTcl_Records *recs;
 188
 189     rec = wais_lookup_record_pos (p, position);
 190     if (!rec)
 191     {
 192         rec = ir_tcl_malloc (sizeof(*rec));
 193
 194         recs = ir_tcl_malloc (sizeof(*recs));
 195         recs->record = rec;
 196         recs->next = p->records;
 197         p->records = recs;
 198     }
 199     else
 200     {
 201         freeAny (rec->documentID);
 202         free (rec->headline);
 203         if (rec->documentText)
 204             free (rec->documentText);
 205     }
 206     rec->position = position;
 207     rec->documentID = duplicateAny (documentID);
 208     rec->score = score;
 209     rec->documentLength = documentLength;
 210     rec->lines = lines;
 211     ir_tcl_strdup (NULL, &rec->headline, headline);
 212     rec->documentText = NULL;
 213 }
 214
 215 static void wais_add_record_full (WaisSetTcl_Obj *p,
 216                                   any *documentID,
 217                                   any *documentText)
 218 {
 219     WaisTcl_Record *rec;
 220     rec = wais_lookup_record_id (p, documentID);
 221
 222     if (!rec)
 223     {
 224         logf (LOG_DEBUG, "Adding text. Didn't find corresponding brief");
 225         return ;
 226     }
 227     if (rec->documentText)
 228         free (rec->documentText);
 229     rec->documentText = ir_tcl_malloc (documentText->size+1);
 230     memcpy (rec->documentText, documentText->bytes, documentText->size);
 231     rec->documentText[documentText->size] = '\0';
 232     logf (LOG_DEBUG, "Adding text record: \n%.20s", rec->documentText);
 233 }
 234
 235 static void wais_handle_search_response (WaisSetTcl_Obj *p, char *buf)
 236 {
 237     SearchResponseAPDU *responseAPDU = NULL;
 238
 239     readSearchResponseAPDU (&responseAPDU, buf);
 240     if (responseAPDU->DatabaseDiagnosticRecords)
 241     {
 242         WAISSearchResponse *ddr = responseAPDU->DatabaseDiagnosticRecords;
 243
 244         p->irtcl_set_obj->searchStatus = 1;
 245
 246         p->irtcl_set_obj->nextResultSetPosition =
 247             responseAPDU->NextResultSetPosition;
 248         p->irtcl_set_obj->numberOfRecordsReturned =
 249             responseAPDU->NumberOfRecordsReturned;
 250
 251         if (!p->irtcl_set_obj->resultCount)
 252         {
 253             if (responseAPDU->NumberOfRecordsReturned >
 254                 responseAPDU->ResultCount)
 255                 p->irtcl_set_obj->resultCount =
 256                     responseAPDU->NumberOfRecordsReturned;
 257             else
 258                 p->irtcl_set_obj->resultCount =
 259                     responseAPDU->ResultCount;
 260         }
 261         free (p->diag);
 262         p->diag = NULL;
 263         free (p->addinfo);
 264         p->addinfo = NULL;
 265         if (ddr->Diagnostics)
 266         {
 267             diagnosticRecord **dr = ddr->Diagnostics;
 268             if (dr[0])
 269             {
 270                 logf (LOG_DEBUG, "Diagnostic response. %s : %s",
 271                       dr[0]->DIAG ? dr[0]->DIAG : "<null>",
 272                       dr[0]->ADDINFO ? dr[0]->ADDINFO : "<null>");
 273                 ir_tcl_strdup (NULL, &p->diag, dr[0]->DIAG);
 274                 ir_tcl_strdup (NULL, &p->addinfo, dr[0]->ADDINFO);
 275             }
 276             else
 277                 logf (LOG_DEBUG, "Diagnostic response");
 278         }
 279         if (ddr->DocHeaders)
 280         {
 281             int i;
 282             logf (LOG_DEBUG, "Got doc header entries");
 283             for (i = 0; ddr->DocHeaders[i]; i++)
 284             {
 285                 WAISDocumentHeader *head = ddr->DocHeaders[i];
 286
 287                 wais_add_record_brief (p, i+1, head->DocumentID,
 288                                        head->Score, head->DocumentLength,
 289                                        head->Lines, head->Headline);
 290             }
 291             logf (LOG_DEBUG, "got %d DBOSD records", i);
 292         }
 293         if (ddr->Text)
 294         {
 295             int i;
 296             logf (LOG_DEBUG, "Got text entries");
 297             for (i = 0; ddr->Text[i]; i++)
 298                 wais_add_record_full (p,
 299                                       ddr->Text[i]->DocumentID,
 300                                       ddr->Text[i]->DocumentText);
 301         }
 302         freeWAISSearchResponse (ddr);
 303     }
 304     else
 305     {
 306         logf (LOG_DEBUG, "No records!");
 307     }
 308     freeSearchResponseAPDU (responseAPDU);
 309 }
 310
 311
 312 static void wais_select_read (ClientData clientData)
 313 {
 314     ClientData objectClientData;
 315     WaisTcl_Obj *p = clientData;
 316     char *pdup;
 317     int r;
 318
 319     logf (LOG_DEBUG, "Wais read handler fd=%d", cs_fileno(p->wais_link));
 320     do
 321     {
 322         /* signal one more use of ir object - callbacks must not
 323            release the ir memory (p pointer) */
 324         p->irtcl_obj->state = IR_TCL_R_Reading;
 325         ++(p->ref_count);
 326
 327         /* read incoming APDU */
 328         if ((r=cs_get (p->wais_link, &p->irtcl_obj->buf_in,
 329                        &p->irtcl_obj->len_in)) <= 0)
 330         {
 331             logf (LOG_DEBUG, "cs_get failed, code %d", r);
 332             do_disconnect (p, NULL, 2, NULL);
 333             if (p->irtcl_obj->failback)
 334             {
 335                 p->irtcl_obj->failInfo = IR_TCL_FAIL_READ;
 336                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 337             }
 338             /* release wais object now if callback deleted it */
 339             wais_obj_delete (p);
 340             return;
 341         }
 342         if (r == 1)
 343         {
 344             logf(LOG_DEBUG, "PDU Fraction read");
 345             --(p->ref_count);
 346             return ;
 347         }
 348         logf (LOG_DEBUG, "cs_get ok, total size %d", r);
 349         /* got complete APDU. Now decode */
 350
 351         /* determine set/ir object corresponding to response */
 352         objectClientData = 0;
 353         if (p->object)
 354         {
 355             Tcl_CmdInfo cmd_info;
 356
 357             if (Tcl_GetCommandInfo (p->interp, p->object, &cmd_info))
 358                 objectClientData = cmd_info.clientData;
 359             free (p->object);
 360             p->object = NULL;
 361         }
 362         pdup = p->irtcl_obj->buf_in + HEADER_LENGTH;
 363         switch (peekPDUType (pdup))
 364         {
 365         case initResponseAPDU:
 366             logf (LOG_DEBUG, "Got Wais Init response");
 367             break;
 368         case searchResponseAPDU:
 369             logf (LOG_DEBUG, "Got Wais Search response");
 370             if (objectClientData)
 371                 wais_handle_search_response (objectClientData,
 372                                              pdup);
 373             break;
 374         default:
 375             logf (LOG_WARN, "Received unknown WAIS APDU type %d",
 376                   peekPDUType (pdup));
 377             do_disconnect (p, NULL, 2, NULL);
 378             if (p->irtcl_obj->failback)
 379             {
 380                 p->irtcl_obj->failInfo = IR_TCL_FAIL_UNKNOWN_APDU;
 381                 ir_tcl_eval (p->interp, p->irtcl_obj->failback);
 382             }
 383             return ;
 384         }
 385         p->irtcl_obj->state = IR_TCL_R_Idle;
 386
 387         if (p->irtcl_obj->callback)
 388             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 389         if (p->ref_count == 1)
 390         {
 391             wais_obj_delete (p);
 392             return;
 393         }
 394         --(p->ref_count);
 395     } while (p->wais_link && cs_more (p->wais_link));
 396 }
 397
 398 static void wais_select_notify (ClientData clientData, int r, int w, int e)
 399 {
 400     if (w)
 401         wais_select_write (clientData);
 402     if (r)
 403         wais_select_read (clientData);
 404 }
 405
 406 static int wais_send_apdu (WaisTcl_Obj *p, const char *msg, const char *object)
 407 {
 408     int r;
 409
 410     if (p->object)
 411     {
 412         logf (LOG_DEBUG, "Cannot send. object=%s", p->object);
 413         return TCL_ERROR;
 414     }
 415     r = cs_put (p->wais_link, p->buf_out, p->len_out);
 416     if (r < 0)
 417         return TCL_ERROR;
 418     ir_tcl_strdup (NULL, &p->object, object);
 419     if (r == 1)
 420     {
 421         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 422                            p, 1, 1, 0);
 423         logf (LOG_DEBUG, "Send part of wais %s APDU", msg);
 424         p->irtcl_obj->state = IR_TCL_R_Writing;
 425     }
 426     else
 427     {
 428         logf (LOG_DEBUG, "Send %s (%d bytes) fd=%d", msg, p->len_out,
 429               cs_fileno(p->wais_link));
 430         p->irtcl_obj->state = IR_TCL_R_Waiting;
 431     }
 432     return TCL_OK;
 433 }
 434
 435 /* --- A S S O C I A T I O N S ----------------------------------------- */
 436
 437 static int do_connect (void *obj, Tcl_Interp *interp,
 438                        int argc, char **argv)
 439 {
 440     void *addr;
 441     WaisTcl_Obj *p = obj;
 442     int r;
 443
 444     if (argc <= 0)
 445         return TCL_OK;
 446     else if (argc == 2)
 447     {
 448         Tcl_AppendResult (interp, p->hostname, NULL);
 449         return TCL_OK;
 450     }
 451     if (p->hostname)
 452     {
 453         interp->result = "already connected";
 454         return TCL_ERROR;
 455     }
 456     if (strcmp (p->irtcl_obj->comstackType, "wais"))
 457     {
 458         interp->result = "only wais comstack supported";
 459         return TCL_ERROR;
 460     }
 461     p->wais_link = cs_create (tcpip_type, 0, PROTO_WAIS);
 462     addr = tcpip_strtoaddr (argv[2]);
 463     if (!addr)
 464     {
 465         interp->result = "tcpip_strtoaddr fail";
 466         return TCL_ERROR;
 467     }
 468     logf (LOG_DEBUG, "tcp/ip wais connect %s", argv[2]);
 469
 470     if (ir_tcl_strdup (interp, &p->hostname, argv[2]) == TCL_ERROR)
 471         return TCL_ERROR;
 472     r = cs_connect (p->wais_link, addr);
 473     logf(LOG_DEBUG, "cs_connect returned %d fd=%d", r,
 474          cs_fileno(p->wais_link));
 475     if (r < 0)
 476     {
 477         interp->result = "wais connect fail";
 478         do_disconnect (p, NULL, 2, NULL);
 479         return TCL_ERROR;
 480     }
 481     p->irtcl_obj->eventType = "connect";
 482     if (r == 1)
 483     {
 484         p->irtcl_obj->state = IR_TCL_R_Connecting;
 485         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 486                            p, 1, 1, 0);
 487     }
 488     else
 489     {
 490         p->irtcl_obj->state = IR_TCL_R_Idle;
 491         ir_tcl_select_set (wais_select_notify, cs_fileno(p->wais_link),
 492                            p, 1, 0, 0);
 493         if (p->irtcl_obj->callback)
 494             ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 495     }
 496     return TCL_OK;
 497 }
 498
 499 static int do_disconnect (void *obj, Tcl_Interp *interp,
 500                           int argc, char **argv)
 501 {
 502     WaisTcl_Obj *p = obj;
 503
 504     if (argc == 0)
 505     {
 506         p->wais_link = NULL;
 507         p->hostname = NULL;
 508         p->object = NULL;
 509         return TCL_OK;
 510     }
 511     if (p->hostname)
 512     {
 513         ir_tcl_select_set (NULL, cs_fileno(p->wais_link), NULL, 0, 0, 0);
 514
 515         free (p->hostname);
 516         p->hostname = NULL;
 517         cs_close (p->wais_link);
 518         p->wais_link = NULL;
 519         free (p->object);
 520         p->object = NULL;
 521     }
 522     return TCL_OK;
 523 }
 524
 525 static int do_init (void *obj, Tcl_Interp *interp, int argc, char **argv)
 526 {
 527     WaisTcl_Obj *p = obj;
 528
 529     if (argc <= 0)
 530         return TCL_OK;
 531     p->irtcl_obj->initResult = 0;
 532     if (!p->hostname)
 533     {
 534         interp->result = "not connected";
 535         return TCL_ERROR;
 536     }
 537     p->irtcl_obj->initResult = 1;
 538     if (p->irtcl_obj->callback)
 539         ir_tcl_eval (p->interp, p->irtcl_obj->callback);
 540     return TCL_OK;
 541 }
 542
 543 static int do_options (void *obj, Tcl_Interp *interp, int argc, char **argv)
 544 {
 545     WaisTcl_Obj *p = obj;
 546
 547     if (argc <= 0)
 548         return TCL_OK;
 549     if (argc != 2)
 550         return TCL_OK;
 551     Tcl_AppendElement (p->interp, "search");
 552     Tcl_AppendElement (p->interp, "present");
 553     return TCL_OK;
 554 }
 555
 556
 557 static IrTcl_Method wais_method_tab[] = {
 558 { "connect",                     do_connect, NULL },
 559 { "disconnect",                  do_disconnect, NULL },
 560 { "init",                        do_init, NULL },
 561 { "options",                     do_options, NULL },
 562 { NULL, NULL}
 563 };
 564
 565
 566 int wais_obj_init(ClientData clientData, Tcl_Interp *interp,
 567                   int argc, char **argv, ClientData *subData,
 568                   ClientData parentData)
 569 {
 570     IrTcl_Methods tab[3];
 571     WaisTcl_Obj *obj;
 572     ClientData subP;
 573     int r;
 574
 575     if (argc != 2)
 576     {
 577         interp->result = "wrong # args";
 578         return TCL_ERROR;
 579     }
 580     obj = ir_tcl_malloc (sizeof(*obj));
 581     obj->ref_count = 1;
 582     obj->interp = interp;
 583
 584     logf (LOG_DEBUG, "wais object create %s", argv[1]);
 585
 586     r = (*ir_obj_class.ir_init)(clientData, interp, argc, argv, &subP, 0);
 587     if (r == TCL_ERROR)
 588         return TCL_ERROR;
 589     obj->irtcl_obj = subP;
 590
 591     obj->max_out = 2048;
 592     obj->buf_out = ir_tcl_malloc (obj->max_out);
 593
 594     free (obj->irtcl_obj->comstackType);
 595     ir_tcl_strdup (NULL, &obj->irtcl_obj->comstackType, "wais");
 596
 597     tab[0].tab = wais_method_tab;
 598     tab[0].obj = obj;
 599     tab[1].tab = NULL;
 600
 601     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
 602     {
 603         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
 604         /* cleanup missing ... */
 605         return TCL_ERROR;
 606     }
 607     *subData = obj;
 608     return TCL_OK;
 609 }
 610
 611
 612 /*
 613  * wais_obj_delete: Wais Object disposal
 614  */
 615 static void wais_obj_delete (ClientData clientData)
 616 {
 617     WaisTcl_Obj *obj = clientData;
 618     IrTcl_Methods tab[3];
 619
 620     --(obj->ref_count);
 621     if (obj->ref_count > 0)
 622         return;
 623
 624     logf (LOG_DEBUG, "wais object delete");
 625
 626     tab[0].tab = wais_method_tab;
 627     tab[0].obj = obj;
 628     tab[1].tab = NULL;
 629
 630     ir_tcl_method (NULL, -1, NULL, tab, NULL);
 631
 632     (*ir_obj_class.ir_delete)((ClientData) obj->irtcl_obj);
 633
 634     free (obj->buf_out);
 635     free (obj);
 636 }
 637
 638 /*
 639  * wais_obj_method: Wais Object methods
 640  */
 641 static int wais_obj_method (ClientData clientData, Tcl_Interp *interp,
 642                             int argc, char **argv)
 643 {
 644     IrTcl_Methods tab[3];
 645     WaisTcl_Obj *p = clientData;
 646     int r;
 647
 648     if (argc < 2)
 649         return TCL_ERROR;
 650
 651     tab[0].tab = wais_method_tab;
 652     tab[0].obj = p;
 653     tab[1].tab = NULL;
 654
 655     if (ir_tcl_method (interp, argc, argv, tab, &r) == TCL_ERROR)
 656     {
 657         return (*ir_obj_class.ir_method)((ClientData) p->irtcl_obj,
 658                                          interp, argc, argv);
 659     }
 660     return r;
 661 }
 662
 663 /*
 664  * wais_obj_mk: Wais Object creation
 665  */
 666 static int wais_obj_mk (ClientData clientData, Tcl_Interp *interp,
 667                         int argc, char **argv)
 668 {
 669     ClientData subData;
 670     int r = wais_obj_init (clientData, interp, argc, argv, &subData, 0);
 671
 672     if (r == TCL_ERROR)
 673         return TCL_ERROR;
 674     Tcl_CreateCommand (interp, argv[1], wais_obj_method,
 675                        subData, wais_obj_delete);
 676     return TCL_OK;
 677 }
 678
 679 /* --- S E T S ---------------------------------------------------------- */
 680
 681 static int do_present (void *o, Tcl_Interp *interp, int argc, char **argv)
 682 {
 683     WaisSetTcl_Obj *obj = o;
 684     WaisTcl_Obj *p = obj->parent;
 685     int i, start, number;
 686     static char *element_names[3];
 687     long left;
 688     char *retp;
 689     any *waisQuery;
 690     SearchAPDU *waisSearch;
 691     DocObj **docObjs;
 692
 693     if (argc <= 0)
 694         return TCL_OK;
 695     if (argc >= 3)
 696     {
 697         if (Tcl_GetInt (interp, argv[2], &start) == TCL_ERROR)
 698             return TCL_ERROR;
 699     }
 700     else
 701         start = 1;
 702     if (argc >= 4)
 703     {
 704         if (Tcl_GetInt (interp, argv[3], &number) == TCL_ERROR)
 705             return TCL_ERROR;
 706     }
 707     else
 708         number = 10;
 709     if (!p->wais_link)
 710     {
 711         interp->result = "present: not connected";
 712         return TCL_ERROR;
 713     }
 714     element_names[0] = " ";
 715     element_names[1] = ES_DocumentText;
 716     element_names[2] = NULL;
 717
 718     docObjs = ir_tcl_malloc (sizeof(*docObjs) * (number+1));
 719     for (i = 0; i<number; i++)
 720     {
 721         WaisTcl_Record *rec;
 722
 723         rec = wais_lookup_record_pos (obj, i+start);
 724         if (!rec)
 725         {
 726             interp->result = "present request out of range";
 727             return TCL_ERROR;
 728         }
 729         docObjs[i] = makeDocObjUsingLines (rec->documentID, "TEXT", 0, 60000);
 730     }
 731     docObjs[i] = NULL;
 732     waisQuery = makeWAISTextQuery (docObjs);
 733     waisSearch =
 734         makeSearchAPDU (30L,                          /* small */
 735                         5000L,                        /* large */
 736                         30L,                          /* medium */
 737                         (boolean) obj->irtcl_set_obj->
 738                         set_inher.replaceIndicator,   /* replace indicator */
 739                         obj->irtcl_set_obj->
 740                         setName,                      /* result set name */
 741                         obj->irtcl_set_obj->set_inher.databaseNames,
 742                         QT_TextRetrievalQuery,        /* query type */
 743                         element_names,                /* element name */
 744                         NULL,                         /* reference ID */
 745                         waisQuery);
 746
 747     left = p->max_out;
 748     retp = writeSearchAPDU (waisSearch, p->buf_out + HEADER_LENGTH, &left);
 749     p->len_out = p->max_out - left;
 750
 751     for (i = 0; i<number; i++)
 752         CSTFreeDocObj (docObjs[i]);
 753     free (docObjs);
 754
 755     CSTFreeWAISTextQuery (waisQuery);
 756     freeSearchAPDU (waisSearch);
 757     if (!retp)
 758     {
 759         interp->result = "Couldn't encode WAIS text search APDU";
 760         return TCL_ERROR;
 761     }
 762     writeWAISPacketHeader (p->buf_out, (long) (p->len_out), (long) 'z', "wais",
 763                            (long) NO_COMPRESSION,
 764                            (long) NO_ENCODING,
 765                            (long) HEADER_VERSION);
 766
 767     p->len_out += HEADER_LENGTH;
 768     return wais_send_apdu (p, "search", argv[0]);
 769 }
 770
 771 static int do_search (void *o, Tcl_Interp *interp, int argc, char **argv)
 772 {
 773     WaisSetTcl_Obj *obj = o;
 774     WaisTcl_Obj *p = obj->parent;
 775     WAISSearch *waisQuery;
 776     SearchAPDU *waisSearch;
 777     char *retp;
 778     long left;
 779
 780     if (argc <= 0)
 781         return TCL_OK;
 782     if (argc != 3)
 783     {
 784         interp->result = "wrong # args";
 785         return TCL_ERROR;
 786     }
 787     if (!obj->irtcl_set_obj->set_inher.num_databaseNames)
 788     {
 789         interp->result = "no databaseNames";
 790         return TCL_ERROR;
 791     }
 792     logf (LOG_DEBUG, "parent = %p", p);
 793     if (!p->hostname)
 794     {
 795         interp->result = "not connected";
 796         return TCL_ERROR;
 797     }
 798     obj->irtcl_set_obj->resultCount = 0;
 799     obj->irtcl_set_obj->searchStatus = 0;
 800     waisQuery =
 801         makeWAISSearch (argv[2],         /* seed words */
 802                         0,               /* doc ptrs */
 803                         0,               /* text list */
 804                         1L,              /* date factor */
 805                         0L,              /* begin date range */
 806                         0L,              /* end date range */
 807                         obj->maxDocs);   /* max docs retrieved */
 808
 809     waisSearch =
 810         makeSearchAPDU (30L,                          /* small */
 811                         5000L,                        /* large */
 812                         30L,                          /* medium */
 813                         (boolean) obj->irtcl_set_obj->
 814                         set_inher.replaceIndicator,   /* replace indicator */
 815                         obj->irtcl_set_obj->
 816                         setName,                      /* result set name */
 817                         obj->irtcl_set_obj->set_inher.databaseNames,
 818                         QT_RelevanceFeedbackQuery,    /* query type */
 819                         NULL,                         /* element name */
 820                         NULL,                         /* reference ID */
 821                         waisQuery);
 822
 823     left = p->max_out;
 824     retp = writeSearchAPDU (waisSearch, p->buf_out + HEADER_LENGTH, &left);
 825     p->len_out = p->max_out - left;
 826
 827     CSTFreeWAISSearch (waisQuery);
 828     freeSearchAPDU (waisSearch);
 829     if (!retp)
 830     {
 831         interp->result = "Couldn't encode WAIS search APDU";
 832         return TCL_ERROR;
 833     }
 834     writeWAISPacketHeader (p->buf_out, (long) (p->len_out), (long) 'z', "wais",
 835                            (long) NO_COMPRESSION,
 836                            (long) NO_ENCODING,
 837                            (long) HEADER_VERSION);
 838
 839     p->len_out += HEADER_LENGTH;
 840     return wais_send_apdu (p, "search", argv[0]);
 841 }
 842
 843 /*
 844  * do_responseStatus: Return response status (present or search)
 845  */
 846 static int do_responseStatus (void *o, Tcl_Interp *interp,
 847                              int argc, char **argv)
 848 {
 849     WaisSetTcl_Obj *obj = o;
 850
 851     if (argc == 0)
 852     {
 853         obj->diag = NULL;
 854         obj->addinfo = NULL;
 855         return TCL_OK;
 856     }
 857     else if (argc == -1)
 858     {
 859         free (obj->diag);
 860         free (obj->addinfo);
 861     }
 862     if (obj->diag)
 863     {
 864         Tcl_AppendElement (interp, "NSD");
 865
 866         Tcl_AppendElement (interp, obj->diag);
 867         Tcl_AppendElement (interp, obj->diag);
 868
 869         Tcl_AppendElement (interp, obj->addinfo ? obj->addinfo : "");
 870         return TCL_OK;
 871     }
 872     Tcl_AppendElement (interp, "DBOSD");
 873     return TCL_OK;
 874 }
 875
 876 /*
 877  * do_maxDocs: Set number of documents to be retrieved in ranked query
 878  */
 879 static int do_maxDocs (void *o, Tcl_Interp *interp, int argc, char **argv)
 880 {
 881     WaisSetTcl_Obj *obj = o;
 882
 883     if (argc <= 0)
 884     {
 885         obj->maxDocs = 100;
 886         return TCL_OK;
 887     }
 888     return ir_tcl_get_set_int (&obj->maxDocs, interp, argc, argv);
 889 }
 890
 891
 892 /*
 893  * do_type: Return type (if any) at position.
 894  */
 895 static int do_type (void *o, Tcl_Interp *interp, int argc, char **argv)
 896 {
 897     WaisSetTcl_Obj *obj = o;
 898     int offset;
 899     WaisTcl_Record *rec;
 900
 901     if (argc == 0)
 902     {
 903         obj->records = NULL;
 904         return TCL_OK;
 905     }
 906     else if (argc == -1)
 907     {
 908 /*
 909         delete_IR_records (obj);
 910 */
 911         return TCL_OK;
 912     }
 913     if (argc != 3)
 914     {
 915         sprintf (interp->result, "wrong # args");
 916         return TCL_ERROR;
 917     }
 918     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 919         return TCL_ERROR;
 920     rec = wais_lookup_record_pos_bf (obj, offset);
 921     if (!rec)
 922     {
 923         logf (LOG_DEBUG, "No record at position %d", offset);
 924         return TCL_OK;
 925     }
 926     interp->result = "DB";
 927     return TCL_OK;
 928 }
 929
 930
 931 /*
 932  * do_recordType: Return record type (if any) at position.
 933  */
 934 static int do_recordType (void *o, Tcl_Interp *interp, int argc, char **argv)
 935 {
 936     WaisSetTcl_Obj *obj = o;
 937     int offset;
 938     WaisTcl_Record *rec;
 939
 940     if (argc <= 0)
 941     {
 942         return TCL_OK;
 943     }
 944     if (argc != 3)
 945     {
 946         sprintf (interp->result, "wrong # args");
 947         return TCL_ERROR;
 948     }
 949     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 950         return TCL_ERROR;
 951
 952     rec = wais_lookup_record_pos_bf (obj, offset);
 953     if (!rec)
 954         return TCL_OK;
 955
 956     Tcl_AppendElement (interp, "WAIS");
 957     return TCL_OK;
 958 }
 959
 960 /*
 961  * do_getWAIS: Return WAIS record at position.
 962  */
 963 static int do_getWAIS (void *o, Tcl_Interp *interp, int argc, char **argv)
 964 {
 965     WaisSetTcl_Obj *obj = o;
 966     int offset;
 967     WaisTcl_Record *rec;
 968     char prbuf[256];
 969
 970     if (argc <= 0)
 971     {
 972         return TCL_OK;
 973     }
 974     if (argc != 4)
 975     {
 976         sprintf (interp->result, "wrong # args");
 977         return TCL_ERROR;
 978     }
 979     if (Tcl_GetInt (interp, argv[2], &offset)==TCL_ERROR)
 980         return TCL_ERROR;
 981     rec = wais_lookup_record_pos_bf (obj, offset);
 982     if (!rec)
 983         return TCL_OK;
 984     if (!strcmp (argv[3], "score"))
 985     {
 986         sprintf (prbuf, "%ld", (long) rec->score);
 987         Tcl_AppendElement (interp, prbuf);
 988     }
 989     else if (!strcmp (argv[3], "headline"))
 990     {
 991         Tcl_AppendElement (interp, rec->headline);
 992     }
 993     else if (!strcmp (argv[3], "documentLength"))
 994     {
 995         sprintf (prbuf, "%ld", (long) rec->documentLength);
 996         Tcl_AppendElement (interp, prbuf);
 997     }
 998     else if (!strcmp (argv[3], "text"))
 999     {
1000         Tcl_AppendElement (interp, rec->documentText);
1001     }
1002     else if (!strcmp (argv[3], "lines"))
1003     {
1004         sprintf (prbuf, "%ld", (long) rec->lines);
1005         Tcl_AppendElement (interp, prbuf);
1006     }
1007     return TCL_OK;
1008 }
1009
1010
1011 static IrTcl_Method wais_set_method_tab[] = {
1012 { "maxDocs",                     do_maxDocs, NULL },
1013 { "search",                      do_search, NULL },
1014 { "present",                     do_present, NULL },
1015 { "responseStatus",              do_responseStatus, NULL },
1016 { "type",                        do_type, NULL },
1017 { "recordType",                  do_recordType, NULL },
1018 { "getWAIS",                     do_getWAIS, NULL },
1019 { NULL, NULL}
1020 };
1021
1022 /*
1023  * wais_obj_method: Wais Set Object methods
1024  */
1025 static int wais_set_obj_method (ClientData clientData, Tcl_Interp *interp,
1026                             int argc, char **argv)
1027 {
1028     IrTcl_Methods tab[3];
1029     WaisSetTcl_Obj *p = clientData;
1030     int r;
1031
1032     if (argc < 2)
1033         return TCL_ERROR;
1034
1035     tab[0].tab = wais_set_method_tab;
1036     tab[0].obj = p;
1037     tab[1].tab = NULL;
1038
1039     if (ir_tcl_method (interp, argc, argv, tab, &r) == TCL_ERROR)
1040     {
1041         return (*ir_set_obj_class.ir_method)((ClientData) p->irtcl_set_obj,
1042                                              interp, argc, argv);
1043     }
1044     return r;
1045 }
1046
1047 int wais_set_obj_init (ClientData clientData, Tcl_Interp *interp,
1048                        int argc, char **argv, ClientData *subData,
1049                        ClientData parentData)
1050 {
1051     IrTcl_Methods tab[3];
1052     WaisSetTcl_Obj *obj;
1053     ClientData subP;
1054     int r;
1055
1056     assert (parentData);
1057     if (argc != 3)
1058     {
1059         interp->result = "wrong # args";
1060         return TCL_ERROR;
1061     }
1062     obj = ir_tcl_malloc (sizeof(*obj));
1063     obj->parent = (WaisTcl_Obj *) parentData;
1064     logf (LOG_DEBUG, "parent = %p", obj->parent);
1065     obj->interp = interp;
1066     obj->diag = NULL;
1067     obj->addinfo = NULL;
1068
1069     logf (LOG_DEBUG, "wais set object create %s", argv[1]);
1070
1071     r = (*ir_set_obj_class.ir_init)(clientData, interp, argc, argv, &subP,
1072                                     obj->parent->irtcl_obj);
1073     if (r == TCL_ERROR)
1074         return TCL_ERROR;
1075     obj->irtcl_set_obj = subP;
1076
1077     tab[0].tab = wais_set_method_tab;
1078     tab[0].obj = obj;
1079     tab[1].tab = NULL;
1080
1081     if (ir_tcl_method (interp, 0, NULL, tab, NULL) == TCL_ERROR)
1082     {
1083         Tcl_AppendResult (interp, "Failed to initialize ", argv[1], NULL);
1084         /* cleanup missing ... */
1085         return TCL_ERROR;
1086     }
1087     *subData = obj;
1088     return TCL_OK;
1089 }
1090
1091
1092 /*
1093  * wais_set_obj_delete: Wais Set Object disposal
1094  */
1095 static void wais_set_obj_delete (ClientData clientData)
1096 {
1097     WaisSetTcl_Obj *obj = clientData;
1098     IrTcl_Methods tab[3];
1099
1100     logf (LOG_DEBUG, "wais set object delete");
1101
1102     tab[0].tab = wais_set_method_tab;
1103     tab[0].obj = obj;
1104     tab[1].tab = NULL;
1105
1106     ir_tcl_method (NULL, -1, NULL, tab, NULL);
1107
1108     (*ir_set_obj_class.ir_delete)((ClientData) obj->irtcl_set_obj);
1109
1110     free (obj);
1111 }
1112
1113 /*
1114  * wais_set_obj_mk: Wais Set Object creation
1115  */
1116 static int wais_set_obj_mk (ClientData clientData, Tcl_Interp *interp,
1117                             int argc, char **argv)
1118 {
1119     int r;
1120     ClientData subData;
1121     Tcl_CmdInfo parent_info;
1122
1123     if (argc != 3)
1124     {
1125         interp->result = "wrong # args";
1126         return TCL_ERROR;
1127     }
1128     parent_info.clientData = 0;
1129     if (!Tcl_GetCommandInfo (interp, argv[2], &parent_info))
1130     {
1131         interp->result = "No parent";
1132         return TCL_ERROR;
1133     }
1134     r = wais_set_obj_init (clientData, interp, argc, argv, &subData,
1135                            parent_info.clientData);
1136     if (r == TCL_ERROR)
1137         return TCL_ERROR;
1138     Tcl_CreateCommand (interp, argv[1], wais_set_obj_method,
1139                        subData, wais_set_obj_delete);
1140     return TCL_OK;
1141 }
1142
1143
1144 /* --- R E G I S T R A T I O N ---------------------------------------- */
1145 /*
1146  * Waistcl_init: Registration of TCL commands.
1147  */
1148 int Waistcl_Init (Tcl_Interp *interp)
1149 {
1150     Tcl_CreateCommand (interp, "wais", wais_obj_mk, (ClientData) NULL,
1151                        (Tcl_CmdDeleteProc *) NULL);
1152     Tcl_CreateCommand (interp, "wais-set", wais_set_obj_mk,
1153                        (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1154     return TCL_OK;
1155 }
1156